Support multiple debug output levels

We now only strip block information from DebugBlocks when compiling with
`-g1`, intended to be used when only minimal debug information is
desired. `-g2` is assumed when `-g` is passed without any integer
argument.

Differential Revision: https://phabricator.haskell.org/D1281

3 files changed, 10 insertions, 9 deletions

diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index b3988026be..46518f8fd8 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -301,7 +301,7 @@ finishNativeGen :: Instruction instr
 finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
  = do
         -- Write debug data and finish
-        let emitDw = gopt Opt_Debug dflags && not (gopt Opt_SplitObjs dflags)
+        let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags)
         us' <- if not emitDw then return us else do
           (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
           emitNativeCode dflags bufh dwarf
@@ -367,7 +367,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
         Right (cmms, cmm_stream') -> do
 
           -- Generate debug information
-          let debugFlag = gopt Opt_Debug dflags
+          let debugFlag = debugLevel dflags > 0
               !ndbgs | debugFlag = cmmDebugGen modLoc cmms
                      | otherwise = []
               dbgMap = debugToMap ndbgs
@@ -445,7 +445,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
         -- force evaluation all this stuff to avoid space leaks
         {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
 
-        let !labels' = if gopt Opt_Debug dflags
+        let !labels' = if debugLevel dflags > 0
                        then cmmDebugLabels isMetaInstr native else []
             !natives' = if dopt Opt_D_dump_asm_stats dflags
                         then native : ngs_natives ngs else []
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/nativeGen/Dwarf.hs
index 6bf49f0e0d..3903dd9580 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/nativeGen/Dwarf.hs
@@ -34,10 +34,11 @@ dwarfGen _  _      us [] = return (empty, us)
 dwarfGen df modLoc us blocks = do
 
   -- Convert debug data structures to DWARF info records
-  -- We strip out block information, as it is not currently useful for
-  -- anything. In future we might want to only do this for -g1.
+  -- We strip out block information when running with -g0 or -g1.
   let procs = debugSplitProcs blocks
-      stripBlocks dbg = dbg { dblBlocks = [] }
+      stripBlocks dbg
+        | debugLevel df < 2 = dbg { dblBlocks = [] }
+        | otherwise         = dbg
   compPath <- getCurrentDirectory
   let lowLabel = dblCLabel $ head procs
       highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 1a1fd86c00..f0ffac10d7 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -64,7 +64,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
            pprSectionAlign (Section Text lbl) $$
            pprLabel lbl $$ -- blocks guaranteed not null, so label needed
            vcat (map (pprBasicBlock top_info) blocks) $$
-           (if gopt Opt_Debug dflags
+           (if debugLevel dflags > 0
             then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
            pprSizeDecl lbl
 
@@ -84,7 +84,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
             <+> char '-'
             <+> ppr (mkDeadStripPreventer info_lbl)
        else empty) $$
-      (if gopt Opt_Debug dflags
+      (if debugLevel dflags > 0
        then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$
       pprSizeDecl info_lbl
 
@@ -102,7 +102,7 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
     maybe_infotable $$
     pprLabel asmLbl $$
     vcat (map pprInstr instrs) $$
-    (if gopt Opt_Debug dflags
+    (if debugLevel dflags > 0
      then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
   where
     asmLbl = mkAsmTempLabel (getUnique blockid)