\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
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
-#endif
-- Standard libraries
import GHC.Word ( Word(..) )
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
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
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
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
-- 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 #)
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"