\begin{code}
module ByteCodeInstr (
- BCInstr(..), ProtoBCO(..), StgWord, bciStackUse
+ BCInstr(..), ProtoBCO(..), bciStackUse
) where
#include "HsVersions.h"
-#include "MachDeps.h"
+#include "../includes/MachDeps.h"
import Outputable
import Name ( Name )
import CoreSyn
import PprCore ( pprCoreExpr, pprCoreAlt )
import Literal ( Literal )
-import PrimRep ( PrimRep )
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
+import SMRep ( StgWord, CgRep )
import GHC.Ptr
-import Data.Word
-
-- ----------------------------------------------------------------------------
-- Bytecode instructions
--- The appropriate StgWord type for this platform (needed for bitmaps)
-#if SIZEOF_HSWORD == 4
-type StgWord = Word32
-#else
-type StgWord = Word64
-#endif
-
data ProtoBCO a
= ProtoBCO {
protoBCOName :: a, -- name, in some sense
-- Push an alt continuation
| PUSH_ALTS (ProtoBCO Name)
- | PUSH_ALTS_UNLIFTED (ProtoBCO Name) PrimRep
+ | PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep
-- Pushing literals
| PUSH_UBX (Either Literal (Ptr ())) Int
| PUSH_APPLY_PPPP
| PUSH_APPLY_PPPPP
| PUSH_APPLY_PPPPPP
- | PUSH_APPLY_PPPPPPP
| SLIDE Int{-this many-} Int{-down by this much-}
-- To Infinity And Beyond
| ENTER
| RETURN -- return a lifted value
- | RETURN_UBX PrimRep -- return an unlifted value, here's its rep
+ | RETURN_UBX CgRep -- return an unlifted value, here's its rep
-- -----------------------------------------------------------------------------
-- Printing bytecode instructions
ppr PUSH_APPLY_PPPP = text "PUSH_APPLY_PPPP"
ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
- ppr PUSH_APPLY_PPPPPPP = text "PUSH_APPLY_PPPPPPP"
ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> int sz
-- The stack use, in words, of each bytecode insn. These _must_ be
-- correct, or overestimates of reality, to be safe.
+-- NOTE: we aggregate the stack use from case alternatives too, so that
+-- we can do a single stack check at the beginning of a function only.
+
+-- This could all be made more accurate by keeping track of a proper
+-- stack high water mark, but it doesn't seem worth the hassle.
+
+protoBCOStackUse :: ProtoBCO a -> Int
+protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
+
bciStackUse :: BCInstr -> Int
bciStackUse STKCHECK{} = 0
bciStackUse PUSH_L{} = 1
bciStackUse PUSH_G{} = 1
bciStackUse PUSH_PRIMOP{} = 1
bciStackUse PUSH_BCO{} = 1
-bciStackUse PUSH_ALTS{} = 2
-bciStackUse PUSH_ALTS_UNLIFTED{} = 2
+bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_UBX _ nw) = nw
bciStackUse PUSH_APPLY_N{} = 1
bciStackUse PUSH_APPLY_V{} = 1
bciStackUse PUSH_APPLY_PPPP{} = 1
bciStackUse PUSH_APPLY_PPPPP{} = 1
bciStackUse PUSH_APPLY_PPPPPP{} = 1
-bciStackUse PUSH_APPLY_PPPPPPP{} = 1
bciStackUse ALLOC_AP{} = 1
bciStackUse ALLOC_PAP{} = 1
bciStackUse (UNPACK sz) = sz