From: sewardj Date: Wed, 20 Dec 2000 14:44:31 +0000 (+0000) Subject: [project @ 2000-12-20 14:44:31 by sewardj] X-Git-Tag: Approximately_9120_patches~3020 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f947b70f9fdfac340fb8c81966dc75b3284cf65b;p=ghc-hetmet.git [project @ 2000-12-20 14:44:31 by sewardj] sync with immediately following ghc/rts/Interpreter.c commit --- diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 9b594c4..157102a 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -23,7 +23,7 @@ import FiniteMap ( FiniteMap, addListToFM, listToFM, filterFM, addToFM, lookupFM, fmToList, emptyFM, plusFM ) import CoreSyn import PprCore ( pprCoreExpr, pprCoreAlt ) -import Literal ( Literal(..) ) +import Literal ( Literal(..), literalPrimRep ) import PrimRep ( PrimRep(..) ) import CoreFVs ( freeVars ) import Type ( typePrimRep ) @@ -244,12 +244,18 @@ data BCInstr | TESTEQ_F Float LocalLabel | TESTLT_D Double LocalLabel | TESTEQ_D Double LocalLabel + + -- The Int value is a constructor number and therefore + -- stored in the insn stream rather than as an offset into + -- the literal pool. | TESTLT_P Int LocalLabel | TESTEQ_P Int LocalLabel + | CASEFAIL -- To Infinity And Beyond | ENTER - | RETURN -- unboxed value on TOS. Use tag to find underlying ret itbl + | RETURN PrimRep + -- unboxed value on TOS. Use tag to find underlying ret itbl -- and return as per that. @@ -281,7 +287,7 @@ instance Outputable BCInstr where ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab ppr CASEFAIL = text "CASEFAIL" ppr ENTER = text "ENTER" - ppr RETURN = text "RETURN" + ppr (RETURN pk) = text "RETURN " <+> ppr pk instance Outputable a => Outputable (ProtoBCO a) where ppr (ProtoBCO name instrs origin) @@ -372,20 +378,23 @@ schemeE :: Int -> Sequel -> BCEnv -> AnnExpr Id VarSet -> BcM BCInstrList schemeE d s p e@(fvs, AnnApp f a) = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnApp f a)) schemeE d s p e@(fvs, AnnVar v) - | isFollowableRep (typePrimRep (idType v)) + | isFollowableRep v_rep = returnBc (schemeT (should_args_be_tagged e) d s 0 p (fvs, AnnVar v)) | otherwise = -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN. let (push, szw) = pushAtom True d p (AnnVar v) in returnBc (push -- value onto stack `snocOL` SLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN) -- go + `snocOL` RETURN v_rep) -- go + where + v_rep = typePrimRep (idType v) schemeE d s p (fvs, AnnLit literal) = let (push, szw) = pushAtom True d p (AnnLit literal) + l_rep = literalPrimRep literal in returnBc (push -- value onto stack `snocOL` SLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN) -- go + `snocOL` RETURN l_rep) -- go schemeE d s p (fvs, AnnLet binds b) = let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs]) @@ -859,8 +868,10 @@ assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO assembleBCO (ProtoBCO nm instrs origin) = let - -- pass 1: collect up the offsets of the local labels - label_env = mkLabelEnv emptyFM 0 instrs + -- pass 1: collect up the offsets of the local labels. + -- Remember that the first insn starts at offset 1 since offset 0 + -- (eventually) will hold the total # of insns. + label_env = mkLabelEnv emptyFM 1 instrs mkLabelEnv env i_offset [] = env mkLabelEnv env i_offset (i:is) @@ -915,7 +926,7 @@ mkBits findLabel st proto_insns 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 - (np, st3) <- ret_itbl st2 pk + (np, st3) <- ctoi_itbl st2 pk instr3 st3 i_PUSH_AS p np PUSH_UBX lit nws -> do (np, st2) <- literal st lit instr3 st2 i_PUSH_UBX np nws @@ -940,13 +951,12 @@ mkBits findLabel st proto_insns instr3 st2 i_TESTLT_D np (findLabel l) TESTEQ_D d l -> do (np, st2) <- double st d instr3 st2 i_TESTEQ_D np (findLabel l) - TESTLT_P i l -> do (np, st2) <- int st i - instr3 st2 i_TESTLT_P np (findLabel l) - TESTEQ_P i l -> do (np, st2) <- int st i - instr3 st2 i_TESTEQ_P np (findLabel l) + 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 ENTER -> instr1 st i_ENTER - RETURN -> instr1 st i_RETURN + RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep + instr2 st2 i_RETURN itbl_no i2s :: Int -> Word16 i2s = fromIntegral @@ -1005,22 +1015,33 @@ mkBits findLabel st proto_insns literal st (MachFloat r) = float st (fromRational r) literal st (MachDouble r) = double st (fromRational r) - ret_itbl st pk + ctoi_itbl st pk = addr st ret_itbl_addr where - ret_itbl_addr - = case pk of - IntRep -> stg_ctoi_ret_R1_info - FloatRep -> stg_ctoi_ret_F1_info - DoubleRep -> stg_ctoi_ret_D1_info - where -- TEMP HACK - stg_ctoi_ret_F1_info = nullAddr - stg_ctoi_ret_D1_info = nullAddr + ret_itbl_addr = case pk of + IntRep -> stg_ctoi_ret_R1_info + FloatRep -> stg_ctoi_ret_F1_info + DoubleRep -> stg_ctoi_ret_D1_info + where -- TEMP HACK + stg_ctoi_ret_F1_info = nullAddr + stg_ctoi_ret_D1_info = nullAddr + + 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 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_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 + -- The size in bytes of an instruction. instrSizeB :: BCInstr -> Int instrSizeB instr @@ -1039,7 +1060,7 @@ instrSizeB instr UNPACK _ -> 4 UPK_TAG _ _ _ -> 8 PACK _ _ -> 6 - LABEL _ -> 4 + LABEL _ -> 0 -- !! TESTLT_I _ _ -> 6 TESTEQ_I _ _ -> 6 TESTLT_F _ _ -> 6 @@ -1050,7 +1071,7 @@ instrSizeB instr TESTEQ_P _ _ -> 6 CASEFAIL -> 2 ENTER -> 2 - RETURN -> 2 + RETURN _ -> 4 -- Make lists of host-sized words for literals, so that when the @@ -1161,7 +1182,11 @@ linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) :: UArray Int Addr itbls_barr = case itbls_arr of UArray lo hi barr -> barr - insns_arr = array (0, n_insns-1) (indexify insns) + insns_arr | n_insns > 65535 + = panic "linkBCO: >= 64k insns in BCO" + | otherwise + = array (0, n_insns) + (indexify (fromIntegral n_insns:insns)) :: UArray Int Word16 insns_barr = case insns_arr of UArray lo hi barr -> barr @@ -1477,7 +1502,6 @@ i_MKAP = (bci_MKAP :: Int) i_UNPACK = (bci_UNPACK :: Int) i_UPK_TAG = (bci_UPK_TAG :: Int) i_PACK = (bci_PACK :: Int) ---i_LABEL = (bci_LABEL :: Int) i_TESTLT_I = (bci_TESTLT_I :: Int) i_TESTEQ_I = (bci_TESTEQ_I :: Int) i_TESTLT_F = (bci_TESTLT_F :: Int)