#include "HsVersions.h"
#include "nativeGen/NCG.h"
-import MachInstrs
-import MachRegs
-import MachCodeGen
-import PprMach
-import RegAllocInfo
+
+import qualified X86.CodeGen
+import qualified X86.Regs
+import qualified X86.Instr
+import qualified X86.Ppr
+
+import qualified SPARC.CodeGen
+import qualified SPARC.Regs
+import qualified SPARC.Instr
+import qualified SPARC.Ppr
+import qualified SPARC.ShortcutJump
+import qualified SPARC.CodeGen.Expand
+
+import qualified PPC.CodeGen
+import qualified PPC.Cond
+import qualified PPC.Regs
+import qualified PPC.RegInfo
+import qualified PPC.Instr
+import qualified PPC.Ppr
+
+import RegAlloc.Liveness
+import qualified RegAlloc.Linear.Main as Linear
+
+import qualified GraphColor as Color
+import qualified RegAlloc.Graph.Main as Color
+import qualified RegAlloc.Graph.Stats as Color
+import qualified RegAlloc.Graph.TrivColorable as Color
+
+import TargetReg
+import Platform
+import Config
+import Instruction
+import PIC
+import Reg
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, pprCmm )
-import MachOp
+
+import BlockId
+import CgUtils ( fixStgRegisters )
+import OldCmm
+import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
+import OldPprCmm
import CLabel
import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
-import FastTypes
-import List ( groupBy, sortBy )
-import ErrUtils ( dumpIfSet_dyn )
import DynFlags
-import StaticFlags ( opt_Static, opt_PIC )
+import StaticFlags
import Util
-import Config ( cProjectVersion )
-import Module
import Digraph
+import Pretty (Doc)
import qualified Pretty
+import BufWrite
import Outputable
import FastString
import UniqSet
+import ErrUtils
+import Module
-- DEBUGGING ONLY
--import OrdList
import Data.List
-import Data.Int
-import Data.Word
-import Data.Bits
import Data.Maybe
-import GHC.Exts
import Control.Monad
+import System.IO
{-
The native-code generator has machine-independent and
-- -----------------------------------------------------------------------------
-- Top-level of the native codegen
--- NB. We *lazilly* compile each block of code for space reasons.
+data NcgImpl instr jumpDest = NcgImpl {
+ cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop instr],
+ generateJumpTableForInstr :: instr -> Maybe (NatCmmTop instr),
+ getJumpDestBlockId :: jumpDest -> Maybe BlockId,
+ canShortcut :: instr -> Maybe jumpDest,
+ shortcutStatic :: (BlockId -> Maybe jumpDest) -> CmmStatic -> CmmStatic,
+ shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
+ pprNatCmmTop :: NatCmmTop instr -> Doc,
+ maxSpillSlots :: Int,
+ allocatableRegs :: [RealReg],
+ ncg_x86fp_kludge :: [NatCmmTop instr] -> [NatCmmTop instr],
+ ncgExpandTop :: [NatCmmTop instr] -> [NatCmmTop instr],
+ ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
+ }
--------------------
-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))
+nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
+nativeCodeGen dflags h us cmms
+ = let nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
+ x86NcgImpl = NcgImpl {
+ cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
+ ,canShortcut = X86.Instr.canShortcut
+ ,shortcutStatic = X86.Instr.shortcutStatic
+ ,shortcutJump = X86.Instr.shortcutJump
+ ,pprNatCmmTop = X86.Ppr.pprNatCmmTop
+ ,maxSpillSlots = X86.Instr.maxSpillSlots
+ ,allocatableRegs = X86.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = id
+ ,ncgMakeFarBranches = id
+ }
+ in case platformArch $ targetPlatform dflags of
+ ArchX86 -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge })
+ ArchX86_64 -> nCG' x86NcgImpl
+ ArchPPC ->
+ nCG' $ NcgImpl {
+ cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
+ ,canShortcut = PPC.RegInfo.canShortcut
+ ,shortcutStatic = PPC.RegInfo.shortcutStatic
+ ,shortcutJump = PPC.RegInfo.shortcutJump
+ ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop
+ ,maxSpillSlots = PPC.Instr.maxSpillSlots
+ ,allocatableRegs = PPC.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = id
+ ,ncgMakeFarBranches = makeFarBranches
+ }
+ ArchSPARC ->
+ nCG' $ NcgImpl {
+ cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+ ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
+ ,canShortcut = SPARC.ShortcutJump.canShortcut
+ ,shortcutStatic = SPARC.ShortcutJump.shortcutStatic
+ ,shortcutJump = SPARC.ShortcutJump.shortcutJump
+ ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop
+ ,maxSpillSlots = SPARC.Instr.maxSpillSlots
+ ,allocatableRegs = SPARC.Regs.allocatableRegs
+ ,ncg_x86fp_kludge = id
+ ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
+ ,ncgMakeFarBranches = id
+ }
+ ArchPPC_64 ->
+ panic "nativeCodeGen: No NCG for PPC 64"
+ ArchUnknown ->
+ panic "nativeCodeGen: No NCG for unknown arch"
+
+nativeCodeGen' :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
+ -> Handle -> UniqSupply -> [RawCmm] -> IO ()
+nativeCodeGen' dflags ncgImpl h us cmms
+ = do
+ let split_cmms = concat $ map add_split cmms
+ -- BufHandle is a performance hack. We could hide it inside
+ -- Pretty if it weren't for the fact that we do lots of little
+ -- printDocs here (in order to do codegen in constant space).
+ bufh <- newBufHandle h
+ (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0
+ bFlush bufh
+
+ let (native, colorStats, linearStats)
+ = unzip3 prof
+
+ -- dump native code
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm "Asm code"
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) $ concat native)
+
+ -- dump global NCG stats for graph coloring allocator
+ (case concat $ catMaybes colorStats of
+ [] -> return ()
+ stats -> do
+ -- build the global register conflict graph
+ let graphGlobal
+ = foldl Color.union Color.initGraph
+ $ [ Color.raGraph stat
+ | stat@Color.RegAllocStatsStart{} <- stats]
+
+ dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+ $ Color.pprStats stats graphGlobal
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_conflicts "Register conflict graph"
+ $ Color.dotGraph
+ targetRegDotColor
+ (Color.trivColorable
+ targetVirtualRegSqueeze
+ targetRealRegSqueeze)
+ $ graphGlobal)
+
+
+ -- dump global NCG stats for linear allocator
+ (case concat $ catMaybes linearStats of
+ [] -> return ()
+ stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats"
+ $ Linear.pprStats (concat native) stats)
+
+ -- write out the imports
+ Pretty.printDoc Pretty.LeftMode h
+ $ makeImportsDoc dflags (concat imports)
+
+ return ()
+
+ where add_split (Cmm tops)
+ | dopt Opt_SplitObjs dflags = split_marker : tops
+ | otherwise = tops
+
+ split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph [])
+
+
+-- | Do native code generation on all these cmms.
+--
+cmmNativeGens :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
+ -> BufHandle
+ -> UniqSupply
+ -> [RawCmmTop]
+ -> [[CLabel]]
+ -> [ ([NatCmmTop instr],
+ Maybe [Color.RegAllocStats instr],
+ Maybe [Linear.RegAllocStats]) ]
+ -> Int
+ -> IO ( [[CLabel]],
+ [([NatCmmTop instr],
+ Maybe [Color.RegAllocStats instr],
+ Maybe [Linear.RegAllocStats])] )
+
+cmmNativeGens _ _ _ _ [] impAcc profAcc _
+ = return (reverse impAcc, reverse profAcc)
+
+cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
+ = do
+ (us', native, imports, colorStats, linearStats)
+ <- cmmNativeGen dflags ncgImpl us cmm count
- cgCmm :: [RawCmmTop] -> UniqSM ( [CmmNativeGenDump], Pretty.Doc, [CLabel])
- cgCmm tops =
- lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
- case unzip3 results of { (dump,docs,imps) ->
- returnUs (dump, my_vcat docs, concat imps)
- }
- in
- case res of { (dump, insn_sdoc, imports) -> do
+ Pretty.bufLeftRender h
+ $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl) native
- cmmNativeGenDump dflags mod modLocation dump
+ -- carefully evaluate this strictly. Binding it with 'let'
+ -- and then using 'seq' doesn't work, because the let
+ -- apparently gets inlined first.
+ lsPprNative <- return $!
+ if dopt Opt_D_dump_asm dflags
+ || dopt Opt_D_dump_asm_stats dflags
+ then native
+ else []
- return (insn_sdoc Pretty.$$ dyld_stubs imports
+ count' <- return $! count + 1;
-#if HAVE_SUBSECTIONS_VIA_SYMBOLS
- -- On recent versions of Darwin, the linker supports
- -- dead-stripping of code and data on a per-symbol basis.
- -- There's a hack to make this work in PprMach.pprNatCmmTop.
- Pretty.$$ Pretty.text ".subsections_via_symbols"
-#endif
-#if HAVE_GNU_NONEXEC_STACK
- -- On recent GNU ELF systems one can mark an object file
- -- as not requiring an executable stack. If all objects
- -- linked into a program have this note then the program
- -- will not use an executable stack, which is good for
- -- security. GHC generated code does not need an executable
- -- stack so add the note in:
- Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
-#endif
-#if !defined(darwin_TARGET_OS)
- -- And just because every other compiler does, lets stick in
- -- an identifier directive: .ident "GHC x.y.z"
- Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
- Pretty.text cProjectVersion
- in Pretty.text ".ident" Pretty.<+>
- Pretty.doubleQuotes compilerIdent
-#endif
- )
- }
+ -- force evaulation all this stuff to avoid space leaks
+ seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
- where
+ cmmNativeGens dflags ncgImpl
+ h us' cmms
+ (imports : impAcc)
+ ((lsPprNative, colorStats, linearStats) : profAcc)
+ count'
- add_split (Cmm tops)
- | dopt Opt_SplitObjs dflags = split_marker : tops
- | otherwise = tops
+ where seqString [] = ()
+ seqString (x:xs) = x `seq` seqString xs `seq` ()
- split_marker = CmmProc [] mkSplitMarkerLabel [] []
- -- Generate "symbol stubs" for all external symbols that might
- -- come from a dynamic library.
-{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
- map head $ group $ sort imps-}
-
- -- (Hack) sometimes two Labels pretty-print the same, but have
- -- different uniques; so we compare their text versions...
- dyld_stubs imps
- | needImportedSymbols
- = Pretty.vcat $
- (pprGotDeclaration :) $
- map (pprImportedSymbol . fst . head) $
- groupBy (\(_,a) (_,b) -> a == b) $
- sortBy (\(_,a) (_,b) -> compare a b) $
- map doPpr $
- imps
- | otherwise
- = Pretty.empty
-
- where doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle)
- astyle = mkCodeStyle AsmStyle
-
-#ifndef NCG_DEBUG
- my_vcat sds = Pretty.vcat sds
-#else
- my_vcat sds = Pretty.vcat (
- intersperse (
- Pretty.char ' '
- Pretty.$$ Pretty.ptext SLIT("# ___ncg_debug_marker")
- Pretty.$$ Pretty.char ' '
- )
- sds
- )
-#endif
+-- | Complete native code generation phase for a single top-level chunk of Cmm.
+-- Dumping the output of each stage along the way.
+-- Global conflict graph and NGC stats
+cmmNativeGen
+ :: (Instruction instr, Outputable instr)
+ => DynFlags
+ -> NcgImpl instr jumpDest
+ -> UniqSupply
+ -> RawCmmTop -- ^ the cmm to generate code for
+ -> Int -- ^ sequence number of this top thing
+ -> IO ( UniqSupply
+ , [NatCmmTop instr] -- native code
+ , [CLabel] -- things imported by this cmm
+ , Maybe [Color.RegAllocStats instr] -- stats for the coloring register allocator
+ , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
+
+cmmNativeGen dflags ncgImpl us cmm count
+ = do
+ -- rewrite assignments to global regs
+ let fixed_cmm =
+ {-# SCC "fixStgRegisters" #-}
+ fixStgRegisters 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.
+ -- cmm to cmm optimisations
+ let (opt_cmm, imports) =
+ {-# SCC "cmmToCmm" #-}
+ cmmToCmm dflags fixed_cmm
-data CmmNativeGenDump
- = CmmNativeGenDump
- { cdCmmOpt :: RawCmmTop
- , cdNative :: [NatCmmTop]
- , cdLiveness :: [LiveCmmTop]
- , cdCoalesce :: Maybe [LiveCmmTop]
- , cdRegAllocStats :: Maybe [RegAllocStats]
- , cdColoredGraph :: Maybe (Color.Graph Reg RegClass Reg)
- , cdAlloced :: [NatCmmTop] }
+ dumpIfSet_dyn dflags
+ Opt_D_dump_opt_cmm "Optimised Cmm"
+ (pprCmm $ Cmm [opt_cmm])
-dchoose dflags opt a b
- | dopt opt dflags = a
- | otherwise = b
+ -- generate native code from cmm
+ let ((native, lastMinuteImports), usGen) =
+ {-# SCC "genMachCode" #-}
+ initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
-dchooses dflags opts a b
- | or $ map ( (flip dopt) dflags) opts = a
- | otherwise = b
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_native "Native code"
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) native)
--- | 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
- = 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
-
+ -- tag instructions with register liveness information
+ let (withLiveness, usLive) =
+ {-# SCC "regLiveness" #-}
+ initUs usGen
+ $ mapUs regLiveness
+ $ map natCmmTopToLive native
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_liveness "Liveness annotations added"
+ (vcat $ map ppr withLiveness)
+
+ -- allocate registers
+ (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
+ if ( dopt Opt_RegsGraph dflags
+ || dopt Opt_RegsIterative dflags)
+ then do
+ -- the regs usable for allocation
+ let (alloc_regs :: UniqFM (UniqSet RealReg))
+ = foldr (\r -> plusUFM_C unionUniqSets
+ $ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
+ emptyUFM
+ $ allocatableRegs ncgImpl
+
+ -- do the graph coloring register allocation
+ let ((alloced, regAllocStats), usAlloc)
+ = {-# SCC "RegAlloc" #-}
+ initUs usLive
+ $ Color.regAlloc
+ dflags
+ alloc_regs
+ (mkUniqSet [0 .. maxSpillSlots ncgImpl])
+ withLiveness
+
+ -- dump out what happened during register allocation
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+ (vcat $ map (\(stage, stats)
+ -> text "# --------------------------"
+ $$ text "# cmm " <> int count <> text " Stage " <> int stage
+ $$ ppr stats)
+ $ zip [0..] regAllocStats)
+
+ let mPprStats =
+ if dopt Opt_D_dump_asm_stats dflags
+ then Just regAllocStats else Nothing
+
+ -- force evaluation of the Maybe to avoid space leak
+ mPprStats `seq` return ()
+
+ return ( alloced, usAlloc
+ , mPprStats
+ , Nothing)
+
+ else do
+ -- do linear register allocation
+ let ((alloced, regAllocStats), usAlloc)
+ = {-# SCC "RegAlloc" #-}
+ initUs usLive
+ $ liftM unzip
+ $ mapUs (Linear.regAlloc dflags) withLiveness
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "Registers allocated"
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) alloced)
+
+ let mPprStats =
+ if dopt Opt_D_dump_asm_stats dflags
+ then Just (catMaybes regAllocStats) else Nothing
+
+ -- force evaluation of the Maybe to avoid space leak
+ mPprStats `seq` return ()
+
+ return ( alloced, usAlloc
+ , Nothing
+ , mPprStats)
+
+ ---- x86fp_kludge. This pass inserts ffree instructions to clear
+ ---- the FPU stack on x86. The x86 ABI requires that the FPU stack
+ ---- is clear, and library functions can return odd results if it
+ ---- isn't.
+ ----
+ ---- NB. must happen before shortcutBranches, because that
+ ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
+ let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
+
+ ---- generate jump tables
+ let tabled =
+ {-# SCC "generateJumpTables" #-}
+ generateJumpTables ncgImpl kludged
---- shortcut branches
let shorted =
{-# SCC "shortcutBranches" #-}
- shortcutBranches dflags alloced
+ shortcutBranches dflags ncgImpl tabled
---- sequence blocks
let sequenced =
{-# SCC "sequenceBlocks" #-}
- map sequenceTop shorted
-
- ---- x86fp_kludge
- let final_mach_code =
-#if i386_TARGET_ARCH
- {-# SCC "x86fp_kludge" #-}
- map x86fp_kludge sequenced
-#else
- 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
+ map (sequenceTop ncgImpl) shorted
+ ---- expansion of SPARC synthetic instrs
+ let expanded =
+ {-# SCC "sparc_expand" #-}
+ ncgExpandTop ncgImpl sequenced
--- 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)
+ Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+ (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl) expanded)
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_native "Native code"
- (vcat $ map (docToSDoc . pprNatCmmTop) $ concatMap cdNative dump)
+ return ( usAlloc
+ , expanded
+ , lastMinuteImports ++ imports
+ , ppr_raStatsColor
+ , ppr_raStatsLinear)
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_liveness "Liveness annotations added"
- (vcat $ map (ppr . cdLiveness) dump)
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
- (vcat $ map (fromMaybe empty . liftM ppr . cdCoalesce) dump)
-
- dumpIfSet_dyn dflags
- Opt_D_dump_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.
- when (dopt Opt_D_dump_asm_regalloc_stages dflags)
- $ do mapM_ (\stats
- -> printDump
- $ vcat $ map (\(stage, stats) ->
- text "-- Stage " <> int stage
- $$ ppr stats)
- (zip [0..] stats))
- $ map (fromMaybe [] . 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 "Register conflict graph"
- $ Color.dotGraph Color.regDotColor trivColorable
- $ foldl Color.union Color.initGraph
- $ catMaybes $ map cdColoredGraph dump
+x86fp_kludge :: NatCmmTop X86.Instr.Instr -> NatCmmTop X86.Instr.Instr
+x86fp_kludge top@(CmmData _ _) = top
+x86fp_kludge (CmmProc info lbl (ListGraph code)) =
+ CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
- -- Drop native code generator statistics.
- -- This is potentially a large amount of information, and we want to be able
- -- to collect it while running nofib. Drop a new file instead of emitting
- -- it to stdout/stderr.
- --
- 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 doc for all the imports.
+--
+makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
+makeImportsDoc dflags imports
+ = dyld_stubs imports
- -- build a global conflict graph
- let graph = foldl Color.union Color.initGraph $ map raGraph stats
+#if HAVE_SUBSECTIONS_VIA_SYMBOLS
+ -- On recent versions of Darwin, the linker supports
+ -- dead-stripping of code and data on a per-symbol basis.
+ -- There's a hack to make this work in PprMach.pprNatCmmTop.
+ Pretty.$$ Pretty.text ".subsections_via_symbols"
+#endif
+#if HAVE_GNU_NONEXEC_STACK
+ -- On recent GNU ELF systems one can mark an object file
+ -- as not requiring an executable stack. If all objects
+ -- linked into a program have this note then the program
+ -- will not use an executable stack, which is good for
+ -- security. GHC generated code does not need an executable
+ -- stack so add the note in:
+ Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits"
+#endif
+ -- And just because every other compiler does, lets stick in
+ -- an identifier directive: .ident "GHC x.y.z"
+ Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+>
+ Pretty.text cProjectVersion
+ in Pretty.text ".ident" Pretty.<+>
+ Pretty.doubleQuotes compilerIdent
- -- 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
+ where
+ -- Generate "symbol stubs" for all external symbols that might
+ -- come from a dynamic library.
+ dyld_stubs :: [CLabel] -> Pretty.Doc
+{- dyld_stubs imps = Pretty.vcat $ map pprDyldSymbolStub $
+ map head $ group $ sort imps-}
- writeFile dropFile
- (showSDoc $ vcat [outSpills, outLife, outConflict, outScatter])
+ arch = platformArch $ targetPlatform dflags
+ os = platformOS $ targetPlatform dflags
+
+ -- (Hack) sometimes two Labels pretty-print the same, but have
+ -- different uniques; so we compare their text versions...
+ dyld_stubs imps
+ | needImportedSymbols arch os
+ = Pretty.vcat $
+ (pprGotDeclaration arch os :) $
+ map ( pprImportedSymbol arch os . fst . head) $
+ groupBy (\(_,a) (_,b) -> a == b) $
+ sortBy (\(_,a) (_,b) -> compare a b) $
+ map doPpr $
+ imps
+ | otherwise
+ = Pretty.empty
+
+ doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle)
+ astyle = mkCodeStyle AsmStyle
- return ()
-- -----------------------------------------------------------------------------
-- Sequencing the basic blocks
-- such that as many of the local jumps as possible turn into
-- fallthroughs.
-sequenceTop :: NatCmmTop -> NatCmmTop
-sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl params blocks) =
- CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
+sequenceTop
+ :: Instruction instr
+ => NcgImpl instr jumpDest -> NatCmmTop instr -> NatCmmTop instr
+
+sequenceTop _ top@(CmmData _ _) = top
+sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
+ CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ 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
-- output the block, then if it has an out edge, we move the
-- destination of the out edge to the front of the list, and continue.
-sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
+-- FYI, the classic layout for basic blocks uses postorder DFS; this
+-- algorithm is implemented in Hoopl.
+
+sequenceBlocks
+ :: Instruction instr
+ => [NatBasicBlock instr]
+ -> [NatBasicBlock instr]
+
sequenceBlocks [] = []
sequenceBlocks (entry:blocks) =
seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
-- the first block is the entry point ==> it must remain at the start.
-sccBlocks :: [NatBasicBlock] -> [SCC (NatBasicBlock,Unique,[Unique])]
-sccBlocks blocks = stronglyConnCompR (map mkNode blocks)
-getOutEdges :: [Instr] -> [Unique]
-getOutEdges instrs = case jumpDests (last instrs) [] of
- [one] -> [getUnique one]
- _many -> []
- -- we're only interested in the last instruction of
- -- the block, and only if it has a single destination.
+sccBlocks
+ :: Instruction instr
+ => [NatBasicBlock instr]
+ -> [SCC ( NatBasicBlock instr
+ , Unique
+ , [Unique])]
+
+sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
+
+-- we're only interested in the last instruction of
+-- the block, and only if it has a single destination.
+getOutEdges
+ :: Instruction instr
+ => [instr] -> [Unique]
+getOutEdges instrs
+ = case jumpDestsOfInstr (last instrs) of
+ [one] -> [getUnique one]
+ _many -> []
+
+mkNode :: (Instruction t)
+ => GenBasicBlock t
+ -> (GenBasicBlock t, Unique, [Unique])
mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
+seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
seqBlocks [] = []
seqBlocks ((block,_,[]) : rest)
= block : seqBlocks rest
-- fallthroughs within a loop.
seqBlocks _ = panic "AsmCodegen:seqBlocks"
-reorder id accum [] = (False, reverse accum)
+reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
+reorder _ accum [] = (False, reverse accum)
reorder id accum (b@(block,id',out) : rest)
| id == id' = (True, (block,id,out) : reverse accum ++ rest)
| otherwise = reorder id (b:accum) rest
-- 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
+ :: [NatBasicBlock PPC.Instr.Instr]
+ -> [NatBasicBlock PPC.Instr.Instr]
makeFarBranches blocks
| last blockAddresses < nearLimit = blocks
| otherwise = zipWith handleBlock blockAddresses blocks
handleBlock addr (BasicBlock id instrs)
= BasicBlock id (zipWith makeFar [addr..] instrs)
- makeFar addr (BCC ALWAYS tgt) = BCC ALWAYS tgt
- makeFar addr (BCC cond tgt)
+ makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt
+ makeFar addr (PPC.Instr.BCC cond tgt)
| abs (addr - targetAddr) >= nearLimit
- = BCCFAR cond tgt
+ = PPC.Instr.BCCFAR cond tgt
| otherwise
- = BCC cond tgt
+ = PPC.Instr.BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
- makeFar addr other = other
+ makeFar _ other = other
nearLimit = 7000 -- 8192 instructions are allowed; let's keep some
-- distance, as we have a few pseudo-insns that are
-- things exactly
blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses
-#else
-makeFarBranches = id
-#endif
+
+-- -----------------------------------------------------------------------------
+-- Generate jump tables
+
+-- Analyzes all native code and generates data sections for all jump
+-- table instructions.
+generateJumpTables
+ :: NcgImpl instr jumpDest
+ -> [NatCmmTop instr] -> [NatCmmTop instr]
+generateJumpTables ncgImpl xs = concatMap f xs
+ where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
+ f p = [p]
+ g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)
-- -----------------------------------------------------------------------------
-- Shortcut branches
-shortcutBranches :: DynFlags -> [NatCmmTop] -> [NatCmmTop]
-shortcutBranches dflags tops
+shortcutBranches
+ :: DynFlags
+ -> NcgImpl instr jumpDest
+ -> [NatCmmTop instr]
+ -> [NatCmmTop instr]
+
+shortcutBranches dflags ncgImpl tops
| optLevel dflags < 1 = tops -- only with -O or higher
- | otherwise = map (apply_mapping mapping) tops'
+ | otherwise = map (apply_mapping ncgImpl mapping) tops'
where
- (tops', mappings) = mapAndUnzip build_mapping tops
+ (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) 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)
+build_mapping :: NcgImpl instr jumpDest
+ -> GenCmmTop d t (ListGraph instr)
+ -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest)
+build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
+build_mapping _ (CmmProc info lbl (ListGraph []))
+ = (CmmProc info lbl (ListGraph []), emptyUFM)
+build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
+ = (CmmProc info lbl (ListGraph (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
+ -- Don't completely eliminate loops here -- that can leave a dangling jump!
+ (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
+ split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
+ | Just jd <- canShortcut ncgImpl insn,
+ Just dest <- getJumpDestBlockId ncgImpl jd,
+ (setMember dest s) || dest == id -- loop checks
+ = (s, shortcut_blocks, b : others)
+ split (s, shortcut_blocks, others) (BasicBlock id [insn])
+ | Just dest <- canShortcut ncgImpl insn
+ = (setInsert id s, (id,dest) : shortcut_blocks, others)
+ split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
+
-- 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)
+apply_mapping :: NcgImpl instr jumpDest
+ -> UniqFM jumpDest
+ -> GenCmmTop CmmStatic h (ListGraph instr)
+ -> GenCmmTop CmmStatic h (ListGraph instr)
+apply_mapping ncgImpl ufm (CmmData sec statics)
+ = CmmData sec (map (shortcutStatic ncgImpl (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)
+apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks))
+ = CmmProc info lbl (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
- short_insn i = shortcutJump (lookupUFM ufm) i
+ short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i
-- shortcutJump should apply the mapping repeatedly,
-- just in case we can short multiple branches.
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode :: DynFlags -> RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode
+ :: DynFlags
+ -> (RawCmmTop -> NatM [NatCmmTop instr])
+ -> RawCmmTop
+ -> UniqSM
+ ( [NatCmmTop instr]
+ , [CLabel])
-genMachCode dflags cmm_top
+genMachCode dflags cmmTopCodeGen cmm_top
= do { initial_us <- getUs
; let initial_st = mkNatM_State initial_us 0 dflags
(new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
}
-- -----------------------------------------------------------------------------
--- Fixup assignments to global registers so that they assign to
--- locations within the RegTable, if appropriate.
-
--- Note that we currently don't fixup reads here: they're done by
--- the generic optimiser below, to avoid having two separate passes
--- over the Cmm.
-
-fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
-fixAssignsTop top@(CmmData _ _) = returnUs top
-fixAssignsTop (CmmProc info lbl params blocks) =
- mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
- returnUs (CmmProc info lbl params blocks')
-
-fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
-fixAssignsBlock (BasicBlock id stmts) =
- fixAssigns stmts `thenUs` \ stmts' ->
- returnUs (BasicBlock id stmts')
-
-fixAssigns :: [CmmStmt] -> UniqSM [CmmStmt]
-fixAssigns stmts =
- mapUs fixAssign stmts `thenUs` \ stmtss ->
- returnUs (concat stmtss)
-
-fixAssign :: CmmStmt -> UniqSM [CmmStmt]
-fixAssign (CmmAssign (CmmGlobal reg) src)
- | Left realreg <- reg_or_addr
- = returnUs [CmmAssign (CmmGlobal reg) src]
- | Right baseRegAddr <- reg_or_addr
- = returnUs [CmmStore baseRegAddr src]
- -- Replace register leaves with appropriate StixTrees for
- -- the given target. GlobalRegs which map to a reg on this
- -- arch are left unchanged. Assigning to BaseReg is always
- -- illegal, so we check for that.
- where
- reg_or_addr = get_GlobalReg_reg_or_addr reg
-
-fixAssign other_stmt = returnUs [other_stmt]
-
--- -----------------------------------------------------------------------------
-- Generic Cmm optimiser
{-
(a) Constant folding
(b) Simple inlining: a temporary which is assigned to and then
used, once, can be shorted.
- (c) Replacement of references to GlobalRegs which do not have
- machine registers by the appropriate memory load (eg.
- Hp ==> *(BaseReg + 34) ).
- (d) Position independent code and dynamic linking
+ (c) Position independent code and dynamic linking
(i) introduce the appropriate indirections
and position independent refs
(ii) compile a list of imported symbols
-Ideas for other things we could do (ToDo):
+Ideas for other things we could do:
- shortcut jumps-to-jumps
- - eliminate dead code blocks
- simple CSE: if an expr is assigned to a temp, then replace later occs of
that expr with the temp, until the expr is no longer valid (can push through
temp assignments, and certain assigns to mem...)
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'
+cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
+ blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks))
+ return $ CmmProc info lbl (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
CmmOptM g' -> g' (imports', dflags)
addImportCmmOpt :: CLabel -> CmmOptM ()
-addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #)
+addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #)
getDynFlagsCmmOpt :: CmmOptM DynFlags
getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #)
stmts' <- mapM cmmStmtConFold stmts
return $ BasicBlock id stmts'
+cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
cmmStmtConFold stmt
= case stmt of
CmmAssign reg src
e' <- cmmExprConFold CallReference e
return $ CmmCallee e' conv
other -> return other
- args' <- mapM (\(arg, hint) -> do
+ args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
- return (arg', hint)) args
+ return (CmmHinted arg' hint)) args
return $ CmmCall target' regs args' srt returns
CmmCondBranch test dest
CmmComment (mkFastString ("deleted: " ++
showSDoc (pprStmt stmt)))
- CmmLit (CmmInt n _) -> CmmBranch dest
- other -> CmmCondBranch test' dest
+ CmmLit (CmmInt _ _) -> CmmBranch dest
+ _other -> CmmCondBranch test' dest
CmmSwitch expr ids
-> do expr' <- cmmExprConFold DataReference expr
-> return other
-cmmExprConFold referenceKind expr
- = case expr of
+cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
+cmmExprConFold referenceKind expr = do
+ dflags <- getDynFlagsCmmOpt
+ let arch = platformArch (targetPlatform dflags)
+ case expr of
CmmLoad addr rep
-> do addr' <- cmmExprConFold DataReference addr
return $ CmmLoad addr' rep
CmmLit (CmmLabel lbl)
-> do
- dflags <- getDynFlagsCmmOpt
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dflags <- getDynFlagsCmmOpt
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
- return $ cmmMachOpFold (MO_Add wordRep) [
+ return $ cmmMachOpFold (MO_Add wordWidth) [
dynRef,
- (CmmLit $ CmmInt (fromIntegral off) wordRep)
+ (CmmLit $ CmmInt (fromIntegral off) wordWidth)
]
-#if powerpc_TARGET_ARCH
- -- On powerpc (non-PIC), it's easier to jump directly to a label than
- -- to use the register table, so we replace these registers
- -- with the corresponding labels:
+ -- On powerpc (non-PIC), it's easier to jump directly to a label than
+ -- to use the register table, so we replace these registers
+ -- with the corresponding labels:
+ CmmReg (CmmGlobal EagerBlackholeInfo)
+ | arch == ArchPPC && not opt_PIC
+ -> cmmExprConFold referenceKind $
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | not opt_PIC
+ | arch == ArchPPC && not opt_PIC
-> cmmExprConFold referenceKind $
- CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
-#endif
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
- CmmReg (CmmGlobal mid)
- -- Replace register leaves with appropriate StixTrees for
- -- the given target. MagicIds which map to a reg on this
- -- arch are left unchanged. For the rest, BaseReg is taken
- -- to mean the address of the reg table in MainCapability,
- -- and for all others we generate an indirection to its
- -- location in the register table.
- -> case get_GlobalReg_reg_or_addr mid of
- Left realreg -> return expr
- Right baseRegAddr
- -> case mid of
- BaseReg -> cmmExprConFold DataReference baseRegAddr
- other -> cmmExprConFold DataReference
- (CmmLoad baseRegAddr (globalRegRep mid))
- -- eliminate zero offsets
- CmmRegOff reg 0
- -> cmmExprConFold referenceKind (CmmReg reg)
-
- CmmRegOff (CmmGlobal mid) offset
- -- RegOf leaves are just a shorthand form. If the reg maps
- -- to a real reg, we keep the shorthand, otherwise, we just
- -- expand it and defer to the above code.
- -> case get_GlobalReg_reg_or_addr mid of
- Left realreg -> return expr
- Right baseRegAddr
- -> cmmExprConFold DataReference (CmmMachOp (MO_Add wordRep) [
- CmmReg (CmmGlobal mid),
- CmmLit (CmmInt (fromIntegral offset)
- wordRep)])
other
-> return other
--- -----------------------------------------------------------------------------
--- Utils
-
-bind f x = x $! f
-
\end{code}
projects / ghc-hetmet.git / blobdiff