From: sewardj Date: Wed, 6 Dec 2000 15:23:31 +0000 (+0000) Subject: [project @ 2000-12-06 15:23:31 by sewardj] X-Git-Tag: Approximately_9120_patches~3193 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=55f6344cb5472b6e0493772de427c34de089e232;p=ghc-hetmet.git [project @ 2000-12-06 15:23:31 by sewardj] Tons of tedious crud which we will henceforth refer to politely as "the bytecode assembler". --- diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 61ca01d..915e404 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,21 +4,17 @@ \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(..) ) @@ -28,7 +24,15 @@ import DataCon ( DataCon, dataConTag, fIRST_TAG ) 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. @@ -46,9 +50,15 @@ byteCodeGen binds BcM_State bcos final_ctr -> bcos \end{code} -The real machinery. + +%************************************************************************ +%* * +\subsection{Bytecodes, and Outputery.} +%* * +%************************************************************************ \begin{code} + type LocalLabel = Int data BCInstr @@ -81,26 +91,6 @@ 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 @@ -118,18 +108,24 @@ pprAltCode discrs_n_codes = 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 @@ -137,49 +133,6 @@ 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. @@ -375,6 +328,7 @@ pushAtom False d p (AnnLit lit) 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! @@ -471,9 +425,70 @@ mkMultiBranch raw_ways 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 @@ -513,4 +528,276 @@ emitBc bco st 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} diff --git a/ghc/rts/Bytecodes.h b/ghc/rts/Bytecodes.h index 37c8bce4..9df263d 100644 --- a/ghc/rts/Bytecodes.h +++ b/ghc/rts/Bytecodes.h @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- - * $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 * @@ -12,481 +12,44 @@ * 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 */ /*-------------------------------------------------------------------------*/