import Name
import NameSet
-import FiniteMap
import Literal
import TyCon
import PrimOp
import Foreign
import Data.Char ( ord )
import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
import GHC.Base ( ByteArray#, MutableByteArray#, RealWorld )
assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced)
= let
-- pass 1: collect up the offsets of the local labels.
- -- Remember that the first insn starts at offset 1 since offset 0
- -- (eventually) will hold the total # of insns.
- label_env = mkLabelEnv emptyFM 1 instrs
-
+ -- Remember that the first insn starts at offset
+ -- sizeOf Word / sizeOf Word16
+ -- since offset 0 (eventually) will hold the total # of insns.
+ lableInitialOffset
+ | wORD_SIZE_IN_BITS == 64 = 4
+ | wORD_SIZE_IN_BITS == 32 = 2
+ | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
+ label_env = mkLabelEnv Map.empty lableInitialOffset instrs
+
+ mkLabelEnv :: Map Word16 Word -> Word -> [BCInstr]
+ -> Map Word16 Word
mkLabelEnv env _ [] = env
mkLabelEnv env i_offset (i:is)
= let new_env
- = case i of LABEL n -> addToFM env n i_offset ; _ -> env
+ = case i of LABEL n -> Map.insert n i_offset env ; _ -> env
in mkLabelEnv new_env (i_offset + instrSize16s i) is
- findLabel :: Word16 -> Word16
+ findLabel :: Word16 -> Word
findLabel lab
- = case lookupFM label_env lab of
+ = case Map.lookup lab label_env of
Just bco_offset -> bco_offset
Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab)
in
let asm_insns = ssElts final_insns
n_insns = sizeSS final_insns
- insns_arr
- | n_insns > 65535 = panic "linkBCO: >= 64k insns in BCO"
- | otherwise = mkInstrArray n_insns asm_insns
+ insns_arr = mkInstrArray lableInitialOffset n_insns asm_insns
!insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr
bitmap_arr = mkBitmapArray bsize bitmap
mkBitmapArray bsize bitmap
= listArray (0, length bitmap) (fromIntegral bsize : bitmap)
-mkInstrArray :: Word16 -> [Word16] -> UArray Word16 Word16
-mkInstrArray n_insns asm_insns
- = listArray (0, n_insns) (fromIntegral n_insns : asm_insns)
+mkInstrArray :: Word -> Word -> [Word16] -> UArray Word Word16
+mkInstrArray lableInitialOffset n_insns asm_insns
+ = let size = lableInitialOffset + n_insns
+ in listArray (0, size - 1) (largeArg size ++ asm_insns)
-- instrs nonptrs ptrs
type AsmState = (SizedSeq Word16,
SizedSeq BCONPtr,
SizedSeq BCOPtr)
-data SizedSeq a = SizedSeq !Word16 [a]
+data SizedSeq a = SizedSeq !Word [a]
emptySS :: SizedSeq a
emptySS = SizedSeq 0 []
ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs
-sizeSS :: SizedSeq a -> Word16
+sizeSS :: SizedSeq a -> Word
sizeSS (SizedSeq n _) = n
+sizeSS16 :: SizedSeq a -> Word16
+sizeSS16 (SizedSeq n _) = fromIntegral n
+
-- Bring in all the bci_ bytecode constants.
-#include "Bytecodes.h"
+#include "rts/Bytecodes.h"
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
| otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-- This is where all the action is (pass 2 of the assembler)
-mkBits :: (Word16 -> Word16) -- label finder
+mkBits :: (Word16 -> Word) -- label finder
-> AsmState
-> [BCInstr] -- instructions (in)
-> IO AsmState
doInstr :: AsmState -> BCInstr -> IO AsmState
doInstr st i
= case i of
- STKCHECK n
- | n > 65535 ->
- instrn st (largeArgInstr bci_STKCHECK : largeArg n)
- | otherwise -> instr2 st bci_STKCHECK (fromIntegral n)
+ STKCHECK n -> instr1Large st bci_STKCHECK n
PUSH_L o1 -> instr2 st bci_PUSH_L o1
PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2
PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3
instr3 st2 bci_PACK itbl_no sz
LABEL _ -> return st
TESTLT_I i l -> do (np, st2) <- int st i
- instr3 st2 bci_TESTLT_I np (findLabel l)
+ instr2Large st2 bci_TESTLT_I np (findLabel l)
TESTEQ_I i l -> do (np, st2) <- int st i
- instr3 st2 bci_TESTEQ_I np (findLabel l)
+ instr2Large st2 bci_TESTEQ_I np (findLabel l)
+ TESTLT_W w l -> do (np, st2) <- word st w
+ instr2Large st2 bci_TESTLT_W np (findLabel l)
+ TESTEQ_W w l -> do (np, st2) <- word st w
+ instr2Large st2 bci_TESTEQ_W np (findLabel l)
TESTLT_F f l -> do (np, st2) <- float st f
- instr3 st2 bci_TESTLT_F np (findLabel l)
+ instr2Large st2 bci_TESTLT_F np (findLabel l)
TESTEQ_F f l -> do (np, st2) <- float st f
- instr3 st2 bci_TESTEQ_F np (findLabel l)
+ instr2Large st2 bci_TESTEQ_F np (findLabel l)
TESTLT_D d l -> do (np, st2) <- double st d
- instr3 st2 bci_TESTLT_D np (findLabel l)
+ instr2Large st2 bci_TESTLT_D np (findLabel l)
TESTEQ_D d l -> do (np, st2) <- double st d
- instr3 st2 bci_TESTEQ_D np (findLabel l)
- TESTLT_P i l -> instr3 st bci_TESTLT_P i (findLabel l)
- TESTEQ_P i l -> instr3 st bci_TESTEQ_P i (findLabel l)
+ instr2Large st2 bci_TESTEQ_D np (findLabel l)
+ TESTLT_P i l -> instr2Large st bci_TESTLT_P i (findLabel l)
+ TESTEQ_P i l -> instr2Large st bci_TESTEQ_P i (findLabel l)
CASEFAIL -> instr1 st bci_CASEFAIL
SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n
- JMP l -> instr2 st bci_JMP (findLabel l)
+ JMP l -> instr1Large st bci_JMP (findLabel l)
ENTER -> instr1 st bci_ENTER
RETURN -> instr1 st bci_RETURN
RETURN_UBX rep -> instr1 st (return_ubx rep)
- CCALL off m_addr -> do (np, st2) <- addr st m_addr
- instr3 st2 bci_CCALL off np
+ CCALL off m_addr int -> do (np, st2) <- addr st m_addr
+ instr4 st2 bci_CCALL off np int
BRK_FUN array index info -> do
(p1, st2) <- ptr st (BCOPtrArray array)
(p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
= do st_i' <- addToSS st_i i
instrn (st_i', st_l, st_p) is
+ instr1Large st i1 large
+ | large > 65535 = instrn st (largeArgInstr i1 : largeArg large)
+ | otherwise = instr2 st i1 (fromIntegral large)
+
+ instr2Large st i1 i2 large
+ | large > 65535 = instrn st (largeArgInstr i1 : i2 : largeArg large)
+ | otherwise = instr3 st i1 i2 (fromIntegral large)
+
instr1 (st_i0,st_l0,st_p0) i1
= do st_i1 <- addToSS st_i0 i1
return (st_i1,st_l0,st_p0)
float (st_i0,st_l0,st_p0) f
= do let ws = mkLitF f
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
double (st_i0,st_l0,st_p0) d
= do let ws = mkLitD d
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
int (st_i0,st_l0,st_p0) i
= do let ws = mkLitI i
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
+
+ word (st_i0,st_l0,st_p0) w
+ = do let ws = [w]
+ st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
int64 (st_i0,st_l0,st_p0) i
= do let ws = mkLitI64 i
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
addr (st_i0,st_l0,st_p0) a
= do let ws = mkLitPtr a
st_l1 <- addListToSS st_l0 (map BCONPtrWord ws)
- return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
litlabel (st_i0,st_l0,st_p0) fs
= do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs]
- return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
ptr (st_i0,st_l0,st_p0) p
= do st_p1 <- addToSS st_p0 p
- return (sizeSS st_p0, (st_i0,st_l0,st_p1))
+ return (sizeSS16 st_p0, (st_i0,st_l0,st_p1))
itbl (st_i0,st_l0,st_p0) dcon
= do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon))
- return (sizeSS st_l0, (st_i0,st_l1,st_p0))
+ return (sizeSS16 st_l0, (st_i0,st_l1,st_p0))
#ifdef mingw32_TARGET_OS
literal st (MachLabel fs (Just sz) _)
-- The size in 16-bit entities of an instruction.
-instrSize16s :: BCInstr -> Word16
+instrSize16s :: BCInstr -> Word
instrSize16s instr
= case instr of
STKCHECK{} -> 2
LABEL{} -> 0 -- !!
TESTLT_I{} -> 3
TESTEQ_I{} -> 3
+ TESTLT_W{} -> 3
+ TESTEQ_W{} -> 3
TESTLT_F{} -> 3
TESTEQ_F{} -> 3
TESTLT_D{} -> 3
ENTER{} -> 1
RETURN{} -> 1
RETURN_UBX{} -> 1
- CCALL{} -> 3
+ CCALL{} -> 4
SWIZZLE{} -> 3
BRK_FUN{} -> 4
projects / ghc-hetmet.git / blobdiff