Commit 7aaeaf81 authored by Ben Gamari's avatar Ben Gamari 🐢

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
parent bb249aa7
......@@ -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)
......
......@@ -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 ()
......
......@@ -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
......
......@@ -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 "???")
......
......@@ -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
......
......@@ -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
......
......@@ -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})
......
......@@ -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 []
......
......@@ -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
......
......@@ -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)
......
......@@ -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
}
]
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment