NCG: Dwarf configuration

* remove references to DynFlags in GHC.CmmToAsm.Dwarf
* add specific Dwarf options in NCGConfig instead of directly querying
  the debug level

5 files changed, 29 insertions, 26 deletions

diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs
index 29d8bcad15..d4abafd402 100644
--- a/compiler/GHC/CmmToAsm/Config.hs
+++ b/compiler/GHC/CmmToAsm/Config.hs
@@ -11,12 +11,13 @@ import GHC.Prelude
 import GHC.Platform
 import GHC.Cmm.Type (Width(..))
 import GHC.CmmToAsm.CFG.Weight
+import GHC.Utils.Outputable
 
 -- | Native code generator configuration
 data NCGConfig = NCGConfig
    { ncgPlatform              :: !Platform        -- ^ Target platform
+   , ncgAsmContext            :: !SDocContext     -- ^ Context for ASM code generation
    , 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
    , ncgInlineThresholdMemcpy :: !Word            -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it
@@ -33,6 +34,9 @@ data NCGConfig = NCGConfig
    , ncgCfgWeights            :: !Weights         -- ^ CFG edge weights
    , ncgCfgBlockLayout        :: !Bool            -- ^ Use CFG based block layout algorithm
    , ncgCfgWeightlessLayout   :: !Bool            -- ^ Layout based on last instruction per block.
+   , ncgDwarfEnabled          :: !Bool            -- ^ Enable Dwarf generation
+   , ncgDwarfUnwindings       :: !Bool            -- ^ Enable unwindings
+   , ncgDwarfStripBlockInfo   :: !Bool            -- ^ Strip out block information from generated Dwarf
    }
 
 -- | Return Word size
diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs
index ccf2cf8758..d09588841b 100644
--- a/compiler/GHC/CmmToAsm/Dwarf.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf.hs
@@ -4,9 +4,6 @@ module GHC.CmmToAsm.Dwarf (
 
 import GHC.Prelude
 
-import GHC.Driver.Session
-import GHC.Driver.Ppr
-
 import GHC.Cmm.CLabel
 import GHC.Cmm.Expr        ( GlobalReg(..) )
 import GHC.Settings.Config ( cProjectName, cProjectVersion )
@@ -20,6 +17,7 @@ import GHC.Types.Unique.Supply
 
 import GHC.CmmToAsm.Dwarf.Constants
 import GHC.CmmToAsm.Dwarf.Types
+import GHC.CmmToAsm.Config
 
 import Control.Arrow    ( first )
 import Control.Monad    ( mfilter )
@@ -34,23 +32,22 @@ import qualified GHC.Cmm.Dataflow.Label as H
 import qualified GHC.Cmm.Dataflow.Collections as H
 
 -- | Generate DWARF/debug information
-dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
+dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]
             -> IO (SDoc, UniqSupply)
-dwarfGen _  _      us [] = return (empty, us)
-dwarfGen df modLoc us blocks = do
-  let platform = targetPlatform df
+dwarfGen _      _      us []     = return (empty, us)
+dwarfGen config modLoc us blocks = do
+  let platform = ncgPlatform config
 
   -- Convert debug data structures to DWARF info records
-  -- We strip out block information when running with -g0 or -g1.
   let procs = debugSplitProcs blocks
       stripBlocks dbg
-        | debugLevel df < 2 = dbg { dblBlocks = [] }
-        | otherwise         = dbg
+        | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }
+        | otherwise                     = dbg
   compPath <- getCurrentDirectory
   let lowLabel = dblCLabel $ head procs
       highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
       dwarfUnit = DwarfCompileUnit
-        { dwChildren = map (procToDwarf df) (map stripBlocks procs)
+        { dwChildren = map (procToDwarf config) (map stripBlocks procs)
         , dwName = fromMaybe "" (ml_hs_file modLoc)
         , dwCompDir = addTrailingPathSeparator compPath
         , dwProducer = cProjectName ++ " " ++ cProjectVersion
@@ -91,8 +88,8 @@ dwarfGen df modLoc us blocks = do
                  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' | ncgSplitSections config = map mkDwarfARange procs
+               | otherwise               = [DwarfARange lowLabel highLabel]
   let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
 
   return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
@@ -177,12 +174,14 @@ parent, B.
 -}
 
 -- | Generate DWARF info for a procedure debug block
-procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
-procToDwarf df prc
+procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
+procToDwarf config prc
   = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)
                     , dwName     = case dblSourceTick prc of
                          Just s@SourceNote{} -> sourceName s
-                         _otherwise -> showSDocDump df $ ppr $ dblLabel prc
+                         _otherwise -> renderWithContext defaultSDocContext
+                                          $ withPprStyle defaultDumpStyle
+                                          $ ppr (dblLabel prc)
                     , dwLabel    = dblCLabel prc
                     , dwParent   = fmap mkAsmTempDieLabel
                                    $ mfilter goodParent
@@ -192,9 +191,9 @@ procToDwarf df prc
   goodParent a | a == dblCLabel prc = False
                -- Omit parent if it would be self-referential
   goodParent a | not (externallyVisibleCLabel a)
-               , debugLevel df < 2 = False
-               -- We strip block information when running -g0 or -g1, don't
-               -- refer to blocks in that case. Fixes #14894.
+               , ncgDwarfStripBlockInfo config = False
+               -- If we strip block information, don't refer to blocks.
+               -- Fixes #14894.
   goodParent _ = True
 
 -- | Generate DWARF info for a block
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index 3622121e6c..259159aa44 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -64,7 +64,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
             _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,
                                            -- so label needed
          vcat (map (pprBasicBlock config top_info) blocks) $$
-         (if ncgDebugLevel config > 0
+         (if ncgDwarfEnabled config
           then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
          pprSizeDecl platform lbl
 
@@ -131,7 +131,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
   = maybe_infotable $$
     pprLabel platform asmLbl $$
     vcat (map (pprInstr platform) instrs) $$
-    (if  ncgDebugLevel config > 0
+    (if  ncgDwarfEnabled config
       then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
       else empty
     )
diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
index cbf3da9925..31b111eab6 100644
--- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs
@@ -229,7 +229,7 @@ basicBlockCodeGen block = do
 addSpUnwindings :: Instr -> NatM (OrdList Instr)
 addSpUnwindings instr@(DELTA d) = do
     config <- getConfig
-    if ncgDebugLevel config >= 1
+    if ncgDwarfUnwindings config
         then do lbl <- mkAsmTempLabel <$> getUniqueM
                 let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)
                 return $ toOL [ instr, UNWIND lbl unwind ]
diff --git a/compiler/GHC/CmmToAsm/X86/Ppr.hs b/compiler/GHC/CmmToAsm/X86/Ppr.hs
index 410eddbf85..b5fb852512 100644
--- a/compiler/GHC/CmmToAsm/X86/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/X86/Ppr.hs
@@ -91,7 +91,7 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
         pprProcAlignment config $$
         pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed
         vcat (map (pprBasicBlock config top_info) blocks) $$
-        (if ncgDebugLevel config > 0
+        (if ncgDwarfEnabled config
          then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
         pprSizeDecl platform lbl
 
@@ -125,7 +125,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
   = maybe_infotable $
     pprLabel platform asmLbl $$
     vcat (map (pprInstr platform) instrs) $$
-    (if ncgDebugLevel config > 0
+    (if ncgDwarfEnabled config
       then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
       else empty
     )
@@ -140,7 +140,7 @@ pprBasicBlock config info_env (BasicBlock blockid instrs)
            vcat (map (pprData config) info) $$
            pprLabel platform infoLbl $$
            c $$
-           (if ncgDebugLevel config > 0
+           (if ncgDwarfEnabled config
                then ppr (mkAsmTempEndLabel infoLbl) <> char ':'
                else empty
            )