{-# LANGUAGE CPP, MagicHash #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
--
--  (c) The University of Glasgow 2002-2006
--

-- | ByteCodeInstrs: Bytecode instruction definitions
module ByteCodeInstr (
        BCInstr(..), ProtoBCO(..), bciStackUse,
  ) where

#include "HsVersions.h"
#include "MachDeps.h"

import GhcPrelude

import ByteCodeTypes
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
import StgCmmLayout     ( ArgRep(..) )
import PprCore
import Outputable
import FastString
import Name
import Unique
import Id
import CoreSyn
import Literal
import DataCon
import VarSet
import PrimOp
import SMRep

import Data.Word
import GHC.Stack.CCS (CostCentre)

-- ----------------------------------------------------------------------------
-- Bytecode instructions

data ProtoBCO a
   = ProtoBCO {
        ProtoBCO a -> a
protoBCOName       :: a,          -- name, in some sense
        ProtoBCO a -> [BCInstr]
protoBCOInstrs     :: [BCInstr],  -- instrs
        -- arity and GC info
        ProtoBCO a -> [StgWord]
protoBCOBitmap     :: [StgWord],
        ProtoBCO a -> Word16
protoBCOBitmapSize :: Word16,
        ProtoBCO a -> Int
protoBCOArity      :: Int,
        -- what the BCO came from, for debugging only
        ProtoBCO a -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),
        -- malloc'd pointers
        ProtoBCO a -> [FFIInfo]
protoBCOFFIs       :: [FFIInfo]
   }

type LocalLabel = Word16

data BCInstr
   -- Messing with the stack
   = STKCHECK  Word

   -- Push locals (existing bits of the stack)
   | PUSH_L    !Word16{-offset-}
   | PUSH_LL   !Word16 !Word16{-2 offsets-}
   | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}

   -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
   -- the stack will grow by 8, 16 or 32 bits)
   | PUSH8  !Word16
   | PUSH16 !Word16
   | PUSH32 !Word16

   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
   -- value will take the whole word on the stack (i.e., the stack will gorw by
   -- a word)
   -- This is useful when extracting a packed constructor field for further use.
   -- Currently we expect all values on the stack to take full words, except for
   -- the ones used for PACK (i.e., actually constracting new data types, in
   -- which case we use PUSH{8,16,32})
   | PUSH8_W  !Word16
   | PUSH16_W !Word16
   | PUSH32_W !Word16

   -- Push a ptr  (these all map to PUSH_G really)
   | PUSH_G       Name
   | PUSH_PRIMOP  PrimOp
   | PUSH_BCO     (ProtoBCO Name)

   -- Push an alt continuation
   | PUSH_ALTS          (ProtoBCO Name)
   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep

   -- Pushing 8, 16 and 32 bits of padding (for constructors).
   | PUSH_PAD8
   | PUSH_PAD16
   | PUSH_PAD32

   -- Pushing literals
   | PUSH_UBX8  Literal
   | PUSH_UBX16 Literal
   | PUSH_UBX32 Literal
   | PUSH_UBX   Literal 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
        -- 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 assemble BCOs.

   -- various kinds of application
   | 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{-this many-} Word16{-down by this much-}

   -- To do with the heap
   | 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 Word16 value is a constructor number and therefore
   -- stored in the insn stream rather than as an offset into
   -- the literal pool.
   | TESTLT_P  Word16 LocalLabel
   | TESTEQ_P  Word16 LocalLabel

   | CASEFAIL
   | JMP              LocalLabel

   -- For doing calls to C (via glue code generated by libffi)
   | CCALL            Word16    -- stack frame size
                      (RemotePtr C_ffi_cif) -- addr of the glue code
                      Word16    -- flags.
                                --
                                -- 0x1: call is interruptible
                                -- 0x2: call is unsafe
                                --
                                -- (XXX: inefficient, but I don't know
                                -- what the alignment constraints are.)

   -- For doing magic ByteArray passing to foreign calls
   | 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             -- return a lifted value
   | RETURN_UBX ArgRep -- return an unlifted value, here's its rep

   -- Breakpoints
   | BRK_FUN          Word16 Unique (RemotePtr CostCentre)

-- -----------------------------------------------------------------------------
-- Printing bytecode instructions

instance Outputable a => Outputable (ProtoBCO a) where
   ppr :: ProtoBCO a -> SDoc
