From 14aa7ae98d17a34a0514b529ffb1587a5edea9b7 Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 3 Jan 2001 16:45:04 +0000 Subject: [PATCH] [project @ 2001-01-03 16:45:04 by sewardj] Updates to track bug fixes in the bytecode interpreter. --- ghc/compiler/ghci/ByteCodeGen.lhs | 96 ++++++++++++++++++++++--------------- 1 file changed, 58 insertions(+), 38 deletions(-) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 157102a..5e24c8a 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -53,10 +53,12 @@ import MArray ( castSTUArray, newAddrArray, writeAddrArray ) import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..), malloc, castPtr, plusPtr ) -import Addr ( Word, Addr, addrToInt, nullAddr ) +import Addr ( Word, addrToInt, nullAddr ) import Bits ( Bits(..), shiftR ) -import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array# ) +import PrelAddr ( Addr(..) ) +import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, + ByteArray#, Array#, addrToHValue# ) import IOExts ( IORef, fixIO ) import ArrayBase import PrelArr ( Array(..) ) @@ -132,36 +134,37 @@ 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 - top_level_binders = map nameOfUnlinkedBCO bcos - final_gie = foldr plusFM gie ies - - (new_bcos, new_gce) <- - fixIO (\ ~(new_bcos, new_gce) -> do - new_bcos <- linkBCOs final_gie new_gce bcos - let new_gce = addListToFM gce (zip top_level_binders new_bcos) - return (new_bcos, new_gce)) - - return (new_bcos, final_gie, new_gce) +linkIModules gie gce mods + = do let (bcoss, ies) = unzip mods + bcos = concat bcoss + final_gie = foldr plusFM gie ies + (final_gce, linked_bcos) <- linkSomeBCOs 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 let aux_ul_binders = map nameOfUnlinkedBCO aux_ul_bcos - (aux_bcos, aux_ce) - <- fixIO - (\ ~(aux_bcos, new_ce) - -> do new_bcos <- linkBCOs ie new_ce aux_ul_bcos - let new_ce = addListToFM ce (zip aux_ul_binders new_bcos) - return (new_bcos, new_ce) - ) - [root_bco] - <- linkBCOs ie aux_ce [root_ul_bco] + = do (aux_ce, _) <- linkSomeBCOs ie ce aux_ul_bcos + (_, [root_bco]) <- linkSomeBCOs 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 + = 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) + return (ce_out, hvals) + where + -- A lazier zip, in which no demand is propagated to the second + -- list unless some demand is propagated to the snd of one of the + -- result list elems. + zipLazily [] ys = [] + zipLazily (x:xs) ys = (x, head ys) : zipLazily xs (tail ys) data UnlinkedBCO @@ -270,7 +273,8 @@ instance Outputable BCInstr where ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d ppr (ALLOC sz) = text "ALLOC " <+> int sz - ppr (MKAP offset sz) = text "MKAP " <+> int offset <+> int sz + ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words," + <+> int offset <+> text "stkoff" ppr (UNPACK sz) = text "UNPACK " <+> int sz ppr (UPK_TAG n m k) = text "UPK_TAG " <+> int n <> text "words" <+> int m <> text "conoff" @@ -328,7 +332,7 @@ type BCEnv = FiniteMap Id Int -- To find vars on the stack -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. mkProtoBCO nm instrs_ordlist origin - = ProtoBCO nm (peep (fromOL instrs_ordlist)) origin + = ProtoBCO nm (id {-peep-} (fromOL instrs_ordlist)) origin where peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) = PUSH_LLL off1 (off2-1) (off3-2) : peep rest @@ -345,7 +349,19 @@ mkProtoBCO nm instrs_ordlist origin -- variable to which this value was bound, so as to give the -- resulting BCO a name. schemeR :: (Id, AnnExpr Id VarSet) -> BcM () -schemeR (nm, rhs) = schemeR_wrk rhs nm (collect [] rhs) +schemeR (nm, rhs) +{- + | trace (showSDoc ( + (char ' ' + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs + $$ pprCoreExpr (deAnnotate rhs) + $$ char ' ' + ))) False + = undefined +-} + | otherwise + = schemeR_wrk rhs nm (collect [] rhs) + collect xs (_, AnnLam x e) = collect (if isTyVar x then xs else (x:xs)) e @@ -358,7 +374,7 @@ schemeR_wrk original_body nm (args, body) szsw_args = map taggedIdSizeW all_args szw_args = sum szsw_args p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args)) - argcheck = if null args then nilOL else unitOL (ARGCHECK szw_args) + argcheck = {-if null args then nilOL else-} unitOL (ARGCHECK szw_args) in schemeE szw_args 0 p_init body `thenBc` \ body_code -> emitBc (mkProtoBCO (getName nm) (appOL argcheck body_code) (Right original_body)) @@ -401,6 +417,8 @@ schemeE d s p (fvs, AnnLet binds b) AnnRec xs_n_rhss -> unzip xs_n_rhss n = length xs fvss = map (filter (not.isTyVar).varSetElems.fst) rhss + + -- Sizes of tagged free vars, + 1 for the fn sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss -- This p', d' defn is safe because all the items being pushed @@ -627,6 +645,7 @@ pushAtom False d p (AnnLit lit) MachInt i -> code IntRep MachFloat r -> code FloatRep MachDouble r -> code DoubleRep + MachChar c -> code CharRep where code rep = let size_host_words = untaggedSizeW rep @@ -1014,6 +1033,7 @@ mkBits findLabel st proto_insns 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 ctoi_itbl st pk = addr st ret_itbl_addr @@ -1155,18 +1175,13 @@ GLOBAL_VAR(v_cafTable, [], [HValue]) -- = do linked_expr <- linkIExpr ie ce (root_bco, other_bcos) -- return linked_expr - -linkBCOs :: ItblEnv -> ClosureEnv -> [UnlinkedBCO] - -> IO [HValue] -- IO [BCO#] really -linkBCOs ie ce binds = mapM (linkBCO ie ce) binds - linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) = do insns <- listFromSS insnsSS literals <- listFromSS literalsSS ptrs <- listFromSS ptrsSS itbls <- listFromSS itblsSS - let linked_ptrs = map (lookupCE ce) ptrs + linked_ptrs <- mapM (lookupCE ce) ptrs linked_itbls <- mapM (lookupIE ie) itbls let n_insns = sizeSS insnsSS @@ -1209,11 +1224,16 @@ newBCO a b c d = IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #)) -lookupCE :: ClosureEnv -> Name -> HValue +lookupCE :: ClosureEnv -> Name -> IO HValue lookupCE ce nm = case lookupFM ce nm of - Just aa -> unsafeCoerce# aa - Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm) + Just aa -> return aa + Nothing + -> do m <- lookupSymbol (nameToCLabel nm "closure") + case m of + Just (A# addr) -> case addrToHValue# addr of + (# hval #) -> return hval + Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm) lookupIE :: ItblEnv -> Name -> IO Addr lookupIE ie con_nm -- 1.7.10.4