+
+\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)
+