2 % (c) The University of Glasgow 2000-2006
4 ByteCodeLink: Bytecode assembler and linker
7 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
11 ClosureEnv, emptyClosureEnv, extendClosureEnv,
12 linkBCO, lookupStaticPtr, lookupName
16 #include "HsVersions.h"
36 import GHC.Word ( Word(..) )
38 import Data.Array.Base
39 import GHC.Arr ( STArray(..) )
41 import Control.Exception ( throwDyn )
42 import Control.Monad ( zipWithM )
43 import Control.Monad.ST ( stToIO )
46 import GHC.Arr ( Array(..) )
47 import GHC.IOBase ( IO(..) )
48 import GHC.Ptr ( Ptr(..), castPtr )
49 import GHC.Base ( writeArray#, RealWorld, Int(..), Word# )
53 %************************************************************************
55 \subsection{Linking interpretables into something we can run}
57 %************************************************************************
60 type ClosureEnv = NameEnv (Name, HValue)
61 newtype HValue = HValue Any
63 emptyClosureEnv = emptyNameEnv
65 extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
66 extendClosureEnv cl_env pairs
67 = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
71 %************************************************************************
73 \subsection{Linking interpretables into something we can run}
75 %************************************************************************
79 data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
80 ByteArray# -- literals :: Array Word32#
81 PtrArray# -- ptrs :: Array HValue
82 ByteArray# -- itbls :: Array Addr#
85 linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
87 = do BCO bco# <- linkBCO' ie ce ul_bco
88 -- SDM: Why do we need mkApUpd0 here? I *think* it's because
89 -- otherwise top-level interpreted CAFs don't get updated
90 -- after evaluation. A top-level BCO will evaluate itself and
91 -- return its value when entered, but it won't update itself.
92 -- Wrapping the BCO in an AP_UPD thunk will take care of the
95 -- Update: the above is true, but now we also have extra invariants:
96 -- (a) An AP thunk *must* point directly to a BCO
97 -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
98 -- (c) An AP is always fully saturated, so we *can't* wrap
99 -- non-zero arity BCOs in an AP thunk.
101 if (unlinkedBCOArity ul_bco > 0)
102 then return (unsafeCoerce# bco#)
103 else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
106 linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
107 linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
108 -- Raises an IO exception on failure
109 = do let literals = ssElts literalsSS
112 linked_literals <- mapM (lookupLiteral ie) literals
114 let n_literals = sizeSS literalsSS
115 n_ptrs = sizeSS ptrsSS
117 ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
120 ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr
122 literals_arr = listArray (0, n_literals-1) linked_literals
124 literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr
128 newBCO insns_barr literals_barr ptrs_parr arity# bitmap
131 -- we recursively link any sub-BCOs while making the ptrs array
132 mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
133 mkPtrsArray ie ce n_ptrs ptrs = do
134 marr <- newArray_ (0, n_ptrs-1)
136 fill (BCOPtrName n) i = do
137 ptr <- lookupName ce n
138 unsafeWrite marr i ptr
139 fill (BCOPtrPrimOp op) i = do
140 ptr <- lookupPrimOp op
141 unsafeWrite marr i ptr
142 fill (BCOPtrBCO ul_bco) i = do
143 BCO bco# <- linkBCO' ie ce ul_bco
144 writeArrayBCO marr i bco#
145 fill (BCOPtrBreakInfo brkInfo) i =
146 unsafeWrite marr i (unsafeCoerce# brkInfo)
147 fill (BCOPtrArray brkArray) i =
148 unsafeWrite marr i (unsafeCoerce# brkArray)
149 zipWithM fill ptrs [0..]
152 newtype IOArray i e = IOArray (STArray RealWorld i e)
154 instance MArray IOArray e IO where
155 getBounds (IOArray marr) = stToIO $ getBounds marr
156 getNumElements (IOArray marr) = stToIO $ getNumElements marr
157 newArray lu init = stToIO $ do
158 marr <- newArray lu init; return (IOArray marr)
159 newArray_ lu = stToIO $ do
160 marr <- newArray_ lu; return (IOArray marr)
161 unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
162 unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
164 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
165 writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
166 writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# ->
167 case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
171 writeArrayMBA :: IOArray Int a -> Int -> MutableByteArray# a -> IO ()
172 writeArrayMBA (IOArray (STArray _ _ marr#)) (I# i#) mba# = IO $ \s# ->
173 case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
179 newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
180 newBCO instrs lits ptrs arity bitmap
181 = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
182 (# s1, bco #) -> (# s1, BCO bco #)
185 lookupLiteral :: ItblEnv -> BCONPtr -> IO Word
186 lookupLiteral ie (BCONPtrWord lit) = return lit
187 lookupLiteral ie (BCONPtrLbl sym) = do Ptr a# <- lookupStaticPtr sym
188 return (W# (int2Word# (addr2Int# a#)))
189 lookupLiteral ie (BCONPtrItbl nm) = do Ptr a# <- lookupIE ie nm
190 return (W# (int2Word# (addr2Int# a#)))
192 lookupStaticPtr :: FastString -> IO (Ptr ())
193 lookupStaticPtr addr_of_label_string
194 = do let label_to_find = unpackFS addr_of_label_string
195 m <- lookupSymbol label_to_find
197 Just ptr -> return ptr
198 Nothing -> linkFail "ByteCodeLink: can't find label"
201 lookupPrimOp :: PrimOp -> IO HValue
203 = do let sym_to_find = primopToCLabel primop "closure"
204 m <- lookupSymbol sym_to_find
206 Just (Ptr addr) -> case addrToHValue# addr of
207 (# hval #) -> return hval
208 Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
210 lookupName :: ClosureEnv -> Name -> IO HValue
212 = case lookupNameEnv ce nm of
213 Just (_,aa) -> return aa
215 -> ASSERT2(isExternalName nm, ppr nm)
216 do let sym_to_find = nameToCLabel nm "closure"
217 m <- lookupSymbol sym_to_find
219 Just (Ptr addr) -> case addrToHValue# addr of
220 (# hval #) -> return hval
221 Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
223 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
225 = case lookupNameEnv ie con_nm of
226 Just (_, a) -> return (castPtr (itblCode a))
228 -> do -- try looking up in the object files.
229 let sym_to_find1 = nameToCLabel con_nm "con_info"
230 m <- lookupSymbol sym_to_find1
232 Just addr -> return addr
234 -> do -- perhaps a nullary constructor?
235 let sym_to_find2 = nameToCLabel con_nm "static_info"
236 n <- lookupSymbol sym_to_find2
238 Just addr -> return addr
239 Nothing -> linkFail "ByteCodeLink.lookupIE"
240 (sym_to_find1 ++ " or " ++ sym_to_find2)
242 linkFail :: String -> String -> IO a
244 = throwDyn (ProgramError $
246 , "During interactive linking, GHCi couldn't find the following symbol:"
248 , "This may be due to you not asking GHCi to load extra object files,"
249 , "archives or DLLs needed by your current session. Restart GHCi, specifying"
250 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
251 , "flags, or simply by naming the relevant files on the GHCi command line."
252 , "Alternatively, this link failure might indicate a bug in GHCi."
253 , "If you suspect the latter, please send a bug report to:"
254 , " glasgow-haskell-bugs@haskell.org"
257 -- HACKS!!! ToDo: cleaner
258 nameToCLabel :: Name -> String{-suffix-} -> String
259 nameToCLabel n suffix
260 = if pkgid /= mainPackageId
261 then package_part ++ '_': qual_name
264 pkgid = modulePackageId mod
266 package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
267 module_part = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
268 occ_part = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
269 qual_name = module_part ++ '_':occ_part ++ '_':suffix
272 primopToCLabel :: PrimOp -> String{-suffix-} -> String
273 primopToCLabel primop suffix
274 = let str = "base_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
275 in --trace ("primopToCLabel: " ++ str)