X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeAsm.lhs;h=af9fbe90494acc6e898029728b5a52f9155d437e;hp=1a99096a9bd1f56dae5ef6210c0dc604701ce21e;hb=c0687066474aa4ce4912f31a5c09c1bcd673fb06;hpb=b0046dd679244886fdc62e5cc2a73128d2e018bb diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 1a99096..af9fbe9 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -6,6 +6,7 @@ ByteCodeLink: Bytecode assembler and linker \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +{-# LANGUAGE BangPatterns #-} module ByteCodeAsm ( assembleBCOs, assembleBCO, @@ -23,14 +24,15 @@ import ByteCodeItbls import Name import NameSet -import FiniteMap import Literal import TyCon import PrimOp import Constants import FastString import SMRep +import DynFlags import Outputable +import Platform import Control.Monad ( foldM ) import Control.Monad.ST ( runST ) @@ -42,6 +44,8 @@ import Data.Array.ST ( castSTUArray ) 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 ) @@ -111,29 +115,36 @@ instance Outputable UnlinkedBCO where -- bytecode address in this BCO. -- Top level assembler fn. -assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode -assembleBCOs proto_bcos tycons +assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode +assembleBCOs dflags proto_bcos tycons = do itblenv <- mkITbls tycons - bcos <- mapM assembleBCO proto_bcos + bcos <- mapM (assembleBCO dflags) proto_bcos return (ByteCode bcos itblenv) -assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO -assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) +assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO dflags (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 @@ -143,14 +154,12 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) ptrs <- return emptySS :: IO (SizedSeq BCOPtr) let init_asm_state = (insns,lits,ptrs) (final_insns, final_lits, final_ptrs) - <- mkBits findLabel init_asm_state instrs + <- mkBits dflags findLabel init_asm_state instrs 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 @@ -172,16 +181,17 @@ mkBitmapArray :: Word16 -> [StgWord] -> UArray Int StgWord 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 [] @@ -195,11 +205,14 @@ addListToSS (SizedSeq n r_xs) xs 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 @@ -217,21 +230,19 @@ largeArg w | 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 :: DynFlags + -> (Word16 -> Word) -- label finder -> AsmState -> [BCInstr] -- instructions (in) -> IO AsmState -mkBits findLabel st proto_insns +mkBits dflags findLabel st proto_insns = foldM doInstr st proto_insns where 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 @@ -239,14 +250,14 @@ mkBits findLabel st proto_insns instr2 st2 bci_PUSH_G p PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op) instr2 st2 bci_PUSH_G p - PUSH_BCO proto -> do ul_bco <- assembleBCO proto + PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 bci_PUSH_G p - PUSH_ALTS proto -> do ul_bco <- assembleBCO proto + PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 bci_PUSH_ALTS p PUSH_ALTS_UNLIFTED proto pk -> do - ul_bco <- assembleBCO proto + ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 (push_alts pk) p PUSH_UBX (Left lit) nws @@ -279,27 +290,31 @@ mkBits findLabel st proto_insns 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) @@ -311,6 +326,14 @@ mkBits findLabel st proto_insns = 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) @@ -336,46 +359,50 @@ mkBits findLabel st proto_insns 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) _) + | platformOS (targetPlatform dflags) == OSMinGW32 = litlabel st (appendFS fs (mkFastString ('@':show sz))) -- On Windows, stdcall labels have a suffix indicating the no. of -- arg words, e.g. foo@8. testcase: ffi012(ghci) -#endif literal st (MachLabel fs _ _) = litlabel st fs literal st (MachWord w) = int st (fromIntegral w) literal st (MachInt j) = int st (fromIntegral j) @@ -406,7 +433,7 @@ return_ubx PtrArg = bci_RETURN_P -- The size in 16-bit entities of an instruction. -instrSize16s :: BCInstr -> Word16 +instrSize16s :: BCInstr -> Word instrSize16s instr = case instr of STKCHECK{} -> 2 @@ -441,6 +468,8 @@ instrSize16s instr LABEL{} -> 0 -- !! TESTLT_I{} -> 3 TESTEQ_I{} -> 3 + TESTLT_W{} -> 3 + TESTEQ_W{} -> 3 TESTLT_F{} -> 3 TESTEQ_F{} -> 3 TESTLT_D{} -> 3 @@ -452,7 +481,7 @@ instrSize16s instr ENTER{} -> 1 RETURN{} -> 1 RETURN_UBX{} -> 1 - CCALL{} -> 3 + CCALL{} -> 4 SWIZZLE{} -> 3 BRK_FUN{} -> 4