{-# 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://hackage.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 PprCore
import Type
import Outputable
import FastString
import Name
import Id
import CoreSyn
import Literal
import DataCon
import VarSet
import PrimOp
import SMRep
import ClosureInfo -- CgRep stuff

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

   -- 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 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 CgRep -- 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) <+> text (show 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