-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 1993-2004
---
+--
-- This is the top-level module in the native code generator.
--
-- -----------------------------------------------------------------------------
\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
module AsmCodeGen ( nativeCodeGen ) where
#include "HsVersions.h"
import qualified PPC.Ppr
import RegAlloc.Liveness
-import qualified RegAlloc.Linear.Main as Linear
+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 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 NCGMonad
import BlockId
-import CgUtils ( fixStgRegisters )
+import CgUtils ( fixStgRegisters )
import OldCmm
-import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold )
+import CmmOpt ( cmmMachOpFold )
import OldPprCmm
import CLabel
import UniqFM
-import Unique ( Unique, getUnique )
import UniqSupply
import DynFlags
-import StaticFlags
import Util
import BasicTypes ( Alignment )
import Digraph
-import Pretty (Doc)
import qualified Pretty
import BufWrite
import Outputable
import UniqSet
import ErrUtils
import Module
+import Stream (Stream)
+import qualified Stream
-- DEBUGGING ONLY
--import OrdList
machine instructions.
* ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really
- a 'Doc').
+ a 'SDoc').
* ["RegAllocInfo"] In the register allocator, we manipulate
'MRegsState's, which are 'BitSet's, one bit per machine register.
canShortcut :: instr -> Maybe jumpDest,
shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics,
shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr,
- pprNatCmmDecl :: Platform -> NatCmmDecl statics instr -> Doc,
+ pprNatCmmDecl :: NatCmmDecl statics instr -> SDoc,
maxSpillSlots :: Int,
allocatableRegs :: [RealReg],
ncg_x86fp_kludge :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
ncgExpandTop :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],
+ ncgAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr,
ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr]
}
--------------------
-nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
+nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
nativeCodeGen dflags h us cmms
= let platform = targetPlatform dflags
- nCG' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
+ nCG' :: (Outputable statics, Outputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO ()
nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms
x86NcgImpl = NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
- ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr
+ ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
- ,maxSpillSlots = X86.Instr.maxSpillSlots (target32Bit platform)
- ,allocatableRegs = X86.Regs.allocatableRegs
+ ,maxSpillSlots = X86.Instr.maxSpillSlots dflags
+ ,allocatableRegs = X86.Regs.allocatableRegs platform
,ncg_x86fp_kludge = id
+ ,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = id
}
ArchPPC ->
nCG' $ NcgImpl {
cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
- ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr
+ ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
- ,maxSpillSlots = PPC.Instr.maxSpillSlots
- ,allocatableRegs = PPC.Regs.allocatableRegs
+ ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags
+ ,allocatableRegs = PPC.Regs.allocatableRegs platform
,ncg_x86fp_kludge = id
+ ,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = id
,ncgMakeFarBranches = makeFarBranches
}
ArchSPARC ->
nCG' $ NcgImpl {
cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
- ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr
+ ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
,shortcutJump = SPARC.ShortcutJump.shortcutJump
,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl
- ,maxSpillSlots = SPARC.Instr.maxSpillSlots
+ ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags
,allocatableRegs = SPARC.Regs.allocatableRegs
,ncg_x86fp_kludge = id
+ ,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = id
}
- ArchARM _ _ ->
+ ArchARM _ _ _ ->
panic "nativeCodeGen: No NCG for ARM"
ArchPPC_64 ->
panic "nativeCodeGen: No NCG for PPC 64"
ArchUnknown ->
panic "nativeCodeGen: No NCG for unknown arch"
-nativeCodeGen' :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+
+--
+-- Allocating more stack space for spilling is currently only
+-- supported for the linear register allocator on x86/x86_64, the rest
+-- default to the panic below. To support allocating extra stack on
+-- more platforms provide a definition of ncgAllocMoreStack.
+--
+noAllocMoreStack :: Int -> NatCmmDecl statics instr -> NatCmmDecl statics instr
+noAllocMoreStack amount _
+ = panic $ "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"
+ ++ " If you are trying to compile SHA1.hs from the crypto library then this\n"
+ ++ " is a known limitation in the linear allocator.\n"
+ ++ "\n"
+ ++ " Try enabling the graph colouring allocator with -fregs-graph instead."
+ ++ " You can still file a bug report if you like.\n"
+
+
+nativeCodeGen' :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
- -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
+ -> Handle -> UniqSupply -> Stream IO RawCmmGroup () -> IO ()
nativeCodeGen' dflags ncgImpl h us cmms
= do
- let platform = targetPlatform dflags
- split_cmms = concat $ map add_split cmms
+ let platform = targetPlatform dflags
+ split_cmms = Stream.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
+ (imports, prof) <- cmmNativeGenStream 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 . pprNatCmmDecl ncgImpl platform) $ 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 platform)
- (Color.trivColorable platform
- (targetVirtualRegSqueeze platform)
- (targetRealRegSqueeze platform))
- $ 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 ()
+ let (native, colorStats, linearStats)
+ = unzip3 prof
+
+ -- dump native code
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm "Asm code"
+ (vcat $ map (pprNatCmmDecl 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 platform)
+ (Color.trivColorable platform
+ (targetVirtualRegSqueeze platform)
+ (targetRealRegSqueeze platform))
+ $ 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 (pprCols dflags) h
+ $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
+ $ makeImportsDoc dflags (concat imports)
+
+ return ()
where add_split tops
- | dopt Opt_SplitObjs dflags = split_marker : tops
- | otherwise = tops
+ | gopt Opt_SplitObjs dflags = split_marker : tops
+ | otherwise = tops
- split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
+ split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph [])
+
+
+cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
+ => DynFlags
+ -> NcgImpl statics instr jumpDest
+ -> BufHandle
+ -> UniqSupply
+ -> Stream IO RawCmmGroup ()
+ -> [[CLabel]]
+ -> [ ([NatCmmDecl statics instr],
+ Maybe [Color.RegAllocStats statics instr],
+ Maybe [Linear.RegAllocStats]) ]
+ -> Int
+ -> IO ( [[CLabel]],
+ [([NatCmmDecl statics instr],
+ Maybe [Color.RegAllocStats statics instr],
+ Maybe [Linear.RegAllocStats])] )
+
+cmmNativeGenStream dflags ncgImpl h us cmm_stream impAcc profAcc count
+ = do
+ r <- Stream.runStream cmm_stream
+ case r of
+ Left () -> return (reverse impAcc, reverse profAcc)
+ Right (cmms, cmm_stream') -> do
+ (impAcc,profAcc,us') <- cmmNativeGens dflags ncgImpl h us cmms
+ impAcc profAcc count
+ cmmNativeGenStream dflags ncgImpl h us' cmm_stream'
+ impAcc profAcc count
-- | Do native code generation on all these cmms.
--
-cmmNativeGens :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+cmmNativeGens :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
-> BufHandle
-> Int
-> IO ( [[CLabel]],
[([NatCmmDecl statics instr],
- Maybe [Color.RegAllocStats statics instr],
- Maybe [Linear.RegAllocStats])] )
+ Maybe [Color.RegAllocStats statics instr],
+ Maybe [Linear.RegAllocStats])],
+ UniqSupply )
-cmmNativeGens _ _ _ _ [] impAcc profAcc _
- = return (reverse impAcc, reverse profAcc)
+cmmNativeGens _ _ _ us [] impAcc profAcc _
+ = return (impAcc,profAcc,us)
cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count
= do
- let platform = targetPlatform dflags
-
- (us', native, imports, colorStats, linearStats)
+ (us', native, imports, colorStats, linearStats)
<- {-# SCC "cmmNativeGen" #-} cmmNativeGen dflags ncgImpl us cmm count
{-# SCC "pprNativeCode" #-} Pretty.bufLeftRender h
- $ Pretty.vcat $ map (pprNatCmmDecl ncgImpl platform) native
+ $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
+ $ vcat $ map (pprNatCmmDecl ncgImpl) native
-- 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 []
+ lsPprNative <- return $!
+ if gopt Opt_D_dump_asm dflags
+ || gopt Opt_D_dump_asm_stats dflags
+ then native
+ else []
- count' <- return $! count + 1;
+ count' <- return $! count + 1;
- -- force evaulation all this stuff to avoid space leaks
- {-# SCC "seqString" #-} seqString (showSDoc $ vcat $ map (pprPlatform platform) imports) `seq` return ()
+ -- force evaulation all this stuff to avoid space leaks
+ {-# SCC "seqString" #-} seqString (showSDoc dflags $ vcat $ map ppr imports) `seq` return ()
- cmmNativeGens dflags ncgImpl
+ cmmNativeGens dflags ncgImpl
h us' cmms
- (imports : impAcc)
- ((lsPprNative, colorStats, linearStats) : profAcc)
- count'
+ (imports : impAcc)
+ ((lsPprNative, colorStats, linearStats) : profAcc)
+ count'
- where seqString [] = ()
- seqString (x:xs) = x `seq` seqString xs `seq` ()
+ where seqString [] = ()
+ seqString (x:xs) = x `seq` seqString xs `seq` ()
-- | 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
+-- Dumping the output of each stage along the way.
+-- Global conflict graph and NGC stats
cmmNativeGen
- :: (PlatformOutputable statics, PlatformOutputable instr, Instruction instr)
+ :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags
-> NcgImpl statics instr jumpDest
- -> UniqSupply
- -> RawCmmDecl -- ^ the cmm to generate code for
- -> Int -- ^ sequence number of this top thing
- -> IO ( UniqSupply
- , [NatCmmDecl statics instr] -- native code
- , [CLabel] -- things imported by this cmm
- , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
- , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
+ -> UniqSupply
+ -> RawCmmDecl -- ^ the cmm to generate code for
+ -> Int -- ^ sequence number of this top thing
+ -> IO ( UniqSupply
+ , [NatCmmDecl statics instr] -- native code
+ , [CLabel] -- things imported by this cmm
+ , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator
+ , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators
cmmNativeGen dflags ncgImpl us cmm count
= do
let platform = targetPlatform dflags
- -- rewrite assignments to global regs
- let fixed_cmm =
- {-# SCC "fixStgRegisters" #-}
- fixStgRegisters cmm
-
- -- cmm to cmm optimisations
- let (opt_cmm, imports) =
- {-# SCC "cmmToCmm" #-}
- cmmToCmm dflags fixed_cmm
-
- dumpIfSet_dyn dflags
- Opt_D_dump_opt_cmm "Optimised Cmm"
- (pprCmmGroup platform [opt_cmm])
-
- -- generate native code from cmm
- let ((native, lastMinuteImports), usGen) =
- {-# SCC "genMachCode" #-}
- initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
-
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_native "Native code"
- (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) native)
-
- -- tag instructions with register liveness information
- let (withLiveness, usLive) =
- {-# SCC "regLiveness" #-}
- initUs usGen
- $ mapUs (regLiveness platform)
- $ map natCmmTopToLive native
-
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_liveness "Liveness annotations added"
- (vcat $ map (pprPlatform platform) 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 platform 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 . pprNatCmmDecl ncgImpl platform) 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
- $$ pprPlatform platform 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 . pprNatCmmDecl ncgImpl platform) 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)
+ -- rewrite assignments to global regs
+ let fixed_cmm =
+ {-# SCC "fixStgRegisters" #-}
+ fixStgRegisters dflags cmm
+
+ -- cmm to cmm optimisations
+ let (opt_cmm, imports) =
+ {-# SCC "cmmToCmm" #-}
+ cmmToCmm dflags fixed_cmm
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_opt_cmm "Optimised Cmm"
+ (pprCmmGroup [opt_cmm])
+
+ -- generate native code from cmm
+ let ((native, lastMinuteImports), usGen) =
+ {-# SCC "genMachCode" #-}
+ initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_native "Native code"
+ (vcat $ map (pprNatCmmDecl ncgImpl) native)
+
+ -- tag instructions with register liveness information
+ let (withLiveness, usLive) =
+ {-# SCC "regLiveness" #-}
+ initUs usGen
+ $ mapM (regLiveness platform)
+ $ 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 ( gopt Opt_RegsGraph dflags
+ || gopt Opt_RegsIterative dflags)
+ then do
+ -- the regs usable for allocation
+ let (alloc_regs :: UniqFM (UniqSet RealReg))
+ = foldr (\r -> plusUFM_C unionUniqSets
+ $ unitUFM (targetClassOfRealReg platform 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 (pprNatCmmDecl 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 gopt 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 reg_alloc proc = do
+ (alloced, maybe_more_stack, ra_stats) <-
+ Linear.regAlloc dflags proc
+ case maybe_more_stack of
+ Nothing -> return ( alloced, ra_stats )
+ Just amount ->
+ return ( ncgAllocMoreStack ncgImpl amount alloced
+ , ra_stats )
+
+ let ((alloced, regAllocStats), usAlloc)
+ = {-# SCC "RegAlloc" #-}
+ initUs usLive
+ $ liftM unzip
+ $ mapM reg_alloc withLiveness
+
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_regalloc "Registers allocated"
+ (vcat $ map (pprNatCmmDecl ncgImpl) alloced)
+
+ let mPprStats =
+ if gopt 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
let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
---- generate jump tables
- let tabled =
- {-# SCC "generateJumpTables" #-}
+ let tabled =
+ {-# SCC "generateJumpTables" #-}
generateJumpTables ncgImpl kludged
- ---- shortcut branches
- let shorted =
- {-# SCC "shortcutBranches" #-}
- shortcutBranches dflags ncgImpl tabled
+ ---- shortcut branches
+ let shorted =
+ {-# SCC "shortcutBranches" #-}
+ shortcutBranches dflags ncgImpl tabled
- ---- sequence blocks
- let sequenced =
- {-# SCC "sequenceBlocks" #-}
- map (sequenceTop ncgImpl) shorted
+ ---- sequence blocks
+ let sequenced =
+ {-# SCC "sequenceBlocks" #-}
+ map (sequenceTop ncgImpl) shorted
---- expansion of SPARC synthetic instrs
- let expanded =
- {-# SCC "sparc_expand" #-}
+ let expanded =
+ {-# SCC "sparc_expand" #-}
ncgExpandTop ncgImpl sequenced
- dumpIfSet_dyn dflags
- Opt_D_dump_asm_expanded "Synthetic instructions expanded"
- (vcat $ map (docToSDoc . pprNatCmmDecl ncgImpl platform) expanded)
+ dumpIfSet_dyn dflags
+ Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+ (vcat $ map (pprNatCmmDecl ncgImpl) expanded)
- return ( usAlloc
- , expanded
- , lastMinuteImports ++ imports
- , ppr_raStatsColor
- , ppr_raStatsLinear)
+ return ( usAlloc
+ , expanded
+ , lastMinuteImports ++ imports
+ , ppr_raStatsColor
+ , ppr_raStatsLinear)
x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) 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)
+x86fp_kludge (CmmProc info lbl (ListGraph code)) =
+ CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code)
-- | Build a doc for all the imports.
--
-makeImportsDoc :: DynFlags -> [CLabel] -> Pretty.Doc
+makeImportsDoc :: DynFlags -> [CLabel] -> SDoc
makeImportsDoc dflags imports
= dyld_stubs imports
- Pretty.$$
+ $$
-- 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.pprNatCmmDecl.
(if platformHasSubsectionsViaSymbols (targetPlatform dflags)
- then Pretty.text ".subsections_via_symbols"
- else Pretty.empty)
- Pretty.$$
+ then text ".subsections_via_symbols"
+ else empty)
+ $$
-- 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
-- security. GHC generated code does not need an executable
-- stack so add the note in:
(if platformHasGnuNonexecStack (targetPlatform dflags)
- then Pretty.text ".section .note.GNU-stack,\"\",@progbits"
- else Pretty.empty)
- Pretty.$$
+ then text ".section .note.GNU-stack,\"\",@progbits"
+ else empty)
+ $$
-- And just because every other compiler does, lets stick in
-- an identifier directive: .ident "GHC x.y.z"
(if platformHasIdentDirective (targetPlatform dflags)
- then let compilerIdent = Pretty.text "GHC" Pretty.<+>
- Pretty.text cProjectVersion
- in Pretty.text ".ident" Pretty.<+>
- Pretty.doubleQuotes compilerIdent
- else Pretty.empty)
+ then let compilerIdent = text "GHC" <+> text cProjectVersion
+ in text ".ident" <+> doubleQuotes compilerIdent
+ else empty)
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-}
-
- platform = targetPlatform dflags
- arch = platformArch platform
- os = platformOS platform
-
- -- (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 platform . fst . head) $
- groupBy (\(_,a) (_,b) -> a == b) $
- sortBy (\(_,a) (_,b) -> compare a b) $
- map doPpr $
- imps
- | otherwise
- = Pretty.empty
-
- doPpr lbl = (lbl, renderWithStyle (pprCLabel platform lbl) astyle)
- astyle = mkCodeStyle AsmStyle
+ -- Generate "symbol stubs" for all external symbols that might
+ -- come from a dynamic library.
+ dyld_stubs :: [CLabel] -> SDoc
+{- dyld_stubs imps = vcat $ map pprDyldSymbolStub $
+ map head $ group $ sort imps-}
+
+ platform = targetPlatform dflags
+ arch = platformArch platform
+ os = platformOS platform
+
+ -- (Hack) sometimes two Labels pretty-print the same, but have
+ -- different uniques; so we compare their text versions...
+ dyld_stubs imps
+ | needImportedSymbols dflags arch os
+ = vcat $
+ (pprGotDeclaration dflags arch os :) $
+ map ( pprImportedSymbol dflags platform . fst . head) $
+ groupBy (\(_,a) (_,b) -> a == b) $
+ sortBy (\(_,a) (_,b) -> compare a b) $
+ map doPpr $
+ imps
+ | otherwise
+ = empty
+
+ doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
+ astyle = mkCodeStyle AsmStyle
-- -----------------------------------------------------------------------------
-- such that as many of the local jumps as possible turn into
-- fallthroughs.
-sequenceTop
- :: Instruction instr
+sequenceTop
+ :: Instruction instr
=> NcgImpl statics instr jumpDest -> NatCmmDecl statics instr -> NatCmmDecl statics instr
sequenceTop _ top@(CmmData _ _) = top
-sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
- CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
+sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
+ CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info 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
-- FYI, the classic layout for basic blocks uses postorder DFS; this
-- algorithm is implemented in Hoopl.
-sequenceBlocks
- :: Instruction instr
- => [NatBasicBlock instr]
- -> [NatBasicBlock instr]
+sequenceBlocks
+ :: Instruction instr
+ => BlockEnv i
+ -> [NatBasicBlock instr]
+ -> [NatBasicBlock instr]
-sequenceBlocks [] = []
-sequenceBlocks (entry:blocks) =
- seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
+sequenceBlocks _ [] = []
+sequenceBlocks infos (entry:blocks) =
+ seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
-- the first block is the entry point ==> it must remain at the start.
-sccBlocks
- :: Instruction instr
- => [NatBasicBlock instr]
- -> [SCC ( NatBasicBlock instr
- , Unique
- , [Unique])]
+sccBlocks
+ :: Instruction instr
+ => [NatBasicBlock instr]
+ -> [SCC ( NatBasicBlock instr
+ , BlockId
+ , [BlockId])]
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
+ :: Instruction instr
+ => [instr] -> [BlockId]
-getOutEdges instrs
- = case jumpDestsOfInstr (last instrs) of
- [one] -> [getUnique one]
- _many -> []
+getOutEdges instrs
+ = case jumpDestsOfInstr (last instrs) of
+ [one] -> [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
-seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
- | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
- | otherwise = block : seqBlocks rest'
+ -> (GenBasicBlock t, BlockId, [BlockId])
+mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
+
+seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
+ -> [GenBasicBlock t1]
+seqBlocks _ [] = []
+seqBlocks infos ((block,_,[]) : rest)
+ = block : seqBlocks infos rest
+seqBlocks infos ((block@(BasicBlock id instrs),_,[next]) : rest)
+ | can_fallthrough = BasicBlock id (init instrs) : seqBlocks infos rest'
+ | otherwise = block : seqBlocks infos rest'
where
- (can_fallthrough, rest') = reorder next [] rest
- -- TODO: we should do a better job for cycles; try to maximise the
- -- fallthroughs within a loop.
-seqBlocks _ = panic "AsmCodegen:seqBlocks"
+ can_fallthrough = not (mapMember next infos) && can_reorder
+ (can_reorder, rest') = reorder next [] rest
+ -- TODO: we should do a better job for cycles; try to maximise the
+ -- fallthroughs within a loop.
+seqBlocks _ _ = panic "AsmCodegen:seqBlocks"
reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
reorder _ accum [] = (False, reverse accum)
-- big, we have to work around this limitation.
makeFarBranches
- :: [NatBasicBlock PPC.Instr.Instr]
- -> [NatBasicBlock PPC.Instr.Instr]
+ :: [NatBasicBlock PPC.Instr.Instr]
+ -> [NatBasicBlock PPC.Instr.Instr]
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 _ (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
= PPC.Instr.BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
makeFar _ 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
-- -----------------------------------------------------------------------------
-- Analyzes all native code and generates data sections for all jump
-- table instructions.
generateJumpTables
- :: NcgImpl statics instr jumpDest
- -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
+ :: NcgImpl statics instr jumpDest
+ -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]
generateJumpTables ncgImpl xs = concatMap f xs
where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs
f p = [p]
-- Shortcut branches
shortcutBranches
- :: DynFlags
+ :: DynFlags
-> NcgImpl statics instr jumpDest
- -> [NatCmmDecl statics instr]
- -> [NatCmmDecl statics instr]
+ -> [NatCmmDecl statics instr]
+ -> [NatCmmDecl statics instr]
shortcutBranches dflags ncgImpl tops
| optLevel dflags < 1 = tops -- only with -O or higher
mapping = foldr plusUFM emptyUFM mappings
build_mapping :: NcgImpl statics instr jumpDest
- -> GenCmmDecl d t (ListGraph instr)
- -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
+ -> GenCmmDecl d (BlockEnv t) (ListGraph instr)
+ -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest)
build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
build_mapping _ (CmmProc info lbl (ListGraph []))
= (CmmProc info lbl (ListGraph []), emptyUFM)
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just jd <- canShortcut ncgImpl insn,
Just dest <- getJumpDestBlockId ncgImpl jd,
+ not (has_info id),
(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
+ | Just dest <- canShortcut ncgImpl insn,
+ not (has_info id)
= (setInsert id s, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
+ -- do not eliminate blocks that have an info table
+ has_info l = mapMember l info
-- 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 :: NcgImpl statics instr jumpDest
-> UniqFM jumpDest
-> GenCmmDecl statics h (ListGraph instr)
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode
- :: DynFlags
+genMachCode
+ :: DynFlags
-> (RawCmmDecl -> NatM [NatCmmDecl statics instr])
- -> RawCmmDecl
- -> UniqSM
- ( [NatCmmDecl statics instr]
- , [CLabel])
+ -> RawCmmDecl
+ -> UniqSM
+ ( [NatCmmDecl statics instr]
+ , [CLabel])
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)
- final_delta = natm_delta final_st
- final_imports = natm_imports final_st
- ; if final_delta == 0
+ = do { initial_us <- getUs
+ ; let initial_st = mkNatM_State initial_us 0 dflags
+ (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)
+ final_delta = natm_delta final_st
+ final_imports = natm_imports final_st
+ ; if final_delta == 0
then return (new_tops, final_imports)
else pprPanic "genMachCode: nonzero final delta" (int final_delta)
}
Here we do:
(a) Constant folding
- (b) Simple inlining: a temporary which is assigned to and then
- used, once, can be shorted.
(c) Position independent code and dynamic linking
(i) introduce the appropriate indirections
and position independent refs
(ii) compile a list of imported symbols
(d) Some arch-specific optimizations
-(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and
+(a) will be moving to the new Hoopl pipeline, however, (c) and
(d) are only needed by the native backend and will continue to live
here.
cmmToCmm :: DynFlags -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
- let platform = targetPlatform dflags
- blocks' <- mapM cmmBlockConFold (cmmMiniInline platform (cmmEliminateDeadBlocks blocks))
+ blocks' <- mapM cmmBlockConFold blocks
return $ CmmProc info lbl (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
-- * reg = reg --> nop
-- * if 0 then jump --> nop
-- * if 1 then jump --> jump
--- We might be tempted to skip this step entirely of not opt_PIC, but
+-- We might be tempted to skip this step entirely of not Opt_PIC, but
-- there is some PowerPC code for the non-PIC case, which would also
-- have to be separated.
cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt
CmmAssign reg src
-> do src' <- cmmExprConFold DataReference src
return $ case src' of
- CmmReg reg' | reg == reg' -> CmmNop
- new_src -> CmmAssign reg new_src
+ CmmReg reg' | reg == reg' -> CmmNop
+ new_src -> CmmAssign reg new_src
CmmStore addr src
-> do addr' <- cmmExprConFold DataReference addr
src' <- cmmExprConFold DataReference src
return $ CmmStore addr' src'
- CmmJump addr
+ CmmJump addr live
-> do addr' <- cmmExprConFold JumpReference addr
- return $ CmmJump addr'
+ return $ CmmJump addr' live
CmmCall target regs args returns
- -> do target' <- case target of
- CmmCallee e conv -> do
- e' <- cmmExprConFold CallReference e
- return $ CmmCallee e' conv
- other -> return other
+ -> do target' <- case target of
+ CmmCallee e conv -> do
+ e' <- cmmExprConFold CallReference e
+ return $ CmmCallee e' conv
+ op@(CmmPrim _ Nothing) ->
+ return op
+ CmmPrim op (Just stmts) ->
+ do stmts' <- mapM cmmStmtConFold stmts
+ return $ CmmPrim op (Just stmts')
args' <- mapM (\(CmmHinted arg hint) -> do
arg' <- cmmExprConFold DataReference arg
return (CmmHinted arg' hint)) args
CmmCondBranch test dest
-> do test' <- cmmExprConFold DataReference test
dflags <- getDynFlags
- let platform = targetPlatform dflags
- return $ case test' of
- CmmLit (CmmInt 0 _) ->
- CmmComment (mkFastString ("deleted: " ++
- showSDoc (pprStmt platform stmt)))
+ return $ case test' of
+ CmmLit (CmmInt 0 _) ->
+ CmmComment (mkFastString ("deleted: " ++
+ showSDoc dflags (pprStmt stmt)))
- CmmLit (CmmInt _ _) -> CmmBranch dest
- _other -> CmmCondBranch test' dest
+ CmmLit (CmmInt _ _) -> CmmBranch dest
+ _other -> CmmCondBranch test' dest
- CmmSwitch expr ids
- -> do expr' <- cmmExprConFold DataReference expr
- return $ CmmSwitch expr' ids
+ CmmSwitch expr ids
+ -> do expr' <- cmmExprConFold DataReference expr
+ return $ CmmSwitch expr' ids
other
-> return other
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr = do
dflags <- getDynFlags
- -- Skip constant folding if new code generator is running
- -- (this optimization is done in Hoopl)
- let expr' = if dopt Opt_TryNewCodeGen dflags
+
+ -- With -O1 and greater, the cmmSink pass does constant-folding, so
+ -- we don't need to do it again here.
+ let expr' = if optLevel dflags >= 1
then expr
- else cmmExprCon (targetPlatform dflags) expr
+ else cmmExprCon dflags expr
+
cmmExprNative referenceKind expr'
-cmmExprCon :: Platform -> CmmExpr -> CmmExpr
-cmmExprCon platform (CmmLoad addr rep) = CmmLoad (cmmExprCon platform addr) rep
-cmmExprCon platform (CmmMachOp mop args)
- = cmmMachOpFold platform mop (map (cmmExprCon platform) args)
+cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
+cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
+cmmExprCon dflags (CmmMachOp mop args)
+ = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
cmmExprCon _ other = other
-- handles both PIC and non-PIC cases... a very strange mixture
-> do args' <- mapM (cmmExprNative DataReference) args
return $ CmmMachOp mop args'
+ CmmLit (CmmBlock id)
+ -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))
+ -- we must convert block Ids to CLabels here, because we
+ -- might have to do the PIC transformation. Hence we must
+ -- not modify BlockIds beyond this point.
+
CmmLit (CmmLabel lbl)
-> do
cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
-> do
dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl
-- need to optimize here, since it's late
- return $ cmmMachOpFold platform (MO_Add wordWidth) [
+ return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
dynRef,
- (CmmLit $ CmmInt (fromIntegral off) wordWidth)
+ (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
]
-- 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
+ | arch == ArchPPC && not (gopt Opt_PIC dflags)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | arch == ArchPPC && not opt_PIC
+ | arch == ArchPPC && not (gopt Opt_PIC dflags)
-> cmmExprNative referenceKind $
- CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
+ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | arch == ArchPPC && not opt_PIC
+ | arch == ArchPPC && not (gopt Opt_PIC dflags)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun")))
git.haskell.org / ghc.git / blobdiff