+
+\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 -> IO AsmState
+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)
+
+ init_n_insns = 10
+ init_n_lits = 4
+ init_n_ptrs = 4
+ in
+ do insns <- newXIOUArray init_n_insns :: IO (XIOUArray Word16)
+ lits <- newXIOUArray init_n_lits :: IO (XIOUArray Word32)
+ ptrs <- newXIOArray init_n_ptrs -- :: IO (XIOArray Name)
+
+ -- pass 2: generate the instruction, ptr and nonptr bits
+ let init_asm_state = (insns,lits,ptrs)
+ final_asm_state <- mkBits findLabel init_asm_state instrs
+
+ return final_asm_state
+
+
+-- instrs nonptrs ptrs
+type AsmState = (XIOUArray Word16, XIOUArray Word32, XIOArray Name)
+
+
+-- This is where all the action is (pass 2 of the assembler)
+mkBits :: (Int -> Int) -- label finder
+ -> AsmState
+ -> [BCInstr] -- instructions (in)
+ -> IO AsmState
+
+mkBits findLabel st proto_insns
+ = foldM doInstr st proto_insns
+ where
+ doInstr :: AsmState -> BCInstr -> IO AsmState
+ doInstr st i
+ = case i of
+ ARGCHECK n -> instr2 st i_ARGCHECK n
+ PUSH_L o1 -> instr2 st i_PUSH_L o1
+ PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2
+ PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
+ PUSH_G nm -> do (p, st2) <- ptr st nm
+ instr2 st2 i_PUSH_G p
+ PUSH_AS nm pk -> do (p, st2) <- ptr st nm
+ (np, st3) <- ret_itbl st2 pk
+ instr3 st3 i_PUSH_AS p np
+ PUSH_UBX lit nw32s -> do (np, st2) <- literal st lit
+ instr3 st2 i_PUSH_UBX np nw32s
+ PUSH_TAG tag -> instr2 st i_PUSH_TAG tag
+ SLIDE n by -> instr3 st i_SLIDE n by
+ ALLOC n -> instr2 st i_ALLOC n
+ MKAP off sz -> instr3 st i_MKAP off sz
+ UNPACK n -> instr2 st i_UNPACK n
+ UPK_TAG n m k -> instr4 st i_UPK_TAG n m k
+ PACK dcon sz -> do (np,st2) <- itbl st dcon
+ instr3 st2 i_PACK np sz
+ LABEL lab -> return st
+ TESTLT_I i l -> do (np, st2) <- int st i
+ instr3 st2 i_TESTLT_I np (findLabel l)
+ TESTEQ_I i l -> do (np, st2) <- int st i
+ instr3 st2 i_TESTEQ_I np (findLabel l)
+ TESTLT_F f l -> do (np, st2) <- float st f
+ instr3 st2 i_TESTLT_F np (findLabel l)
+ TESTEQ_F f l -> do (np, st2) <- float st f
+ instr3 st2 i_TESTEQ_F np (findLabel l)
+ TESTLT_D d l -> do (np, st2) <- double st d
+ instr3 st2 i_TESTLT_D np (findLabel l)
+ TESTEQ_D d l -> do (np, st2) <- double st d
+ instr3 st2 i_TESTEQ_D np (findLabel l)
+ TESTLT_P i l -> do (np, st2) <- int st i
+ instr3 st2 i_TESTLT_P np (findLabel l)
+ TESTEQ_P i l -> do (np, st2) <- int st i
+ instr3 st2 i_TESTEQ_P np (findLabel l)
+ CASEFAIL -> instr1 st i_CASEFAIL
+ ENTER -> instr1 st i_ENTER
+ RETURN -> instr1 st i_RETURN
+
+ i2s :: Int -> Word16
+ i2s = fromIntegral
+
+ instr1 (st_i0,st_l0,st_p0) i1
+ = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
+ return (st_i1,st_l0,st_p0)
+
+ instr2 (st_i0,st_l0,st_p0) i1 i2
+ = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
+ st_i2 <- addToXIOUArray st_i1 (i2s i2)
+ return (st_i2,st_l0,st_p0)
+
+ instr3 (st_i0,st_l0,st_p0) i1 i2 i3
+ = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
+ st_i2 <- addToXIOUArray st_i1 (i2s i2)
+ st_i3 <- addToXIOUArray st_i2 (i2s i3)
+ return (st_i3,st_l0,st_p0)
+
+ instr4 (st_i0,st_l0,st_p0) i1 i2 i3 i4
+ = do st_i1 <- addToXIOUArray st_i0 (i2s i1)
+ st_i2 <- addToXIOUArray st_i1 (i2s i2)
+ st_i3 <- addToXIOUArray st_i2 (i2s i3)
+ st_i4 <- addToXIOUArray st_i3 (i2s i4)
+ return (st_i4,st_l0,st_p0)
+
+ float (st_i0,st_l0,st_p0) f
+ = do let w32s = mkLitF f
+ st_l1 <- addListToXIOUArray st_l0 w32s
+ return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
+
+ double (st_i0,st_l0,st_p0) d
+ = do let w32s = mkLitD d
+ st_l1 <- addListToXIOUArray st_l0 w32s
+ return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
+
+ int (st_i0,st_l0,st_p0) i
+ = do let w32s = mkLitI i
+ st_l1 <- addListToXIOUArray st_l0 w32s
+ return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
+
+ addr (st_i0,st_l0,st_p0) a
+ = do let w32s = mkLitA a
+ st_l1 <- addListToXIOUArray st_l0 w32s
+ return (usedXIOU st_l0, (st_i0,st_l1,st_p0))
+
+ ptr (st_i0,st_l0,st_p0) p
+ = do st_p1 <- addToXIOArray st_p0 p
+ return (usedXIO st_p0, (st_i0,st_l0,st_p1))
+
+ literal st (MachInt j) = int st (fromIntegral j)
+ literal st (MachFloat r) = float st (fromRational r)
+ literal st (MachDouble r) = double st (fromRational r)
+
+ ret_itbl st pk = panic "ret_itbl" -- return (65535, st)
+ itbl st dcon = panic "itbl" -- return (65536, st)
+
+
+-- 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
+ 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.
+mkLitI :: Int -> [Word32]
+mkLitF :: Float -> [Word32]
+mkLitD :: Double -> [Word32]
+mkLitA :: Addr -> [Word32]
+
+mkLitF f
+ = runST (do
+ arr <- newFloatArray ((0::Int),0)
+ writeFloatArray arr 0 f
+ f_arr <- castSTUArray arr
+ w0 <- readWord32Array f_arr 0
+ return [w0]
+ )
+
+mkLitD d
+ = runST (do
+ arr <- newDoubleArray ((0::Int),0)
+ writeDoubleArray arr 0 d
+ d_arr <- castSTUArray arr
+ w0 <- readWord32Array d_arr 0
+ w1 <- readWord32Array d_arr 1
+ return [w0,w1]
+ )
+
+mkLitI i
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newIntArray ((0::Int),0)
+ writeIntArray arr 0 i
+ i_arr <- castSTUArray arr
+ w0 <- readWord32Array i_arr 0
+ return [w0]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newIntArray ((0::Int),0)
+ writeIntArray arr 0 i
+ i_arr <- castSTUArray arr
+ w0 <- readWord32Array i_arr 0
+ w1 <- readWord32Array i_arr 1
+ return [w0,w1]
+ )
+
+mkLitA a
+ | wORD_SIZE == 4
+ = runST (do
+ arr <- newAddrArray ((0::Int),0)
+ writeAddrArray arr 0 a
+ a_arr <- castSTUArray arr
+ w0 <- readWord32Array a_arr 0
+ return [w0]
+ )
+ | wORD_SIZE == 8
+ = runST (do
+ arr <- newAddrArray ((0::Int),0)
+ writeAddrArray arr 0 a
+ a_arr <- castSTUArray arr
+ w0 <- readWord32Array a_arr 0
+ w1 <- readWord32Array a_arr 1
+ return [w0,w1]
+ )
+
+
+
+-- Zero-based expandable arrays
+data XIOUArray ele
+ = XIOUArray { usedXIOU :: Int, stuffXIOU :: (IOUArray Int ele) }
+data XIOArray ele
+ = XIOArray { usedXIO :: Int , stuffXIO :: (IOArray Int ele) }
+
+newXIOUArray size
+ = do arr <- newArray (0, size-1)
+ return (XIOUArray 0 arr)
+
+addListToXIOUArray xarr []
+ = return xarr
+addListToXIOUArray xarr (x:xs)
+ = addToXIOUArray xarr x >>= \ xarr' -> addListToXIOUArray xarr' xs
+
+
+addToXIOUArray :: MArray IOUArray a IO
+ => XIOUArray a -> a -> IO (XIOUArray a)
+addToXIOUArray (XIOUArray n_arr arr) x
+ = case bounds arr of
+ (lo, hi) -> ASSERT(lo == 0)
+ if n_arr > hi
+ then do new_arr <- newArray (0, 2*hi-1)
+ copy hi arr new_arr
+ addToXIOUArray (XIOUArray n_arr new_arr) x
+ else do writeArray arr n_arr x
+ return (XIOUArray (n_arr+1) arr)
+ where
+ copy :: MArray IOUArray a IO
+ => Int -> IOUArray Int a -> IOUArray Int a -> IO ()
+ copy n src dst
+ | n < 0 = return ()
+ | otherwise = do nx <- readArray src n
+ writeArray dst n nx
+ copy (n-1) src dst
+
+
+
+newXIOArray size
+ = do arr <- newArray (0, size-1)
+ return (XIOArray 0 arr)
+
+addToXIOArray :: XIOArray a -> a -> IO (XIOArray a)
+addToXIOArray (XIOArray n_arr arr) x
+ = case bounds arr of
+ (lo, hi) -> ASSERT(lo == 0)
+ if n_arr > hi
+ then do new_arr <- newArray (0, 2*hi-1)
+ copy hi arr new_arr
+ addToXIOArray (XIOArray n_arr new_arr) x
+ else do writeArray arr n_arr x
+ return (XIOArray (n_arr+1) arr)
+ where
+ copy :: Int -> IOArray Int a -> IOArray Int a -> IO ()
+ copy n src dst
+ | n < 0 = return ()
+ | otherwise = do nx <- readArray src n
+ writeArray dst n nx
+ copy (n-1) src dst
+
+
+#include "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_PUSH_UBX = (bci_PUSH_UBX :: Int)
+i_PUSH_TAG = (bci_PUSH_TAG :: Int)
+i_SLIDE = (bci_SLIDE :: Int)
+i_ALLOC = (bci_ALLOC :: Int)
+i_MKAP = (bci_MKAP :: Int)
+i_UNPACK = (bci_UNPACK :: Int)
+i_UPK_TAG = (bci_UPK_TAG :: 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)
+