X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fghci%2FByteCodeLink.lhs;h=65a01085817060dce2bd7913758e7142459243d9;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hp=6bca06a8f39caa7f33510cf9f3e22e06a3d385d4;hpb=a61822e8b6d9d85f5f16df059d5588993bbe39de;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 6bca06a..65a0108 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -1,35 +1,41 @@ % -% (c) The University of Glasgow 2000 +% (c) The University of Glasgow 2000-2006 % -\section[ByteCodeLink]{Bytecode assembler and linker} +ByteCodeLink: Bytecode assembler and linker \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/CodingStyle#Warnings +-- for details + module ByteCodeLink ( HValue, ClosureEnv, emptyClosureEnv, extendClosureEnv, - linkBCO, lookupStaticPtr + linkBCO, lookupStaticPtr, lookupName + ,lookupIE ) where #include "HsVersions.h" -import ByteCodeItbls ( ItblEnv, ItblPtr ) -import ByteCodeAsm ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts ) -import ObjLink ( lookupSymbol ) +import ByteCodeItbls +import ByteCodeAsm +import ObjLink -import Name ( Name, nameModule, nameOccName ) +import Name import NameEnv -import OccName ( occNameFS ) -import PrimOp ( PrimOp, primOpOcc ) +import OccName +import PrimOp import Module -import PackageConfig ( mainPackageId, packageIdFS ) -import FastString ( FastString(..), unpackFS, zEncodeFS ) -import Panic ( GhcException(..) ) +import PackageConfig +import FastString +import Panic #ifdef DEBUG -import Name ( isExternalName ) import Outputable #endif @@ -43,13 +49,11 @@ import Control.Exception ( throwDyn ) 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(..) ) -import GHC.Base ( writeArray#, RealWorld, Int(..) ) +import GHC.Ptr ( Ptr(..), castPtr ) +import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) \end{code} @@ -61,7 +65,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 @@ -107,35 +111,28 @@ linkBCO ie ce ul_bco 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 - :: UArray Int ItblPtr - itbls_barr = case itbls_arr of UArray lo hi barr -> barr + 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 - 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 @@ -152,6 +149,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 @@ -159,6 +160,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 @@ -168,27 +170,31 @@ 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 - -> 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 @@ -224,7 +230,7 @@ lookupName ce nm lookupIE :: ItblEnv -> Name -> IO (Ptr a) lookupIE ie con_nm = case lookupNameEnv ie con_nm of - Just (_, Ptr a) -> return (Ptr a) + Just (_, a) -> return (castPtr (itblCode a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info"