From: sewardj Date: Tue, 6 Feb 2001 12:00:17 +0000 (+0000) Subject: [project @ 2001-02-06 12:00:17 by sewardj] X-Git-Tag: Approximately_9120_patches~2737 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3a8cc90c45bea721ff9aceba4b4954bd42662ac8;p=ghc-hetmet.git [project @ 2001-02-06 12:00:17 by sewardj] Support stack overflow checks in interpreted code. The deal is: * If a BCO is reckoned to need less than iNTERP_STACK_CHECK_THRESH words of stack, no stack check insn is added. * If a BCO needs >= iNTERP_STACK_CHECK_THRESH words, an explicit check insn is added. The interpreter ensures at least iNTERP_STACK_CHECK_THRESH words of stack are available before running each BCO, regardless of whether or not the BCO contains an explicit check insn too. By setting iNTERP_STACK_CHECK_THRESH to a suitably large level (currently 50), most BCOs only require the implicit stack check, which avoids the overhead of decoding one extra insn per BCO. BCOs which do have a stack check insn then do 2 stack checks rather than 1 (implicit, then explicit), but this is rare enough that we don't care. --- diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 554692c..883416e 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -39,10 +39,11 @@ import ErrUtils ( showPass, dumpIfSet_dyn ) import Unique ( mkPseudoUnique3 ) import FastString ( FastString(..) ) import PprType ( pprType ) -import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO ) +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) import ByteCodeItbls ( ItblEnv, mkITbls ) import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, linkSomeBCOs, filterNameMap ) + ClosureEnv, HValue, linkSomeBCOs, filterNameMap, + iNTERP_STACK_CHECK_THRESH ) import List ( intersperse, sortBy ) import Foreign ( Ptr(..), mallocBytes ) @@ -169,8 +170,31 @@ ppBCEnv p -- 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 maybe_with_stack_check origin where + -- Overestimate the stack usage (in words) of this BCO, + -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit + -- stack check. (The interpreter always does a stack check + -- for iNTERP_STACK_CHECK_THRESH words at the start of each + -- BCO anyway, so we only need to add an explicit on in the + -- (hopefully rare) cases when the (overestimated) stack use + -- exceeds iNTERP_STACK_CHECK_THRESH. + maybe_with_stack_check + | stack_overest >= 65535 + = pprPanic "mkProtoBCO: stack use won't fit in 16 bits" + (int stack_overest) + | stack_overest >= iNTERP_STACK_CHECK_THRESH + = (STKCHECK stack_overest) : peep_d + | otherwise + = peep_d -- the supposedly common case + + stack_overest = sum (map bciStackUse peep_d) + + 10 {- just to be really really sure -} + + + -- Merge local pushes + peep_d = peep (fromOL instrs_ordlist) + peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest) = PUSH_LLL off1 (off2-1) (off3-2) : peep rest peep (PUSH_L off1 : PUSH_L off2 : rest) diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index c66a872..e903939 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -4,7 +4,8 @@ \section[ByteCodeInstrs]{Bytecode instruction definitions} \begin{code} -module ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO ) where +module ByteCodeInstr ( BCInstr(..), ProtoBCO(..), + nameOfProtoBCO, bciStackUse ) where #include "HsVersions.h" @@ -43,6 +44,7 @@ type LocalLabel = Int data BCInstr -- Messing with the stack = ARGCHECK Int + | STKCHECK Int -- Push locals (existing bits of the stack) | PUSH_L Int{-offset-} | PUSH_LL Int Int{-2 offsets-} @@ -92,7 +94,16 @@ data BCInstr -- and return as per that. +instance Outputable a => Outputable (ProtoBCO a) where + ppr (ProtoBCO name instrs origin) + = (text "ProtoBCO" <+> ppr name <> colon) + $$ nest 6 (vcat (map ppr instrs)) + $$ case origin of + Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts) + Right rhs -> pprCoreExpr (deAnnotate rhs) + instance Outputable BCInstr where + ppr (STKCHECK n) = text "STKCHECK" <+> int n ppr (ARGCHECK n) = text "ARGCHECK" <+> int n ppr (PUSH_L offset) = text "PUSH_L " <+> int offset ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2 @@ -125,11 +136,39 @@ instance Outputable BCInstr where ppr ENTER = text "ENTER" ppr (RETURN pk) = text "RETURN " <+> ppr pk -instance Outputable a => Outputable (ProtoBCO a) where - ppr (ProtoBCO name instrs origin) - = (text "ProtoBCO" <+> ppr name <> colon) - $$ nest 6 (vcat (map ppr instrs)) - $$ case origin of - Left alts -> vcat (map (pprCoreAlt.deAnnAlt) alts) - Right rhs -> pprCoreExpr (deAnnotate rhs) + +-- The stack use, in words, of each bytecode insn. These _must_ be +-- correct, or overestimates of reality, to be safe. +bciStackUse :: BCInstr -> Int +bciStackUse (STKCHECK n) = 0 +bciStackUse (ARGCHECK n) = 0 +bciStackUse (PUSH_L offset) = 1 +bciStackUse (PUSH_LL o1 o2) = 2 +bciStackUse (PUSH_LLL o1 o2 o3) = 3 +bciStackUse (PUSH_G globalish) = 1 +bciStackUse (PUSH_AS nm pk) = 2 +bciStackUse (PUSH_UBX lit nw) = nw +bciStackUse (PUSH_TAG n) = 1 +bciStackUse (ALLOC sz) = 1 +bciStackUse (UNPACK sz) = sz +bciStackUse (UPK_TAG n m k) = n + 1{-tag-} +bciStackUse (LABEL lab) = 0 +bciStackUse (TESTLT_I i lab) = 0 +bciStackUse (TESTEQ_I i lab) = 0 +bciStackUse (TESTLT_F f lab) = 0 +bciStackUse (TESTEQ_F f lab) = 0 +bciStackUse (TESTLT_D d lab) = 0 +bciStackUse (TESTEQ_D d lab) = 0 +bciStackUse (TESTLT_P i lab) = 0 +bciStackUse (TESTEQ_P i lab) = 0 +bciStackUse CASEFAIL = 0 +bciStackUse ENTER = 0 +bciStackUse (RETURN pk) = 0 + +-- These insns actually reduce stack use, but we need the high-tide level, +-- so can't use this info. Not that it matters much. +bciStackUse (SLIDE n d) = 0 +bciStackUse (MKAP offset sz) = 0 +bciStackUse (PACK dcon sz) = 1 -- worst case is PACK 0 words + \end{code} diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 22a083e..39e36fb 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -5,7 +5,8 @@ \begin{code} module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, linkSomeBCOs, filterNameMap + ClosureEnv, HValue, linkSomeBCOs, filterNameMap, + iNTERP_STACK_CHECK_THRESH ) where #include "HsVersions.h" @@ -188,6 +189,7 @@ mkBits findLabel st proto_insns doInstr st i = case i of 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 @@ -320,6 +322,7 @@ foreign label "stg_gc_d1_info" stg_gc_d1_info :: Addr instrSize16s :: BCInstr -> Int instrSize16s instr = case instr of + STKCHECK _ -> 2 ARGCHECK _ -> 2 PUSH_L _ -> 2 PUSH_LL _ _ -> 3 @@ -553,5 +556,8 @@ 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) + +iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int) \end{code}