2 % (c) The University of Glasgow 2000
4 \section[ByteCodeLink]{Bytecode assembler and linker}
8 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
12 ClosureEnv, emptyClosureEnv, extendClosureEnv,
13 linkBCO, lookupStaticPtr
16 #include "HsVersions.h"
18 import ByteCodeItbls ( ItblEnv, ItblPtr )
19 import ByteCodeAsm ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts )
20 import ObjLink ( lookupSymbol )
22 import Name ( Name, nameModule, nameOccName, isExternalName )
24 import OccName ( occNameString )
25 import PrimOp ( PrimOp, primOpOcc )
26 import Module ( moduleString )
27 import FastString ( FastString(..), unpackFS )
29 import Panic ( GhcException(..) )
32 import GHC.Word ( Word(..) )
34 import Data.Array.IArray ( listArray )
35 import Data.Array.Base
36 import GHC.Arr ( STArray(..) )
38 import Control.Exception ( throwDyn )
39 import Control.Monad ( zipWithM )
40 import Control.Monad.ST ( stToIO )
42 import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#,
43 ByteArray#, Array#, addrToHValue#, mkApUpd0# )
45 import GHC.Arr ( Array(..) )
46 import GHC.IOBase ( IO(..) )
47 import GHC.Ptr ( Ptr(..) )
48 import GHC.Base ( writeArray#, RealWorld, Int(..) )
52 %************************************************************************
54 \subsection{Linking interpretables into something we can run}
56 %************************************************************************
59 type ClosureEnv = NameEnv (Name, HValue)
60 newtype HValue = HValue (forall a . a)
62 emptyClosureEnv = emptyNameEnv
64 extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv
65 extendClosureEnv cl_env pairs
66 = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs]
70 %************************************************************************
72 \subsection{Linking interpretables into something we can run}
74 %************************************************************************
78 data BCO# = BCO# ByteArray# -- instrs :: Array Word16#
79 ByteArray# -- literals :: Array Word32#
80 PtrArray# -- ptrs :: Array HValue
81 ByteArray# -- itbls :: Array Addr#
84 linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue
86 = do BCO bco# <- linkBCO' ie ce ul_bco
87 -- SDM: Why do we need mkApUpd0 here? I *think* it's because
88 -- otherwise top-level interpreted CAFs don't get updated
89 -- after evaluation. A top-level BCO will evaluate itself and
90 -- return its value when entered, but it won't update itself.
91 -- Wrapping the BCO in an AP_UPD thunk will take care of the
94 -- Update: the above is true, but now we also have extra invariants:
95 -- (a) An AP thunk *must* point directly to a BCO
96 -- (b) A zero-arity BCO *must* be wrapped in an AP thunk
97 -- (c) An AP is always fully saturated, so we *can't* wrap
98 -- non-zero arity BCOs in an AP thunk.
100 if (unlinkedBCOArity ul_bco > 0)
101 then return (unsafeCoerce# bco#)
102 else case mkApUpd0# bco# of { (# final_bco #) -> return final_bco }
105 linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
106 linkBCO' ie ce (UnlinkedBCO nm arity insns_barr literalsSS ptrsSS itblsSS)
107 -- Raises an IO exception on failure
108 = do let literals = ssElts literalsSS
110 itbls = ssElts itblsSS
112 linked_itbls <- mapM (lookupIE ie) itbls
113 linked_literals <- mapM lookupLiteral literals
115 let n_literals = sizeSS literalsSS
116 n_ptrs = sizeSS ptrsSS
117 n_itbls = sizeSS itblsSS
119 ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
122 ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
124 itbls_arr = listArray (0, n_itbls-1) linked_itbls
125 :: UArray Int ItblPtr
126 itbls_barr = case itbls_arr of UArray lo hi barr -> barr
128 literals_arr = listArray (0, n_literals-1) linked_literals
130 literals_barr = case literals_arr of UArray lo hi barr -> barr
132 newBCO insns_barr literals_barr ptrs_parr itbls_barr
135 -- we recursively link any sub-BCOs while making the ptrs array
136 mkPtrsArray :: ItblEnv -> ClosureEnv -> Int -> [BCOPtr] -> IO (Array Int HValue)
137 mkPtrsArray ie ce n_ptrs ptrs = do
138 marr <- newArray_ (0, n_ptrs-1)
140 fill (BCOPtrName n) i = do
141 ptr <- lookupName ce n
142 unsafeWrite marr i ptr
143 fill (BCOPtrPrimOp op) i = do
144 ptr <- lookupPrimOp op
145 unsafeWrite marr i ptr
146 fill (BCOPtrBCO ul_bco) i = do
147 BCO bco# <- linkBCO' ie ce ul_bco
148 writeArrayBCO marr i bco#
149 zipWithM fill ptrs [0..]
152 newtype IOArray i e = IOArray (STArray RealWorld i e)
154 instance HasBounds IOArray where
155 bounds (IOArray marr) = bounds marr
157 instance MArray IOArray e IO where
158 newArray lu init = stToIO $ do
159 marr <- newArray lu init; return (IOArray marr)
160 newArray_ lu = stToIO $ do
161 marr <- newArray_ lu; return (IOArray marr)
162 unsafeRead (IOArray marr) i = stToIO (unsafeRead marr i)
163 unsafeWrite (IOArray marr) i e = stToIO (unsafeWrite marr i e)
165 -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#.
166 writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO ()
167 writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# ->
168 case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
173 newBCO :: ByteArray# -> ByteArray# -> Array# a -> ByteArray# -> IO BCO
175 = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
178 lookupLiteral :: Either Word FastString -> IO Word
179 lookupLiteral (Left lit) = return lit
180 lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
181 return (W# (unsafeCoerce# addr))
182 -- Can't be bothered to find the official way to convert Addr# to Word#;
183 -- the FFI/Foreign designers make it too damn difficult
184 -- Hence we apply the Blunt Instrument, which works correctly
185 -- on all reasonable architectures anyway
187 lookupStaticPtr :: FastString -> IO (Ptr ())
188 lookupStaticPtr addr_of_label_string
189 = do let label_to_find = unpackFS addr_of_label_string
190 m <- lookupSymbol label_to_find
192 Just ptr -> return ptr
193 Nothing -> linkFail "ByteCodeLink: can't find label"
196 lookupPrimOp :: PrimOp -> IO HValue
198 = do let sym_to_find = primopToCLabel primop "closure"
199 m <- lookupSymbol sym_to_find
201 Just (Ptr addr) -> case addrToHValue# addr of
202 (# hval #) -> return hval
203 Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
205 lookupName :: ClosureEnv -> Name -> IO HValue
207 = case lookupNameEnv ce nm of
208 Just (_,aa) -> return aa
210 -> ASSERT2(isExternalName nm, ppr nm)
211 do let sym_to_find = nameToCLabel nm "closure"
212 m <- lookupSymbol sym_to_find
214 Just (Ptr addr) -> case addrToHValue# addr of
215 (# hval #) -> return hval
216 Nothing -> linkFail "ByteCodeLink.lookupCE" sym_to_find
218 lookupIE :: ItblEnv -> Name -> IO (Ptr a)
220 = case lookupNameEnv ie con_nm of
221 Just (_, Ptr a) -> return (Ptr a)
223 -> do -- try looking up in the object files.
224 let sym_to_find1 = nameToCLabel con_nm "con_info"
225 m <- lookupSymbol sym_to_find1
227 Just addr -> return addr
229 -> do -- perhaps a nullary constructor?
230 let sym_to_find2 = nameToCLabel con_nm "static_info"
231 n <- lookupSymbol sym_to_find2
233 Just addr -> return addr
234 Nothing -> linkFail "ByteCodeLink.lookupIE"
235 (sym_to_find1 ++ " or " ++ sym_to_find2)
237 linkFail :: String -> String -> IO a
239 = throwDyn (ProgramError $
241 , "During interactive linking, GHCi couldn't find the following symbol:"
243 , "This may be due to you not asking GHCi to load extra object files,"
244 , "archives or DLLs needed by your current session. Restart GHCi, specifying"
245 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
246 , "flags, or simply by naming the relevant files on the GHCi command line."
247 , "Alternatively, this link failure might indicate a bug in GHCi."
248 , "If you suspect the latter, please send a bug report to:"
249 , " glasgow-haskell-bugs@haskell.org"
252 -- HACKS!!! ToDo: cleaner
253 nameToCLabel :: Name -> String{-suffix-} -> String
254 nameToCLabel n suffix
255 = moduleString (nameModule n)
256 ++ '_':occNameString (nameOccName n) ++ '_':suffix
258 primopToCLabel :: PrimOp -> String{-suffix-} -> String
259 primopToCLabel primop suffix
260 = let str = "GHCziPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix
261 in --trace ("primopToCLabel: " ++ str)