-\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 origin)
- = let
- -- pass 1: collect up the offsets of the local labels
- 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 off -> boring2 i_PUSH_L off
- PUSH_LL o1 o2 -> boring3 i_PUSH_LL o1 o2
- PUSH_LLL o1 o2 o3 -> boring4 i_PUSH_LLL o1 o2 o3
- 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
- RETURN -> boring1 i_RETURN
- 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
- boring4 i1 i2 i3 i4
- = mkBits findLabel (mkw i4 : mkw i3 : mkw i2 : mkw i1 : r_is) (n_is+4)
- 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 _ -> 4
- PUSH_LL _ _ -> 6
- PUSH_LLL _ _ _ -> 8
- 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
- RETURN -> 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_LL = (bci_PUSH_LL :: Int)
-i_PUSH_LLL = (bci_PUSH_LLL :: Int)
-i_PUSH_G = (bci_PUSH_G :: Int)
-i_PUSH_AS = (bci_PUSH_AS :: 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)
-i_RETURN = (bci_RETURN :: Int)