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 ...@@ -796,7 +796,7 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
-- Add unwind pseudo-instructions to document Sp level for debugging -- Add unwind pseudo-instructions to document Sp level for debugging
add_unwind_info block add_unwind_info block
| gopt Opt_Debug dflags = CmmUnwind Sp sp_unwind : block | debugLevel dflags > 0 = CmmUnwind Sp sp_unwind : block
| otherwise = block | otherwise = block
sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 - wORD_SIZE dflags) sp_unwind = CmmRegOff (CmmGlobal Sp) (sp0 - wORD_SIZE dflags)
......
...@@ -576,7 +576,7 @@ getTickScope = do ...@@ -576,7 +576,7 @@ getTickScope = do
tickScope :: FCode a -> FCode a tickScope :: FCode a -> FCode a
tickScope code = do tickScope code = do
info <- getInfoDown 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 u <- newUnique
let scope' = SubScope u (cgd_tick_scope info) let scope' = SubScope u (cgd_tick_scope info)
withInfoDown code info{ cgd_tick_scope = scope' } withInfoDown code info{ cgd_tick_scope = scope' }
...@@ -729,7 +729,7 @@ emitTick = emitCgStmt . CgStmt . CmmTick ...@@ -729,7 +729,7 @@ emitTick = emitCgStmt . CgStmt . CmmTick
emitUnwind :: GlobalReg -> CmmExpr -> FCode () emitUnwind :: GlobalReg -> CmmExpr -> FCode ()
emitUnwind g e = do emitUnwind g e = do
dflags <- getDynFlags dflags <- getDynFlags
when (gopt Opt_Debug dflags) $ when (debugLevel dflags > 0) $
emitCgStmt $ CgStmt $ CmmUnwind g e emitCgStmt $ CgStmt $ CmmUnwind g e
emitAssign :: CmmReg -> CmmExpr -> FCode () emitAssign :: CmmReg -> CmmExpr -> FCode ()
......
...@@ -1914,13 +1914,13 @@ lintAnnots pname pass guts = do ...@@ -1914,13 +1914,13 @@ lintAnnots pname pass guts = do
return nguts return nguts
-- | Run the given pass without annotations. This means that we both -- | 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. -- annotations from incoming modules.
withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
withoutAnnots pass guts = do withoutAnnots pass guts = do
-- Remove debug flag from environment. -- Remove debug flag from environment.
dflags <- getDynFlags dflags <- getDynFlags
let removeFlag env = env{hsc_dflags = gopt_unset dflags Opt_Debug} let removeFlag env = env{ hsc_dflags = dflags{ debugLevel = 0} }
withoutFlag corem = withoutFlag corem =
liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*> liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
getUniqueSupplyM <*> getModule <*> getUniqueSupplyM <*> getModule <*>
...@@ -1929,7 +1929,7 @@ withoutAnnots pass guts = do ...@@ -1929,7 +1929,7 @@ withoutAnnots pass guts = do
pure corem pure corem
-- Nuke existing ticks in module. -- Nuke existing ticks in module.
-- TODO: Ticks in unfoldings. Maybe change unfolding so it removes -- 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) let nukeTicks = stripTicksE (not . tickishIsCode)
nukeAnnotsBind :: CoreBind -> CoreBind nukeAnnotsBind :: CoreBind -> CoreBind
nukeAnnotsBind bind = case bind of nukeAnnotsBind bind = case bind of
......
...@@ -221,7 +221,7 @@ mkDataConWorkers dflags mod_loc data_tycons ...@@ -221,7 +221,7 @@ mkDataConWorkers dflags mod_loc data_tycons
-- If we want to generate debug info, we put a source note on the -- If we want to generate debug info, we put a source note on the
-- worker. This is useful, especially for heap profiling. -- worker. This is useful, especially for heap profiling.
tick_it name tick_it name
| not (gopt Opt_Debug dflags) = id | debugLevel dflags == 0 = id
| RealSrcSpan span <- nameSrcSpan name = tick span | RealSrcSpan span <- nameSrcSpan name = tick span
| Just file <- ml_hs_file mod_loc = tick (span1 file) | Just file <- ml_hs_file mod_loc = tick (span1 file)
| otherwise = tick (span1 "???") | otherwise = tick (span1 "???")
......
...@@ -980,7 +980,7 @@ coveragePasses dflags = ...@@ -980,7 +980,7 @@ coveragePasses dflags =
ifa (gopt Opt_Hpc dflags) HpcTicks $ ifa (gopt Opt_Hpc dflags) HpcTicks $
ifa (gopt Opt_SccProfilingOn dflags && ifa (gopt Opt_SccProfilingOn dflags &&
profAuto dflags /= NoProfAuto) ProfNotes $ profAuto dflags /= NoProfAuto) ProfNotes $
ifa (gopt Opt_Debug dflags) SourceNotes [] ifa (debugLevel dflags > 0) SourceNotes []
where ifa f x xs | f = x:xs where ifa f x xs | f = x:xs
| otherwise = xs | otherwise = xs
......
...@@ -1088,9 +1088,9 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body) ...@@ -1088,9 +1088,9 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
tcIfaceExpr (IfaceTick tickish expr) = do tcIfaceExpr (IfaceTick tickish expr) = do
expr' <- tcIfaceExpr expr expr' <- tcIfaceExpr expr
-- If debug flag is not set: Ignore source notes -- If debug flag is not set: Ignore source notes
dbgFlag <- fmap (gopt Opt_Debug) getDynFlags dbgLvl <- fmap debugLevel getDynFlags
case tickish of case tickish of
IfaceSource{} | not dbgFlag IfaceSource{} | dbgLvl > 0
-> return expr' -> return expr'
_otherwise -> do _otherwise -> do
tickish' <- tcIfaceTickish tickish tickish' <- tcIfaceTickish tickish
......
...@@ -470,9 +470,6 @@ data GeneralFlag ...@@ -470,9 +470,6 @@ data GeneralFlag
| Opt_DistrustAllPackages | Opt_DistrustAllPackages
| Opt_PackageTrust | Opt_PackageTrust
-- debugging flags
| Opt_Debug
deriving (Eq, Show, Enum) deriving (Eq, Show, Enum)
data WarningFlag = data WarningFlag =
...@@ -676,6 +673,7 @@ data DynFlags = DynFlags { ...@@ -676,6 +673,7 @@ data DynFlags = DynFlags {
sigOf :: SigOf, -- ^ Compiling an hs-boot against impl. sigOf :: SigOf, -- ^ Compiling an hs-boot against impl.
verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels]
optLevel :: Int, -- ^ Optimisation level optLevel :: Int, -- ^ Optimisation level
debugLevel :: Int, -- ^ How much debug information to produce
simplPhases :: Int, -- ^ Number of simplifier phases simplPhases :: Int, -- ^ Number of simplifier phases
maxSimplIterations :: Int, -- ^ Max simplifier iterations maxSimplIterations :: Int, -- ^ Max simplifier iterations
ruleCheck :: Maybe String, ruleCheck :: Maybe String,
...@@ -1424,6 +1422,7 @@ defaultDynFlags mySettings = ...@@ -1424,6 +1422,7 @@ defaultDynFlags mySettings =
sigOf = Map.empty, sigOf = Map.empty,
verbosity = 0, verbosity = 0,
optLevel = 0, optLevel = 0,
debugLevel = 0,
simplPhases = 2, simplPhases = 2,
maxSimplIterations = 4, maxSimplIterations = 4,
ruleCheck = Nothing, ruleCheck = Nothing,
...@@ -2719,7 +2718,7 @@ dynamic_flags = [ ...@@ -2719,7 +2718,7 @@ dynamic_flags = [
, defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) , defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC))
------ Debugging flags ---------------------------------------------- ------ Debugging flags ----------------------------------------------
, defGhcFlag "g" (NoArg (setGeneralFlag Opt_Debug)) , defGhcFlag "g" (OptIntSuffix setDebugLevel)
] ]
++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlags ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlags
++ map (mkFlag turnOff "no-" unSetGeneralFlag) negatableFlags ++ map (mkFlag turnOff "no-" unSetGeneralFlag) negatableFlags
...@@ -3725,6 +3724,9 @@ setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core ...@@ -3725,6 +3724,9 @@ setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core
setVerbosity :: Maybe Int -> DynP () setVerbosity :: Maybe Int -> DynP ()
setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) 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 :: String -> DynP ()
addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s})
......
...@@ -301,7 +301,7 @@ finishNativeGen :: Instruction instr ...@@ -301,7 +301,7 @@ finishNativeGen :: Instruction instr
finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
= do = do
-- Write debug data and finish -- 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 us' <- if not emitDw then return us else do
(dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs) (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
emitNativeCode dflags bufh dwarf emitNativeCode dflags bufh dwarf
...@@ -367,7 +367,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs ...@@ -367,7 +367,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
Right (cmms, cmm_stream') -> do Right (cmms, cmm_stream') -> do
-- Generate debug information -- Generate debug information
let debugFlag = gopt Opt_Debug dflags let debugFlag = debugLevel dflags > 0
!ndbgs | debugFlag = cmmDebugGen modLoc cmms !ndbgs | debugFlag = cmmDebugGen modLoc cmms
| otherwise = [] | otherwise = []
dbgMap = debugToMap ndbgs dbgMap = debugToMap ndbgs
...@@ -445,7 +445,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us ...@@ -445,7 +445,7 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap us
-- force evaluation all this stuff to avoid space leaks -- force evaluation all this stuff to avoid space leaks
{-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports) {-# 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 [] then cmmDebugLabels isMetaInstr native else []
!natives' = if dopt Opt_D_dump_asm_stats dflags !natives' = if dopt Opt_D_dump_asm_stats dflags
then native : ngs_natives ngs else [] then native : ngs_natives ngs else []
......
...@@ -34,10 +34,11 @@ dwarfGen _ _ us [] = return (empty, us) ...@@ -34,10 +34,11 @@ dwarfGen _ _ us [] = return (empty, us)
dwarfGen df modLoc us blocks = do dwarfGen df modLoc us blocks = do
-- Convert debug data structures to DWARF info records -- Convert debug data structures to DWARF info records
-- We strip out block information, as it is not currently useful for -- We strip out block information when running with -g0 or -g1.
-- anything. In future we might want to only do this for -g1.
let procs = debugSplitProcs blocks let procs = debugSplitProcs blocks
stripBlocks dbg = dbg { dblBlocks = [] } stripBlocks dbg
| debugLevel df < 2 = dbg { dblBlocks = [] }
| otherwise = dbg
compPath <- getCurrentDirectory compPath <- getCurrentDirectory
let lowLabel = dblCLabel $ head procs let lowLabel = dblCLabel $ head procs
highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs
......
...@@ -64,7 +64,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = ...@@ -64,7 +64,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
pprSectionAlign (Section Text lbl) $$ pprSectionAlign (Section Text lbl) $$
pprLabel lbl $$ -- blocks guaranteed not null, so label needed pprLabel lbl $$ -- blocks guaranteed not null, so label needed
vcat (map (pprBasicBlock top_info) blocks) $$ vcat (map (pprBasicBlock top_info) blocks) $$
(if gopt Opt_Debug dflags (if debugLevel dflags > 0
then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$
pprSizeDecl lbl pprSizeDecl lbl
...@@ -84,7 +84,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) = ...@@ -84,7 +84,7 @@ pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =
<+> char '-' <+> char '-'
<+> ppr (mkDeadStripPreventer info_lbl) <+> ppr (mkDeadStripPreventer info_lbl)
else empty) $$ else empty) $$
(if gopt Opt_Debug dflags (if debugLevel dflags > 0
then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$ then ppr (mkAsmTempEndLabel info_lbl) <> char ':' else empty) $$
pprSizeDecl info_lbl pprSizeDecl info_lbl
...@@ -102,7 +102,7 @@ pprBasicBlock info_env (BasicBlock blockid instrs) ...@@ -102,7 +102,7 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
maybe_infotable $$ maybe_infotable $$
pprLabel asmLbl $$ pprLabel asmLbl $$
vcat (map pprInstr instrs) $$ vcat (map pprInstr instrs) $$
(if gopt Opt_Debug dflags (if debugLevel dflags > 0
then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty) then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
where where
asmLbl = mkAsmTempLabel (getUnique blockid) asmLbl = mkAsmTempLabel (getUnique blockid)
......
...@@ -32,4 +32,11 @@ codegenOptions = ...@@ -32,4 +32,11 @@ codegenOptions =
, flagDescription = "Generate object code" , flagDescription = "Generate object code"
, flagType = DynamicFlag , 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