X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeLink.lhs;h=c9e2ee5d015ed51d86b3f4e6d156ef558ac0ad1d;hb=8f7779f8d0def3e9671a30ed146cd4c92beed538;hp=5e938173130b725070d2ae9a9e2a11f382a236b9;hpb=388a634754d1d512ddcc207d3b12fd04522d2868;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 5e93817..c9e2ee5 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -16,7 +16,7 @@ module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, #include "HsVersions.h" import Outputable -import Name ( Name, getName, nameModule, toRdrName, isGlobalName ) +import Name ( Name, getName, nameModule, toRdrName, isExternalName ) import RdrName ( rdrNameOcc, rdrNameModule ) import OccName ( occNameString ) import FiniteMap ( FiniteMap, addListToFM, filterFM, @@ -28,37 +28,41 @@ import PrimRep ( PrimRep(..) ) import Constants ( wORD_SIZE ) import Module ( ModuleName, moduleName, moduleNameFS ) import Linker ( lookupSymbol ) -import FastString ( FastString(..) ) +import FastString ( FastString(..), unpackFS ) import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) ) import ByteCodeItbls ( ItblEnv, ItblPtr ) +import FiniteMap +import Panic ( GhcException(..) ) +import Util ( notNull ) +import Control.Monad ( when, foldM ) +import Control.Monad.ST ( runST ) +import Data.Array.IArray ( array ) -import Monad ( when, foldM ) -import ST ( runST ) -import IArray ( array ) -import MArray ( castSTUArray, - newInt64Array, writeInt64Array, - newFloatArray, writeFloatArray, - newDoubleArray, writeDoubleArray, - newIntArray, writeIntArray, - newAddrArray, writeAddrArray, - readWordArray ) -import Foreign ( Word16, Ptr(..), free ) -import Addr ( Word, Addr(..), nullAddr ) -import Weak ( addFinalizer ) -import FiniteMap +import GHC.Word ( Word(..) ) +import Data.Array.MArray ( MArray, newArray_, readArray, writeArray ) +import Data.Array.ST ( castSTUArray ) +import Data.Array.Base ( UArray(..) ) +import Foreign.Ptr ( nullPtr ) +import Foreign ( Word16, free ) +import System.Mem.Weak ( addFinalizer ) +import Data.Int ( Int64 ) + +import System.IO ( fixIO ) +import Control.Exception ( throwDyn ) -import PrelBase ( Int(..) ) -import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, +import GlaExts ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array#, addrToHValue#, mkApUpd0# ) -import IOExts ( fixIO ) -import Exception ( throwDyn ) -import Panic ( GhcException(..) ) + +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Arr ( Array(..) ) +import GHC.IOBase ( IO(..) ) +import GHC.Ptr ( Ptr(..) ) +#else import PrelArr ( Array(..) ) -import ArrayBase ( UArray(..) ) import PrelIOBase ( IO(..) ) -import Int ( Int64 ) - +import Ptr ( Ptr(..) ) +#endif \end{code} %************************************************************************ @@ -102,7 +106,7 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos in mapM (linkBCO ie ce_out) ul_bcos ) let ce_all_additions = zip nms hvals - ce_top_additions = filter (isGlobalName.fst) ce_all_additions + ce_top_additions = filter (isExternalName.fst) ce_all_additions ce_additions = if toplevs_only then ce_top_additions else ce_all_additions ce_out = -- make sure we're not inserting duplicate names into the @@ -121,7 +125,10 @@ linkSomeBCOs toplevs_only ie ce_in ul_bcos data UnlinkedBCO = UnlinkedBCO Name (SizedSeq Word16) -- insns - (SizedSeq Word) -- literals + (SizedSeq (Either Word FastString)) -- literals + -- Either literal words or a pointer to a asciiz + -- string, denoting a label whose *address* should + -- be determined at link time (SizedSeq (Either Name PrimOp)) -- ptrs (SizedSeq Name) -- itbl refs @@ -149,7 +156,7 @@ data HValue = HValue -- dummy type, actually a pointer to some Real Code. -- the command line). filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a filterNameMap mods env - = filterFM (\n _ -> isGlobalName n + = filterFM (\n _ -> isExternalName n && moduleName (nameModule n) `elem` mods) env \end{code} @@ -190,7 +197,7 @@ assembleBCO (ProtoBCO nm instrs origin malloced) in do -- pass 2: generate the instruction, ptr and nonptr bits insns <- return emptySS :: IO (SizedSeq Word16) - lits <- return emptySS :: IO (SizedSeq Word) + lits <- return emptySS :: IO (SizedSeq (Either Word FastString)) ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp)) itbls <- return emptySS :: IO (SizedSeq Name) let init_asm_state = (insns,lits,ptrs,itbls) @@ -202,16 +209,18 @@ assembleBCO (ProtoBCO nm instrs origin malloced) -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive -- objects, since they might get run too early. Disable this until -- we figure out what to do. - -- when (not (null malloced)) (addFinalizer ul_bco (mapM_ zonk malloced)) + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) return ul_bco where - zonk (A# a#) = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) - free (Ptr a#) + zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) + free ptr -- instrs nonptrs ptrs itbls -type AsmState = (SizedSeq Word16, SizedSeq Word, - SizedSeq (Either Name PrimOp), SizedSeq Name) +type AsmState = (SizedSeq Word16, + SizedSeq (Either Word FastString), + SizedSeq (Either Name PrimOp), + SizedSeq Name) data SizedSeq a = SizedSeq !Int [a] emptySS = SizedSeq 0 [] @@ -310,27 +319,31 @@ mkBits findLabel st proto_insns float (st_i0,st_l0,st_p0,st_I0) f = do let ws = mkLitF f - st_l1 <- addListToSS st_l0 ws + st_l1 <- addListToSS st_l0 (map Left ws) return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) double (st_i0,st_l0,st_p0,st_I0) d = do let ws = mkLitD d - st_l1 <- addListToSS st_l0 ws + st_l1 <- addListToSS st_l0 (map Left ws) return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) int (st_i0,st_l0,st_p0,st_I0) i = do let ws = mkLitI i - st_l1 <- addListToSS st_l0 ws + st_l1 <- addListToSS st_l0 (map Left ws) return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) int64 (st_i0,st_l0,st_p0,st_I0) i = do let ws = mkLitI64 i - st_l1 <- addListToSS st_l0 ws + st_l1 <- addListToSS st_l0 (map Left ws) return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) addr (st_i0,st_l0,st_p0,st_I0) a - = do let ws = mkLitA a - st_l1 <- addListToSS st_l0 ws + = do let ws = mkLitPtr a + st_l1 <- addListToSS st_l0 (map Left ws) + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + + litlabel (st_i0,st_l0,st_p0,st_I0) fs + = do st_l1 <- addListToSS st_l0 [Right fs] return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) ptr (st_i0,st_l0,st_p0,st_I0) p @@ -341,6 +354,7 @@ mkBits findLabel st proto_insns = do st_I1 <- addToSS st_I0 (getName dcon) return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1)) + literal st (MachLabel fs) = litlabel st fs literal st (MachWord w) = int st (fromIntegral w) literal st (MachInt j) = int st (fromIntegral j) literal st (MachFloat r) = float st (fromRational r) @@ -376,19 +390,19 @@ mkBits findLabel st proto_insns AddrRep -> stg_gc_unbx_r1_info FloatRep -> stg_gc_f1_info DoubleRep -> stg_gc_d1_info - VoidRep -> nullAddr + VoidRep -> nullPtr -- Interpreter.c spots this special case other -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) -foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr -foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr -foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr -foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr -foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Addr +foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr () +foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr () +foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr () +foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr () +foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr () -foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr -foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr -foreign label "stg_gc_d1_info" stg_gc_d1_info :: Addr +foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr () +foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr () +foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr () -- The size in 16-bit entities of an instruction. instrSize16s :: BCInstr -> Int @@ -430,74 +444,73 @@ instrSize16s instr mkLitI :: Int -> [Word] mkLitF :: Float -> [Word] mkLitD :: Double -> [Word] -mkLitA :: Addr -> [Word] +mkLitPtr :: Ptr () -> [Word] mkLitI64 :: Int64 -> [Word] mkLitF f = runST (do - arr <- newFloatArray ((0::Int),0) - writeFloatArray arr 0 f + arr <- newArray_ ((0::Int),0) + writeArray arr 0 f f_arr <- castSTUArray arr - w0 <- readWordArray f_arr 0 - return [w0] + w0 <- readArray f_arr 0 + return [w0 :: Word] ) mkLitD d | wORD_SIZE == 4 = runST (do - arr <- newDoubleArray ((0::Int),1) - writeDoubleArray arr 0 d + arr <- newArray_ ((0::Int),1) + writeArray arr 0 d d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - w1 <- readWordArray d_arr 1 - return [w0,w1] + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word, w1] ) | wORD_SIZE == 8 = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d + arr <- newArray_ ((0::Int),0) + writeArray arr 0 d d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - return [w0] + w0 <- readArray d_arr 0 + return [w0 :: Word] ) mkLitI64 ii | wORD_SIZE == 4 = runST (do - arr <- newInt64Array ((0::Int),1) - writeInt64Array arr 0 ii + arr <- newArray_ ((0::Int),1) + writeArray arr 0 ii d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - w1 <- readWordArray d_arr 1 - return [w0,w1] + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word,w1] ) | wORD_SIZE == 8 = runST (do - arr <- newInt64Array ((0::Int),0) - writeInt64Array arr 0 ii + arr <- newArray_ ((0::Int),0) + writeArray arr 0 ii d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - return [w0] + w0 <- readArray d_arr 0 + return [w0 :: Word] ) mkLitI i = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i + arr <- newArray_ ((0::Int),0) + writeArray arr 0 i i_arr <- castSTUArray arr - w0 <- readWordArray i_arr 0 - return [w0] + w0 <- readArray i_arr 0 + return [w0 :: Word] ) -mkLitA a +mkLitPtr a = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a + arr <- newArray_ ((0::Int),0) + writeArray arr 0 a a_arr <- castSTUArray arr - w0 <- readWordArray a_arr 0 - return [w0] + w0 <- readArray a_arr 0 + return [w0 :: Word] ) - \end{code} %************************************************************************ @@ -521,8 +534,9 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) ptrs <- listFromSS ptrsSS itbls <- listFromSS itblsSS - linked_ptrs <- mapM (lookupCE ce) ptrs - linked_itbls <- mapM (lookupIE ie) itbls + linked_ptrs <- mapM (lookupCE ce) ptrs + linked_itbls <- mapM (lookupIE ie) itbls + linked_literals <- mapM lookupLiteral literals let n_insns = sizeSS insnsSS n_literals = sizeSS literalsSS @@ -545,7 +559,7 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) :: UArray Int Word16 insns_barr = case insns_arr of UArray lo hi barr -> barr - literals_arr = array (0, n_literals-1) (indexify literals) + literals_arr = array (0, n_literals-1) (indexify linked_literals) :: UArray Int Word literals_barr = case literals_arr of UArray lo hi barr -> barr @@ -566,6 +580,20 @@ newBCO a b c d = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) +lookupLiteral :: Either Word FastString -> IO Word +lookupLiteral (Left w) = return w +lookupLiteral (Right addr_of_label_string) + = do let label_to_find = unpackFS addr_of_label_string + m <- lookupSymbol label_to_find + case m of + -- 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 + Just (Ptr addr) -> return (W# (unsafeCoerce# addr)) + Nothing -> linkFail "ByteCodeLink: can't find label" + label_to_find + lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue lookupCE ce (Right primop) = do let sym_to_find = primopToCLabel primop "closure" @@ -578,7 +606,7 @@ lookupCE ce (Left nm) = case lookupFM ce nm of Just aa -> return aa Nothing - -> ASSERT2(isGlobalName nm, ppr nm) + -> ASSERT2(isExternalName nm, ppr nm) do let sym_to_find = nameToCLabel nm "closure" m <- lookupSymbol sym_to_find case m of @@ -623,13 +651,13 @@ linkFail who what -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix - = _UNPK_(moduleNameFS (rdrNameModule rn)) + = unpackFS(moduleNameFS (rdrNameModule rn)) ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix where rn = toRdrName n primopToCLabel :: PrimOp -> String{-suffix-} -> String primopToCLabel primop suffix - = let str = "PrelPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix + = let str = "GHCziPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix in --trace ("primopToCLabel: " ++ str) str