\section[ByteCodeInstrs]{Bytecode instruction definitions}
\begin{code}
-module ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO ) where
+module ByteCodeInstr ( BCInstr(..), ProtoBCO(..),
+ nameOfProtoBCO, bciStackUse ) where
#include "HsVersions.h"
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
-
+import GHC.Ptr
\end{code}
%************************************************************************
-- what the BCO came from
(Either [AnnAlt Id VarSet]
(AnnExpr Id VarSet))
+ [Ptr ()] -- malloc'd; free when BCO is GCd
-nameOfProtoBCO (ProtoBCO nm insns origin) = nm
+nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm
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-}
| PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
-- PrimRep so we know which itbl
-- Pushing literals
- | PUSH_UBX Literal Int
- -- push this int/float/double, NO TAG, on the stack
+ | PUSH_UBX (Either Literal (Ptr ()))
+ Int -- push this int/float/double/addr, NO TAG, on the stack
-- Int is # of words to copy from literal pool
+ -- Eitherness reflects the difficulty of dealing with
+ -- MachAddr here, mostly due to the excessive
+ -- (and unnecessary) restrictions imposed by the designers
+ -- of the new Foreign library. In particular it is quite
+ -- impossible to convert an Addr to any other integral type,
+ -- and it appears impossible to get hold of the bits of an
+ -- addr, even though we need to to assemble BCOs.
+
| PUSH_TAG Int -- push this tag on the stack
| SLIDE Int{-this many-} Int{-down by this much-}
| TESTEQ_P Int LocalLabel
| CASEFAIL
+ | JMP LocalLabel
+
+ -- For doing calls to C (via glue code generated by ByteCodeFFI)
+ | CCALL (Ptr ()) -- of the glue code
+ | SWIZZLE Int Int -- to the ptr N words down the stack,
+ -- add M (interpreted as a signed 16-bit entity)
+
-- To Infinity And Beyond
| ENTER
- | RETURN PrimRep
- -- unboxed value on TOS. Use tag to find underlying ret itbl
- -- and return as per that.
+ | RETURN PrimRep
+ -- unboxed value on TOS. Use tag to find underlying ret itbl
+ -- and return as per that.
+instance Outputable a => Outputable (ProtoBCO a) where
+ ppr (ProtoBCO name instrs origin malloced)
+ = (text "ProtoBCO" <+> ppr name <+> text (show malloced) <> 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
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
ppr (PUSH_G (Left nm)) = text "PUSH_G " <+> ppr nm
- ppr (PUSH_G (Right op)) = text "PUSH_G " <+> text "PrelPrimopWrappers."
+ ppr (PUSH_G (Right op)) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk
- ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
+
+ ppr (PUSH_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
+ ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (int nw) <+> text (show aa)
+
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 (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> int lab
ppr (TESTLT_P i lab) = text "TESTLT_P" <+> int i <+> text "__" <> int lab
ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> int i <+> text "__" <> int lab
+ ppr (JMP lab) = text "JMP" <+> int lab
ppr CASEFAIL = text "CASEFAIL"
ppr ENTER = text "ENTER"
ppr (RETURN pk) = text "RETURN " <+> ppr pk
+ ppr (CCALL marshall_addr) = text "CCALL " <+> text "marshall code at"
+ <+> text (show marshall_addr)
+ ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> int stkoff
+ <+> text "by" <+> int n
+
+-- 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 (JMP lab) = 0
+bciStackUse ENTER = 0
+bciStackUse (RETURN pk) = 0
+bciStackUse (CCALL marshall_addr) = 0
+bciStackUse (SWIZZLE stkoff n) = 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
-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)
\end{code}
projects / ghc-hetmet.git / blobdiff