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

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

    #include "HsVersions.h"
    #include "../includes/MachDeps.h"

    import ByteCodeItbls    ( ItblPtr )

    import StgCmmLayout     ( ArgRep(..) )
    import PprCore
    import Type
    import Outputable
    import FastString
    import Name
    import Id
    import CoreSyn
    import Literal
    import DataCon
    import VarSet
    import PrimOp
    import SMRep

    import Module (Module)
    import GHC.Exts
    import Data.Word

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

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

    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 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 literals
       | 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
            -- 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
                          (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          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          (MutableByteArray# RealWorld) Word16 BreakInfo

    data BreakInfo
       = BreakInfo
       { breakInfo_module :: Module
       , breakInfo_number :: {-# UNPACK #-} !Int
       , breakInfo_vars   :: [(Id,Word16)]
       , breakInfo_resty  :: Type
       }

    instance Outputable BreakInfo where
       ppr info = text "BreakInfo" <+>
                  parens (ppr (breakInfo_module info) <+>
                          ppr (breakInfo_number info) <+>
                          ppr (breakInfo_vars info) <+>
                          ppr (breakInfo_resty info))

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

    instance Outputable a => Outputable (ProtoBCO a) where
       ppr (ProtoBCO name instrs bitmap bsize arity origin malloced)
          = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
                    <+> text (show malloced) <> 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))

    -- 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 expr@(Lam _ _)
      = let
            (bndrs, _) = collectBinders expr
        in
        char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> ptext (sLit "...")

    pprCoreExprShort (Case _expr var _ty _alts)
     = ptext (sLit "case of") <+> ppr var

    pprCoreExprShort (Let (NonRec x _) _) = ptext (sLit "let") <+> ppr x <+> ptext (sLit ("= ... in ..."))
    pprCoreExprShort (Let (Rec bs) _) = ptext (sLit "let {") <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))

    pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e
    pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> ptext (sLit "`cast` T")

    pprCoreExprShort e = pprCoreExpr e

    pprCoreAltShort :: CoreAlt -> SDoc
    pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> ptext (sLit "->") <+> 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 (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_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_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 int) = text "CCALL   " <+> ppr off
                                                    <+> text "marshall code at"
                                                   <+> text (show marshall_addr)
                                                   <+> (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>" <+> ppr index <+> ppr info

    -- -----------------------------------------------------------------------------
    -- 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 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 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_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

    -- 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