module ByteCodeLink (
HValue,
ClosureEnv, emptyClosureEnv, extendClosureEnv,
- linkBCO, lookupStaticPtr
+ linkBCO, lookupStaticPtr, lookupName
,lookupIE
) where
import PackageConfig
import FastString
import Panic
-import Breakpoints
#ifdef DEBUG
import Outputable
import Control.Monad ( zipWithM )
import Control.Monad.ST ( stToIO )
-import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, Int#,
- ByteArray#, Array#, addrToHValue#, mkApUpd0# )
-
+import GHC.Exts
import GHC.Arr ( Array(..) )
import GHC.IOBase ( IO(..) )
import GHC.Ptr ( Ptr(..), castPtr )
-import GHC.Base ( writeArray#, RealWorld, Int(..) )
+import GHC.Base ( writeArray#, RealWorld, Int(..), Word# )
\end{code}
\begin{code}
type ClosureEnv = NameEnv (Name, HValue)
-newtype HValue = HValue (forall a . a)
+newtype HValue = HValue Any
emptyClosureEnv = emptyNameEnv
linkBCO' :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO BCO
-linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS itblsSS)
+linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS)
-- Raises an IO exception on failure
= do let literals = ssElts literalsSS
ptrs = ssElts ptrsSS
- itbls = ssElts itblsSS
- linked_itbls <- mapM (lookupIE ie) itbls
- linked_literals <- mapM lookupLiteral literals
+ linked_literals <- mapM (lookupLiteral ie) literals
let n_literals = sizeSS literalsSS
n_ptrs = sizeSS ptrsSS
- n_itbls = sizeSS itblsSS
ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs
let
ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
- itbls_arr = listArray (0, n_itbls-1) linked_itbls
-
- itbls_barr = case itbls_arr of UArray lo hi barr -> barr
-
literals_arr = listArray (0, n_literals-1) linked_literals
:: UArray Int Word
literals_barr = case literals_arr of UArray lo hi barr -> barr
(I# arity#) = arity
- newBCO insns_barr literals_barr ptrs_parr itbls_barr arity# bitmap
+ newBCO insns_barr literals_barr ptrs_parr arity# bitmap
-- we recursively link any sub-BCOs while making the ptrs array
fill (BCOPtrBCO ul_bco) i = do
BCO bco# <- linkBCO' ie ce ul_bco
writeArrayBCO marr i bco#
+ fill (BCOPtrBreakInfo brkInfo) i =
+ unsafeWrite marr i (unsafeCoerce# brkInfo)
+ fill (BCOPtrArray brkArray) i =
+ unsafeWrite marr i (unsafeCoerce# brkArray)
zipWithM fill ptrs [0..]
unsafeFreeze marr
case (unsafeCoerce# writeArray#) marr# i# bco# s# of { s# ->
(# s#, () #) }
+{-
+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#, () #) }
+-}
+
data BCO = BCO BCO#
-newBCO :: ByteArray# -> ByteArray# -> Array# a
- -> ByteArray# -> Int# -> ByteArray# -> IO BCO
-newBCO instrs lits ptrs itbls arity bitmap
- = IO $ \s -> case newBCO# instrs lits ptrs itbls arity bitmap s of
+newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO
+newBCO instrs lits ptrs arity bitmap
+ = IO $ \s -> case newBCO# instrs lits ptrs arity bitmap s of
(# s1, bco #) -> (# s1, BCO bco #)
-lookupLiteral :: Either Word FastString -> IO Word
-lookupLiteral (Left lit) = return lit
-lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym
- return (W# (unsafeCoerce# addr))
- -- Can't be bothered to find the official way to convert Addr# to Word#;
- -- the FFI/Foreign designers make it too damn difficult
- -- Hence we apply the Blunt Instrument, which works correctly
- -- on all reasonable architectures anyway
+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#)))
lookupStaticPtr :: FastString -> IO (Ptr ())
lookupStaticPtr addr_of_label_string
lookupName ce nm
= case lookupNameEnv ce nm of
Just (_,aa) -> return aa
- Nothing | Just bk <- lookupBogusBreakpointVal nm
- -> return bk
Nothing
-> ASSERT2(isExternalName nm, ppr nm)
do let sym_to_find = nameToCLabel nm "closure"