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

11 files changed, 33 insertions, 23 deletions

diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 5140aa3ae6..90fc613475 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -796,7 +796,7 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
 
     -- Add unwind pseudo-instructions to document Sp level for debugging
     add_unwind_info block
-      | gopt Opt_Debug dflags = CmmUnwind Sp sp_unwind : block
+      | debugLevel dflags > 0 = CmmUnwind Sp sp_unwind : block
       | otherwise             = block
     sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 - wORD_SIZE dflags)
 
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 3083bfffc4..7ddbcd6cbc 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -576,7 +576,7 @@ getTickScope = do
 tickScope :: FCode a -> FCode a
 tickScope code = do
         info <- getInfoDown
-        if not (gopt Opt_Debug (cgd_dflags info)) then code else do
+        if debugLevel (cgd_dflags info) == 0 then code else do
           u <- newUnique
           let scope' = SubScope u (cgd_tick_scope info)
           withInfoDown code info{ cgd_tick_scope = scope' }
@@ -729,7 +729,7 @@ emitTick = emitCgStmt . CgStmt . CmmTick
 emitUnwind :: GlobalReg -> CmmExpr -> FCode ()
 emitUnwind g e = do
   dflags <- getDynFlags
-  when (gopt Opt_Debug dflags) $
+  when (debugLevel dflags > 0) $
      emitCgStmt $ CgStmt $ CmmUnwind g e
 
 emitAssign :: CmmReg  -> CmmExpr -> FCode ()
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index d9116a6f9b..10a93e5281 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1914,13 +1914,13 @@ lintAnnots pname pass guts = do
   return nguts
 
 -- | Run the given pass without annotations. This means that we both
--- remove the @Opt_Debug@ flag from the environment as well as all
+-- set the debugLevel setting to 0 in the environment as well as all
 -- annotations from incoming modules.
 withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
 withoutAnnots pass guts = do
   -- Remove debug flag from environment.
   dflags <- getDynFlags
-  let removeFlag env = env{hsc_dflags = gopt_unset dflags Opt_Debug}
+  let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }
       withoutFlag corem =
         liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
                                 getUniqueSupplyM <*> getModule <*>
@@ -1929,7 +1929,7 @@ withoutAnnots pass guts = do
                                 pure corem
   -- Nuke existing ticks in module.
   -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
-  -- them in absence of @Opt_Debug@?
+  -- them in absence of debugLevel > 0.
   let nukeTicks = stripTicksE (not . tickishIsCode)
       nukeAnnotsBind :: CoreBind -> CoreBind
       nukeAnnotsBind bind = case bind of
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index e49ece43d2..fdf25d60d9 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -221,7 +221,7 @@ mkDataConWorkers dflags mod_loc data_tycons
    -- If we want to generate debug info, we put a source note on the
    -- worker. This is useful, especially for heap profiling.
    tick_it name
-     | not (gopt Opt_Debug dflags)           = id
+     | debugLevel dflags == 0                = id
      | RealSrcSpan span <- nameSrcSpan name  = tick span
      | Just file <- ml_hs_file mod_loc       = tick (span1 file)
      | otherwise                             = tick (span1 "???")
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 18de4c4d9d..ac9438f2aa 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -980,7 +980,7 @@ coveragePasses dflags =
     ifa (gopt Opt_Hpc dflags)                HpcTicks $
     ifa (gopt Opt_SccProfilingOn dflags &&
          profAuto dflags /= NoProfAuto)      ProfNotes $
-    ifa (gopt Opt_Debug dflags)              SourceNotes []
+    ifa (debugLevel dflags > 0)              SourceNotes []
   where ifa f x xs | f         = x:xs
                    | otherwise = xs
 
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index 80de36e82d..45b583cd91 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -1088,9 +1088,9 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
 tcIfaceExpr (IfaceTick tickish expr) = do
     expr' <- tcIfaceExpr expr
     -- If debug flag is not set: Ignore source notes
-    dbgFlag <- fmap (gopt Opt_Debug) getDynFlags
+    dbgLvl <- fmap debugLevel getDynFlags
     case tickish of
-      IfaceSource{} | not dbgFlag
+      IfaceSource{} | dbgLvl > 0
                     -> return expr'
       _otherwise    -> do
         tickish' <- tcIfaceTickish tickish
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 19df18e677..9aba2e6ee3 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -470,9 +470,6 @@ data GeneralFlag
    | Opt_DistrustAllPackages
    | Opt_PackageTrust
 
-   -- debugging flags
-   | Opt_Debug
-
    deriving (Eq, Show, Enum)
 
 data WarningFlag =
@@ -676,6 +673,7 @@ data DynFlags = DynFlags {
   sigOf                 :: SigOf,       -- ^ Compiling an hs-boot against impl.
   verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]
   optLevel              :: Int,         -- ^ Optimisation level
+  debugLevel            :: Int,         -- ^ How much debug information to produce
   simplPhases           :: Int,         -- ^ Number of simplifier phases
   maxSimplIterations    :: Int,         -- ^ Max simplifier iterations
   ruleCheck             :: Maybe String,
@@ -1424,6 +1422,7 @@ defaultDynFlags mySettings =
         sigOf                   = Map.empty,
         verbosity               = 0,
         optLevel                = 0,
+        debugLevel              = 0,
         simplPhases             = 2,
         maxSimplIterations      = 4,
         ruleCheck               = Nothing,
@@ -2719,7 +2718,7 @@ dynamic_flags = [
   , defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))
 
          ------ Debugging flags ----------------------------------------------
-  , defGhcFlag "g"             (NoArg (setGeneralFlag Opt_Debug))
+  , defGhcFlag "g"             (OptIntSuffix setDebugLevel)
  ]
  ++ map (mkFlag turnOn  ""     setGeneralFlag  ) negatableFlags
  ++ map (mkFlag turnOff "no-"  unSetGeneralFlag) negatableFlags
@@ -3725,6 +3724,9 @@ setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core
 setVerbosity :: Maybe Int -> DynP ()
 setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })
 
+setDebugLevel :: Maybe Int -> DynP ()
+setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 })
+
 addCmdlineHCInclude :: String -> DynP ()
 addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes =  a : cmdlineHcIncludes s})
 
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)
diff --git a/utils/mkUserGuidePart/Options/CodeGen.hs b/utils/mkUserGuidePart/Options/CodeGen.hs
index 0d9cabb27d..9939d9e100 100644
--- a/utils/mkUserGuidePart/Options/CodeGen.hs
+++ b/utils/mkUserGuidePart/Options/CodeGen.hs
@@ -32,4 +32,11 @@ codegenOptions =
          , flagDescription = "Generate object code"
          , flagType = DynamicFlag
          }
+  , flag { flagName = "-g⟨n⟩"
+         , flagDescription =
+           "Produce DWARF debug information in compiled object files." ++
+           "⟨n⟩ can be 0, 1, or 2, with higher numbers producing richer " ++
+           "output. If ⟨n⟩ is omitted level 2 is assumed."
+         , flagType = DynamicFlag
+         }
   ]