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
15 #include "HsVersions.h"
35 import GHC.Word ( Word(..) )
37 import Data.Array.Base
38 import GHC.Arr ( STArray(..) )
40 import Control.Exception ( throwDyn )
41 import Control.Monad ( zipWithM )
42 import Control.Monad.ST ( stToIO )
44 import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#,
45 ByteArray#, Array#, addrToHValue#, mkApUpd0# )
47 import GHC.Arr ( Array(..) )
48 import GHC.IOBase ( IO(..) )
49 import GHC.Ptr ( Ptr(..) )
50 import GHC.Base ( writeArray#, RealWorld, Int(..) )
54 %************************************************************************
56 \subsection{Linking interpretables into something we can run}
58 %************************************************************************
61 type ClosureEnv = NameEnv (Name, HValue)
62 newtype HValue = HValue (forall a . a)
64 emptyClosureEnv = emptyNameEnv
66 extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
67 extendClosureEnv cl_env pairs
68 = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
72 %************************************************************************
74 \subsection{Linking interpretables into something we can run}
76 %************************************************************************
80 data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
81 ByteArray# -- literals :: Array Word32#
82 PtrArray# -- ptrs :: Array HValue
83 ByteArray# -- itbls :: Array Addr#
86 linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
88 = do BCO bco# <- linkBCO' ie ce ul_bco
89 -- SDM: Why do we need mkApUpd0 here? I *think* it's because
90 -- otherwise top-level interpreted CAFs don't get updated
91 -- after evaluation. A top-level BCO will evaluate itself and
92 -- return its value when entered, but it won't update itself.
93 -- Wrapping the BCO in an AP_UPD thunk will take care of the
96 -- Update: the above is true, but now we also have extra invariants:
97 -- (a) An AP thunk *must* point directly to a BCO
98 -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
99 -- (c) An AP is always fully saturated, so we *can't* wrap
100 -- non-zero arity BCOs in an AP thunk.
102 if (unlinkedBCOArity ul_bco > 0)
103 then return (unsafeCoerce# bco#)
104 else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
107 linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
108 linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS)
109 -- Raises an IO exception on failure
110 = do let literals = ssElts literalsSS
112 itbls = ssElts itblsSS
114 linked_itbls <- mapM (lookupIE ie) itbls
115 linked_literals <- mapM lookupLiteral literals
117 let n_literals = sizeSS literalsSS
118 n_ptrs = sizeSS ptrsSS
119 n_itbls = sizeSS itblsSS
121 ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
124 ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
126 itbls_arr = listArray (0, n_itbls-1) linked_itbls
127 :: UArray Int ItblPtr
128 itbls_barr = case itbls_arr of UArray lo hi barr -> barr
130 literals_arr = listArray (0, n_literals-1) linked_literals
132 literals_barr = case literals_arr of UArray lo hi barr -> barr
136 newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap
139 -- we recursively link any sub-BCOs while making the ptrs array
140 mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
141 mkPtrsArray ie ce n_ptrs ptrs = do
142 marr <- newArray_ (0, n_ptrs-1)
144 fill (BCOPtrName n) i = do
145 ptr <- lookupName ce n
146 unsafeWrite marr i ptr
147 fill (BCOPtrPrimOp op) i = do
148 ptr <- lookupPrimOp op
149 unsafeWrite marr i ptr
150 fill (BCOPtrBCO ul_bco) i = do
151 BCO bco# <- linkBCO' ie ce ul_bco
152 writeArrayBCO marr i bco#
153 zipWithM fill ptrs [0..]
156 newtype IOArray i e = IOArray (STArray RealWorld i e)
158 instance MArray IOArray e IO where
159 getBounds (IOArray marr) = stToIO $ getBounds marr
160 newArray lu init = stToIO $ do
161 marr <- newArray lu init; return (IOArray marr)
162 newArray_ lu = stToIO $ do
163 marr <- newArray_ lu; return (IOArray marr)
164 unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
165 unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
167 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
168 writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
169 writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
170 case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
175 newBCO :: ByteArray# -> ByteArray# -> Array# a
176 -> ByteArray# -> Int# -> ByteArray# -> IO BCO
177 newBCO instrs lits ptrs itbls arity bitmap
178 = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of
179 (# s1, bco #) -> (# s1, BCO bco #)
182 lookupLiteral :: Either Word FastString -> IO Word
183 lookupLiteral (Left lit) = return lit
184 lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
185 return (W# (unsafeCoerce# addr))
186 -- Can't be bothered to find the official way to convert Addr# to Word#;
187 -- the FFI/Foreign designers make it too damn difficult
188 -- Hence we apply the Blunt Instrument, which works correctly
189 -- on all reasonable architectures anyway
191 lookupStaticPtr :: FastString -> IO (Ptr ())
192 lookupStaticPtr addr_of_label_string
193 = do let label_to_find = unpackFS addr_of_label_string
194 m <- lookupSymbol label_to_find
196 Just ptr -> return ptr
197 Nothing -> linkFail "ByteCodeLink: can't find label"
200 lookupPrimOp :: PrimOp -> IO HValue
202 = do let sym_to_find = primopToCLabel primop "closure"
203 m <- lookupSymbol sym_to_find
205 Just (Ptr addr) -> case addrToHValue# addr of
206 (# hval #) -> return hval
207 Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
209 lookupName :: ClosureEnv -> Name -> IO HValue
211 = case lookupNameEnv ce nm of
212 Just (_,aa) -> return aa
214 -> ASSERT2(isExternalName nm, ppr nm)
215 do let sym_to_find = nameToCLabel nm "closure"
216 m <- lookupSymbol sym_to_find
218 Just (Ptr addr) -> case addrToHValue# addr of
219 (# hval #) -> return hval
220 Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
222 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
224 = case lookupNameEnv ie con_nm of
225 Just (_, Ptr a) -> return (Ptr a)
227 -> do -- try looking up in the object files.
228 let sym_to_find1 = nameToCLabel con_nm "con_info"
229 m <- lookupSymbol sym_to_find1
231 Just addr -> return addr
233 -> do -- perhaps a nullary constructor?
234 let sym_to_find2 = nameToCLabel con_nm "static_info"
235 n <- lookupSymbol sym_to_find2
237 Just addr -> return addr
238 Nothing -> linkFail "ByteCodeLink.lookupIE"
239 (sym_to_find1 ++ " or " ++ sym_to_find2)
241 linkFail :: String -> String -> IO a
243 = throwDyn (ProgramError $
245 , "During interactive linking, GHCi couldn't find the following symbol:"
247 , "This may be due to you not asking GHCi to load extra object files,"
248 , "archives or DLLs needed by your current session. Restart GHCi, specifying"
249 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
250 , "flags, or simply by naming the relevant files on the GHCi command line."
251 , "Alternatively, this link failure might indicate a bug in GHCi."
252 , "If you suspect the latter, please send a bug report to:"
253 , " glasgow-haskell-bugs@haskell.org"
256 -- HACKS!!! ToDo: cleaner
257 nameToCLabel :: Name -> String{-suffix-} -> String
258 nameToCLabel n suffix
259 = if pkgid /= mainPackageId
260 then package_part ++ '_': qual_name
263 pkgid = modulePackageId mod
265 package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod)))
266 module_part = unpackFS (zEncodeFS (moduleNameFS (moduleName mod)))
267 occ_part = unpackFS (zEncodeFS (occNameFS (nameOccName n)))
268 qual_name = module_part ++ '_':occ_part ++ '_':suffix
271 primopToCLabel :: PrimOp -> String{-suffix-} -> String
272 primopToCLabel primop suffix
273 = let str = "base_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix
274 in --trace ("primopToCLabel: " ++ str)