module GHC.ByteCode.Instr (
BCInstr(..), ProtoBCO(..), bciStackUse,
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Core.Ppr
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Types.Name
import GHC.Types.Unique
import GHC.Types.Id
import GHC.Core
import GHC.Types.Literal
import GHC.Core.DataCon
import GHC.Types.Var.Set
import GHC.Builtin.PrimOps
import GHC.Runtime.Heap.Layout
import Data.Word
import GHC.Stack.CCS (CostCentre)
data ProtoBCO a
= ProtoBCO {
protoBCOName :: a,
protoBCOInstrs :: [BCInstr],
protoBCOBitmap :: [StgWord],
protoBCOBitmapSize :: Word16,
protoBCOArity :: Int,
protoBCOExpr :: Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
protoBCOFFIs :: [FFIInfo]
}
type LocalLabel = Word16
data BCInstr
= STKCHECK Word
| PUSH_L !Word16
| PUSH_LL !Word16 !Word16
| PUSH_LLL !Word16 !Word16 !Word16
| PUSH8 !Word16
| PUSH16 !Word16
| PUSH32 !Word16
| PUSH8_W !Word16
| PUSH16_W !Word16
| PUSH32_W !Word16
| PUSH_G Name
| PUSH_PRIMOP PrimOp
| PUSH_BCO (ProtoBCO Name)
| PUSH_ALTS (ProtoBCO Name)
| PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
| PUSH_PAD8
| PUSH_PAD16
| PUSH_PAD32
| PUSH_UBX8 Literal
| PUSH_UBX16 Literal
| PUSH_UBX32 Literal
| PUSH_UBX Literal Word16
| PUSH_APPLY_N
| PUSH_APPLY_V
| PUSH_APPLY_F
| PUSH_APPLY_D
| PUSH_APPLY_L
| PUSH_APPLY_P
| PUSH_APPLY_PP
| PUSH_APPLY_PPP
| PUSH_APPLY_PPPP
| PUSH_APPLY_PPPPP
| PUSH_APPLY_PPPPPP
| SLIDE Word16 Word16
| ALLOC_AP !Word16
| ALLOC_AP_NOUPD !Word16
| ALLOC_PAP !Word16 !Word16
| MKAP !Word16 !Word16
| MKPAP !Word16 !Word16
| UNPACK !Word16
| PACK DataCon !Word16
| 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
| TESTLT_P Word16 LocalLabel
| TESTEQ_P Word16 LocalLabel
| CASEFAIL
| JMP LocalLabel
| CCALL Word16
(RemotePtr C_ffi_cif)
Word16
| SWIZZLE Word16
Word16
| ENTER
| RETURN
| RETURN_UBX ArgRep
| BRK_FUN Word16 Unique (RemotePtr CostCentre)
instance Outputable a => Outputable (ProtoBCO a) where
ppr (ProtoBCO { protoBCOName = name
, protoBCOInstrs = instrs
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
, protoBCOArity = arity
, protoBCOExpr = origin
, protoBCOFFIs = ffis })
= (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
<+> text (show ffis) <> colon)
$$ nest 3 (case origin of
Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))
(map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'
Right rhs -> pprCoreExprShort (deAnnotate rhs))
$$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)
$$ nest 3 (vcat (map ppr instrs))
pprCoreExprShort :: CoreExpr -> SDoc
pprCoreExprShort expr@(Lam _ _)
= let
(bndrs, _) = collectBinders expr
in
char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."
pprCoreExprShort (Case _expr var _ty _alts)
= text "case of" <+> ppr var
pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))
pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))
pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"
pprCoreExprShort e = pprCoreExpr e
pprCoreAltShort :: CoreAlt -> SDoc
pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr
instance Outputable BCInstr where
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 (PUSH8 offset) = text "PUSH8 " <+> ppr offset
ppr (PUSH16 offset) = text "PUSH16 " <+> ppr offset
ppr (PUSH32 offset) = text "PUSH32 " <+> ppr offset
ppr (PUSH8_W offset) = text "PUSH8_W " <+> ppr offset
ppr (PUSH16_W offset) = text "PUSH16_W " <+> ppr offset
ppr (PUSH32_W offset) = text "PUSH32_W " <+> ppr offset
ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
ppr (PUSH_PRIMOP op) = text "PUSH_G " <+> text "GHC.PrimopWrappers."
<> ppr op
ppr (PUSH_BCO bco) = hang (text "PUSH_BCO") 2 (ppr bco)
ppr (PUSH_ALTS bco) = hang (text "PUSH_ALTS") 2 (ppr bco)
ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
ppr PUSH_PAD8 = text "PUSH_PAD8"
ppr PUSH_PAD16 = text "PUSH_PAD16"
ppr PUSH_PAD32 = text "PUSH_PAD32"
ppr (PUSH_UBX8 lit) = text "PUSH_UBX8" <+> ppr lit
ppr (PUSH_UBX16 lit) = text "PUSH_UBX16" <+> ppr lit
ppr (PUSH_UBX32 lit) = text "PUSH_UBX32" <+> ppr lit
ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
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_D = text "PUSH_APPLY_D"
ppr PUSH_APPLY_L = text "PUSH_APPLY_L"
ppr PUSH_APPLY_P = text "PUSH_APPLY_P"
ppr PUSH_APPLY_PP = text "PUSH_APPLY_PP"
ppr PUSH_APPLY_PPP = text "PUSH_APPLY_PPP"
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 (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 "__" <> 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" <+> ppr lab
ppr (CCALL off marshall_addr flags) = text "CCALL " <+> ppr off
<+> text "marshall code at"
<+> text (show marshall_addr)
<+> (case flags of
0x1 -> text "(interruptible)"
0x2 -> text "(unsafe)"
_ -> 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 index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"
protoBCOStackUse :: ProtoBCO a -> Word
protoBCOStackUse bco = sum (map bciStackUse (protoBCOInstrs bco))
bciStackUse :: BCInstr -> Word
bciStackUse STKCHECK{} = 0
bciStackUse PUSH_L{} = 1
bciStackUse PUSH_LL{} = 2
bciStackUse PUSH_LLL{} = 3
bciStackUse PUSH8{} = 1
bciStackUse PUSH16{} = 1
bciStackUse PUSH32{} = 1
bciStackUse PUSH8_W{} = 1
bciStackUse PUSH16_W{} = 1
bciStackUse PUSH32_W{} = 1
bciStackUse PUSH_G{} = 1
bciStackUse PUSH_PRIMOP{} = 1
bciStackUse PUSH_BCO{} = 1
bciStackUse (PUSH_ALTS bco) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
bciStackUse (PUSH_PAD8) = 1
bciStackUse (PUSH_PAD16) = 1
bciStackUse (PUSH_PAD32) = 1
bciStackUse (PUSH_UBX8 _) = 1
bciStackUse (PUSH_UBX16 _) = 1
bciStackUse (PUSH_UBX32 _) = 1
bciStackUse (PUSH_UBX _ nw) = fromIntegral nw
bciStackUse PUSH_APPLY_N{} = 1
bciStackUse PUSH_APPLY_V{} = 1
bciStackUse PUSH_APPLY_F{} = 1
bciStackUse PUSH_APPLY_D{} = 1
bciStackUse PUSH_APPLY_L{} = 1
bciStackUse PUSH_APPLY_P{} = 1
bciStackUse PUSH_APPLY_PP{} = 1
bciStackUse PUSH_APPLY_PPP{} = 1
bciStackUse PUSH_APPLY_PPPP{} = 1
bciStackUse PUSH_APPLY_PPPPP{} = 1
bciStackUse PUSH_APPLY_PPPPPP{} = 1
bciStackUse ALLOC_AP{} = 1
bciStackUse ALLOC_AP_NOUPD{} = 1
bciStackUse ALLOC_PAP{} = 1
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
bciStackUse TESTEQ_D{} = 0
bciStackUse TESTLT_P{} = 0
bciStackUse TESTEQ_P{} = 0
bciStackUse CASEFAIL{} = 0
bciStackUse JMP{} = 0
bciStackUse ENTER{} = 0
bciStackUse RETURN{} = 0
bciStackUse RETURN_UBX{} = 1
bciStackUse CCALL{} = 0
bciStackUse SWIZZLE{} = 0
bciStackUse BRK_FUN{} = 0
bciStackUse SLIDE{} = 0
bciStackUse MKAP{} = 0
bciStackUse MKPAP{} = 0
bciStackUse PACK{} = 1