{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

{-# OPTIONS_GHC -funbox-strict-fields #-}

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