X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FByteCodeAsm.lhs;h=af9fbe90494acc6e898029728b5a52f9155d437e;hp=d5ffae1d38a01a24f7869577129e8dc717953327;hb=0af06ed99ed56341adfdda4a92a0a36678780109;hpb=656e9d6b1db053c88ba1518b6095060347e09418 diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index d5ffae1..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,14 +115,14 @@ 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 @@ -128,19 +132,19 @@ assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) | 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 emptyFM lableInitialOffset instrs + label_env = mkLabelEnv Map.empty lableInitialOffset instrs - mkLabelEnv :: FiniteMap Word16 Word -> Word -> [BCInstr] - -> FiniteMap Word16 Word + 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 -> 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 @@ -150,7 +154,7 @@ 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 @@ -226,12 +230,13 @@ 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 -> Word) -- 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 @@ -245,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 @@ -308,8 +313,8 @@ mkBits findLabel st proto_insns 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) @@ -393,12 +398,11 @@ mkBits findLabel st proto_insns = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon)) 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) @@ -477,7 +481,7 @@ instrSize16s instr ENTER{} -> 1 RETURN{} -> 1 RETURN_UBX{} -> 1 - CCALL{} -> 3 + CCALL{} -> 4 SWIZZLE{} -> 3 BRK_FUN{} -> 4