\section[ByteCodeGen]{Generate bytecode from Core}
\begin{code}
-module ByteCodeGen ( byteCodeGen ) where
+module ByteCodeGen ( byteCodeGen, assembleBCO ) where
#include "HsVersions.h"
---import Id
---import Name
---import PrimOp
-
import Outputable
import Name ( Name, getName )
import Id ( Id, idType, isDataConId_maybe )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
- addToFM, lookupFM, fmToList )
+ addToFM, lookupFM, fmToList, emptyFM )
import CoreSyn
import Literal ( Literal(..) )
import PrimRep ( PrimRep(..) )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe )
import VarSet ( VarSet, varSetElems )
import PrimRep ( getPrimRepSize, isFollowableRep )
---import FastTypes
+import Constants ( wORD_SIZE )
+
+import Foreign ( Addr, Word16, Word32, nullAddr )
+import ST ( runST )
+import MutableArray ( readWord32Array,
+ newFloatArray, writeFloatArray,
+ newDoubleArray, writeDoubleArray,
+ newIntArray, writeIntArray,
+ newAddrArray, writeAddrArray )
\end{code}
Entry point.
BcM_State bcos final_ctr -> bcos
\end{code}
-The real machinery.
+
+%************************************************************************
+%* *
+\subsection{Bytecodes, and Outputery.}
+%* *
+%************************************************************************
\begin{code}
+
type LocalLabel = Int
data BCInstr
| CASEFAIL
-- To Infinity And Beyond
| ENTER
-\end{code}
-
-The object format for this is: 16 bits for the opcode, and 16 for each
-field -- so the code can be considered a sequence of 16-bit ints.
-Each field denotes either a stack offset or number of items on the
-stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
-index into the literal table (eg PUSH_I/D/L), or a bytecode address in
-this BCO.
-
-\begin{code}
-
---data BCO a = BCO [Word16] -- instructions
--- [Word8] -- literal pool
--- [a] -- Names or HValues
-
---assembleBCO :: ProtoBCO -> BCO
---assembleBCO (ProtoBCO nm instrs)
--- = -- pass 1: collect up the offsets of the local labels,
--- -- and also the literals and
-
instance Outputable BCInstr where
ppr (ARGCHECK n) = text "ARGCHECK" <+> int n
= vcat (map f discrs_n_codes)
where f (discr, code) = ppr discr <> colon <+> vcat (map ppr (fromOL code))
-
-type BCInstrList = OrdList BCInstr
-
-data ProtoBCO a = ProtoBCO a BCInstrList
-
instance Outputable a => Outputable (ProtoBCO a) where
ppr (ProtoBCO name instrs)
= (text "ProtoBCO" <+> ppr name <> colon)
$$ nest 6 (vcat (map ppr (fromOL instrs)))
+\end{code}
+%************************************************************************
+%* *
+\subsection{Compilation schema for the bytecode generator.}
+%* *
+%************************************************************************
+\begin{code}
+
+type BCInstrList = OrdList BCInstr
+
+data ProtoBCO a = ProtoBCO a BCInstrList
type Sequel = Int -- back off to this depth before ENTER
-- to mess with it after each push/pop.
type BCEnv = FiniteMap Id Int -- To find vars on the stack
-lookupBCEnv :: BCEnv -> Id -> Int
-lookupBCEnv env nm
- = case lookupFM env nm of
- Nothing -> pprPanic "lookupBCEnv"
- (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
- Just xx -> xx
-
-lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
-lookupBCEnv_maybe = lookupFM
-
-
--- Describes case alts
-data Discr
- = DiscrI Int
- | DiscrF Float
- | DiscrD Double
- | DiscrP Int
- | NoDiscr
-
-instance Outputable Discr where
- ppr (DiscrI i) = int i
- ppr (DiscrF f) = text (show f)
- ppr (DiscrD d) = text (show d)
- ppr (DiscrP i) = int i
- ppr NoDiscr = text "DEF"
-
-
-
--- When I push one of these on the stack, how much does Sp move by?
-taggedSizeW :: PrimRep -> Int
-taggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = 1{-the tag-} + getPrimRepSize pr
-
--- The plain size of something, without tag.
-untaggedSizeW :: PrimRep -> Int
-untaggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = getPrimRepSize pr
-
-taggedIdSizeW, untaggedIdSizeW :: Id -> Int
-taggedIdSizeW = taggedSizeW . typePrimRep . idType
-untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
-- Compile code for the right hand side of a let binding.
MachFloat r -> (PUSHU_F (fromRational r), untaggedSizeW FloatRep)
MachDouble r -> (PUSHU_D (fromRational r), untaggedSizeW DoubleRep)
+
-- Given a bunch of alts code and their discrs, do the donkey work
-- of making a multiway branch using a switch tree.
-- What a load of hassle!
maxD = 1.0e308
in
mkTree notd_ways init_lo init_hi
+
\end{code}
-The bytecode generator's monad.
+%************************************************************************
+%* *
+\subsection{Supporting junk for the compilation schemes}
+%* *
+%************************************************************************
+
+\begin{code}
+
+-- Describes case alts
+data Discr
+ = DiscrI Int
+ | DiscrF Float
+ | DiscrD Double
+ | DiscrP Int
+ | NoDiscr
+
+instance Outputable Discr where
+ ppr (DiscrI i) = int i
+ ppr (DiscrF f) = text (show f)
+ ppr (DiscrD d) = text (show d)
+ ppr (DiscrP i) = int i
+ ppr NoDiscr = text "DEF"
+
+
+-- Find things in the BCEnv (the what's-on-the-stack-env)
+lookupBCEnv :: BCEnv -> Id -> Int
+lookupBCEnv env nm
+ = case lookupFM env nm of
+ Nothing -> pprPanic "lookupBCEnv"
+ (ppr nm $$ char ' ' $$ vcat (map ppr (fmToList env)))
+ Just xx -> xx
+
+lookupBCEnv_maybe :: BCEnv -> Id -> Maybe Int
+lookupBCEnv_maybe = lookupFM
+
+
+-- When I push one of these on the stack, how much does Sp move by?
+taggedSizeW :: PrimRep -> Int
+taggedSizeW pr
+ | isFollowableRep pr = 1
+ | otherwise = 1{-the tag-} + getPrimRepSize pr
+
+
+-- The plain size of something, without tag.
+untaggedSizeW :: PrimRep -> Int
+untaggedSizeW pr
+ | isFollowableRep pr = 1
+ | otherwise = getPrimRepSize pr
+
+
+taggedIdSizeW, untaggedIdSizeW :: Id -> Int
+taggedIdSizeW = taggedSizeW . typePrimRep . idType
+untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The bytecode generator's monad}
+%* *
+%************************************************************************
\begin{code}
data BcM_State
getLabelBc :: BcM Int
getLabelBc st
= (nextlabel st, st{nextlabel = 1 + nextlabel st})
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The bytecode assembler}
+%* *
+%************************************************************************
+
+The object format for bytecodes is: 16 bits for the opcode, and 16 for
+each field -- so the code can be considered a sequence of 16-bit ints.
+Each field denotes either a stack offset or number of items on the
+stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an
+index into the literal table (eg PUSH_I/D/L), or a bytecode address in
+this BCO.
+
+\begin{code}
+-- An (almost) assembled BCO.
+data BCO a = BCO [Word16] -- instructions
+ [Word32] -- literal pool
+ [a] -- Names or HValues
+
+-- Top level assembler fn.
+assembleBCO :: ProtoBCO Name -> BCO Name
+assembleBCO (ProtoBCO nm instrs_ordlist)
+ = let
+ -- pass 1: collect up the offsets of the local labels
+ instrs = fromOL instrs_ordlist
+ label_env = mkLabelEnv emptyFM 0 instrs
+
+ mkLabelEnv env i_offset [] = env
+ mkLabelEnv env i_offset (i:is)
+ = let new_env
+ = case i of LABEL n -> addToFM env n i_offset ; _ -> env
+ in mkLabelEnv new_env (i_offset + instrSizeB i) is
+
+ findLabel lab
+ = case lookupFM label_env lab of
+ Just bco_offset -> bco_offset
+ Nothing -> pprPanic "assembleBCO.findLabel" (int lab)
+
+ -- pass 2: generate the instruction, ptr and nonptr bits
+ (insnW16s, litW32s, ptrs) = mkBits findLabel [] 0 [] 0 [] 0 instrs
+ in
+ BCO insnW16s litW32s ptrs
+
+
+-- This is where all the action is (pass 2 of the assembler)
+mkBits :: (Int -> Int) -- label finder
+ -> [Word16] -> Int -- reverse acc instr bits
+ -> [Word32] -> Int -- reverse acc literal bits
+ -> [Name] -> Int -- reverse acc ptrs
+ -> [BCInstr] -- insns!
+ -> ([Word16], [Word32], [Name])
+
+mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs []
+ = (reverse r_is, reverse r_lits, reverse r_ptrs)
+mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs (instr:instrs)
+ = case instr of
+ ARGCHECK n -> boring2 i_ARGCHECK n
+ PUSH_L sz off -> boring3 i_PUSH_L sz off
+ PUSH_G nm -> exciting2_P i_PUSH_G n_ptrs nm
+ PUSHT_I i -> exciting2_I i_PUSHT_I n_lits i
+ PUSHT_F f -> exciting2_F i_PUSHT_F n_lits f
+ PUSHT_D d -> exciting2_D i_PUSHT_D n_lits d
+ PUSHU_I i -> exciting2_I i_PUSHU_I n_lits i
+ PUSHU_F f -> exciting2_F i_PUSHU_F n_lits f
+ PUSHU_D d -> exciting2_D i_PUSHU_D n_lits d
+ SLIDE n by -> boring3 i_SLIDE n by
+ ALLOC n -> boring2 i_ALLOC n
+ MKAP off sz -> boring3 i_MKAP off sz
+ UNPACK n -> boring2 i_UNPACK n
+ PACK dcon sz -> exciting3_A i_PACK sz n_lits nullAddr {-findItbl dcon-}
+ LABEL lab -> nop
+ TESTLT_I i l -> exciting3_I i_TESTLT_I n_lits (findLabel l) i
+ TESTEQ_I i l -> exciting3_I i_TESTEQ_I n_lits (findLabel l) i
+ TESTLT_F f l -> exciting3_F i_TESTLT_F n_lits (findLabel l) f
+ TESTEQ_F f l -> exciting3_F i_TESTEQ_F n_lits (findLabel l) f
+ TESTLT_D d l -> exciting3_D i_TESTLT_D n_lits (findLabel l) d
+ TESTEQ_D d l -> exciting3_D i_TESTEQ_D n_lits (findLabel l) d
+ TESTLT_P i l -> exciting3_I i_TESTLT_P n_lits (findLabel l) i
+ TESTEQ_P i l -> exciting3_I i_TESTEQ_P n_lits (findLabel l) i
+ CASEFAIL -> boring1 i_CASEFAIL
+ ENTER -> boring1 i_ENTER
+ where
+ r_mkILit = reverse . mkILit
+ r_mkFLit = reverse . mkFLit
+ r_mkDLit = reverse . mkDLit
+ r_mkALit = reverse . mkALit
+
+ mkw :: Int -> Word16
+ mkw = fromIntegral
+
+ nop
+ = mkBits findLabel r_is n_is r_lits n_lits r_ptrs n_ptrs instrs
+ boring1 i1
+ = mkBits findLabel (mkw i1 : r_is) (n_is+1)
+ r_lits n_lits r_ptrs n_ptrs instrs
+ boring2 i1 i2
+ = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
+ r_lits n_lits r_ptrs n_ptrs instrs
+ boring3 i1 i2 i3
+ = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
+ r_lits n_lits r_ptrs n_ptrs instrs
+
+ exciting2_P i1 i2 p
+ = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2) r_lits n_lits
+ (p:r_ptrs) (n_ptrs+1) instrs
+ exciting3_P i1 i2 i3 p
+ = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3) r_lits n_lits
+ (p:r_ptrs) (n_ptrs+1) instrs
+
+ exciting2_I i1 i2 i
+ = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
+ (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
+ r_ptrs n_ptrs instrs
+ exciting3_I i1 i2 i3 i
+ = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
+ (r_mkILit i ++ r_lits) (n_lits + intLitSz32s)
+ r_ptrs n_ptrs instrs
+
+ exciting2_F i1 i2 f
+ = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
+ (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
+ r_ptrs n_ptrs instrs
+ exciting3_F i1 i2 i3 f
+ = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
+ (r_mkFLit f ++ r_lits) (n_lits + floatLitSz32s)
+ r_ptrs n_ptrs instrs
+
+ exciting2_D i1 i2 d
+ = mkBits findLabel (mkw i2 : mkw i1 : r_is) (n_is+2)
+ (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
+ r_ptrs n_ptrs instrs
+ exciting3_D i1 i2 i3 d
+ = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
+ (r_mkDLit d ++ r_lits) (n_lits + doubleLitSz32s)
+ r_ptrs n_ptrs instrs
+
+ exciting3_A i1 i2 i3 d
+ = mkBits findLabel (mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+3)
+ (r_mkALit d ++ r_lits) (n_lits + addrLitSz32s)
+ r_ptrs n_ptrs instrs
+
+
+-- The size in bytes of an instruction.
+instrSizeB :: BCInstr -> Int
+instrSizeB instr
+ = case instr of
+ ARGCHECK _ -> 4
+ PUSH_L _ _ -> 6
+ PUSH_G _ -> 4
+ PUSHT_I _ -> 4
+ PUSHT_F _ -> 4
+ PUSHT_D _ -> 4
+ PUSHU_I _ -> 4
+ PUSHU_F _ -> 4
+ PUSHU_D _ -> 4
+ SLIDE _ _ -> 6
+ ALLOC _ -> 4
+ MKAP _ _ -> 6
+ UNPACK _ -> 4
+ PACK _ _ -> 6
+ LABEL _ -> 4
+ TESTLT_I _ _ -> 6
+ TESTEQ_I _ _ -> 6
+ TESTLT_F _ _ -> 6
+ TESTEQ_F _ _ -> 6
+ TESTLT_D _ _ -> 6
+ TESTEQ_D _ _ -> 6
+ TESTLT_P _ _ -> 6
+ TESTEQ_P _ _ -> 6
+ CASEFAIL -> 2
+ ENTER -> 2
+
+
+-- Sizes of Int, Float and Double literals, in units of 32-bitses
+intLitSz32s, floatLitSz32s, doubleLitSz32s, addrLitSz32s :: Int
+intLitSz32s = wORD_SIZE `div` 4
+floatLitSz32s = 1 -- Assume IEEE floats
+doubleLitSz32s = 2
+addrLitSz32s = intLitSz32s
+
+-- Make lists of 32-bit words for literals, so that when the
+-- words are placed in memory at increasing addresses, the
+-- bit pattern is correct for the host's word size and endianness.
+mkILit :: Int -> [Word32]
+mkFLit :: Float -> [Word32]
+mkDLit :: Double -> [Word32]
+mkALit :: Addr -> [Word32]
+
+mkFLit f
+ = runST (do
+ arr <- newFloatArray ((0::Int),0)
+ writeFloatArray arr 0 f
+ w0 <- readWord32Array arr 0
+ return [w0]
+ )
+
+mkDLit d
+ = runST (do
+ arr <- newDoubleArray ((0::Int),0)
+ writeDoubleArray arr 0 d
+ w0 <- readWord32Array arr 0
+ w1 <- readWord32Array arr 1
+ return [w0,w1]
+ )
+
+mkILit i
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newIntArray ((0::Int),0)
+ writeIntArray arr 0 i
+ w0 <- readWord32Array arr 0
+ return [w0]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newIntArray ((0::Int),0)
+ writeIntArray arr 0 i
+ w0 <- readWord32Array arr 0
+ w1 <- readWord32Array arr 1
+ return [w0,w1]
+ )
+
+mkALit a
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newAddrArray ((0::Int),0)
+ writeAddrArray arr 0 a
+ w0 <- readWord32Array arr 0
+ return [w0]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newAddrArray ((0::Int),0)
+ writeAddrArray arr 0 a
+ w0 <- readWord32Array arr 0
+ w1 <- readWord32Array arr 1
+ return [w0,w1]
+ )
+
+
+
+#include "../rts/Bytecodes.h"
+
+i_ARGCHECK = (bci_ARGCHECK :: Int)
+i_PUSH_L = (bci_PUSH_L :: Int)
+i_PUSH_G = (bci_PUSH_G :: Int)
+i_PUSHT_I = (bci_PUSHT_I :: Int)
+i_PUSHT_F = (bci_PUSHT_F :: Int)
+i_PUSHT_D = (bci_PUSHT_D :: Int)
+i_PUSHU_I = (bci_PUSHU_I :: Int)
+i_PUSHU_F = (bci_PUSHU_F :: Int)
+i_PUSHU_D = (bci_PUSHU_D :: Int)
+i_SLIDE = (bci_SLIDE :: Int)
+i_ALLOC = (bci_ALLOC :: Int)
+i_MKAP = (bci_MKAP :: Int)
+i_UNPACK = (bci_UNPACK :: Int)
+i_PACK = (bci_PACK :: Int)
+i_LABEL = (bci_LABEL :: Int)
+i_TESTLT_I = (bci_TESTLT_I :: Int)
+i_TESTEQ_I = (bci_TESTEQ_I :: Int)
+i_TESTLT_F = (bci_TESTLT_F :: Int)
+i_TESTEQ_F = (bci_TESTEQ_F :: Int)
+i_TESTLT_D = (bci_TESTLT_D :: Int)
+i_TESTEQ_D = (bci_TESTEQ_D :: Int)
+i_TESTLT_P = (bci_TESTLT_P :: Int)
+i_TESTEQ_P = (bci_TESTEQ_P :: Int)
+i_CASEFAIL = (bci_CASEFAIL :: Int)
+i_ENTER = (bci_ENTER :: Int)
+
\end{code}
/* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.17 2000/10/09 11:20:16 daan Exp $
+ * $Id: Bytecodes.h,v 1.18 2000/12/06 15:23:31 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
* Instructions
*
* Notes:
- * o INTERNAL_ERROR is never generated by the compiler and usually
- * indicates an error in the heap.
- * PANIC is generated by the compiler whenever it tests an "irrefutable"
+ * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable"
* pattern which fails. If we don't see too many of these, we could
* optimise out the redundant test.
- *
- * o If you add any new instructions, you have to check that each enumeration
- * has at most 256 entries in it --- some of the lists are very close to
- * overflowing.
* ------------------------------------------------------------------------*/
-#define INSTRLIST \
- Ins(i_INTERNAL_ERROR), \
- Ins(i_PANIC), \
- Ins(i_STK_CHECK), \
- Ins(i_STK_CHECK_big), \
- Ins(i_ARG_CHECK), \
- Ins(i_ALLOC_AP), \
- Ins(i_ALLOC_PAP), \
- Ins(i_ALLOC_CONSTR), \
- Ins(i_ALLOC_CONSTR_big), \
- Ins(i_MKAP), \
- Ins(i_MKAP_big), \
- Ins(i_MKPAP), \
- Ins(i_PACK), \
- Ins(i_PACK_big), \
- Ins(i_SLIDE), \
- Ins(i_SLIDE_big), \
- Ins(i_TEST), \
- Ins(i_UNPACK), \
- Ins(i_VAR), \
- Ins(i_VAR_big), \
- Ins(i_CONST), \
- Ins(i_CONST_big), \
- Ins(i_ENTER), \
- Ins(i_RETADDR), \
- Ins(i_RETADDR_big), \
- Ins(i_VOID), \
- \
- Ins(i_ALLOC_ROW), \
- Ins(i_ALLOC_ROW_big), \
- Ins(i_PACK_ROW), \
- Ins(i_PACK_ROW_big), \
- Ins(i_UNPACK_ROW), \
- Ins(i_CONST_ROW_TRIV), \
- \
- Ins(i_PACK_INJ), \
- Ins(i_PACK_INJ_VAR), \
- Ins(i_PACK_INJ_VAR_big), \
- Ins(i_PACK_INJ_CONST_8), \
- Ins(i_PACK_INJ_REL_8), \
- Ins(i_TEST_INJ), \
- Ins(i_TEST_INJ_VAR), \
- Ins(i_TEST_INJ_VAR_big), \
- Ins(i_TEST_INJ_CONST_8), \
- Ins(i_TEST_INJ_REL_8), \
- Ins(i_UNPACK_INJ), \
- Ins(i_CONST_WORD_8), \
- Ins(i_ADD_WORD_VAR), \
- Ins(i_ADD_WORD_VAR_big), \
- Ins(i_ADD_WORD_VAR_8), \
- \
- Ins(i_VAR_INT), \
- Ins(i_VAR_INT_big), \
- Ins(i_CONST_INT), \
- Ins(i_CONST_INT_big), \
- Ins(i_PACK_INT), \
- Ins(i_UNPACK_INT), \
- Ins(i_TEST_INT), \
- Ins(i_CONST_INTEGER), \
- Ins(i_CONST_INTEGER_big), \
- Ins(i_VAR_WORD), \
- Ins(i_VAR_WORD_big), \
- Ins(i_CONST_WORD), \
- Ins(i_CONST_WORD_big), \
- Ins(i_PACK_WORD), \
- Ins(i_UNPACK_WORD), \
- Ins(i_VAR_ADDR), \
- Ins(i_VAR_ADDR_big), \
- Ins(i_CONST_ADDR), \
- Ins(i_CONST_ADDR_big), \
- Ins(i_PACK_ADDR), \
- Ins(i_UNPACK_ADDR), \
- Ins(i_VAR_CHAR), \
- Ins(i_VAR_CHAR_big), \
- Ins(i_CONST_CHAR), \
- Ins(i_CONST_CHAR_big), \
- Ins(i_PACK_CHAR), \
- Ins(i_UNPACK_CHAR), \
- Ins(i_VAR_FLOAT), \
- Ins(i_VAR_FLOAT_big), \
- Ins(i_CONST_FLOAT), \
- Ins(i_CONST_FLOAT_big), \
- Ins(i_PACK_FLOAT), \
- Ins(i_UNPACK_FLOAT), \
- Ins(i_VAR_DOUBLE), \
- Ins(i_VAR_DOUBLE_big), \
- Ins(i_CONST_DOUBLE), \
- Ins(i_CONST_DOUBLE_big), \
- Ins(i_PACK_DOUBLE), \
- Ins(i_UNPACK_DOUBLE), \
- Ins(i_VAR_STABLE), \
- Ins(i_VAR_STABLE_big), \
- Ins(i_PACK_STABLE), \
- Ins(i_UNPACK_STABLE), \
- Ins(i_PRIMOP1), \
- Ins(i_PRIMOP2), \
- Ins(i_RV), \
- Ins(i_RVE), \
- Ins(i_SE), \
- Ins(i_VV)
-
-#define BIGGEST_OPCODE ((int)(i_VV))
-
-#define Ins(x) x
-typedef enum { INSTRLIST } Instr;
-#undef Ins
-
-
-
-typedef enum
- { i_INTERNAL_ERROR1 /* Instruction 0 raises an internal error */
-
- , i_pushseqframe
- , i_pushcatchframe
-
- /* Char# operations */
- , i_gtChar
- , i_geChar
- , i_eqChar
- , i_neChar
- , i_ltChar
- , i_leChar
- , i_charToInt
- , i_intToChar
-
- /* Int# operations */
- , i_gtInt
- , i_geInt
- , i_eqInt
- , i_neInt
- , i_ltInt
- , i_leInt
- , i_minInt
- , i_maxInt
- , i_plusInt
- , i_minusInt
- , i_timesInt
- , i_quotInt
- , i_remInt
- , i_quotRemInt
- , i_negateInt
- , i_andInt
- , i_orInt
- , i_xorInt
- , i_notInt
- , i_shiftLInt
- , i_shiftRAInt
- , i_shiftRLInt
-
- /* Word# operations */
- , i_gtWord
- , i_geWord
- , i_eqWord
- , i_neWord
- , i_ltWord
- , i_leWord
- , i_minWord
- , i_maxWord
- , i_plusWord
- , i_minusWord
- , i_timesWord
- , i_quotWord
- , i_remWord
- , i_quotRemWord
- , i_negateWord
- , i_andWord
- , i_orWord
- , i_xorWord
- , i_notWord
- , i_shiftLWord
- , i_shiftRAWord
- , i_shiftRLWord
- , i_intToWord
- , i_wordToInt
-
- /* Addr# operations */
- , i_gtAddr
- , i_geAddr
- , i_eqAddr
- , i_neAddr
- , i_ltAddr
- , i_leAddr
- , i_intToAddr
- , i_addrToInt
-
- /* Stable# operations */
- , i_intToStable
- , i_stableToInt
-
- /* Stateless Addr operations */
- , i_indexCharOffAddr
- , i_indexIntOffAddr
- , i_indexWordOffAddr
- , i_indexAddrOffAddr
- , i_indexFloatOffAddr
- , i_indexDoubleOffAddr
- , i_indexStableOffAddr
-
- , i_readCharOffAddr
- , i_readIntOffAddr
- , i_readWordOffAddr
- , i_readAddrOffAddr
- , i_readFloatOffAddr
- , i_readDoubleOffAddr
- , i_readStableOffAddr
-
- , i_writeCharOffAddr
- , i_writeIntOffAddr
- , i_writeWordOffAddr
- , i_writeAddrOffAddr
- , i_writeFloatOffAddr
- , i_writeDoubleOffAddr
- , i_writeStableOffAddr
-
- /* Integer operations */
- , i_compareInteger
- , i_negateInteger
- , i_plusInteger
- , i_minusInteger
- , i_timesInteger
- , i_quotRemInteger
- , i_divModInteger
- , i_integerToInt
- , i_intToInteger
- , i_integerToWord
- , i_wordToInteger
- , i_integerToFloat
- , i_floatToInteger
- , i_integerToDouble
- , i_doubleToInteger
-
- /* Float# operations */
- , i_gtFloat
- , i_geFloat
- , i_eqFloat
- , i_neFloat
- , i_ltFloat
- , i_leFloat
- , i_minFloat
- , i_maxFloat
- , i_radixFloat
- , i_digitsFloat
- , i_minExpFloat
- , i_maxExpFloat
- , i_plusFloat
- , i_minusFloat
- , i_timesFloat
- , i_divideFloat
- , i_negateFloat
- , i_floatToInt
- , i_intToFloat
- , i_expFloat
- , i_logFloat
- , i_sqrtFloat
- , i_sinFloat
- , i_cosFloat
- , i_tanFloat
- , i_asinFloat
- , i_acosFloat
- , i_atanFloat
- , i_sinhFloat
- , i_coshFloat
- , i_tanhFloat
- , i_powerFloat
- , i_decodeFloatZ
- , i_encodeFloatZ
- , i_isNaNFloat
- , i_isInfiniteFloat
- , i_isDenormalizedFloat
- , i_isNegativeZeroFloat
- , i_isIEEEFloat
-
- /* Double# operations */
- , i_gtDouble
- , i_geDouble
- , i_eqDouble
- , i_neDouble
- , i_ltDouble
- , i_leDouble
- , i_minDouble
- , i_maxDouble
- , i_radixDouble
- , i_digitsDouble
- , i_minExpDouble
- , i_maxExpDouble
- , i_plusDouble
- , i_minusDouble
- , i_timesDouble
- , i_divideDouble
- , i_negateDouble
- , i_doubleToInt
- , i_intToDouble
- , i_doubleToFloat
- , i_floatToDouble
- , i_expDouble
- , i_logDouble
- , i_sqrtDouble
- , i_sinDouble
- , i_cosDouble
- , i_tanDouble
- , i_asinDouble
- , i_acosDouble
- , i_atanDouble
- , i_sinhDouble
- , i_coshDouble
- , i_tanhDouble
- , i_powerDouble
- , i_decodeDoubleZ
- , i_encodeDoubleZ
- , i_isNaNDouble
- , i_isInfiniteDouble
- , i_isDenormalizedDouble
- , i_isNegativeZeroDouble
- , i_isIEEEDouble
-
- /* If you add a new primop to this table, check you don't
- * overflow the 256 limit. That is MAX_Primop1 <= 255.
- * Current value (30/10/98) = 0xc8
- */
- , MAX_Primop1 = i_isIEEEDouble
-} Primop1;
-
-
-typedef enum
- { i_INTERNAL_ERROR2 /* Instruction 0 raises an internal error */
-
- , i_raise
-
-#ifdef XMLAMBDA
- /* row primitives. */
- , i_rowInsertAt
- , i_rowChainInsert
- , i_rowChainBuild
- , i_rowRemoveAt
- , i_rowChainRemove
- , i_rowChainSelect
-#endif
-
- /* Ref operations */
- , i_newRef
- , i_writeRef
- , i_readRef
- , i_sameRef
-
- /* Prim[Mutable]Array operations */
- , i_sameMutableArray
- , i_unsafeFreezeArray
-
- , i_newArray
- , i_writeArray
- , i_readArray
- , i_indexArray
- , i_sizeArray
- , i_sizeMutableArray
-
- /* Prim[Mutable]ByteArray operations */
- , i_sameMutableByteArray
- , i_unsafeFreezeByteArray
- , i_newByteArray
-
- , i_writeCharArray
- , i_readCharArray
- , i_indexCharArray
-
- , i_writeIntArray
- , i_readIntArray
- , i_indexIntArray
-
- /* {write,read,index}IntegerArray not provided */
-
- , i_writeWordArray
- , i_readWordArray
- , i_indexWordArray
- , i_writeAddrArray
- , i_readAddrArray
- , i_indexAddrArray
- , i_writeFloatArray
- , i_readFloatArray
- , i_indexFloatArray
- , i_writeDoubleArray
- , i_readDoubleArray
- , i_indexDoubleArray
-
-#if 0
-#ifdef PROVIDE_STABLE
- , i_writeStableArray
- , i_readStableArray
- , i_indexStableArray
-#endif
-#endif
-
- /* {write,read,index}ForeignObjArray not provided */
-
-#ifdef PROVIDE_PTREQUALITY
- , i_reallyUnsafePtrEquality
-#endif
-#ifdef PROVIDE_COERCE
- , i_unsafeCoerce
-#endif
-
-#ifdef PROVIDE_FOREIGN
- /* ForeignObj# operations */
- , i_mkForeignObj
-
- , indexCharOffForeignObj
- , indexIntOffForeignObj
- , indexInt64OffForeignObj
- , indexWordOffForeignObj
- , indexAddrOffForeignObj
- , indexFloatOffForeignObj
- , indexDoubleOffForeignObj
- , indexStablePtrOffForeignObj
-#endif
-#ifdef PROVIDE_WEAK
- /* Weak# operations */
- , i_makeWeak
- , i_deRefWeak
-#endif
- /* StablePtr# operations */
- , i_makeStablePtr
- , i_deRefStablePtr
- , i_freeStablePtr
-
- /* foreign export dynamic support */
- , i_createAdjThunkARCH
-
- /* misc handy hacks */
- , i_getArgc
- , i_getArgv
-
-#ifdef PROVIDE_CONCURRENT
- /* Concurrency operations */
- , i_forkIO
- , i_killThread
- , i_raiseInThread
- , i_delay
- , i_waitRead
- , i_waitWrite
- , i_yield
- , i_getThreadId
- , i_cmpThreadIds
-#endif
- , i_sameMVar
- , i_newMVar
- , i_takeMVar
- , i_putMVar
-
-
- /* CCall! */
-#ifdef XMLAMBDA
- , i_ccall
-#endif
- , i_ccall_ccall_Id
- , i_ccall_ccall_IO
- , i_ccall_stdcall_Id
- , i_ccall_stdcall_IO
-
- /* If you add a new primop to this table, check you don't
- * overflow the 256 limit. That is MAX_Primop2 <= 255.
- * Current value (1 oct 2000) = 0x48
- */
- , MAX_Primop2 = i_ccall_stdcall_IO
-} Primop2;
+/* NOTE:
+
+ THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/ghci/ByteCodeGen.lhs).
+ DO NOT PUT C-SPECIFIC STUFF IN HERE!
+
+ I hope that's clear :-)
+*/
+
+#define bci_ARGCHECK 1
+#define bci_PUSH_L 2
+#define bci_PUSH_G 3
+#define bci_PUSHT_I 4
+#define bci_PUSHT_F 5
+#define bci_PUSHT_D 6
+#define bci_PUSHU_I 7
+#define bci_PUSHU_F 8
+#define bci_PUSHU_D 9
+#define bci_SLIDE 10
+#define bci_ALLOC 11
+#define bci_MKAP 12
+#define bci_UNPACK 13
+#define bci_PACK 14
+#define bci_LABEL 15
+#define bci_TESTLT_I 16
+#define bci_TESTEQ_I 17
+#define bci_TESTLT_F 18
+#define bci_TESTEQ_F 19
+#define bci_TESTLT_D 20
+#define bci_TESTEQ_D 21
+#define bci_TESTLT_P 22
+#define bci_TESTEQ_P 23
+#define bci_CASEFAIL 24
+#define bci_ENTER 25
-typedef unsigned int InstrPtr; /* offset of instruction within BCO */
/*-------------------------------------------------------------------------*/
projects / ghc-hetmet.git / commitdiff