ppr (ProtoBCO { protoBCOName :: forall a. ProtoBCO a -> a
protoBCOName       = a
name
                 , protoBCOInstrs :: forall a. ProtoBCO a -> [BCInstr]
protoBCOInstrs     = [BCInstr]
instrs
                 , protoBCOBitmap :: forall a. ProtoBCO a -> [StgWord]
protoBCOBitmap     = [StgWord]
bitmap
                 , protoBCOBitmapSize :: forall a. ProtoBCO a -> Word16
protoBCOBitmapSize = Word16
bsize
                 , protoBCOArity :: forall a. ProtoBCO a -> Int
protoBCOArity      = Int
arity
                 , protoBCOExpr :: forall a.
ProtoBCO a -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
protoBCOExpr       = Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
origin
                 , protoBCOFFIs :: forall a. ProtoBCO a -> [FFIInfo]
protoBCOFFIs       = [FFIInfo]
ffis })
      = (String -> SDoc
text "ProtoBCO" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char '#' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
arity
                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text ([FFIInfo] -> String
forall a. Show a => a -> String
show [FFIInfo]
ffis) SDoc -> SDoc -> SDoc
<> SDoc
colon)
        SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 3 (case Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)
origin of
                      Left alts :: [AnnAlt Id DVarSet]
alts -> [SDoc] -> SDoc
vcat ((SDoc -> SDoc -> SDoc) -> [SDoc] -> [SDoc] -> [SDoc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith SDoc -> SDoc -> SDoc
(<+>) (Char -> SDoc
char '{' SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: SDoc -> [SDoc]
forall a. a -> [a]
repeat (Char -> SDoc
char ';'))
                                                       ((AnnAlt Id DVarSet -> SDoc) -> [AnnAlt Id DVarSet] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (CoreAlt -> SDoc
pprCoreAltShort(CoreAlt -> SDoc)
-> (AnnAlt Id DVarSet -> CoreAlt) -> AnnAlt Id DVarSet -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.AnnAlt Id DVarSet -> CoreAlt
forall bndr annot. AnnAlt bndr annot -> Alt bndr
deAnnAlt) [AnnAlt Id DVarSet]
alts)) SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char '}'
                      Right rhs :: AnnExpr Id DVarSet
rhs -> CoreExpr -> SDoc
pprCoreExprShort (AnnExpr Id DVarSet -> CoreExpr
forall bndr annot. AnnExpr bndr annot -> Expr bndr
deAnnotate AnnExpr Id DVarSet
rhs))
        SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 3 (String -> SDoc
text "bitmap: " SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (Word16 -> String
forall a. Show a => a -> String
show Word16
bsize) SDoc -> SDoc -> SDoc
<+> [StgWord] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgWord]
bitmap)
        SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest 3 ([SDoc] -> SDoc
vcat ((BCInstr -> SDoc) -> [BCInstr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map BCInstr -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BCInstr]
instrs))

-- Print enough of the Core expression to enable the reader to find
-- the expression in the -ddump-prep output.  That is, we need to
-- include at least a binder.

pprCoreExprShort :: CoreExpr -> SDoc
pprCoreExprShort :: CoreExpr -> SDoc
pprCoreExprShort expr :: CoreExpr
expr@(Lam _ _)
  = let
        (bndrs :: [Id]
bndrs, _) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
expr
    in
    Char -> SDoc
char '\\' SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (BindingSite -> Id -> SDoc
forall a. OutputableBndr a => BindingSite -> a -> SDoc
pprBndr BindingSite
LambdaBind) [Id]
bndrs) SDoc -> SDoc -> SDoc
<+> SDoc
arrow SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "..."

pprCoreExprShort (Case _expr :: CoreExpr
_expr var :: Id
var _ty :: Type
_ty _alts :: [CoreAlt]
_alts)
 = String -> SDoc
text "case of" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
var

pprCoreExprShort (Let (NonRec x :: Id
x _) _) = String -> SDoc
text "let" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
x SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit ("= ... in ..."))
pprCoreExprShort (Let (Rec bs :: [(Id, CoreExpr)]
bs) _) = String -> SDoc
text "let {" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst ([(Id, CoreExpr)] -> (Id, CoreExpr)
forall a. [a] -> a
head [(Id, CoreExpr)]
bs)) SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext (String -> PtrString
sLit ("= ...; ... } in ..."))

