2 % (c) The University of Glasgow 2000-2006
4 ByteCodeLink: Bytecode assembler and linker
7 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
18 ClosureEnv, emptyClosureEnv, extendClosureEnv,
19 linkBCO, lookupStaticPtr, lookupName
23 #include "HsVersions.h"
40 import GHC.Word ( Word(..) )
42 import Data.Array.Base
43 import GHC.Arr ( STArray(..) )
45 import Control.Monad ( zipWithM )
46 import Control.Monad.ST ( stToIO )
49 import GHC.Arr ( Array(..) )
50 import GHC.IOBase ( IO(..) )
51 import GHC.Ptr ( Ptr(..), castPtr )
52 import GHC.Base ( writeArray#, RealWorld, Int(..), Word# )
58 %************************************************************************
60 \subsection{Linking interpretables into something we can run}
62 %************************************************************************
65 type ClosureEnv = NameEnv (Name, HValue)
66 newtype HValue = HValue Any
68 emptyClosureEnv = emptyNameEnv
70 extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
71 extendClosureEnv cl_env pairs
72 = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
76 %************************************************************************
78 \subsection{Linking interpretables into something we can run}
80 %************************************************************************
84 data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
85 ByteArray# -- literals :: Array Word32#
86 PtrArray# -- ptrs :: Array HValue
87 ByteArray# -- itbls :: Array Addr#
90 linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
92 = do BCO bco# <- linkBCO' ie ce ul_bco
93 -- SDM: Why do we need mkApUpd0 here? I *think* it's because
94 -- otherwise top-level interpreted CAFs don't get updated
95 -- after evaluation. A top-level BCO will evaluate itself and
96 -- return its value when entered, but it won't update itself.
97 -- Wrapping the BCO in an AP_UPD thunk will take care of the
100 -- Update: the above is true, but now we also have extra invariants:
101 -- (a) An AP thunk *must* point directly to a BCO
102 -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
103 -- (c) An AP is always fully saturated, so we *can't* wrap
104 -- non-zero arity BCOs in an AP thunk.
106 if (unlinkedBCOArity ul_bco > 0)
107 then return (unsafeCoerce# bco#)
108 else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
111 linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
112 linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
113 -- Raises an IO exception on failure
114 = do let literals = ssElts literalsSS
117 linked_literals <- mapM (lookupLiteral ie) literals
119 let n_literals = sizeSS literalsSS
120 n_ptrs = sizeSS ptrsSS
122 ptrs_arr <- if n_ptrs > 65535
123 then panic "linkBCO: >= 64k ptrs"
124 else mkPtrsArray ie ce (fromIntegral n_ptrs) ptrs
127 !ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
130 | n_literals > 65535 = panic "linkBCO: >= 64k literals"
131 | n_literals > 0 = (0, fromIntegral n_literals - 1)
133 literals_arr :: UArray Word16 Word
134 literals_arr = listArray litRange linked_literals
135 !literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
139 newBCO insns_barr literals_barr ptrs_parr arity# bitmap
142 -- we recursively link any sub-BCOs while making the ptrs array
143 mkPtrsArray :: ItblEnv -> ClosureEnv -> Word16 -> [BCOPtr] -> IO (Array Word16 HValue)
144 mkPtrsArray ie ce n_ptrs ptrs = do
145 let ptrRange = if n_ptrs > 0 then (0, n_ptrs-1) else (1, 0)
146 marr <- newArray_ ptrRange
148 fill (BCOPtrName n) i = do
149 ptr <- lookupName ce n
150 unsafeWrite marr i ptr
151 fill (BCOPtrPrimOp op) i = do
152 ptr <- lookupPrimOp op
153 unsafeWrite marr i ptr
154 fill (BCOPtrBCO ul_bco) i = do
155 BCO bco# <- linkBCO' ie ce ul_bco
156 writeArrayBCO marr i bco#
157 fill (BCOPtrBreakInfo brkInfo) i =
158 unsafeWrite marr i (unsafeCoerce# brkInfo)
159 fill (BCOPtrArray brkArray) i =
160 unsafeWrite marr i (unsafeCoerce# brkArray)
161 zipWithM fill ptrs [0..]
164 newtype IOArray i e = IOArray (STArray RealWorld i e)
166 instance MArray IOArray e IO where
167 getBounds (IOArray marr) = stToIO $ getBounds marr
168 getNumElements (IOArray marr) = stToIO $ getNumElements marr
169 newArray lu init = stToIO $ do
170 marr <- newArray lu init; return (IOArray marr)
171 newArray_ lu = stToIO $ do
172 marr <- newArray_ lu; return (IOArray marr)
173 unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
174 unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
176 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
177 writeArrayBCO :: IOArray Word16 a -> Int -> BCO# -> IO ()
178 writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
179 case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
183 writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
184 writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
185 case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
191 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
192 newBCO instrs lits ptrs arity bitmap
193 = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
194 (# s1, bco #) -> (# s1, BCO bco #)
197 lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
198 lookupLiteral ie (BCONPtrWord lit) = return lit
199 lookupLiteral ie (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym
200 return (W# (int2Word# (addr2Int# a#)))
201 lookupLiteral ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE ie nm
202 return (W# (int2Word# (addr2Int# a#)))
204 lookupStaticPtr :: FastString -> IO (Ptr ())
205 lookupStaticPtr addr_of_label_string
206 = do let label_to_find = unpackFS addr_of_label_string
207 m <- lookupSymbol label_to_find
209 Just ptr -> return ptr
210 Nothing -> linkFail "ByteCodeLink: can't find label"
213 lookupPrimOp :: PrimOp -> IO HValue
215 = do let sym_to_find = primopToCLabel primop "closure"
216 m <- lookupSymbol sym_to_find
218 Just (Ptr addr) -> case addrToHValue# addr of
219 (# hval #) -> return hval
220 Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
222 lookupName :: ClosureEnv -> Name -> IO HValue
224 = case lookupNameEnv ce nm of
225 Just (_,aa) -> return aa
227 -> ASSERT2(isExternalName nm, ppr nm)
228 do let sym_to_find = nameToCLabel nm "closure"
229 m <- lookupSymbol sym_to_find
231 Just (Ptr addr) -> case addrToHValue# addr of
232 (# hval #) -> return hval
233 Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
235 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
237 = case lookupNameEnv ie con_nm of
238 Just (_, a) -> return (castPtr (itblCode a))
240 -> do -- try looking up in the object files.
241 let sym_to_find1 = nameToCLabel con_nm "con_info"
242 m <- lookupSymbol sym_to_find1
244 Just addr -> return addr
246 -> do -- perhaps a nullary constructor?
247 let sym_to_find2 = nameToCLabel con_nm "static_info"
248 n <- lookupSymbol sym_to_find2
250 Just addr -> return addr
251 Nothing -> linkFail "ByteCodeLink.lookupIE"
252 (sym_to_find1 ++ " or " ++ sym_to_find2)
254 linkFail :: String -> String -> IO a
256 = ghcError (ProgramError $
258 , "During interactive linking, GHCi couldn't find the following symbol:"
260 , "This may be due to you not asking GHCi to load extra object files,"
261 , "archives or DLLs needed by your current session. Restart GHCi, specifying"
262 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
263 , "flags, or simply by naming the relevant files on the GHCi command line."
264 , "Alternatively, this link failure might indicate a bug in GHCi."
265 , "If you suspect the latter, please send a bug report to:"
266 , " glasgow-haskell-bugs@haskell.org"
269 -- HACKS!!! ToDo: cleaner
270 nameToCLabel :: Name -> String{-suffix-} -> String
271 nameToCLabel n suffix
272 = if pkgid /= mainPackageId
273 then package_part ++ '_': qual_name
276 pkgid = modulePackageId mod
277 mod = ASSERT( isExternalName n ) nameModule n
278 package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
279 module_part = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
280 occ_part = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
281 qual_name = module_part ++ '_':occ_part ++ '_':suffix
284 primopToCLabel :: PrimOp -> String{-suffix-} -> String
285 primopToCLabel primop suffix
286 = let str = "ghczmprim_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
287 in --trace ("primopToCLabel: " ++ str)