import MachRegs
import MachCodeGen
import PprMach
-import RegisterAlloc
-import RegAllocInfo ( jumpDests )
+import RegAllocInfo
import NCGMonad
import PositionIndependentCode
+import RegAllocLinear
+import RegAllocStats
+import RegLiveness
+import RegCoalesce
+import qualified RegAllocColor as Color
+import qualified GraphColor as Color
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
-import PprCmm ( pprStmt, pprCmms )
+import PprCmm ( pprStmt, pprCmms, pprCmm )
import MachOp
-import CLabel ( CLabel, mkSplitMarkerLabel, mkAsmTempLabel )
-#if powerpc_TARGET_ARCH
-import CLabel ( mkRtsCodeLabel )
-#endif
+import CLabel
import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
import FastTypes
import List ( groupBy, sortBy )
-import CLabel ( pprCLabel )
import ErrUtils ( dumpIfSet_dyn )
-import DynFlags ( DynFlags, DynFlag(..), dopt )
+import DynFlags
import StaticFlags ( opt_Static, opt_PIC )
+import Util
import Config ( cProjectVersion )
+import Module
import Digraph
import qualified Pretty
import Outputable
import FastString
+import UniqSet
-- DEBUGGING ONLY
--import OrdList
-#ifdef NCG_DEBUG
-import List ( intersperse )
-#endif
-
+import Data.List
import Data.Int
import Data.Word
import Data.Bits
+import Data.Maybe
import GHC.Exts
+import Control.Monad
{-
The native-code generator has machine-independent and
-- NB. We *lazilly* compile each block of code for space reasons.
-nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
-nativeCodeGen dflags cmms us
+--------------------
+nativeCodeGen :: DynFlags -> Module -> ModLocation -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
+nativeCodeGen dflags mod modLocation cmms us
= let (res, _) = initUs us $
cgCmm (concat (map add_split cmms))
- cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
+ cgCmm :: [RawCmmTop] -> UniqSM ( [CmmNativeGenDump], Pretty.Doc, [CLabel])
cgCmm tops =
lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
- case unzip3 results of { (cmms,docs,imps) ->
- returnUs (Cmm cmms, my_vcat docs, concat imps)
+ case unzip3 results of { (dump,docs,imps) ->
+ returnUs (dump, my_vcat docs, concat imps)
}
in
- case res of { (ppr_cmms, insn_sdoc, imports) -> do
- dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmms [ppr_cmms])
+ case res of { (dump, insn_sdoc, imports) -> do
+
+ cmmNativeGenDump dflags mod modLocation dump
+
return (insn_sdoc Pretty.$$ dyld_stubs imports
+
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-- On recent versions of Darwin, the linker supports
-- dead-stripping of code and data on a per-symbol basis.
#endif
--- Complete native code generation phase for a single top-level chunk
--- of Cmm.
+-- Carries output of the code generator passes, for dumping.
+-- Make sure to only fill the one's we're interested in to avoid
+-- creating space leaks.
+
+data CmmNativeGenDump
+ = CmmNativeGenDump
+ { cdCmmOpt :: RawCmmTop
+ , cdNative :: [NatCmmTop]
+ , cdLiveness :: [LiveCmmTop]
+ , cdCoalesce :: Maybe [LiveCmmTop]
+ , cdRegAllocStats :: Maybe [RegAllocStats]
+ , cdColoredGraph :: Maybe (Color.Graph Reg RegClass Reg)
+ , cdAlloced :: [NatCmmTop] }
-cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
+dchoose dflags opt a b
+ | dopt opt dflags = a
+ | otherwise = b
+
+dchooses dflags opts a b
+ | or $ map ( (flip dopt) dflags) opts = a
+ | otherwise = b
+
+-- | Complete native code generation phase for a single top-level chunk of Cmm.
+-- Unless they're being dumped, intermediate data structures are squashed after
+-- every stage to avoid creating space leaks.
+--
+cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (CmmNativeGenDump, Pretty.Doc, [CLabel])
cmmNativeGen dflags cmm
- = {-# SCC "fixAssigns" #-}
- fixAssignsTop cmm `thenUs` \ fixed_cmm ->
- {-# SCC "genericOpt" #-}
- cmmToCmm fixed_cmm `bind` \ (cmm, imports) ->
- (if dopt Opt_D_dump_opt_cmm dflags -- space leak avoidance
- then cmm
- else CmmData Text []) `bind` \ ppr_cmm ->
- {-# SCC "genMachCode" #-}
- genMachCode cmm `thenUs` \ (pre_regalloc, lastMinuteImports) ->
- {-# SCC "regAlloc" #-}
- mapUs regAlloc pre_regalloc `thenUs` \ with_regs ->
- {-# SCC "sequenceBlocks" #-}
- map sequenceTop with_regs `bind` \ sequenced ->
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge sequenced `bind` \ final_mach_code ->
- {-# SCC "vcat" #-}
- Pretty.vcat (map pprNatCmmTop final_mach_code) `bind` \ final_sdoc ->
-
- returnUs (ppr_cmm, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
- where
- x86fp_kludge :: NatCmmTop -> NatCmmTop
- x86fp_kludge top@(CmmData _ _) = top
+ = do
+ --
+ fixed_cmm
+ <- {-# SCC "fixAssigns" #-}
+ fixAssignsTop cmm
+
+ ---- cmm to cmm optimisations
+ (cmm, imports, ppr_cmm)
+ <- (\fixed_cmm
+ -> {-# SCC "genericOpt" #-}
+ do let (cmm, imports) = cmmToCmm dflags fixed_cmm
+
+ return ( cmm
+ , imports
+ , dchoose dflags Opt_D_dump_cmm cmm (CmmData Text []))
+ ) fixed_cmm
+
+
+ ---- generate native code from cmm
+ (native, lastMinuteImports, ppr_native)
+ <- (\cmm
+ -> {-# SCC "genMachCode" #-}
+ do (machCode, lastMinuteImports)
+ <- genMachCode dflags cmm
+
+ return ( machCode
+ , lastMinuteImports
+ , dchoose dflags Opt_D_dump_asm_native machCode [])
+ ) cmm
+
+
+ ---- tag instructions with register liveness information
+ (withLiveness, ppr_withLiveness)
+ <- (\native
+ -> {-# SCC "regLiveness" #-}
+ do
+ withLiveness <- mapUs regLiveness native
+
+ return ( withLiveness
+ , dchoose dflags Opt_D_dump_asm_liveness withLiveness []))
+ native
+
+ ---- allocate registers
+ (alloced, ppr_alloced, ppr_coalesce, ppr_regAllocStats, ppr_coloredGraph)
+ <- (\withLiveness
+ -> {-# SCC "regAlloc" #-}
+ do
+ if dopt Opt_RegsGraph dflags
+ then do
+ -- the regs usable for allocation
+ let alloc_regs
+ = foldr (\r -> plusUFM_C unionUniqSets
+ $ unitUFM (regClass r) (unitUniqSet r))
+ emptyUFM
+ $ map RealReg allocatableRegs
+
+ -- aggressively coalesce moves between virtual regs
+ coalesced <- regCoalesce withLiveness
+
+ -- graph coloring register allocation
+ (alloced, regAllocStats)
+ <- Color.regAlloc
+ alloc_regs
+ (mkUniqSet [0..maxSpillSlots])
+ coalesced
+
+ return ( alloced
+ , dchoose dflags Opt_D_dump_asm_regalloc alloced []
+ , dchoose dflags Opt_D_dump_asm_coalesce (Just coalesced) Nothing
+ , dchooses dflags
+ [ Opt_D_dump_asm_regalloc_stages
+ , Opt_D_drop_asm_stats]
+ (Just regAllocStats) Nothing
+ , dchoose dflags Opt_D_dump_asm_conflicts Nothing Nothing)
+
+ else do
+ -- do linear register allocation
+ alloced <- mapUs regAlloc withLiveness
+ return ( alloced
+ , dchoose dflags Opt_D_dump_asm_regalloc alloced []
+ , Nothing
+ , Nothing
+ , Nothing ))
+ withLiveness
+
+
+ ---- shortcut branches
+ let shorted =
+ {-# SCC "shortcutBranches" #-}
+ shortcutBranches dflags alloced
+
+ ---- sequence blocks
+ let sequenced =
+ {-# SCC "sequenceBlocks" #-}
+ map sequenceTop shorted
+
+ ---- x86fp_kludge
+ let final_mach_code =
#if i386_TARGET_ARCH
- x86fp_kludge top@(CmmProc info lbl params code) =
- CmmProc info lbl params (map bb_i386_insert_ffrees code)
- where
- bb_i386_insert_ffrees (BasicBlock id instrs) =
- BasicBlock id (i386_insert_ffrees instrs)
+ {-# SCC "x86fp_kludge" #-}
+ map x86fp_kludge sequenced
#else
- x86fp_kludge top = top
+ sequenced
#endif
+
+ ---- vcat
+ let final_sdoc =
+ {-# SCC "vcat" #-}
+ Pretty.vcat (map pprNatCmmTop final_mach_code)
+
+ let dump =
+ CmmNativeGenDump
+ { cdCmmOpt = ppr_cmm
+ , cdNative = ppr_native
+ , cdLiveness = ppr_withLiveness
+ , cdCoalesce = ppr_coalesce
+ , cdRegAllocStats = ppr_regAllocStats
+ , cdColoredGraph = ppr_coloredGraph
+ , cdAlloced = ppr_alloced }
+
+ returnUs (dump, final_sdoc Pretty.$$ Pretty.text "", lastMinuteImports ++ imports)
+
+#if i386_TARGET_ARCH
+x86fp_kludge :: NatCmmTop -> NatCmmTop
+x86fp_kludge top@(CmmData _ _) = top
+x86fp_kludge top@(CmmProc info lbl params code) =
+ CmmProc info lbl params (map bb_i386_insert_ffrees code)
+ where
+ bb_i386_insert_ffrees (BasicBlock id instrs) =
+ BasicBlock id (i386_insert_ffrees instrs)
+#endif
+
+
+-- Dump output of native code generator passes
+-- stripe across the outputs for each block so all the information for a
+-- certain stage is concurrent in the dumps.
+--
+cmmNativeGenDump :: DynFlags -> Module -> ModLocation -> [CmmNativeGenDump] -> IO ()
+cmmNativeGenDump dflags mod modLocation dump
+ = do
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_opt_cmm "Optimised Cmm"
+ (pprCmm $ Cmm $ map cdCmmOpt dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_native "(asm-native) Native code"
+ (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdNative dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_liveness "(asm-liveness) Liveness info added"
+ (vcat $ map (ppr . cdLiveness) dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_coalesce "(asm-coalesce) Register moves coalesced."
+ (vcat $ map (ppr . (\(Just c) -> c) . cdCoalesce) dump)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "(asm-regalloc) Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdAlloced dump)
+
+ -- with the graph coloring allocator, show the result of each build/spill stage
+ -- for each block in turn.
+ mapM_ (\codeGraphs
+ -> dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc_stages "(asm-regalloc-stages)"
+ (vcat $ map (\(stage, stats) ->
+ text "-- Stage " <> int stage
+ $$ ppr stats)
+ (zip [0..] codeGraphs)))
+ $ map ((\(Just c) -> c) . cdRegAllocStats) dump
+
+
+ -- Build a global register conflict graph.
+ -- If you want to see the graph for just one basic block then use asm-regalloc-stages instead.
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_conflicts "(asm-conflicts) Register conflict graph"
+ $ Color.dotGraph Color.regDotColor trivColorable
+ $ foldl Color.union Color.initGraph
+ $ catMaybes $ map cdColoredGraph dump
+
+
+ -- Drop native code gen statistics.
+ -- This is potentially a large amount of information, so we make a new file instead
+ -- of dumping it to stdout.
+ when (dopt Opt_D_drop_asm_stats dflags)
+ $ do -- make the drop file name based on the object file name
+ let dropFile = (init $ ml_obj_file modLocation) ++ "drop-asm-stats"
+
+ -- slurp out all the regalloc stats
+ let stats = concat $ catMaybes $ map cdRegAllocStats dump
+
+ -- build a global conflict graph
+ let graph = foldl Color.union Color.initGraph $ map raGraph stats
+
+ -- pretty print the various sections and write out the file.
+ let outSpills = pprStatsSpills stats
+ let outLife = pprStatsLifetimes stats
+ let outConflict = pprStatsConflict stats
+ let outScatter = pprStatsLifeConflict stats graph
+
+ writeFile dropFile
+ (showSDoc $ vcat [outSpills, outLife, outConflict, outScatter])
+
+ return ()
+
+ return ()
-- -----------------------------------------------------------------------------
-- Sequencing the basic blocks
sequenceTop :: NatCmmTop -> NatCmmTop
sequenceTop top@(CmmData _ _) = top
sequenceTop (CmmProc info lbl params blocks) =
- CmmProc info lbl params (sequenceBlocks blocks)
+ CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff the
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
+
+-- -----------------------------------------------------------------------------
+-- Making far branches
+
+-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
+-- big, we have to work around this limitation.
+
+makeFarBranches :: [NatBasicBlock] -> [NatBasicBlock]
+
+#if powerpc_TARGET_ARCH
+makeFarBranches blocks
+ | last blockAddresses < nearLimit = blocks
+ | otherwise = zipWith handleBlock blockAddresses blocks
+ where
+ blockAddresses = scanl (+) 0 $ map blockLen blocks
+ blockLen (BasicBlock _ instrs) = length instrs
+
+ handleBlock addr (BasicBlock id instrs)
+ = BasicBlock id (zipWith makeFar [addr..] instrs)
+
+ makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
+ makeFar addr (BCC cond tgt)
+ | abs (addr - targetAddr) >= nearLimit
+ = BCCFAR cond tgt
+ | otherwise
+ = BCC cond tgt
+ where Just targetAddr = lookupUFM blockAddressMap tgt
+ makeFar addr other = other
+
+ nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
+ -- distance, as we have a few pseudo-insns that are
+ -- pretty-printed as multiple instructions,
+ -- and it's just not worth the effort to calculate
+ -- things exactly
+
+ blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
+#else
+makeFarBranches = id
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Shortcut branches
+
+shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
+shortcutBranches dflags tops
+ | optLevel dflags < 1 = tops -- only with -O or higher
+ | otherwise = map (apply_mapping mapping) tops'
+ where
+ (tops', mappings) = mapAndUnzip build_mapping tops
+ mapping = foldr plusUFM emptyUFM mappings
+
+build_mapping top@(CmmData _ _) = (top, emptyUFM)
+build_mapping (CmmProc info lbl params [])
+ = (CmmProc info lbl params [], emptyUFM)
+build_mapping (CmmProc info lbl params (head:blocks))
+ = (CmmProc info lbl params (head:others), mapping)
+ -- drop the shorted blocks, but don't ever drop the first one,
+ -- because it is pointed to by a global label.
+ where
+ -- find all the blocks that just consist of a jump that can be
+ -- shorted.
+ (shortcut_blocks, others) = partitionWith split blocks
+ split (BasicBlock id [insn]) | Just dest <- canShortcut insn
+ = Left (id,dest)
+ split other = Right other
+
+ -- build a mapping from BlockId to JumpDest for shorting branches
+ mapping = foldl add emptyUFM shortcut_blocks
+ add ufm (id,dest) = addToUFM ufm id dest
+
+apply_mapping ufm (CmmData sec statics)
+ = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
+ -- we need to get the jump tables, so apply the mapping to the entries
+ -- of a CmmData too.
+apply_mapping ufm (CmmProc info lbl params blocks)
+ = CmmProc info lbl params (map short_bb blocks)
+ where
+ short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
+ short_insn i = shortcutJump (lookupUFM ufm) i
+ -- shortcutJump should apply the mapping repeatedly,
+ -- just in case we can short multiple branches.
+
-- -----------------------------------------------------------------------------
-- Instruction selection
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
-genMachCode cmm_top
+genMachCode dflags cmm_top
= do { initial_us <- getUs
- ; let initial_st = mkNatM_State initial_us 0
+ ; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
- final_us = natm_us final_st
final_delta = natm_delta final_st
final_imports = natm_imports final_st
; if final_delta == 0
-- the generic optimiser below, to avoid having two separate passes
-- over the Cmm.
-fixAssignsTop :: CmmTop -> UniqSM CmmTop
+fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
fixAssignsTop top@(CmmData _ _) = returnUs top
fixAssignsTop (CmmProc info lbl params blocks) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
returnUs (concat stmtss)
fixAssign :: CmmStmt -> UniqSM [CmmStmt]
-fixAssign (CmmAssign (CmmGlobal BaseReg) src)
- = panic "cmmStmtConFold: assignment to BaseReg";
-
fixAssign (CmmAssign (CmmGlobal reg) src)
| Left realreg <- reg_or_addr
= returnUs [CmmAssign (CmmGlobal reg) src]
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
-fixAssign (CmmCall target results args vols)
- = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
- returnUs (caller_save ++
- CmmCall target results' args vols :
- caller_restore ++
- concat stores)
- where
- -- we also save/restore any caller-saves STG registers here
- (caller_save, caller_restore) = callerSaveVolatileRegs vols
-
- fixResult g@(CmmGlobal reg,hint) =
- case get_GlobalReg_reg_or_addr reg of
- Left realreg -> returnUs (g, [])
- Right baseRegAddr ->
- getUniqueUs `thenUs` \ uq ->
- let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
- returnUs ((local,hint),
- [CmmStore baseRegAddr (CmmReg local)])
- fixResult other =
- returnUs (other,[])
-
fixAssign other_stmt = returnUs [other_stmt]
-- -----------------------------------------------------------------------------
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
-cmmToCmm top@(CmmData _ _) = (top, [])
-cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
+cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
+cmmToCmm _ top@(CmmData _ _) = (top, [])
+cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
return $ CmmProc info lbl params blocks'
-newtype CmmOptM a = CmmOptM ([CLabel] -> (# a, [CLabel] #))
+newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
instance Monad CmmOptM where
- return x = CmmOptM $ \imports -> (# x,imports #)
+ return x = CmmOptM $ \(imports, _) -> (# x,imports #)
(CmmOptM f) >>= g =
- CmmOptM $ \imports ->
- case f imports of
+ CmmOptM $ \(imports, dflags) ->
+ case f (imports, dflags) of
(# x, imports' #) ->
case g x of
- CmmOptM g' -> g' imports'
+ CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \imports -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
+
+getDynFlagsCmmOpt :: CmmOptM DynFlags
+getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
-runCmmOpt :: CmmOptM a -> (a, [CLabel])
-runCmmOpt (CmmOptM f) = case f [] of
+runCmmOpt :: DynFlags -> CmmOptM a -> (a, [CLabel])
+runCmmOpt dflags (CmmOptM f) = case f ([], dflags) of
(# result, imports #) -> (result, imports)
cmmBlockConFold :: CmmBasicBlock -> CmmOptM CmmBasicBlock
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
- -> do src' <- cmmExprConFold False src
+ -> do src' <- cmmExprConFold DataReference src
return $ case src' of
CmmReg reg' | reg == reg' -> CmmNop
new_src -> CmmAssign reg new_src
CmmStore addr src
- -> do addr' <- cmmExprConFold False addr
- src' <- cmmExprConFold False src
+ -> do addr' <- cmmExprConFold DataReference addr
+ src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src'
CmmJump addr regs
- -> do addr' <- cmmExprConFold True addr
+ -> do addr' <- cmmExprConFold JumpReference addr
return $ CmmJump addr' regs
- CmmCall target regs args vols
+ CmmCall target regs args srt returns
-> do target' <- case target of
- CmmForeignCall e conv -> do
- e' <- cmmExprConFold True e
- return $ CmmForeignCall e' conv
+ CmmCallee e conv -> do
+ e' <- cmmExprConFold CallReference e
+ return $ CmmCallee e' conv
other -> return other
args' <- mapM (\(arg, hint) -> do
- arg' <- cmmExprConFold False arg
+ arg' <- cmmExprConFold DataReference arg
return (arg', hint)) args
- return $ CmmCall target' regs args' vols
+ return $ CmmCall target' regs args' srt returns
CmmCondBranch test dest
- -> do test' <- cmmExprConFold False test
+ -> do test' <- cmmExprConFold DataReference test
return $ case test' of
CmmLit (CmmInt 0 _) ->
CmmComment (mkFastString ("deleted: " ++
other -> CmmCondBranch test' dest
CmmSwitch expr ids
- -> do expr' <- cmmExprConFold False expr
+ -> do expr' <- cmmExprConFold DataReference expr
return $ CmmSwitch expr' ids
other
-> return other
-cmmExprConFold isJumpTarget expr
+cmmExprConFold referenceKind expr
= case expr of
CmmLoad addr rep
- -> do addr' <- cmmExprConFold False addr
+ -> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
CmmMachOp mop args
-- For MachOps, we first optimize the children, and then we try
-- our hand at some constant-folding.
- -> do args' <- mapM (cmmExprConFold False) args
+ -> do args' <- mapM (cmmExprConFold DataReference) args
return $ cmmMachOpFold mop args'
CmmLit (CmmLabel lbl)
- -> cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ -> do
+ dflags <- getDynFlagsCmmOpt
+ cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
- -> do dynRef <- cmmMakeDynamicReference addImportCmmOpt isJumpTarget lbl
+ -> do
+ dflags <- getDynFlagsCmmOpt
+ dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
return $ cmmMachOpFold (MO_Add wordRep) [
dynRef,
(CmmLit $ CmmInt (fromIntegral off) wordRep)
-- with the corresponding labels:
CmmReg (CmmGlobal GCEnter1)
| not opt_PIC
- -> cmmExprConFold isJumpTarget $
+ -> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
| not opt_PIC
- -> cmmExprConFold isJumpTarget $
+ -> cmmExprConFold referenceKind $
CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
#endif
Left realreg -> return expr
Right baseRegAddr
-> case mid of
- BaseReg -> cmmExprConFold False baseRegAddr
- other -> cmmExprConFold False (CmmLoad baseRegAddr
- (globalRegRep mid))
+ BaseReg -> cmmExprConFold DataReference baseRegAddr
+ other -> cmmExprConFold DataReference
+ (CmmLoad baseRegAddr (globalRegRep mid))
-- eliminate zero offsets
CmmRegOff reg 0
- -> cmmExprConFold False (CmmReg reg)
+ -> cmmExprConFold referenceKind (CmmReg reg)
CmmRegOff (CmmGlobal mid) offset
-- RegOf leaves are just a shorthand form. If the reg maps
-> case get_GlobalReg_reg_or_addr mid of
Left realreg -> return expr
Right baseRegAddr
- -> cmmExprConFold False (CmmMachOp (MO_Add wordRep) [
+ -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
CmmReg (CmmGlobal mid),
CmmLit (CmmInt (fromIntegral offset)
wordRep)])
projects / ghc-hetmet.git / blobdiff