X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeLink.lhs;h=9988325dd3317dbdedb72766878ab542bc3e64b0;hb=b067bdc33ce1a0bb01957b0bcfbb1c516dba53a4;hp=875f1d63314c9d4e645432db550931f5759929a8;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 875f1d6..9988325 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -1,37 +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 #-} module ByteCodeLink ( HValue, ClosureEnv, emptyClosureEnv, extendClosureEnv, linkBCO, lookupStaticPtr + ,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, isExternalName ) +import Name import NameEnv -import OccName ( occNameFS ) -import PrimOp ( PrimOp, primOpOcc ) -import Module ( moduleFS ) -import FastString ( FastString(..), unpackFS, zEncodeFS ) +import OccName +import PrimOp +import Module +import PackageConfig +import FastString +import Panic +import Breakpoints + +#ifdef DEBUG import Outputable -import Panic ( GhcException(..) ) +#endif -- Standard libraries import GHC.Word ( Word(..) ) -import Data.Array.IArray ( listArray ) import Data.Array.Base import GHC.Arr ( STArray(..) ) @@ -39,12 +43,10 @@ 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.Ptr ( Ptr(..), castPtr ) import GHC.Base ( writeArray#, RealWorld, Int(..) ) \end{code} @@ -103,35 +105,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 - 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 @@ -153,10 +148,8 @@ mkPtrsArray ie ce n_ptrs ptrs = do newtype IOArray i e = IOArray (STArray RealWorld i e) -instance HasBounds IOArray where - bounds (IOArray marr) = bounds marr - instance MArray IOArray e IO where + getBounds (IOArray marr) = stToIO $ getBounds marr newArray lu init = stToIO $ do marr <- newArray lu init; return (IOArray marr) newArray_ lu = stToIO $ do @@ -173,20 +166,18 @@ writeArrayBCO (IOArray (STArray _ _ marr#)) (I# i#) bco# = IO $ \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 + -> 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 @@ -210,6 +201,8 @@ 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" @@ -222,7 +215,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" @@ -256,12 +249,21 @@ linkFail who what -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix - = unpackFS (zEncodeFS (moduleFS (nameModule n))) - ++ '_': unpackFS (zEncodeFS (occNameFS (nameOccName n))) ++ '_':suffix + = if pkgid /= mainPackageId + then package_part ++ '_': qual_name + else qual_name + where + pkgid = modulePackageId mod + mod = nameModule n + package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod))) + module_part = unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) + occ_part = unpackFS (zEncodeFS (occNameFS (nameOccName n))) + qual_name = module_part ++ '_':occ_part ++ '_':suffix + primopToCLabel :: PrimOp -> String{-suffix-} -> String primopToCLabel primop suffix - = let str = "GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix + = let str = "base_GHCziPrimopWrappers_" ++ unpackFS (zEncodeFS (occNameFS (primOpOcc primop))) ++ '_':suffix in --trace ("primopToCLabel: " ++ str) str \end{code}