Commit 2e82465f authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Refactor CmmToAsm (disentangle DynFlags)

This patch disentangles a bit more DynFlags from the native code
generator (CmmToAsm).

In more details:

- add a new NCGConfig datatype in GHC.CmmToAsm.Config which contains the
  configuration of a native code generation session
- explicitly pass NCGConfig/Platform arguments when necessary
- as a consequence `sdocWithPlatform` is gone and there are only a few
  `sdocWithDynFlags` left
- remove the use of `unsafeGlobalDynFlags` from GHC.CmmToAsm.CFG
- remove `sdocDebugLevel` (now we pass the debug level via NCGConfig)

There are still some places where DynFlags is used, especially because
of pretty-printing (CLabel), because of Cmm helpers (such as
`cmmExprType`) and because of `Outputable` instance for the
instructions. These are left for future refactoring as this patch is
already big.
parent dd6ffe6b
Pipeline #16745 passed with stages
in 442 minutes and 25 seconds
......@@ -1355,18 +1355,18 @@ instance Outputable ForeignLabelSource where
internalNamePrefix :: Name -> SDoc
internalNamePrefix name = getPprStyle $ \ sty ->
if asmStyle sty && isRandomGenerated then
sdocWithPlatform $ \platform ->
ptext (asmTempLabelPrefix platform)
sdocWithDynFlags $ \dflags ->
ptext (asmTempLabelPrefix (targetPlatform dflags))
else
empty
where
isRandomGenerated = not $ isExternalName name
tempLabelPrefixOrUnderscore :: SDoc
tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->
tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags ->
getPprStyle $ \ sty ->
if asmStyle sty then
ptext (asmTempLabelPrefix platform)
ptext (asmTempLabelPrefix (targetPlatform dflags))
else
char '_'
......
......@@ -69,6 +69,7 @@ import GHC.Platform.Reg
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Dwarf
import GHC.CmmToAsm.Config
import GHC.Cmm.DebugBlock
import GHC.Cmm.BlockId
......@@ -191,14 +192,15 @@ x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, RawCmmStatics)
X86.Instr.Instr X86.Instr.JumpDest
x86_64NcgImpl dflags
= NcgImpl {
cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
ncgConfig = config
,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
,maxSpillSlots = X86.Instr.maxSpillSlots dflags
,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl config
,maxSpillSlots = X86.Instr.maxSpillSlots config
,allocatableRegs = X86.Regs.allocatableRegs platform
,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
,ncgExpandTop = id
......@@ -206,19 +208,22 @@ x86_64NcgImpl dflags
,extractUnwindPoints = X86.CodeGen.extractUnwindPoints
,invertCondBranches = X86.CodeGen.invertCondBranches
}
where platform = targetPlatform dflags
where
config = initConfig dflags
platform = ncgPlatform config
ppcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
ppcNcgImpl dflags
= NcgImpl {
cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
ncgConfig = config
,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
,maxSpillSlots = PPC.Instr.maxSpillSlots dflags
,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl config
,maxSpillSlots = PPC.Instr.maxSpillSlots config
,allocatableRegs = PPC.Regs.allocatableRegs platform
,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform
,ncgExpandTop = id
......@@ -226,19 +231,22 @@ ppcNcgImpl dflags
,extractUnwindPoints = const []
,invertCondBranches = \_ _ -> id
}
where platform = targetPlatform dflags
where
config = initConfig dflags
platform = ncgPlatform config
sparcNcgImpl :: DynFlags -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
sparcNcgImpl dflags
= NcgImpl {
cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
ncgConfig = config
,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
,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 dflags
,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl config
,maxSpillSlots = SPARC.Instr.maxSpillSlots config
,allocatableRegs = SPARC.Regs.allocatableRegs
,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
......@@ -246,6 +254,8 @@ sparcNcgImpl dflags
,extractUnwindPoints = const []
,invertCondBranches = \_ _ -> id
}
where
config = initConfig dflags
--
-- Allocating more stack space for spilling is currently only
......@@ -538,7 +548,8 @@ cmmNativeGen
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= do
let platform = targetPlatform dflags
let config = ncgConfig ncgImpl
let platform = ncgPlatform config
let proc_name = case cmm of
(CmmProc _ entry_label _ _) -> ppr entry_label
......@@ -577,7 +588,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- tag instructions with register liveness information
-- also drops dead code. We don't keep the cfg in sync on
-- some backends, so don't use it there.
let livenessCfg = if (backendMaintainsCfg dflags)
let livenessCfg = if backendMaintainsCfg platform
then Just nativeCfgWeights
else Nothing
let (withLiveness, usLive) =
......@@ -607,7 +618,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= {-# SCC "RegAlloc-color" #-}
initUs usLive
$ Color.regAlloc
dflags
config
alloc_regs
(mkUniqSet [0 .. maxSpillSlots ncgImpl])
(maxSpillSlots ncgImpl)
......@@ -655,7 +666,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- do linear register allocation
let reg_alloc proc = do
(alloced, maybe_more_stack, ra_stats) <-
Linear.regAlloc dflags proc
Linear.regAlloc config proc
case maybe_more_stack of
Nothing -> return ( alloced, ra_stats, [] )
Just amount -> do
......@@ -691,11 +702,11 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
let cfgWithFixupBlks =
(\cfg -> addNodesBetween cfg cfgRegAllocUpdates) <$> livenessCfg
(\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg
-- Insert stack update blocks
let postRegCFG =
pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m ))
pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m ))
<*> cfgWithFixupBlks
<*> pure stack_updt_blks
......@@ -725,7 +736,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
getBlks _ = []
when ( backendMaintainsCfg dflags &&
when ( backendMaintainsCfg platform &&
(gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
let blocks = concatMap getBlks shorted
let labels = setFromList $ fmap blockId blocks :: LabelSet
......@@ -854,7 +865,7 @@ makeImportsDoc dflags imports
-- security. GHC generated code does not need an executable
-- stack so add the note in:
(if platformHasGnuNonexecStack platform
then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"
then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"
else Outputable.empty)
$$
-- And just because every other compiler does, let's stick in
......@@ -865,9 +876,8 @@ makeImportsDoc dflags imports
else Outputable.empty)
where
platform = targetPlatform dflags
arch = platformArch platform
os = platformOS platform
config = initConfig dflags
platform = ncgPlatform config
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
......@@ -877,10 +887,10 @@ makeImportsDoc dflags imports
-- (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
| needImportedSymbols config
= vcat $
(pprGotDeclaration dflags arch os :) $
map ( pprImportedSymbol dflags platform . fst . head) $
(pprGotDeclaration config :) $
map ( pprImportedSymbol dflags config . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
sortBy (\(_,a) (_,b) -> compare a b) $
map doPpr $
......
......@@ -10,7 +10,7 @@
{-# LANGUAGE FlexibleContexts #-}
module GHC.CmmToAsm.BlockLayout
( sequenceTop )
( sequenceTop, backendMaintainsCfg)
where
#include "HsVersions.h"
......@@ -25,7 +25,8 @@ import GHC.Cmm
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)
import GHC.Platform
import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)
import UniqFM
import Util
import Unique
......@@ -785,7 +786,7 @@ sequenceTop
sequenceTop _ _ _ top@(CmmData _ _) = top
sequenceTop dflags ncgImpl edgeWeights
(CmmProc info lbl live (ListGraph blocks))
| (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags
| (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags)
--Use chain based algorithm
, Just cfg <- edgeWeights
= CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
......@@ -799,7 +800,7 @@ sequenceTop dflags ncgImpl edgeWeights
sequenceBlocks cfg info blocks)
where
dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||
(not $ backendMaintainsCfg dflags)
(not $ backendMaintainsCfg (targetPlatform dflags))
-- The old algorithm:
-- It is very simple (and stupid): We make a graph out of
......@@ -893,3 +894,10 @@ lookupDeleteUFM :: Uniquable key => UniqFM elt -> key
lookupDeleteUFM m k = do -- Maybe monad
v <- lookupUFM m k
return (v, delFromUFM m k)
backendMaintainsCfg :: Platform -> Bool
backendMaintainsCfg platform = case platformArch platform of
-- ArchX86 -- Should work but not tested so disabled currently.
ArchX86_64 -> True
_otherwise -> False
......@@ -328,12 +328,12 @@ shortcutWeightMap cuts cfg =
-- \ \
-- -> C => -> C
--
addImmediateSuccessor :: BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor node follower cfg
addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG
addImmediateSuccessor dflags node follower cfg
= updateEdges . addWeightEdge node follower uncondWeight $ cfg
where
uncondWeight = fromIntegral . D.uncondWeight .
D.cfgWeightInfo $ D.unsafeGlobalDynFlags
D.cfgWeightInfo $ dflags
targets = getSuccessorEdges cfg node
successors = map fst targets :: [BlockId]
updateEdges = addNewSuccs . remOldSuccs
......@@ -508,13 +508,13 @@ mapWeights f cfg =
-- these cases.
-- We assign the old edge info to the edge A -> B and assign B -> C the
-- weight of an unconditional jump.
addNodesBetween :: CFG -> [(BlockId,BlockId,BlockId)] -> CFG
addNodesBetween m updates =
addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
addNodesBetween dflags m updates =
foldl' updateWeight m .
weightUpdates $ updates
where
weight = fromIntegral . D.uncondWeight .
D.cfgWeightInfo $ D.unsafeGlobalDynFlags
D.cfgWeightInfo $ dflags
-- We might add two blocks for different jumps along a single
-- edge. So we end up with edges: A -> B -> C , A -> D -> C
-- in this case after applying the first update the weight for A -> C
......
-- | Native code generator configuration
module GHC.CmmToAsm.Config
( NCGConfig(..)
, ncgWordWidth
)
where
import GhcPrelude
import GHC.Platform
import GHC.Cmm.Type (Width(..))
-- | Native code generator configuration
data NCGConfig = NCGConfig
{ ncgPlatform :: !Platform -- ^ Target platform
, ncgProcAlignment :: !(Maybe Int) -- ^ Mandatory proc alignment
, ncgDebugLevel :: !Int -- ^ Debug level
, ncgExternalDynamicRefs :: !Bool -- ^ Generate code to link against dynamic libraries
, ncgPIC :: !Bool -- ^ Enable Position-Independent Code
, ncgSplitSections :: !Bool -- ^ Split sections
, ncgSpillPreallocSize :: !Int -- ^ Size in bytes of the pre-allocated spill space on the C stack
, ncgRegsIterative :: !Bool
, ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass
, ncgDumpRegAllocStages :: !Bool
, ncgDumpAsmStats :: !Bool
, ncgDumpAsmConflicts :: !Bool
}
-- | Return Word size
ncgWordWidth :: NCGConfig -> Width
ncgWordWidth config = case platformWordSize (ncgPlatform config) of
PW4 -> W32
PW8 -> W64
......@@ -36,6 +36,7 @@ dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen _ _ us [] = return (empty, us)
dwarfGen df modLoc us blocks = do
let platform = targetPlatform df
-- Convert debug data structures to DWARF info records
-- We strip out block information when running with -g0 or -g1.
......@@ -64,33 +65,33 @@ dwarfGen df modLoc us blocks = do
haveSrc = any haveSrcIn procs
-- .debug_abbrev section: Declare the format we're using
let abbrevSct = pprAbbrevDecls haveSrc
let abbrevSct = pprAbbrevDecls platform haveSrc
-- .debug_info section: Information records on procedures and blocks
let -- unique to identify start and end compilation unit .debug_inf
(unitU, us') = takeUniqFromSupply us
infoSct = vcat [ ptext dwarfInfoLabel <> colon
, dwarfInfoSection
, compileUnitHeader unitU
, pprDwarfInfo haveSrc dwarfUnit
, dwarfInfoSection platform
, compileUnitHeader platform unitU
, pprDwarfInfo platform haveSrc dwarfUnit
, compileUnitFooter unitU
]
-- .debug_line section: Generated mainly by the assembler, but we
-- need to label it
let lineSct = dwarfLineSection $$
let lineSct = dwarfLineSection platform $$
ptext dwarfLineLabel <> colon
-- .debug_frame section: Information about the layout of the GHC stack
let (framesU, us'') = takeUniqFromSupply us'
frameSct = dwarfFrameSection $$
frameSct = dwarfFrameSection platform $$
ptext dwarfFrameLabel <> colon $$
pprDwarfFrame (debugFrame framesU procs)
pprDwarfFrame platform (debugFrame framesU procs)
-- .aranges section: Information about the bounds of compilation units
let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
| otherwise = [DwarfARange lowLabel highLabel]
let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
......@@ -106,17 +107,17 @@ mkDwarfARange proc = DwarfARange start end
-- | Header for a compilation unit, establishing global format
-- parameters
compileUnitHeader :: Unique -> SDoc
compileUnitHeader unitU = sdocWithPlatform $ \plat ->
compileUnitHeader :: Platform -> Unique -> SDoc
compileUnitHeader platform unitU =
let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field
length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
<> text "-4" -- length of initialLength field
in vcat [ ppr cuLabel <> colon
, text "\t.long " <> length -- compilation unit size
, pprHalf 3 -- DWARF version
, sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
, sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
-- abbrevs offset
, text "\t.byte " <> ppr (platformWordSizeInBytes plat) -- word size
, text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size
]
-- | Compilation unit footer, mainly establishing size of debug sections
......@@ -176,7 +177,7 @@ parent, B.
-- | Generate DWARF info for a procedure debug block
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf df prc
= DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)
= DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)
, dwName = case dblSourceTick prc of
Just s@SourceNote{} -> sourceName s
_otherwise -> showSDocDump df $ ppr $ dblLabel prc
......@@ -195,10 +196,10 @@ procToDwarf df prc
goodParent _ = True
-- | Generate DWARF info for a block
blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
blockToDwarf df blk
= DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)
++ map (blockToDwarf df) (dblBlocks blk)
blockToDwarf :: DebugBlock -> DwarfInfo
blockToDwarf blk
= DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk)
++ map blockToDwarf (dblBlocks blk)
, dwLabel = dblCLabel blk
, dwMarker = marker
}
......@@ -207,9 +208,9 @@ blockToDwarf df blk
| Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
| otherwise = Nothing -- block was optimized out
tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss]
tickToDwarf _ _ = []
tickToDwarf :: Tickish () -> [DwarfInfo]
tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss]
tickToDwarf _ = []
-- | Generates the data for the debug frame section, which encodes the
-- desired stack unwind behaviour for the debugger
......
......@@ -144,20 +144,20 @@ dW_OP_call_frame_cfa = 0x9c
-- * Dwarf section declarations
dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc
dwarfInfoSection = dwarfSection "info"
dwarfAbbrevSection = dwarfSection "abbrev"
dwarfLineSection = dwarfSection "line"
dwarfFrameSection = dwarfSection "frame"
dwarfGhcSection = dwarfSection "ghc"
dwarfARangesSection = dwarfSection "aranges"
dwarfSection :: String -> SDoc
dwarfSection name = sdocWithPlatform $ \plat ->
case platformOS plat of
dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc
dwarfInfoSection platform = dwarfSection platform "info"
dwarfAbbrevSection platform = dwarfSection platform "abbrev"
dwarfLineSection platform = dwarfSection platform "line"
dwarfFrameSection platform = dwarfSection platform "frame"
dwarfGhcSection platform = dwarfSection platform "ghc"
dwarfARangesSection platform = dwarfSection platform "aranges"
dwarfSection :: Platform -> String -> SDoc
dwarfSection platform name =
case platformOS platform of
os | osElfTarget os
-> text "\t.section .debug_" <> text name <> text ",\"\","
<> sectionType "progbits"
<> sectionType platform "progbits"
| osMachOTarget os
-> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
| otherwise
......
This diff is collapsed.
......@@ -16,14 +16,15 @@ where
import GhcPrelude
import GHC.Platform
import GHC.Platform.Reg
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Driver.Session
import GHC.Cmm hiding (topInfoTable)
import GHC.Platform
import GHC.CmmToAsm.Config
-- | Holds a list of source and destination registers used by a
-- particular instruction.
......@@ -132,7 +133,7 @@ class Instruction instr where
-- | An instruction to spill a register into a spill slot.
mkSpillInstr
:: DynFlags
:: NCGConfig
-> Reg -- ^ the reg to spill
-> Int -- ^ the current stack delta
-> Int -- ^ spill slot to use
......@@ -141,7 +142,7 @@ class Instruction instr where
-- | An instruction to reload a register from a spill slot.
mkLoadInstr
:: DynFlags
:: NCGConfig
-> Reg -- ^ the reg to reload.
-> Int -- ^ the current stack delta
-> Int -- ^ the spill slot to use
......
......@@ -16,6 +16,7 @@ module GHC.CmmToAsm.Monad (
NatM, -- instance Monad
initNat,
initConfig,
addImportNat,
addNodeBetweenNat,
addImmediateSuccessorNat,
......@@ -23,6 +24,8 @@ module GHC.CmmToAsm.Monad (
getUniqueNat,
mapAccumLNat,
setDeltaNat,
getConfig,
getPlatform,
getDeltaNat,
getThisModuleNat,
getBlockIdNat,
......@@ -45,9 +48,11 @@ where
import GhcPrelude
import GHC.Platform
import GHC.Platform.Reg
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
......@@ -69,6 +74,7 @@ import GHC.Cmm (RawCmmDecl, RawCmmStatics)
import GHC.CmmToAsm.CFG
data NcgImpl statics instr jumpDest = NcgImpl {
ncgConfig :: !NCGConfig,
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl statics instr],
generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),
getJumpDestBlockId :: jumpDest -> Maybe BlockId,
......@@ -102,6 +108,7 @@ data NatM_State
natm_imports :: [(CLabel)],
natm_pic :: Maybe Reg,
natm_dflags :: DynFlags,
natm_config :: NCGConfig,
natm_this_module :: Module,
natm_modloc :: ModLocation,
natm_fileid :: DwarfFiles,
......@@ -130,6 +137,7 @@ mkNatM_State us delta dflags this_mod
, natm_imports = []
, natm_pic = Nothing
, natm_dflags = dflags
, natm_config = initConfig dflags
, natm_this_module = this_mod
, natm_modloc = loc
, natm_fileid = dwf
......@@ -137,6 +145,24 @@ mkNatM_State us delta dflags this_mod
, natm_cfg = cfg
}
-- | Initialize the native code generator configuration from the DynFlags
initConfig :: DynFlags -> NCGConfig
initConfig dflags = NCGConfig
{ ncgPlatform = targetPlatform dflags
, ncgProcAlignment = cmmProcAlignment dflags
, ncgDebugLevel = debugLevel dflags
, ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
, ncgPIC = positionIndependent dflags
, ncgSplitSections = gopt Opt_SplitSections dflags
, ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags
, ncgRegsIterative = gopt Opt_RegsIterative dflags
, ncgAsmLinting = gopt Opt_DoAsmLinting dflags
, ncgDumpRegAllocStages = dopt Opt_D_dump_asm_regalloc_stages dflags
, ncgDumpAsmStats = dopt Opt_D_dump_asm_stats dflags
, ncgDumpAsmConflicts = dopt Opt_D_dump_asm_conflicts dflags
}
initNat :: NatM_State -> NatM a -> (a, NatM_State)
initNat init_st m
= case unNat m init_st of { (r,st) -> (r,st) }
......@@ -232,8 +258,9 @@ addNodeBetweenNat from between to
-- | Place `succ` after `block` and change any edges
-- block -> X to `succ` -> X
addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()
addImmediateSuccessorNat block succ
= updateCfgNat (addImmediateSuccessor block succ)
addImmediateSuccessorNat block succ = do
dflags <- getDynFlags
updateCfgNat (addImmediateSuccessor dflags block succ)
getBlockIdNat :: NatM BlockId
getBlockIdNat
......@@ -249,16 +276,16 @@ getNewLabelNat
getNewRegNat :: Format -> NatM Reg
getNewRegNat rep
= do u <- getUniqueNat
dflags <- getDynFlags
return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)
platform <- getPlatform
return (RegVirtual $ targetMkVirtualReg platform u rep)
getNewRegPairNat :: Format -> NatM (Reg,Reg)
getNewRegPairNat rep
= do u <- getUniqueNat
dflags <- getDynFlags
let vLo = targetMkVirtualReg (targetPlatform dflags) u rep
let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep
platform <- getPlatform
let vLo = targetMkVirtualReg platform u rep
let lo = RegVirtual $ targetMkVirtualReg platform u rep
let hi = RegVirtual $ getHiVirtualRegFromLo vLo
return (lo, hi)
......@@ -282,6 +309,14 @@ getModLoc :: NatM ModLocation
getModLoc
= NatM $ \ st -> (natm_modloc st, st)
-- | Get native code generator configuration
getConfig :: NatM NCGConfig
getConfig = NatM $ \st -> (natm_config st, st)
-- | Get target platform from native code generator configuration
getPlatform :: NatM Platform
getPlatform = ncgPlatform <$> getConfig
getFileId :: FastString -> NatM Int
getFileId f = NatM $ \st ->
case lookupUFM (natm_fileid st) f of
......
This diff is collapsed.
This diff is collapsed.
......@@ -31,6 +31,7 @@ import GHC.CmmToAsm.PPC.Cond
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
......@@ -38,7 +39,6 @@ import GHC.Platform.Regs
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Driver.Session
import GHC.Cmm
import GHC.Cmm.Info
import FastString
......@@ -534,15 +534,15 @@ ppc_patchJumpInstr insn patchF
-- | An instruction to spill a register into a spill slot.
ppc_mkSpillInstr
:: DynFlags
:: NCGConfig
-> Reg -- register to spill
-> Int -- current stack delta
-> Int -- spill slot to use
-> Instr
ppc_mkSpillInstr dflags reg delta slot
= let platform = targetPlatform dflags
off = spillSlotToOffset dflags slot
ppc_mkSpillInstr config reg delta slot
= let platform = ncgPlatform config
off = spillSlotToOffset platform slot
arch = platformArch platform
in
let fmt = case targetClassOfReg platform reg of
......@@ -559,15 +559,15 @@ ppc_mkSpillInstr dflags reg delta slot
ppc_mkLoadInstr
:: DynFlags
:: NCGConfig
-> Reg -- register to load
-> Int -- current stack delta
-> Int -- spill slot to use
-> Instr
ppc_mkLoadInstr dflags reg delta slot
= let platform = targetPlatform dflags
off = spillSlotToOffset dflags slot
ppc_mkLoadInstr config reg delta slot
= let platform = ncgPlatform config
off = spillSlotToOffset platform slot
arch = platformArch platform
in
let fmt = case targetClassOfReg platform reg of
......@@ -585,8 +585,8 @@ ppc_mkLoadInstr dflags reg delta slot
-- | The size of a minimal stackframe header including minimal
-- parameter save area.
stackFrameHeaderSize :: DynFlags -> Int
stackFrameHeaderSize dflags
stackFrameHeaderSize :: Platform -> Int
stackFrameHeaderSize platform
= case platformOS platform of
OSAIX -> 24 + 8 * 4
_ -> case platformArch platform of
......@@ -595,7 +595,6 @@ stackFrameHeaderSize dflags
ArchPPC_64 ELF_V1 -> 48 + 8 * 8
ArchPPC_64 ELF_V2 -> 32 + 8 * 8