pprCoreExprShort (Tick t :: Tickish Id
t e :: CoreExpr
e) = Tickish Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Tickish Id
t SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
pprCoreExprShort CoreExpr
e
pprCoreExprShort (Cast e :: CoreExpr
e _) = CoreExpr -> SDoc
pprCoreExprShort CoreExpr
e SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "`cast` T"

pprCoreExprShort e :: CoreExpr
e = CoreExpr -> SDoc
forall b. OutputableBndr b => Expr b -> SDoc
pprCoreExpr CoreExpr
e

pprCoreAltShort :: CoreAlt -> SDoc
pprCoreAltShort :: CoreAlt -> SDoc
pprCoreAltShort (con :: AltCon
con, args :: [Id]
args, expr :: CoreExpr
expr) = AltCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr AltCon
con SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
sep ((Id -> SDoc) -> [Id] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
args) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "->" SDoc -> SDoc -> SDoc
<+> CoreExpr -> SDoc
pprCoreExprShort CoreExpr
expr

instance Outputable BCInstr where
   ppr :: BCInstr -> SDoc
ppr (STKCHECK n :: Word
n)          = String -> SDoc
text "STKCHECK" SDoc -> SDoc -> SDoc
<+> Word -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word
n
   ppr (PUSH_L offset :: Word16
offset)       = String -> SDoc
text "PUSH_L  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset
   ppr (PUSH_LL o1 :: Word16
o1 o2 :: Word16
o2)       = String -> SDoc
text "PUSH_LL " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
o1 SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
o2
   ppr (PUSH_LLL o1 :: Word16
o1 o2 :: Word16
o2 o3 :: Word16
o3)   = String -> SDoc
text "PUSH_LLL" SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
o1 SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
o2 SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
o3
   ppr (PUSH8  offset :: Word16
offset)       = String -> SDoc
text "PUSH8  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset
   ppr (PUSH16 offset :: Word16
offset)       = String -> SDoc
text "PUSH16  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset
   ppr (PUSH32 offset :: Word16
offset)       = String -> SDoc
text "PUSH32  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset
   ppr (PUSH8_W  offset :: Word16
offset)     = String -> SDoc
text "PUSH8_W  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset
   ppr (PUSH16_W offset :: Word16
offset)     = String -> SDoc
text "PUSH16_W  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset
   ppr (PUSH32_W offset :: Word16
offset)     = String -> SDoc
text "PUSH32_W  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset
   ppr (PUSH_G nm :: Name
nm)           = String -> SDoc
text "PUSH_G  " SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
nm
   ppr (PUSH_PRIMOP op :: PrimOp
op)      = String -> SDoc
text "PUSH_G  " SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "GHC.PrimopWrappers."
                                               SDoc -> SDoc -> SDoc
<> PrimOp -> SDoc
forall a. Outputable a => a -> SDoc
ppr PrimOp
op
   ppr (PUSH_BCO bco :: ProtoBCO Name
bco)        = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "PUSH_BCO") 2 (ProtoBCO Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr ProtoBCO Name
bco)
   ppr (PUSH_ALTS bco :: ProtoBCO Name
bco)       = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "PUSH_ALTS") 2 (ProtoBCO Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr ProtoBCO Name
bco)
   ppr (PUSH_ALTS_UNLIFTED bco :: ProtoBCO Name
bco pk :: ArgRep
pk) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text "PUSH_ALTS_UNLIFTED" SDoc -> SDoc -> SDoc
<+> ArgRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr ArgRep
pk) 2 (ProtoBCO Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr ProtoBCO Name
bco)

   ppr PUSH_PAD8             = String -> SDoc
text "PUSH_PAD8"
   ppr PUSH_PAD16            = String -> SDoc
text "PUSH_PAD16"
   ppr PUSH_PAD32            = String -> SDoc
text "PUSH_PAD32"

   ppr (PUSH_UBX8  lit :: Literal
lit)      = String -> SDoc
text "PUSH_UBX8" SDoc -> SDoc -> SDoc
<+> Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit
   ppr (PUSH_UBX16 lit :: Literal
lit)      = String -> SDoc
text "PUSH_UBX16" SDoc -> SDoc -> SDoc
<+> Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit
   ppr (PUSH_UBX32 lit :: Literal
lit)      = String -> SDoc
text "PUSH_UBX32" SDoc -> SDoc -> SDoc
<+> Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit
   ppr (PUSH_UBX lit :: Literal
lit nw :: Word16
nw)     = String -> SDoc
text "PUSH_UBX" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
nw) SDoc -> SDoc -> SDoc
<+> Literal -> SDoc
forall a. Outputable a => a -> SDoc
ppr Literal
lit
   ppr PUSH_APPLY_N          = String -> SDoc
