X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fghci%2FByteCodeLink.lhs;h=389c9e7e29f9f1caf06ed0b6dc2a4a611e747f4c;hb=f2eb50cc42d4ce9e27c2328016b1ddbc2abab04c;hp=9988325dd3317dbdedb72766878ab542bc3e64b0;hpb=b067bdc33ce1a0bb01957b0bcfbb1c516dba53a4;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 9988325..389c9e7 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -9,7 +9,7 @@ ByteCodeLink: Bytecode assembler and linker module ByteCodeLink ( HValue, ClosureEnv, emptyClosureEnv, extendClosureEnv, - linkBCO, lookupStaticPtr + linkBCO, lookupStaticPtr, lookupName ,lookupIE ) where @@ -27,7 +27,6 @@ import Module import PackageConfig import FastString import Panic -import Breakpoints #ifdef DEBUG import Outputable @@ -47,7 +46,7 @@ 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} @@ -59,7 +58,7 @@ import GHC.Base ( writeArray#, RealWorld, Int(..) ) \begin{code} type ClosureEnv = NameEnv (Name, HValue) -newtype HValue = HValue (forall a . a) +newtype HValue = HValue Any emptyClosureEnv = emptyNameEnv @@ -118,11 +117,11 @@ linkBCO' ie ce (UnlinkedBCO nm arity insns_barr bitmap literalsSS ptrsSS) ptrs_arr <- mkPtrsArray ie ce n_ptrs ptrs let - ptrs_parr = case ptrs_arr of Array lo hi parr -> parr + ptrs_parr = case ptrs_arr of Array _lo _hi _n parr -> parr literals_arr = listArray (0, n_literals-1) linked_literals :: UArray Int Word - literals_barr = case literals_arr of UArray lo hi barr -> barr + literals_barr = case literals_arr of UArray _lo _hi _n barr -> barr (I# arity#) = arity @@ -143,6 +142,10 @@ mkPtrsArray ie ce n_ptrs ptrs = do 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 @@ -150,6 +153,7 @@ newtype IOArray i e = IOArray (STArray RealWorld i e) instance MArray IOArray e IO where getBounds (IOArray marr) = stToIO $ getBounds marr + getNumElements (IOArray marr) = stToIO $ getNumElements marr newArray lu init = stToIO $ do marr <- newArray lu init; return (IOArray marr) newArray_ lu = stToIO $ do @@ -159,14 +163,20 @@ instance MArray IOArray e IO where -- XXX HACK: we should really have a new writeArray# primop that takes a BCO#. writeArrayBCO :: IOArray Int a -> Int -> BCO# -> IO () -writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \s# -> +writeArrayBCO (IOArray (STArray _ _ _ marr#)) (I# i#) bco# = IO $ \s# -> 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 - -> Int# -> ByteArray# -> IO BCO +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 #) @@ -201,8 +211,6 @@ lookupName :: ClosureEnv -> Name -> IO HValue 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"