ByteCodeLink.lhs 9.74 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2000-2006
3
%
4
ByteCodeLink: Bytecode assembler and linker
5
6

\begin{code}
7
8
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}

9
{-# OPTIONS -w #-}
10
11
12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14
15
-- for details

16
17
18
module ByteCodeLink ( 
	HValue, 
	ClosureEnv, emptyClosureEnv, extendClosureEnv,
19
	linkBCO, lookupStaticPtr, lookupName
20
       ,lookupIE
21
  ) where
22
23
24

#include "HsVersions.h"

25
26
27
import ByteCodeItbls
import ByteCodeAsm
import ObjLink
28

29
import Name
30
import NameEnv
31
32
import OccName
import PrimOp
Simon Marlow's avatar
Simon Marlow committed
33
import Module
34
35
36
import PackageConfig
import FastString
import Panic
Simon Marlow's avatar
Simon Marlow committed
37
38
import Outputable

39
-- Standard libraries
40
import GHC.Word		( Word(..) )
41

42
43
import Data.Array.Base
import GHC.Arr		( STArray(..) )
44
45

import Control.Exception ( throwDyn )
46
47
import Control.Monad	( zipWithM )
import Control.Monad.ST ( stToIO )
48

49
import GHC.Exts
50
51
import GHC.Arr		( Array(..) )
import GHC.IOBase	( IO(..) )
52
import GHC.Ptr		( Ptr(..), castPtr )
53
import GHC.Base		( writeArray#, RealWorld, Int(..), Word# )  
54
55
\end{code}

56

57
58
%************************************************************************
%*									*
59
\subsection{Linking interpretables into something we can run}
60
61
62
63
%*									*
%************************************************************************

\begin{code}
64
type ClosureEnv = NameEnv (Name, HValue)
65
newtype HValue = HValue Any
66

67
emptyClosureEnv = emptyNameEnv
68

69
70
71
extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
extendClosureEnv cl_env pairs
  = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
72
73
\end{code}

74

75
76
77
78
79
80
81
82
%************************************************************************
%*									*
\subsection{Linking interpretables into something we can run}
%*									*
%************************************************************************

\begin{code}
{- 
83
84
data BCO# = BCO# ByteArray# 		-- instrs   :: Array Word16#
                 ByteArray# 		-- literals :: Array Word32#
85
86
87
88
                 PtrArray# 		-- ptrs     :: Array HValue
                 ByteArray#		-- itbls    :: Array Addr#
-}

89
linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
linkBCO ie ce ul_bco
   = do BCO bco# <- linkBCO' ie ce ul_bco
	-- SDM: Why do we need mkApUpd0 here?  I *think* it's because
	-- otherwise top-level interpreted CAFs don't get updated 
 	-- after evaluation.   A top-level BCO will evaluate itself and
	-- return its value when entered, but it won't update itself.
	-- Wrapping the BCO in an AP_UPD thunk will take care of the
	-- update for us.
	--
	-- Update: the above is true, but now we also have extra invariants:
	--   (a) An AP thunk *must* point directly to a BCO
	--   (b) A zero-arity BCO *must* be wrapped in an AP thunk
	--   (c) An AP is always fully saturated, so we *can't* wrap
	--       non-zero arity BCOs in an AP thunk.
	-- 
	if (unlinkedBCOArity ul_bco > 0) 
	   then return (unsafeCoerce# bco#)
	   else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }


linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
111
linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
112
113
   -- Raises an IO exception on failure
   = do let literals = ssElts literalsSS
114
	    ptrs     = ssElts ptrsSS
115

116
        linked_literals <- mapM (lookupLiteral ie) literals
117

118
        let n_literals = sizeSS literalsSS
119
120
            n_ptrs     = sizeSS ptrsSS

121
122
123
	ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs

        let 
124
            ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
125

126
            literals_arr = listArray (0, n_literals-1) linked_literals
127
                           :: UArray Int Word
128
            literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
129

130
131
	    (I# arity#)  = arity

132
        newBCO insns_barr literals_barr ptrs_parr arity# bitmap
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148


-- we recursively link any sub-BCOs while making the ptrs array
mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
mkPtrsArray ie ce n_ptrs ptrs = do
  marr <- newArray_ (0, n_ptrs-1)
  let 
    fill (BCOPtrName n)     i = do
	ptr <- lookupName ce n
	unsafeWrite marr i ptr
    fill (BCOPtrPrimOp op)  i = do
 	ptr <- lookupPrimOp op
	unsafeWrite marr i ptr
    fill (BCOPtrBCO ul_bco) i = do
	BCO bco# <- linkBCO' ie ce ul_bco
	writeArrayBCO marr i bco#
149
150
151
152
    fill (BCOPtrBreakInfo brkInfo) i =                    
        unsafeWrite marr i (unsafeCoerce# brkInfo)
    fill (BCOPtrArray brkArray) i =                    
        unsafeWrite marr i (unsafeCoerce# brkArray)
153
154
155
156
157
158
  zipWithM fill ptrs [0..]
  unsafeFreeze marr

newtype IOArray i e = IOArray (STArray RealWorld i e)

instance MArray IOArray e IO where
159
    getBounds (IOArray marr) = stToIO $ getBounds marr
160
    getNumElements (IOArray marr) = stToIO $ getNumElements marr
161
162
163
164
165
166
167
168
169
    newArray lu init = stToIO $ do
        marr <- newArray lu init; return (IOArray marr)
    newArray_ lu = stToIO $ do
        marr <- newArray_ lu; return (IOArray marr)
    unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
    unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)

-- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
170
writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
171
172
  case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
  (# s#, () #) }
173

174
175
176
177
178
179
180
{-
writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
  case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
  (# s#, () #) }
-}

181
182
data BCO = BCO BCO#

183
newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
184
185
newBCO instrs lits ptrs arity bitmap
   = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of 
186
		  (# s1, bco #) -> (# s1, BCO bco #)
187
188


189
190
191
192
193
194
lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
lookupLiteral ie (BCONPtrWord lit) = return lit
lookupLiteral ie (BCONPtrLbl  sym) = do Ptr a# <- lookupStaticPtr sym
			                return (W# (int2Word# (addr2Int# a#)))
lookupLiteral ie (BCONPtrItbl nm)  = do Ptr a# <- lookupIE ie nm
			                return (W# (int2Word# (addr2Int# a#)))
195
196
197

lookupStaticPtr :: FastString -> IO (Ptr ())
lookupStaticPtr addr_of_label_string 
198
   = do let label_to_find = unpackFS addr_of_label_string
199
200
        m <- lookupSymbol label_to_find 
        case m of
201
202
203
           Just ptr -> return ptr
           Nothing  -> linkFail "ByteCodeLink: can't find label" 
                                label_to_find
204

205
206
lookupPrimOp :: PrimOp -> IO HValue
lookupPrimOp primop
207
208
   = do let sym_to_find = primopToCLabel primop "closure"
        m <- lookupSymbol sym_to_find
209
210
        case m of
           Just (Ptr addr) -> case addrToHValue# addr of
211
                                 (# hval #) -> return hval
212
           Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
213

214
215
lookupName :: ClosureEnv -> Name -> IO HValue
lookupName ce nm
216
217
   = case lookupNameEnv ce nm of
        Just (_,aa) -> return aa
218
        Nothing 
219
           -> ASSERT2(isExternalName nm, ppr nm)
220
	      do let sym_to_find = nameToCLabel nm "closure"
221
                 m <- lookupSymbol sym_to_find
222
                 case m of
223
                    Just (Ptr addr) -> case addrToHValue# addr of
224
                                          (# hval #) -> return hval
225
                    Nothing         -> linkFail "ByteCodeLink.lookupCE" sym_to_find
226

227
lookupIE :: ItblEnv -> Name -> IO (Ptr a)
228
lookupIE ie con_nm 
229
   = case lookupNameEnv ie con_nm of
230
        Just (_, a) -> return (castPtr (itblCode a))
231
232
        Nothing
           -> do -- try looking up in the object files.
233
234
                 let sym_to_find1 = nameToCLabel con_nm "con_info"
                 m <- lookupSymbol sym_to_find1
235
236
237
238
                 case m of
                    Just addr -> return addr
                    Nothing 
                       -> do -- perhaps a nullary constructor?
239
240
                             let sym_to_find2 = nameToCLabel con_nm "static_info"
                             n <- lookupSymbol sym_to_find2
241
242
                             case n of
                                Just addr -> return addr
243
244
245
246
247
                                Nothing   -> linkFail "ByteCodeLink.lookupIE" 
                                                (sym_to_find1 ++ " or " ++ sym_to_find2)

linkFail :: String -> String -> IO a
linkFail who what
sof's avatar
sof committed
248
249
250
251
252
253
254
255
256
257
258
259
   = throwDyn (ProgramError $
        unlines [ ""
	        , "During interactive linking, GHCi couldn't find the following symbol:"
		, ' ' : ' ' : what 
		, "This may be due to you not asking GHCi to load extra object files,"
		, "archives or DLLs needed by your current session.  Restart GHCi, specifying"
		, "the missing library using the -L/path/to/object/dir and -lmissinglibname"
		, "flags, or simply by naming the relevant files on the GHCi command line."
		, "Alternatively, this link failure might indicate a bug in GHCi."
		, "If you suspect the latter, please send a bug report to:"
		, "  glasgow-haskell-bugs@haskell.org"
		])
260

261
-- HACKS!!!  ToDo: cleaner
262
263
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
Simon Marlow's avatar
Simon Marlow committed
264
265
266
267
268
269
270
271
272
273
274
   = if pkgid /= mainPackageId
        then package_part ++ '_': qual_name
        else qual_name
  where
        pkgid = modulePackageId mod
        mod = nameModule n
        package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
        module_part  = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
        occ_part     = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
        qual_name = module_part ++ '_':occ_part ++ '_':suffix

275

276
277
primopToCLabel :: PrimOp -> String{-suffix-} -> String
primopToCLabel primop suffix
278
   = let str = "base_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
279
     in --trace ("primopToCLabel: " ++ str)
280
        str
281
282
\end{code}