text "PUSH_APPLY_N"
   ppr PUSH_APPLY_V          = String -> SDoc
text "PUSH_APPLY_V"
   ppr PUSH_APPLY_F          = String -> SDoc
text "PUSH_APPLY_F"
   ppr PUSH_APPLY_D          = String -> SDoc
text "PUSH_APPLY_D"
   ppr PUSH_APPLY_L          = String -> SDoc
text "PUSH_APPLY_L"
   ppr PUSH_APPLY_P          = String -> SDoc
text "PUSH_APPLY_P"
   ppr PUSH_APPLY_PP         = String -> SDoc
text "PUSH_APPLY_PP"
   ppr PUSH_APPLY_PPP        = String -> SDoc
text "PUSH_APPLY_PPP"
   ppr PUSH_APPLY_PPPP       = String -> SDoc
text "PUSH_APPLY_PPPP"
   ppr PUSH_APPLY_PPPPP      = String -> SDoc
text "PUSH_APPLY_PPPPP"
   ppr PUSH_APPLY_PPPPPP     = String -> SDoc
text "PUSH_APPLY_PPPPPP"

   ppr (SLIDE n :: Word16
n d :: Word16
d)           = String -> SDoc
text "SLIDE   " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
n SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
d
   ppr (ALLOC_AP sz :: Word16
sz)         = String -> SDoc
text "ALLOC_AP   " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
sz
   ppr (ALLOC_AP_NOUPD sz :: Word16
sz)   = String -> SDoc
text "ALLOC_AP_NOUPD   " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
sz
   ppr (ALLOC_PAP arity :: Word16
arity sz :: Word16
sz)  = String -> SDoc
text "ALLOC_PAP   " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
arity SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
sz
   ppr (MKAP offset :: Word16
offset sz :: Word16
sz)      = String -> SDoc
text "MKAP    " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
sz SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "words,"
                                               SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "stkoff"
   ppr (MKPAP offset :: Word16
offset sz :: Word16
sz)     = String -> SDoc
text "MKPAP   " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
sz SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "words,"
                                               SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
offset SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "stkoff"
   ppr (UNPACK sz :: Word16
sz)           = String -> SDoc
text "UNPACK  " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
sz
   ppr (PACK dcon :: DataCon
dcon sz :: Word16
sz)        = String -> SDoc
text "PACK    " SDoc -> SDoc -> SDoc
<+> DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dcon SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
sz
   ppr (LABEL     lab :: Word16
lab)       = String -> SDoc
text "__"       SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab SDoc -> SDoc -> SDoc
<> SDoc
colon
   ppr (TESTLT_I  i :: Int
i lab :: Word16
lab)     = String -> SDoc
text "TESTLT_I" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTEQ_I  i :: Int
i lab :: Word16
lab)     = String -> SDoc
text "TESTEQ_I" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTLT_W  i :: Word
i lab :: Word16
lab)     = String -> SDoc
text "TESTLT_W" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTEQ_W  i :: Word
i lab :: Word16
lab)     = String -> SDoc
text "TESTEQ_W" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTLT_F  f :: Float
f lab :: Word16
lab)     = String -> SDoc
text "TESTLT_F" SDoc -> SDoc -> SDoc
<+> Float -> SDoc
float Float
f SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTEQ_F  f :: Float
f lab :: Word16
lab)     = String -> SDoc
text "TESTEQ_F" SDoc -> SDoc -> SDoc
<+> Float -> SDoc
float Float
f SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTLT_D  d :: Double
d lab :: Word16
lab)     = String -> SDoc
text "TESTLT_D" SDoc -> SDoc -> SDoc
<+> Double -> SDoc
double Double
d SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTEQ_D  d :: Double
d lab :: Word16
lab)     = String -> SDoc
text "TESTEQ_D" SDoc -> SDoc -> SDoc
<+> Double -> SDoc
double Double
d SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTLT_P  i :: Word16
i lab :: Word16
lab)     = String -> SDoc
text "TESTLT_P" SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (TESTEQ_P  i :: Word16
i lab :: Word16
lab)     = String -> SDoc
text "TESTEQ_P" SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
i SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "__" SDoc -> SDoc -> SDoc
<> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr CASEFAIL              = String -> SDoc
text "CASEFAIL"
   ppr (JMP lab :: Word16
lab)             = String -> SDoc
text "JMP"      SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
lab
   ppr (CCALL off :: Word16
off marshall_addr :: RemotePtr C_ffi_cif
marshall_addr flags :: Word16
flags) = String -> SDoc
text "CCALL   " SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
off
                                                SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "marshall code at"
                                               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (RemotePtr C_ffi_cif -> String
forall a. Show a => a -> String
show RemotePtr C_ffi_cif
marshall_addr)
                                               SDoc -> SDoc -> SDoc
