[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 (file)
--- 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 (file)
--- 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 (file)
--- 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}