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
......
......@@ -90,8 +90,8 @@ pprAbbrev = pprLEBWord . fromIntegral . fromEnum
-- | Abbreviation declaration. This explains the binary encoding we
-- use for representing 'DwarfInfo'. Be aware that this must be updated
-- along with 'pprDwarfInfo'.
pprAbbrevDecls :: Bool -> SDoc
pprAbbrevDecls haveDebugLine =
pprAbbrevDecls :: Platform -> Bool -> SDoc
pprAbbrevDecls platform haveDebugLine =
let mkAbbrev abbr tag chld flds =
let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
......@@ -106,7 +106,7 @@ pprAbbrevDecls haveDebugLine =
, (dW_AT_high_pc, dW_FORM_addr)
, (dW_AT_frame_base, dW_FORM_block1)
]
in dwarfAbbrevSection $$
in dwarfAbbrevSection platform $$
ptext dwarfAbbrevLabel <> colon $$
mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
([(dW_AT_name, dW_FORM_string)
......@@ -142,8 +142,8 @@ pprAbbrevDecls haveDebugLine =
pprByte 0
-- | Generate assembly for DWARF data
pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
pprDwarfInfo haveSrc d
pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc
pprDwarfInfo platform haveSrc d
= case d of
DwarfCompileUnit {} -> hasChildren
DwarfSubprogram {} -> hasChildren
......@@ -151,36 +151,36 @@ pprDwarfInfo haveSrc d
DwarfSrcNote {} -> noChildren
where
hasChildren =
pprDwarfInfoOpen haveSrc d $$
vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
pprDwarfInfoOpen platform haveSrc d $$
vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
pprDwarfInfoClose
noChildren = pprDwarfInfoOpen haveSrc d
noChildren = pprDwarfInfoOpen platform haveSrc d
-- | Prints assembler data corresponding to DWARF info records. Note
-- that the binary format of this is parameterized in @abbrevDecls@ and
-- has to be kept in synch.
pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc
pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
highLabel lineLbl) =
pprAbbrev DwAbbrCompileUnit
$$ pprString name
$$ pprString producer
$$ pprData4 dW_LANG_Haskell
$$ pprString compDir
$$ pprWord (ppr lowLabel)
$$ pprWord (ppr highLabel)
$$ pprWord platform (ppr lowLabel)
$$ pprWord platform (ppr highLabel)
$$ if haveSrc
then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)
else empty
pprDwarfInfoOpen _ (DwarfSubprogram _ name label
pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label
parent) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprFlag (externallyVisibleCLabel label)
$$ pprWord (ppr label)
$$ pprWord (ppr $ mkAsmTempEndLabel label)
$$ pprWord platform (ppr label)
$$ pprWord platform (ppr $ mkAsmTempEndLabel label)
$$ pprByte 1
$$ pprByte dW_OP_call_frame_cfa
$$ parentValue
......@@ -188,18 +188,18 @@ pprDwarfInfoOpen _ (DwarfSubprogram _ name label
abbrev = case parent of Nothing -> DwAbbrSubprogram
Just _ -> DwAbbrSubprogramWithParent
parentValue = maybe empty pprParentDie parent
pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)
pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlockWithoutCode
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlock
$$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprWord (ppr marker)
$$ pprWord (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ (DwarfSrcNote ss) =
$$ pprWord platform (ppr marker)
$$ pprWord platform (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
pprAbbrev DwAbbrGhcSrcNote
$$ pprString' (ftext $ srcSpanFile ss)
$$ pprData4 (fromIntegral $ srcSpanStartLine ss)
......@@ -222,9 +222,9 @@ data DwarfARange
-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
-- address table entry.
pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
let wordSize = platformWordSizeInBytes plat
pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc
pprDwarfARanges platform arngs unitU =
let wordSize = platformWordSizeInBytes platform
paddingSize = 4 :: Int
-- header is 12 bytes long.
-- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
......@@ -234,19 +234,19 @@ pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
in pprDwWord (ppr initialLength)
$$ pprHalf 2
$$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
(ptext dwarfInfoLabel)
$$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU)
(ptext dwarfInfoLabel)
$$ pprByte (fromIntegral wordSize)
$$ pprByte 0
$$ pad paddingSize
-- body
$$ vcat (map pprDwarfARange arngs)
$$ vcat (map (pprDwarfARange platform) arngs)
-- terminus
$$ pprWord (char '0')
$$ pprWord (char '0')
$$ pprWord platform (char '0')
$$ pprWord platform (char '0')
pprDwarfARange :: DwarfARange -> SDoc
pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
pprDwarfARange :: Platform -> DwarfARange -> SDoc
pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length
where
length = ppr (dwArngEndLabel arng)
<> char '-' <> ppr (dwArngStartLabel arng)
......@@ -286,21 +286,20 @@ instance Outputable DwarfFrameBlock where
-- | Header for the @.debug_frame@ section. Here we emit the "Common
-- Information Entry" record that establishes general call frame
-- parameters and the default stack layout.
pprDwarfFrame :: DwarfFrame -> SDoc
pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
= sdocWithPlatform $ \plat ->
let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
pprDwarfFrame :: Platform -> DwarfFrame -> SDoc
pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
= let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
cieEndLabel = mkAsmTempEndLabel cieLabel
length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel
spReg = dwarfGlobalRegNo plat Sp
retReg = dwarfReturnRegNo plat
wordSize = platformWordSizeInBytes plat
spReg = dwarfGlobalRegNo platform Sp
retReg = dwarfReturnRegNo platform
wordSize = platformWordSizeInBytes platform
pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc
pprInit (g, uw) = pprSetUnwind plat g (Nothing, uw)
pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)
-- Preserve C stack pointer: This necessary to override that default
-- unwinding behavior of setting $sp = CFA.
preserveSp = case platformArch plat of
preserveSp = case platformArch platform of
ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4
ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7
_ -> empty
......@@ -333,16 +332,16 @@ pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
, pprLEBWord (fromIntegral spReg)
, pprLEBWord 0
] $$
wordAlign $$
wordAlign platform $$
ppr cieEndLabel <> colon $$
-- Procedure unwind tables
vcat (map (pprFrameProc cieLabel cieInit) procs)
vcat (map (pprFrameProc platform cieLabel cieInit) procs)
-- | Writes a "Frame Description Entry" for a procedure. This consists
-- mainly of referencing the CIE and writing state machine
-- instructions to describe how the frame base (CFA) changes.
pprFrameProc :: CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc
pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
= let fdeLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde")
fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")
procEnd = mkAsmTempEndLabel procLbl
......@@ -353,20 +352,20 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)
, ppr fdeLabel <> colon
, pprData4' (ppr frameLbl <> char '-' <>
ptext dwarfFrameLabel) -- Reference to CIE
, pprWord (ppr procLbl <> ifInfo "-1") -- Code pointer
, pprWord (ppr procEnd <> char '-' <>
ppr procLbl <> ifInfo "+1") -- Block byte length
, pprWord platform (ppr procLbl <> ifInfo "-1") -- Code pointer
, pprWord platform (ppr procEnd <> char '-' <>
ppr procLbl <> ifInfo "+1") -- Block byte length
] $$
vcat (S.evalState (mapM pprFrameBlock blocks) initUw) $$
wordAlign $$
vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$
wordAlign platform $$
ppr fdeEndLabel <> colon
-- | Generates unwind information for a block. We only generate
-- instructions where unwind information actually changes. This small
-- optimisations saves a lot of space, as subsequent blocks often have
-- the same unwind information.
pprFrameBlock :: DwarfFrameBlock -> S.State UnwindTable SDoc
pprFrameBlock (DwarfFrameBlock hasInfo uws0) =