\begin{code}
{-# OPTIONS_GHC -funbox-strict-fields #-}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module ByteCodeInstr (
BCInstr(..), ProtoBCO(..), bciStackUse, BreakInfo (..)
) where
import PrimOp
import SMRep
-import GHC.Ptr
-
import Module (Module)
import GHC.Exts
-
+import Data.Word
-- ----------------------------------------------------------------------------
-- Bytecode instructions
protoBCOInstrs :: [BCInstr], -- instrs
-- arity and GC info
protoBCOBitmap :: [StgWord],
- protoBCOBitmapSize :: Int,
+ protoBCOBitmapSize :: Word16,
protoBCOArity :: Int,
-- what the BCO came from
protoBCOExpr :: Either [AnnAlt Id VarSet] (AnnExpr Id VarSet),
protoBCOPtrs :: [Either ItblPtr (Ptr ())]
}
-type LocalLabel = Int
+type LocalLabel = Word16
data BCInstr
-- Messing with the stack
- = STKCHECK Int
+ = STKCHECK Word
-- Push locals (existing bits of the stack)
- | PUSH_L !Int{-offset-}
- | PUSH_LL !Int !Int{-2 offsets-}
- | PUSH_LLL !Int !Int !Int{-3 offsets-}
+ | PUSH_L !Word16{-offset-}
+ | PUSH_LL !Word16 !Word16{-2 offsets-}
+ | PUSH_LLL !Word16 !Word16 !Word16{-3 offsets-}
-- Push a ptr (these all map to PUSH_G really)
| PUSH_G Name
| PUSH_ALTS_UNLIFTED (ProtoBCO Name) CgRep
-- Pushing literals
- | PUSH_UBX (Either Literal (Ptr ())) Int
- -- push this int/float/double/addr, on the stack. Int
+ | PUSH_UBX (Either Literal (Ptr ())) Word16
+ -- push this int/float/double/addr, on the stack. Word16
-- 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
| PUSH_APPLY_PPPPP
| PUSH_APPLY_PPPPPP
- | SLIDE Int{-this many-} Int{-down by this much-}
+ | SLIDE Word16{-this many-} Word16{-down by this much-}
-- To do with the heap
- | ALLOC_AP !Int -- make an AP with this many payload words
- | ALLOC_AP_NOUPD !Int -- make an AP_NOUPD with this many payload words
- | ALLOC_PAP !Int !Int -- make a PAP with this arity / payload words
- | MKAP !Int{-ptr to AP is this far down stack-} !Int{-# words-}
- | MKPAP !Int{-ptr to PAP is this far down stack-} !Int{-# words-}
- | UNPACK !Int -- unpack N words from t.o.s Constr
- | PACK DataCon !Int
+ | ALLOC_AP !Word16 -- make an AP with this many payload words
+ | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words
+ | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words
+ | MKAP !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}
+ | MKPAP !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}
+ | UNPACK !Word16 -- unpack N words from t.o.s Constr
+ | PACK DataCon !Word16
-- after assembly, the DataCon is an index into the
-- itbl array
-- For doing case trees
| LABEL LocalLabel
| TESTLT_I Int LocalLabel
| TESTEQ_I Int LocalLabel
+ | TESTLT_W Word LocalLabel
+ | TESTEQ_W Word LocalLabel
| TESTLT_F Float LocalLabel
| TESTEQ_F Float LocalLabel
| TESTLT_D Double LocalLabel
| TESTEQ_D Double LocalLabel
- -- The Int value is a constructor number and therefore
+ -- The Word16 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
+ | TESTLT_P Word16 LocalLabel
+ | TESTEQ_P Word16 LocalLabel
| CASEFAIL
| JMP LocalLabel
- -- For doing calls to C (via glue code generated by ByteCodeFFI)
- | CCALL Int -- stack frame size
- (Ptr ()) -- addr of the glue code
+ -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
+ | CCALL Word16 -- stack frame size
+ (Ptr ()) -- addr of the glue code
+ Word16 -- whether or not the call is interruptible
+ -- (XXX: inefficient, but I don't know
+ -- what the alignment constraints are.)
-- For doing magic ByteArray passing to foreign calls
- | SWIZZLE Int -- to the ptr N words down the stack,
- Int -- add M (interpreted as a signed 16-bit entity)
+ | SWIZZLE Word16 -- to the ptr N words down the stack,
+ Word16 -- add M (interpreted as a signed 16-bit entity)
-- To Infinity And Beyond
| ENTER
| RETURN_UBX CgRep -- return an unlifted value, here's its rep
-- Breakpoints
- | BRK_FUN (MutableByteArray# RealWorld) Int BreakInfo
+ | BRK_FUN (MutableByteArray# RealWorld) Word16 BreakInfo
data BreakInfo
= BreakInfo
{ breakInfo_module :: Module
, breakInfo_number :: {-# UNPACK #-} !Int
- , breakInfo_vars :: [(Id,Int)]
+ , breakInfo_vars :: [(Id,Word16)]
, breakInfo_resty :: Type
}
Right rhs -> pprCoreExpr (deAnnotate rhs)
instance Outputable BCInstr where
- ppr (STKCHECK n) = text "STKCHECK" <+> 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 (STKCHECK n) = text "STKCHECK" <+> ppr n
+ ppr (PUSH_L offset) = text "PUSH_L " <+> ppr offset
+ ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> ppr o1 <+> ppr o2
+ ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
ppr (PUSH_ALTS bco) = text "PUSH_ALTS " <+> ppr bco
ppr (PUSH_ALTS_UNLIFTED bco pk) = text "PUSH_ALTS_UNLIFTED " <+> ppr pk <+> ppr bco
- 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_UBX (Left lit) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
+ ppr (PUSH_UBX (Right aa) nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> text (show aa)
ppr PUSH_APPLY_N = text "PUSH_APPLY_N"
ppr PUSH_APPLY_V = text "PUSH_APPLY_V"
ppr PUSH_APPLY_F = text "PUSH_APPLY_F"
ppr PUSH_APPLY_PPPPP = text "PUSH_APPLY_PPPPP"
ppr PUSH_APPLY_PPPPPP = text "PUSH_APPLY_PPPPPP"
- ppr (SLIDE n d) = text "SLIDE " <+> int n <+> int d
- ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> int sz
- ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> int sz
- ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> int arity <+> int sz
- ppr (MKAP offset sz) = text "MKAP " <+> int sz <+> text "words,"
- <+> int offset <+> text "stkoff"
- ppr (MKPAP offset sz) = text "MKPAP " <+> int sz <+> text "words,"
- <+> int offset <+> text "stkoff"
- ppr (UNPACK sz) = text "UNPACK " <+> int sz
+ ppr (SLIDE n d) = text "SLIDE " <+> ppr n <+> ppr d
+ ppr (ALLOC_AP sz) = text "ALLOC_AP " <+> ppr sz
+ ppr (ALLOC_AP_NOUPD sz) = text "ALLOC_AP_NOUPD " <+> ppr sz
+ ppr (ALLOC_PAP arity sz) = text "ALLOC_PAP " <+> ppr arity <+> ppr sz
+ ppr (MKAP offset sz) = text "MKAP " <+> ppr sz <+> text "words,"
+ <+> ppr offset <+> text "stkoff"
+ ppr (MKPAP offset sz) = text "MKPAP " <+> ppr sz <+> text "words,"
+ <+> ppr offset <+> text "stkoff"
+ ppr (UNPACK sz) = text "UNPACK " <+> ppr sz
ppr (PACK dcon sz) = text "PACK " <+> ppr dcon <+> ppr sz
- ppr (LABEL lab) = text "__" <> int lab <> colon
- ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> int lab
- ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> int lab
- ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> int lab
- ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> int lab
- ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> int lab
- 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 (LABEL lab) = text "__" <> ppr lab <> colon
+ ppr (TESTLT_I i lab) = text "TESTLT_I" <+> int i <+> text "__" <> ppr lab
+ ppr (TESTEQ_I i lab) = text "TESTEQ_I" <+> int i <+> text "__" <> ppr lab
+ ppr (TESTLT_W i lab) = text "TESTLT_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+ ppr (TESTEQ_W i lab) = text "TESTEQ_W" <+> int (fromIntegral i) <+> text "__" <> ppr lab
+ ppr (TESTLT_F f lab) = text "TESTLT_F" <+> float f <+> text "__" <> ppr lab
+ ppr (TESTEQ_F f lab) = text "TESTEQ_F" <+> float f <+> text "__" <> ppr lab
+ ppr (TESTLT_D d lab) = text "TESTLT_D" <+> double d <+> text "__" <> ppr lab
+ ppr (TESTEQ_D d lab) = text "TESTEQ_D" <+> double d <+> text "__" <> ppr lab
+ ppr (TESTLT_P i lab) = text "TESTLT_P" <+> ppr i <+> text "__" <> ppr lab
+ ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
ppr CASEFAIL = text "CASEFAIL"
- ppr (JMP lab) = text "JMP" <+> int lab
- ppr (CCALL off marshall_addr) = text "CCALL " <+> int off
+ ppr (JMP lab) = text "JMP" <+> ppr lab
+ ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off
<+> text "marshall code at"
<+> text (show marshall_addr)
- ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> int stkoff
- <+> text "by" <+> int n
+ <+> (if int == 1
+ then text "(interruptible)"
+ else empty)
+ ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
+ <+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
ppr RETURN = text "RETURN"
ppr (RETURN_UBX pk) = text "RETURN_UBX " <+> ppr pk
- ppr (BRK_FUN breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> int index <+> ppr info
+ ppr (BRK_FUN _breakArray index info) = text "BRK_FUN" <+> text "<array>" <+> ppr index <+> ppr info
-- -----------------------------------------------------------------------------
-- The stack use, in words, of each bytecode insn. These _must_ be
-- 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 :: ProtoBCO a -> Word
protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
-bciStackUse :: BCInstr -> Int
+bciStackUse :: BCInstr -> Word
bciStackUse STKCHECK{} = 0
bciStackUse PUSH_L{} = 1
bciStackUse PUSH_LL{} = 2
bciStackUse PUSH_BCO{} = 1
bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
-bciStackUse (PUSH_UBX _ nw) = nw
+bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
bciStackUse PUSH_APPLY_N{} = 1
bciStackUse PUSH_APPLY_V{} = 1
bciStackUse PUSH_APPLY_F{} = 1
bciStackUse ALLOC_AP{} = 1
bciStackUse ALLOC_AP_NOUPD{} = 1
bciStackUse ALLOC_PAP{} = 1
-bciStackUse (UNPACK sz) = sz
+bciStackUse (UNPACK sz) = fromIntegral sz
bciStackUse LABEL{} = 0
bciStackUse TESTLT_I{} = 0
bciStackUse TESTEQ_I{} = 0
+bciStackUse TESTLT_W{} = 0
+bciStackUse TESTEQ_W{} = 0
bciStackUse TESTLT_F{} = 0
bciStackUse TESTEQ_F{} = 0
bciStackUse TESTLT_D{} = 0
projects / ghc-hetmet.git / blobdiff