X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FByteCodeLink.lhs;h=73ccb9554612ee4f17649dbc3519f584f00bc135;hb=bc5c802181b513216bc88f0d1ec9574157ee05fe;hp=99d0bc203ff0ce0b7acbe0c2d54052fb336b806c;hpb=66a42dafd3dbcd85368132b10cce850ffadab1cb;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 99d0bc2..73ccb95 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -4,47 +4,55 @@ \section[ByteCodeLink]{Bytecode assembler and linker} \begin{code} + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, linkSomeBCOs, filterNameMap + ClosureEnv, HValue, filterNameMap, + linkIModules, linkIExpr, + iNTERP_STACK_CHECK_THRESH ) where #include "HsVersions.h" import Outputable -import Name ( Name, getName, nameModule, toRdrName ) +import Name ( Name, getName, nameModule, toRdrName, isGlobalName ) import RdrName ( rdrNameOcc, rdrNameModule ) import OccName ( occNameString ) import FiniteMap ( FiniteMap, addListToFM, filterFM, addToFM, lookupFM, emptyFM ) import CoreSyn import Literal ( Literal(..) ) +import PrimOp ( PrimOp, primOpOcc ) import PrimRep ( PrimRep(..) ) -import Util ( global ) import Constants ( wORD_SIZE ) import Module ( ModuleName, moduleName, moduleNameFS ) import Linker ( lookupSymbol ) import FastString ( FastString(..) ) import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) ) -import ByteCodeItbls ( ItblEnv ) +import ByteCodeItbls ( ItblEnv, ItblPtr ) -import Monad ( foldM ) +import Monad ( when, foldM ) import ST ( runST ) +import IArray ( array ) import MArray ( castSTUArray, newFloatArray, writeFloatArray, newDoubleArray, writeDoubleArray, newIntArray, writeIntArray, - newAddrArray, writeAddrArray ) -import Foreign ( Word16, Ptr(..) ) -import Addr ( Word ) + newAddrArray, writeAddrArray, + readWordArray ) +import Foreign ( Word16, Ptr(..), free ) +import Addr ( Word, Addr(..), nullAddr ) +import Weak ( addFinalizer ) +import FiniteMap import PrelBase ( Int(..) ) -import PrelAddr ( Addr(..) ) import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, - ByteArray#, Array#, addrToHValue# ) -import IOExts ( IORef, fixIO, readIORef, writeIORef ) -import ArrayBase + ByteArray#, Array#, addrToHValue#, mkApUpd0# ) +import IOExts ( fixIO ) import PrelArr ( Array(..) ) +import ArrayBase ( UArray(..) ) import PrelIOBase ( IO(..) ) \end{code} @@ -56,16 +64,47 @@ import PrelIOBase ( IO(..) ) %************************************************************************ \begin{code} +-- Linking stuff +linkIModules :: ItblEnv -- incoming global itbl env; returned updated + -> ClosureEnv -- incoming global closure env; returned updated + -> [([UnlinkedBCO], ItblEnv)] + -> IO ([HValue], ItblEnv, ClosureEnv) +linkIModules gie gce mods + = do let (bcoss, ies) = unzip mods + bcos = concat bcoss + final_gie = foldr plusFM gie ies + (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos + return (linked_bcos, final_gie, final_gce) + + +linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr + -> IO HValue -- IO BCO# really +linkIExpr ie ce (root_ul_bco, aux_ul_bcos) + = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos + (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco] + return root_bco -- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO] - -> IO (ClosureEnv, [HValue]) -linkSomeBCOs ie ce_in ul_bcos +linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env + -- True <=> add only toplevel BCOs to closure env + -> ItblEnv + -> ClosureEnv + -> [UnlinkedBCO] + -> IO (ClosureEnv, [HValue]) +linkSomeBCOs toplevs_only ie ce_in ul_bcos = do let nms = map nameOfUnlinkedBCO ul_bcos hvals <- fixIO ( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs) in mapM (linkBCO ie ce_out) ul_bcos ) - let ce_out = addListToFM ce_in (zip nms hvals) + + let ce_all_additions = zip nms hvals + ce_top_additions = filter (isGlobalName.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 + -- closure environment, which leads to trouble. + ASSERT (all (not . (`elemFM` ce_in)) (map fst ce_additions)) + addListToFM ce_in ce_additions return (ce_out, hvals) where -- A lazier zip, in which no demand is propagated to the second @@ -77,10 +116,10 @@ linkSomeBCOs ie ce_in ul_bcos data UnlinkedBCO = UnlinkedBCO Name - (SizedSeq Word16) -- insns - (SizedSeq Word) -- literals - (SizedSeq Name) -- ptrs - (SizedSeq Name) -- itbl refs + (SizedSeq Word16) -- insns + (SizedSeq Word) -- literals + (SizedSeq (Either Name PrimOp)) -- ptrs + (SizedSeq Name) -- itbl refs nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm @@ -101,11 +140,13 @@ instance Outputable UnlinkedBCO where type ClosureEnv = FiniteMap Name HValue data HValue = HValue -- dummy type, actually a pointer to some Real Code. --- remove all entries for a given set of modules from the environment +-- remove all entries for a given set of modules from the environment; +-- note that this removes all local names too (ie. temporary bindings from +-- the command line). filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a filterNameMap mods env - = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env - + = filterFM (\n _ -> isGlobalName n && + moduleName (nameModule n) `elem` mods) env \end{code} %************************************************************************ @@ -125,7 +166,7 @@ this BCO. -- Top level assembler fn. assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO -assembleBCO (ProtoBCO nm instrs origin) +assembleBCO (ProtoBCO nm instrs origin malloced) = let -- pass 1: collect up the offsets of the local labels. -- Remember that the first insn starts at offset 1 since offset 0 @@ -146,16 +187,27 @@ assembleBCO (ProtoBCO nm instrs origin) do -- pass 2: generate the instruction, ptr and nonptr bits insns <- return emptySS :: IO (SizedSeq Word16) lits <- return emptySS :: IO (SizedSeq Word) - ptrs <- return emptySS :: IO (SizedSeq Name) + ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp)) itbls <- return emptySS :: IO (SizedSeq Name) let init_asm_state = (insns,lits,ptrs,itbls) (final_insns, final_lits, final_ptrs, final_itbls) - <- mkBits findLabel init_asm_state instrs + <- mkBits findLabel init_asm_state instrs - return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls) + let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls + + -- 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)) + + return ul_bco + where + zonk (A# a#) = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) + free (Ptr a#) -- instrs nonptrs ptrs itbls -type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name) +type AsmState = (SizedSeq Word16, SizedSeq Word, + SizedSeq (Either Name PrimOp), SizedSeq Name) data SizedSeq a = SizedSeq !Int [a] emptySS = SizedSeq 0 [] @@ -178,17 +230,24 @@ mkBits findLabel st proto_insns doInstr :: AsmState -> BCInstr -> IO AsmState doInstr st i = case i of + SWIZZLE stkoff n -> instr3 st i_SWIZZLE stkoff n ARGCHECK n -> instr2 st i_ARGCHECK n + STKCHECK n -> instr2 st i_STKCHECK n PUSH_L o1 -> instr2 st i_PUSH_L o1 PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2 PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3 PUSH_G nm -> do (p, st2) <- ptr st nm instr2 st2 i_PUSH_G p - PUSH_AS nm pk -> do (p, st2) <- ptr st nm + PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm) (np, st3) <- ctoi_itbl st2 pk instr3 st3 i_PUSH_AS p np - PUSH_UBX lit nws -> do (np, st2) <- literal st lit + PUSH_UBX (Left lit) nws + -> do (np, st2) <- literal st lit instr3 st2 i_PUSH_UBX np nws + PUSH_UBX (Right aa) nws + -> do (np, st2) <- addr st aa + instr3 st2 i_PUSH_UBX np nws + PUSH_TAG tag -> instr2 st i_PUSH_TAG tag SLIDE n by -> instr3 st i_SLIDE n by ALLOC n -> instr2 st i_ALLOC n @@ -213,9 +272,12 @@ mkBits findLabel st proto_insns TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l) TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l) CASEFAIL -> instr1 st i_CASEFAIL + JMP l -> instr2 st i_JMP (findLabel l) ENTER -> instr1 st i_ENTER - RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep + RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep instr2 st2 i_RETURN itbl_no + CCALL m_addr -> do (np, st2) <- addr st m_addr + instr2 st2 i_CCALL np i2s :: Int -> Word16 i2s = fromIntegral @@ -270,42 +332,57 @@ 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 (MachWord w) = int st (fromIntegral w) literal st (MachInt j) = int st (fromIntegral j) literal st (MachFloat r) = float st (fromRational r) literal st (MachDouble r) = double st (fromRational r) literal st (MachChar c) = int st c + literal st other = pprPanic "ByteCodeLink.literal" (ppr other) ctoi_itbl st pk = addr st ret_itbl_addr where - ret_itbl_addr = case pk of - PtrRep -> stg_ctoi_ret_R1_info - IntRep -> stg_ctoi_ret_R1_info - CharRep -> stg_ctoi_ret_R1_info - FloatRep -> stg_ctoi_ret_F1_info - DoubleRep -> stg_ctoi_ret_D1_info - _ -> pprPanic "mkBits.ctoi_itbl" (ppr pk) + ret_itbl_addr + = case pk of + PtrRep -> stg_ctoi_ret_R1p_info + WordRep -> stg_ctoi_ret_R1n_info + IntRep -> stg_ctoi_ret_R1n_info + AddrRep -> stg_ctoi_ret_R1n_info + CharRep -> stg_ctoi_ret_R1n_info + FloatRep -> stg_ctoi_ret_F1_info + DoubleRep -> stg_ctoi_ret_D1_info + VoidRep -> stg_ctoi_ret_V_info + other -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk) itoc_itbl st pk = addr st ret_itbl_addr where - ret_itbl_addr = case pk of - IntRep -> stg_gc_unbx_r1_info - FloatRep -> stg_gc_f1_info - DoubleRep -> stg_gc_d1_info + ret_itbl_addr + = case pk of + CharRep -> stg_gc_unbx_r1_ret_info + IntRep -> stg_gc_unbx_r1_ret_info + AddrRep -> stg_gc_unbx_r1_ret_info + FloatRep -> stg_gc_f1_ret_info + DoubleRep -> stg_gc_d1_ret_info + VoidRep -> nullAddr + -- Interpreter.c spots this special case + other -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) -foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_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_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_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_ret_info" stg_gc_unbx_r1_ret_info :: Addr +foreign label "stg_gc_f1_ret_info" stg_gc_f1_ret_info :: Addr +foreign label "stg_gc_d1_ret_info" stg_gc_d1_ret_info :: Addr -- The size in 16-bit entities of an instruction. instrSize16s :: BCInstr -> Int instrSize16s instr = case instr of + STKCHECK _ -> 2 ARGCHECK _ -> 2 PUSH_L _ -> 2 PUSH_LL _ _ -> 3 @@ -329,6 +406,7 @@ instrSize16s instr TESTEQ_D _ _ -> 3 TESTLT_P _ _ -> 3 TESTEQ_P _ _ -> 3 + JMP _ -> 2 CASEFAIL -> 1 ENTER -> 1 RETURN _ -> 2 @@ -399,20 +477,12 @@ mkLitA a \begin{code} {- -data BCO# = BCO# ByteArray# -- instrs :: array Word16# - ByteArray# -- literals :: array Word32# +data BCO# = BCO# ByteArray# -- instrs :: Array Word16# + ByteArray# -- literals :: Array Word32# PtrArray# -- ptrs :: Array HValue ByteArray# -- itbls :: Array Addr# -} -GLOBAL_VAR(v_cafTable, [], [HValue]) - -addCAF :: HValue -> IO () -addCAF x = do xs <- readIORef v_cafTable - --putStrLn ("addCAF " ++ show (1 + length xs)) - writeIORef v_cafTable (x:xs) - - linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) = do insns <- listFromSS insnsSS literals <- listFromSS literalsSS @@ -432,7 +502,7 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) ptrs_parr = case ptrs_arr of Array lo hi parr -> parr itbls_arr = array (0, n_itbls-1) (indexify linked_itbls) - :: UArray Int Addr + :: UArray Int ItblPtr itbls_barr = case itbls_arr of UArray lo hi barr -> barr insns_arr | n_insns > 65535 @@ -452,7 +522,9 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr - return (unsafeCoerce# bco#) + -- WAS: return (unsafeCoerce# bco#) + case mkApUpd0# (unsafeCoerce# bco#) of + (# final_bco #) -> return final_bco data BCO = BCO BCO# @@ -462,22 +534,27 @@ newBCO a b c d = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) -lookupCE :: ClosureEnv -> Name -> IO HValue -lookupCE ce nm +lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue +lookupCE ce (Right primop) + = do m <- lookupSymbol (primopToCLabel primop "closure") + case m of + Just (Ptr addr) -> case addrToHValue# addr of + (# hval #) -> return hval + Nothing -> pprPanic "ByteCodeLink.lookupCE(primop)" (ppr primop) +lookupCE ce (Left nm) = case lookupFM ce nm of Just aa -> return aa Nothing -> do m <- lookupSymbol (nameToCLabel nm "closure") case m of - Just (A# addr) -> case addrToHValue# addr of - (# hval #) -> do addCAF hval - return hval - Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm) + Just (Ptr addr) -> case addrToHValue# addr of + (# hval #) -> return hval + Nothing -> pprPanic "ByteCodeLink.lookupCE" (ppr nm) -lookupIE :: ItblEnv -> Name -> IO Addr +lookupIE :: ItblEnv -> Name -> IO (Ptr a) lookupIE ie con_nm = case lookupFM ie con_nm of - Just (Ptr a) -> return a + Just (Ptr a) -> return (Ptr a) Nothing -> do -- try looking up in the object files. m <- lookupSymbol (nameToCLabel con_nm "con_info") @@ -488,15 +565,21 @@ lookupIE ie con_nm n <- lookupSymbol (nameToCLabel con_nm "static_info") case n of Just addr -> return addr - Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr con_nm) + Nothing -> pprPanic "ByteCodeLink.lookupIE" (ppr con_nm) --- HACK!!! ToDo: cleaner +-- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix = _UNPK_(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 + in --trace ("primopToCLabel: " ++ str) + str + \end{code} %************************************************************************ @@ -534,5 +617,16 @@ i_TESTEQ_P = (bci_TESTEQ_P :: Int) i_CASEFAIL = (bci_CASEFAIL :: Int) i_ENTER = (bci_ENTER :: Int) i_RETURN = (bci_RETURN :: Int) +i_STKCHECK = (bci_STKCHECK :: Int) +i_JMP = (bci_JMP :: Int) +#ifdef bci_CCALL +i_CCALL = (bci_CCALL :: Int) +i_SWIZZLE = (bci_SWIZZLE :: Int) +#else +i_CCALL = error "Sorry pal, you need to bootstrap to use i_CCALL." +i_SWIZZLE = error "Sorry pal, you need to bootstrap to use i_SWIZZLE." +#endif + +iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int) \end{code}