<+> (case Word16
flags of
                                                      0x1 -> String -> SDoc
text "(interruptible)"
                                                      0x2 -> String -> SDoc
text "(unsafe)"
                                                      _   -> SDoc
empty)
   ppr (SWIZZLE stkoff :: Word16
stkoff n :: Word16
n)    = String -> SDoc
text "SWIZZLE " SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "stkoff" SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
stkoff
                                               SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "by" SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
n
   ppr ENTER                 = String -> SDoc
text "ENTER"
   ppr RETURN                = String -> SDoc
text "RETURN"
   ppr (RETURN_UBX pk :: ArgRep
pk)       = String -> SDoc
text "RETURN_UBX  " SDoc -> SDoc -> SDoc
<+> ArgRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr ArgRep
pk
   ppr (BRK_FUN index :: Word16
index uniq :: Unique
uniq _cc :: RemotePtr CostCentre
_cc) = String -> SDoc
text "BRK_FUN" SDoc -> SDoc -> SDoc
<+> Word16 -> SDoc
forall a. Outputable a => a -> SDoc
ppr Word16
index SDoc -> SDoc -> SDoc
<+> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uniq SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "<cc>"

-- -----------------------------------------------------------------------------
-- 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 -> Word
protoBCOStackUse :: ProtoBCO a -> Word
protoBCOStackUse bco :: ProtoBCO a
bco = [Word] -> Word
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((BCInstr -> Word) -> [BCInstr] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map BCInstr -> Word
bciStackUse (ProtoBCO a -> [BCInstr]
forall a. ProtoBCO a -> [BCInstr]
protoBCOInstrs ProtoBCO a
bco))

bciStackUse :: BCInstr -> Word
bciStackUse :: BCInstr -> Word
bciStackUse STKCHECK{}            = 0
bciStackUse PUSH_L{}              = 1
bciStackUse PUSH_LL{}             = 2
bciStackUse PUSH_LLL{}            = 3
bciStackUse PUSH8{}               = 1  -- overapproximation
bciStackUse PUSH16{}              = 1  -- overapproximation
bciStackUse PUSH32{}              = 1  -- overapproximation on 64bit arch
bciStackUse PUSH8_W{}             = 1  -- takes exactly 1 word
bciStackUse PUSH16_W{}            = 1  -- takes exactly 1 word
bciStackUse PUSH32_W{}            = 1  -- takes exactly 1 word
bciStackUse PUSH_G{}              = 1
bciStackUse PUSH_PRIMOP{}         = 1
bciStackUse PUSH_BCO{}            = 1
bciStackUse (PUSH_ALTS bco :: ProtoBCO Name
bco)       = 2 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ ProtoBCO Name -> Word
forall a. ProtoBCO a -> Word
protoBCOStackUse ProtoBCO Name
bco
bciStackUse (PUSH_ALTS_UNLIFTED bco :: ProtoBCO Name
bco _) = 2 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ ProtoBCO Name -> Word
forall a. ProtoBCO a -> Word
protoBCOStackUse ProtoBCO Name
bco
bciStackUse (BCInstr
PUSH_PAD8)           = 1  -- overapproximation
bciStackUse (BCInstr
PUSH_PAD16)          = 1  -- overapproximation
bciStackUse (BCInstr
PUSH_PAD32)          = 1  -- overapproximation on 64bit arch
bciStackUse (PUSH_UBX8 _)         = 1  -- overapproximation
bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation
bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch
bciStackUse (PUSH_UBX _ nw :: Word16
nw)       = Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
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 :: Word16
sz)           = Word16 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
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

-- 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{}               = 0
bciStackUse MKAP{}                = 0
bciStackUse MKPAP{}               = 0
bciStackUse PACK{}                = 1 -- worst case is PACK 0 words