diff options
37 files changed, 323 insertions, 193 deletions
diff --git a/compiler/GHC/HsToCore/PmCheck/Oracle.hs b/compiler/GHC/HsToCore/PmCheck/Oracle.hs index 1486dde365..713656c6ff 100644 --- a/compiler/GHC/HsToCore/PmCheck/Oracle.hs +++ b/compiler/GHC/HsToCore/PmCheck/Oracle.hs @@ -90,7 +90,7 @@ tracePm herald doc = do dflags <- getDynFlags printer <- mkPrintUnqualifiedDs liftIO $ dumpIfSet_dyn_printer printer dflags - Opt_D_dump_ec_trace (text herald $$ (nest 2 doc)) + Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) -- | Generate a fresh `Id` of a given type mkPmId :: Type -> DsM Id diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs index 071ec9442e..fbabea8f66 100644 --- a/compiler/cmm/CmmPipeline.hs +++ b/compiler/cmm/CmmPipeline.hs @@ -45,7 +45,7 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops - dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms) + dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms) return (srtInfo, cmms) @@ -92,7 +92,7 @@ cpsTop hsc_env proc = pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ minimalProcPointSet (targetPlatform dflags) call_pps g dumpWith dflags Opt_D_dump_cmm_proc "Proc points" - (ppr l $$ ppr pp $$ ppr g) + FormatCMM (ppr l $$ ppr pp $$ ppr g) return pp else return call_pps @@ -112,15 +112,15 @@ cpsTop hsc_env proc = ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g - dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv) + dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv) g <- if splitting_proc_points then do ------------- Split into separate procedures ----------------------- let pp_map = {-# SCC "procPointAnalysis" #-} procPointAnalysis proc_points g - dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $ - ppr pp_map + dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" + FormatCMM (ppr pp_map) g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints dflags l call_pps proc_points pp_map (CmmProc h l v g) @@ -151,7 +151,7 @@ cpsTop hsc_env proc = dump = dumpGraph dflags dumps flag name - = mapM_ (dumpWith dflags flag name . ppr) + = mapM_ (dumpWith dflags flag name FormatCMM . ppr) condPass flag pass g dumpflag dumpname = if gopt flag dflags @@ -347,7 +347,7 @@ runUniqSM m = do dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () dumpGraph dflags flag name g = do when (gopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith dflags flag name (ppr g) + dumpWith dflags flag name FormatCMM (ppr g) where do_lint g = case cmmLintGraph dflags g of Just err -> do { fatalErrorMsg dflags err @@ -355,12 +355,13 @@ dumpGraph dflags flag name g = do } Nothing -> return () -dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpWith dflags flag txt sdoc = do - dumpIfSet_dyn dflags flag txt sdoc +dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpWith dflags flag txt fmt sdoc = do + dumpIfSet_dyn dflags flag txt fmt sdoc when (not (dopt flag dflags)) $ -- If `-ddump-cmm-verbose -ddump-to-file` is specified, -- dump each Cmm pipeline stage output to a separate file. #16930 when (dopt Opt_D_dump_cmm_verbose dflags) - $ dumpSDoc dflags alwaysQualify flag txt sdoc - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt sdoc + $ dumpAction dflags (mkDumpStyle dflags alwaysQualify) + (dumpOptionsFromFlag flag) txt fmt sdoc + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 3ebad40adb..6f551c009f 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -259,8 +259,10 @@ dumpPassResult :: DynFlags -> CoreProgram -> [CoreRule] -> IO () dumpPassResult dflags unqual mb_flag hdr extra_info binds rules - = do { forM_ mb_flag $ \flag -> - Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc + = do { forM_ mb_flag $ \flag -> do + let sty = mkDumpStyle dflags unqual + dumpAction dflags sty (dumpOptionsFromFlag flag) + (showSDoc dflags hdr) FormatCore dump_doc -- Report result size -- This has the side effect of forcing the intermediate to be evaluated diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs index de3c96ba45..d4451e9ff8 100644 --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -138,7 +138,7 @@ simpleOptPgm :: DynFlags -> Module -- See Note [The simple optimiser] simpleOptPgm dflags this_mod binds rules = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings occ_anald_binds $$ pprRules rules ); + FormatCore (pprCoreBindings occ_anald_binds $$ pprRules rules ); ; return (reverse binds', rules') } where diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 3ce2afc6b8..227ad8542c 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -209,7 +209,7 @@ corePrepExpr dflags hsc_env expr = us <- mkSplitUniqSupply 's' initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) + dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) return new_expr corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index 6535d37307..65f0e9b8f8 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -65,6 +65,7 @@ import Util import Outputable import ForeignCall import Name +import ErrUtils import qualified Data.ByteString as BS import Data.List @@ -1280,10 +1281,10 @@ traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a traceInline dflags inline_id str doc result | Just prefix <- inlineCheck dflags = if prefix `isPrefixOf` occNameString (getOccName inline_id) - then pprTrace str doc result + then traceAction dflags str doc result else result | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags - = pprTrace str doc result + = traceAction dflags str doc result | otherwise = result diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 8a823906af..6930af6e0b 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -111,7 +111,8 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 modBreaks <- mkModBreaks hsc_env mod tickCount entries - dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1) + dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell + (pprLHsBinds binds1) return (binds1, HpcInfo tickCount hashNo, Just modBreaks) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index f5aa6f0785..48edd61b1b 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -270,7 +270,7 @@ deSugarExpr hsc_env tc_expr = do { ; case mb_core_expr of Nothing -> return () Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" - (pprCoreExpr expr) + FormatCore (pprCoreExpr expr) ; return (msgs, mb_core_expr) } diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index ece728a288..4a8e138daf 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -107,7 +107,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") dumpIfSet_dyn dflags Opt_D_dump_BCOs - "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) + "Proto-BCOs" FormatByteCode + (vcat (intersperse (char ' ') (map ppr proto_bcos))) cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs) (case modBreaks of @@ -175,7 +176,8 @@ coreExprToBCOs hsc_env this_mod expr when (notNull mallocd) (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?") - dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) + dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode + (ppr proto_bco) assembleOneBCO hsc_env proto_bco where dflags = hsc_dflags hsc_env diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index a9bf9a87e9..373369e733 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -91,6 +91,7 @@ pprintClosureCommand bindThings force str = do Just subst' -> do { dflags <- GHC.getSessionDynFlags ; liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + FormatText (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, text "new substitution:" , ppr subst']) diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index cb9e183c1a..02948d67c8 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -167,7 +167,7 @@ mkFullIface hsc_env partial_iface = do addFingerprints hsc_env partial_iface -- Debug printing - dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" (pprModIface full_iface) + dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface) return full_iface @@ -311,7 +311,7 @@ mkIface_ hsc_env mi_doc_hdr = doc_hdr, mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, - mi_final_exts = () } + mi_final_exts = () } where cmp_rule = comparing ifRuleName -- Compare these lexicographically by OccName, *not* by unique, diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index b463693a82..5b37f83ee6 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -189,7 +189,8 @@ cmmLlvmGen cmm@CmmProc{} = do {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm - dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) + dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" + FormatCMM (pprCmmGroup [fixed_cmm]) -- generate llvm code from cmm llvmBC <- withClearVars $ genLlvmProc fixed_cmm diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index eaa49fc50e..f43c3dcf75 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -337,10 +337,10 @@ getLlvmPlatform :: LlvmM Platform getLlvmPlatform = getDynFlag targetPlatform -- | Dumps the document if the corresponding flag has been set by the user -dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM () -dumpIfSetLlvm flag hdr doc = do +dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () +dumpIfSetLlvm flag hdr fmt doc = do dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags flag hdr doc + liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM () @@ -353,7 +353,7 @@ renderLlvm sdoc = do (Outp.mkCodeStyle Outp.CStyle) sdoc -- Dump, if requested - dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc + dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc return () -- | Marks a variable as "used" diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs index 6b70366f45..2b9770c78e 100644 --- a/compiler/main/CodeOutput.hs +++ b/compiler/main/CodeOutput.hs @@ -212,7 +212,9 @@ outputForeignStubs dflags mod location stubs createDirectoryIfMissing True (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign - "Foreign export header file" stub_h_output_d + "Foreign export header file" + FormatC + stub_h_output_d -- we need the #includes from the rts package for the stub files let rts_includes = @@ -230,7 +232,7 @@ outputForeignStubs dflags mod location stubs ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr dumpIfSet_dyn dflags Opt_D_dump_foreign - "Foreign export stubs" stub_c_output_d + "Foreign export stubs" FormatC stub_c_output_d stub_c_file_exists <- outputForeignStubs_help stub_c stub_c_output_w diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d3cd6577ab..94cee4a7cd 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} ------------------------------------------------------------------------------- -- @@ -282,7 +283,8 @@ import ToolSettings import Foreign.C ( CInt(..) ) import System.IO.Unsafe ( unsafeDupablePerformIO ) import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn - , getCaretDiagnostic ) + , getCaretDiagnostic, DumpAction, TraceAction + , defaultDumpAction, defaultTraceAction ) import Json import SysTools.Terminal ( stderrSupportsAnsiColors ) import SysTools.BaseDir ( expandToolDir, expandTopDir ) @@ -1211,6 +1213,8 @@ data DynFlags = DynFlags { -- | MsgDoc output action: use "ErrUtils" instead of this if you can log_action :: LogAction, + dump_action :: DumpAction, + trace_action :: TraceAction, flushOut :: FlushOut, flushErr :: FlushErr, @@ -2096,7 +2100,9 @@ defaultDynFlags mySettings llvmConfig = -- Logging - log_action = defaultLogAction, + log_action = defaultLogAction, + dump_action = defaultDumpAction, + trace_action = defaultTraceAction, flushOut = defaultFlushOut, flushErr = defaultFlushErr, diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs index c66496bc61..b5dab7ea35 100644 --- a/compiler/main/ErrUtils.hs +++ b/compiler/main/ErrUtils.hs @@ -7,6 +7,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} module ErrUtils ( -- * Basic types @@ -41,8 +42,10 @@ module ErrUtils ( -- * Dump files dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, - mkDumpDoc, dumpSDoc, dumpSDocForUser, - dumpSDocWithStyle, + dumpOptionsFromFlag, DumpOptions (..), + DumpFormat (..), DumpAction, dumpAction, defaultDumpAction, + TraceAction, traceAction, defaultTraceAction, + touchDumpFile, -- * Issuing messages during compilation putMsg, printInfoForUser, printOutputForUser, @@ -442,23 +445,23 @@ dumpIfSet dflags flag hdr doc (defaultDumpStyle dflags) (mkDumpDoc hdr doc) --- | a wrapper around 'dumpSDoc'. +-- | a wrapper around 'dumpAction'. -- First check whether the dump flag is set -- Do nothing if it is unset -dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpIfSet_dyn dflags flag hdr doc - = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc +dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify --- | a wrapper around 'dumpSDoc'. +-- | a wrapper around 'dumpAction'. -- First check whether the dump flag is set -- Do nothing if it is unset -- --- Unlike 'dumpIfSet_dyn', --- has a printer argument but no header argument -dumpIfSet_dyn_printer :: PrintUnqualified - -> DynFlags -> DumpFlag -> SDoc -> IO () -dumpIfSet_dyn_printer printer dflags flag doc - = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc +-- Unlike 'dumpIfSet_dyn', has a printer argument +dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String + -> DumpFormat -> SDoc -> IO () +dumpIfSet_dyn_printer printer dflags flag hdr fmt doc + = when (dopt flag dflags) $ do + let sty = mkDumpStyle dflags printer + dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc @@ -469,11 +472,16 @@ mkDumpDoc hdr doc where line = text (replicate 20 '=') + +-- | Ensure that a dump file is created even if it stays empty +touchDumpFile :: DynFlags -> DumpOptions -> IO () +touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ())) + -- | Run an action with the handle of a 'DumpFlag' if we are outputting to a -- file, otherwise 'Nothing'. -withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () -withDumpFileHandle dflags flag action = do - let mFile = chooseDumpFile dflags flag +withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dflags dumpOpt action = do + let mFile = chooseDumpFile dflags dumpOpt case mFile of Just fileName -> do let gdref = generatedDumps dflags @@ -494,31 +502,15 @@ withDumpFileHandle dflags flag action = do Nothing -> action Nothing -dumpSDoc, dumpSDocForUser - :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () - --- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style. -dumpSDoc dflags print_unqual - = dumpSDocWithStyle dump_style dflags - where dump_style = mkDumpStyle dflags print_unqual - --- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style. -dumpSDocForUser dflags print_unqual - = dumpSDocWithStyle user_style dflags - where user_style = mkUserStyle dflags print_unqual AllTheWay - -- | Write out a dump. -- If --dump-to-file is set then this goes to a file. -- otherwise emit to stdout. -- -- When @hdr@ is empty, we print in a more compact format (no separators and -- blank lines) --- --- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@ --- is used; it is not used to decide whether to dump the output -dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO () -dumpSDocWithStyle sty dflags flag hdr doc = - withDumpFileHandle dflags flag writeDump +dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO () +dumpSDocWithStyle sty dflags dumpOpt hdr doc = + withDumpFileHandle dflags dumpOpt writeDump where -- write dump to file writeDump (Just handle) = do @@ -544,12 +536,12 @@ dumpSDocWithStyle sty dflags flag hdr doc = -- | Choose where to put a dump file based on DynFlags -- -chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath -chooseDumpFile dflags flag +chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath +chooseDumpFile dflags dumpOpt - | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file + | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt , Just prefix <- getPrefix - = Just $ setDir (prefix ++ (beautifyDumpName flag)) + = Just $ setDir (prefix ++ dumpSuffix dumpOpt) | otherwise = Nothing @@ -569,16 +561,39 @@ chooseDumpFile dflags flag Just d -> d </> f Nothing -> f --- | Build a nice file name from name of a 'DumpFlag' constructor -beautifyDumpName :: DumpFlag -> String -beautifyDumpName Opt_D_th_dec_file = "th.hs" -beautifyDumpName flag - = let str = show flag - suff = case stripPrefix "Opt_D_" str of - Just x -> x - Nothing -> panic ("Bad flag name: " ++ str) - dash = map (\c -> if c == '_' then '-' else c) suff - in dash +-- | Dump options +-- +-- Dumps are printed on stdout by default except when the `dumpForcedToFile` +-- field is set to True. +-- +-- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are +-- written into a file whose suffix is given in the `dumpSuffix` field. +-- +data DumpOptions = DumpOptions + { dumpForcedToFile :: Bool -- ^ Must be dumped into a file, even if + -- -ddump-to-file isn't set + , dumpSuffix :: String -- ^ Filename suffix used when dumped into + -- a file + } + +-- | Create dump options from a 'DumpFlag' +dumpOptionsFromFlag :: DumpFlag -> DumpOptions +dumpOptionsFromFlag Opt_D_th_dec_file = + DumpOptions -- -dth-dec-file dumps expansions of TH + { dumpForcedToFile = True -- splices into MODULE.th.hs even when + , dumpSuffix = "th.hs" -- -ddump-to-file isn't set + } +dumpOptionsFromFlag flag = + DumpOptions + { dumpForcedToFile = False + , dumpSuffix = suffix -- build a suffix from the flag name + } -- e.g. -ddump-asm => ".dump-asm" + where + str = show flag + suff = case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("Bad flag name: " ++ str) + suffix = map (\c -> if c == '_' then '-' else c) suff -- ----------------------------------------------------------------------------- @@ -738,7 +753,7 @@ withTiming' dflags what force_result prtimings action <+> text "megabytes") whenPrintTimings $ - dumpIfSet_dyn dflags Opt_D_dump_timings "" + dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText $ text $ showSDocOneLine dflags $ hsep [ what <> colon , text "alloc=" <> ppr alloc @@ -919,3 +934,43 @@ of the execution through the various labels) and ghc.totals.txt (total time spent in each label). -} + + +-- | Format of a dump +-- +-- Dump formats are loosely defined: dumps may contain various additional +-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint +-- (e.g. for syntax highlighters). +data DumpFormat + = FormatHaskell -- ^ Haskell + | FormatCore -- ^ Core + | FormatSTG -- ^ STG + | FormatByteCode -- ^ ByteCode + | FormatCMM -- ^ Cmm + | FormatASM -- ^ Assembly code + | FormatC -- ^ C code/header + | FormatLLVM -- ^ LLVM bytecode + | FormatText -- ^ Unstructured dump + deriving (Show,Eq) + +type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String + -> DumpFormat -> SDoc -> IO () + +type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a + +-- | Default action for 'dumpAction' hook +defaultDumpAction :: DumpAction +defaultDumpAction dflags sty dumpOpt title _fmt doc = do + dumpSDocWithStyle sty dflags dumpOpt title doc + +-- | Default action for 'traceAction' hook +defaultTraceAction :: TraceAction +defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc + +-- | Helper for `dump_action` +dumpAction :: DumpAction +dumpAction dflags = dump_action dflags dflags + +-- | Helper for `trace_action` +traceAction :: TraceAction +traceAction dflags = trace_action dflags dflags diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot index 6f180af546..a2ba51b304 100644 --- a/compiler/main/ErrUtils.hs-boot +++ b/compiler/main/ErrUtils.hs-boot @@ -1,10 +1,33 @@ +{-# LANGUAGE RankNTypes #-} + module ErrUtils where import GhcPrelude -import Outputable (SDoc, PrintUnqualified ) +import Outputable (SDoc, PprStyle ) import SrcLoc (SrcSpan) import Json -import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag ) +import {-# SOURCE #-} DynFlags ( DynFlags ) + +type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String + -> DumpFormat -> SDoc -> IO () + +type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a + +data DumpOptions = DumpOptions + { dumpForcedToFile :: Bool + , dumpSuffix :: String + } + +data DumpFormat + = FormatHaskell + | FormatCore + | FormatSTG + | FormatByteCode + | FormatCMM + | FormatASM + | FormatC + | FormatLLVM + | FormatText data Severity = SevOutput @@ -21,6 +44,7 @@ type MsgDoc = SDoc mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc -dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () +defaultDumpAction :: DumpAction +defaultTraceAction :: TraceAction instance ToJson Severity diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 9daecdb550..81f3caa033 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -356,12 +356,12 @@ hscParse' mod_summary POk pst rdr_module -> do let (warns, errs) = getMessages pst dflags logWarnings warns - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $ - ppr rdr_module - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - showAstData NoBlankSrcSpan rdr_module - liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $ - ppSourceStats False rdr_module + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan rdr_module) + liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + FormatText (ppSourceStats False rdr_module) when (not $ isEmptyBag errs) $ throwErrors errs -- To get the list of extra source files, we take the list @@ -412,8 +412,8 @@ extract_renamed_stuff mod_summary tc_result = do let rn_info = getRenamedStuff tc_result dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $ - showAstData NoBlankSrcSpan rn_info + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" + FormatHaskell (showAstData NoBlankSrcSpan rn_info) -- Create HIE files when (gopt Opt_WriteHie dflags) $ do @@ -1457,7 +1457,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do cmmToRawCmm dflags cmms let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" - (ppr a) + FormatCMM (ppr a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1506,13 +1506,14 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename cmm_mod = mkModule (thisPackage dflags) mod_name (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm - dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" + FormatCMM (ppr cmmgroup) rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup) _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] [] rawCmms @@ -1550,7 +1551,7 @@ doCodeGen hsc_env this_mod data_tycons -- to proc-point splitting). let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg - "Cmm produced by codegen" (ppr a) + "Cmm produced by codegen" FormatCMM (ppr a) return a ppr_stream1 = Stream.mapM dump1 cmm_stream @@ -1561,7 +1562,7 @@ doCodeGen hsc_env this_mod data_tycons in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1 dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm - "Output Cmm" (ppr a) + "Output Cmm" FormatCMM (ppr a) return a ppr_stream2 = Stream.mapM dump2 pipeline_stream @@ -1853,9 +1854,10 @@ hscParseThingWithLocation source linenumber parser str POk pst thing -> do logWarningsReportErrors (getMessages pst dflags) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $ - showAstData NoBlankSrcSpan thing + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan thing) return thing diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 04e50ebca8..ac48c3f24f 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -639,6 +639,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do Just subst -> do let dflags = hsc_dflags hsc_env dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + FormatText (fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]) diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index b3ee7f5e6c..9feffe7cb5 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -85,7 +85,7 @@ import CmdLineParser import System.Environment ( getEnv ) import FastString import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn, compilationProgressMsg, - withTiming ) + withTiming, DumpFormat (..) ) import Exception import System.Directory @@ -1616,6 +1616,7 @@ mkPackageState dflags dbs preload0 = do mod_map = Map.union mod_map1 mod_map2 dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" + FormatText (pprModuleMap mod_map) -- Force pstate to avoid leaking the dflags0 passed to mkPackageState diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 2ad9dc7bd4..47e89560b2 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -417,11 +417,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; unless (dopt Opt_D_dump_simpl dflags) $ Err.dumpIfSet_dyn dflags Opt_D_dump_rules (showSDoc dflags (ppr CoreTidy <+> text "rules")) + Err.FormatText (pprRulesForUser dflags tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" + Err.FormatText (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs index 7d830d0337..556c943dc2 100644 --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -359,6 +359,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs let platform = targetPlatform dflags dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" + FormatText $ Color.dotGraph (targetRegDotColor platform) (Color.trivColorable platform @@ -377,7 +378,9 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs $ makeImportsDoc dflags (concat (ngs_imports ngs)) return us' where - dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats" + dump_stats = dumpAction dflags (mkDumpStyle dflags alwaysQualify) + (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" + FormatText cmmNativeGenStream :: (Outputable statics, Outputable instr ,Outputable jumpDest, Instruction instr) @@ -420,7 +423,7 @@ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs -- See Note [What is this unwinding business?] in Debug. let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs unless (null ldbgs) $ - dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" + dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText (vcat $ map ppr ldbgs) -- Accumulate debug information for emission in finishNativeGen. @@ -505,7 +508,7 @@ emitNativeCode dflags h sdoc = do -- dump native code dumpIfSet_dyn dflags - Opt_D_dump_asm "Asm code" + Opt_D_dump_asm "Asm code" FormatASM sdoc -- | Complete native code generation phase for a single top-level chunk of Cmm. @@ -550,7 +553,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count cmmToCmm dflags this_mod fixed_cmm dumpIfSet_dyn dflags - Opt_D_dump_opt_cmm "Optimised Cmm" + Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM (pprCmmGroup [opt_cmm]) let cmmCfg = {-# SCC "getCFG" #-} @@ -564,7 +567,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count fileIds dbgMap opt_cmm cmmCfg dumpIfSet_dyn dflags - Opt_D_dump_asm_native "Native code" + Opt_D_dump_asm_native "Native code" FormatASM (vcat $ map (pprNatCmmDecl ncgImpl) native) maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name @@ -582,6 +585,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" + FormatCMM (vcat $ map ppr withLiveness) -- allocate registers @@ -621,10 +625,12 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count -- dump out what happened during register allocation dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" + FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" + FormatText (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage @@ -663,6 +669,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" + FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) let mPprStats = @@ -697,6 +704,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags Opt_D_dump_cfg_weights "CFG Update information" + FormatText ( text "stack:" <+> ppr stack_updt_blks $$ text "linearAlloc:" <+> ppr cfgRegAllocUpdates ) @@ -753,6 +761,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" + FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) expanded) -- generate unwinding information from cmm @@ -779,6 +788,7 @@ maybeDumpCfg dflags (Just cfg) msg proc_name | otherwise = dumpIfSet_dyn dflags Opt_D_dump_cfg_weights msg + FormatText (proc_name <> char ':' $$ pprEdgeWeights cfg) -- | Make sure all blocks we want the layout algorithm to place have been placed. diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index 6319a8ce10..4094402697 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -40,7 +40,7 @@ import THNames ( liftName ) import DynFlags import FastString -import ErrUtils ( dumpIfSet_dyn_printer ) +import ErrUtils ( dumpIfSet_dyn_printer, DumpFormat (..) ) import TcEnv ( tcMetaTy ) import Hooks import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName @@ -746,7 +746,7 @@ traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src ; when is_decl $ -- Raw material for -dth-dec-file do { dflags <- getDynFlags ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file - (spliceCodeDoc loc) } } + "" FormatHaskell (spliceCodeDoc loc) } } where -- `-ddump-splices` spliceDebugDoc :: SrcSpan -> SDoc diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 620f24c680..04898921de 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -61,14 +61,14 @@ import qualified IOEnv ( liftIO ) import Var import Outputable import FastString -import qualified ErrUtils as Err -import ErrUtils( Severity(..) ) +import ErrUtils( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) import UniqSupply import MonadUtils import NameCache import NameEnv import SrcLoc import Data.Bifunctor ( bimap ) +import ErrUtils (dumpAction) import Data.List import Data.Ord import Data.Dynamic @@ -825,9 +825,10 @@ debugTraceMsg :: SDoc -> CoreM () debugTraceMsg = msg SevDump NoReason -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher -dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () -dumpIfSet_dyn flag str doc +dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM () +dumpIfSet_dyn flag str fmt doc = do { dflags <- getDynFlags ; unqual <- getPrintUnqualified - ; when (dopt flag dflags) $ liftIO $ - Err.dumpSDoc dflags unqual flag str doc } + ; when (dopt flag dflags) $ liftIO $ do + let sty = mkDumpStyle dflags unqual + dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc } diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 015d096a0a..c0110fa1d9 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -19,7 +19,7 @@ import CoreArity ( etaExpand ) import CoreMonad ( FloatOutSwitches(..) ) import DynFlags -import ErrUtils ( dumpIfSet_dyn ) +import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) import Id ( Id, idArity, idType, isBottomingId, isJoinId, isJoinId_maybe ) import SetLevels @@ -174,11 +174,13 @@ floatOutwards float_sws dflags us pgm } ; dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" + FormatCore (vcat (map ppr annotated_w_levels)); let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" + FormatText (hcat [ int tlets, text " Lets floated to top level; ", int ntlets, text " Lets floated elsewhere; from ", int lams, text " Lambda groups"]); diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 149a079a0a..19465082dc 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -36,7 +36,7 @@ import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv import Id -import ErrUtils ( withTiming, withTimingD ) +import ErrUtils ( withTiming, withTimingD, DumpFormat (..) ) import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma ) import VarSet import VarEnv @@ -90,6 +90,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" + FormatText (pprSimplCount stats) ; return guts2 } @@ -576,6 +577,7 @@ simplifyExpr dflags expr "Simplifier statistics" (pprSimplCount counts) ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + FormatCore (pprCoreExpr expr') ; return expr' @@ -688,6 +690,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) binds } ; Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + FormatCore (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs index 32c277cc55..271f75e49b 100644 --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -141,6 +141,7 @@ traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc = do { dflags <- getDynFlags ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" + FormatText (hang (text herald) 2 doc) } {- diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 01e417ffaa..f5d8f1aeb0 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -260,7 +260,8 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs | not (dopt Opt_D_verbose_core2core dflags) = thing_inside | otherwise - = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside + = traceAction dflags ("SimplBind " ++ what) + (ppr old_bndr) thing_inside -------------------------- simplLazyBind :: SimplEnv @@ -1793,14 +1794,20 @@ completeCall env var cont interesting_cont = interestingCallContext env call_cont active_unf = activeUnfolding (getMode env) var + log_inlining doc + = liftIO $ dumpAction dflags + (mkUserStyle dflags alwaysQualify AllTheWay) + (dumpOptionsFromFlag Opt_D_dump_inlinings) + "" FormatText doc + dump_inline unfolding cont | not (dopt Opt_D_dump_inlinings dflags) = return () | not (dopt Opt_D_verbose_core2core dflags) = when (isExternalName (idName var)) $ - liftIO $ printOutputForUser dflags alwaysQualify $ + log_inlining $ sep [text "Inlining done:", nest 4 (ppr var)] | otherwise - = liftIO $ printOutputForUser dflags alwaysQualify $ + = liftIO $ log_inlining $ sep [text "Inlining done: " <> ppr var, nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont])] @@ -2065,17 +2072,21 @@ tryRules env rules fn args call_cont nodump | dopt Opt_D_dump_rule_rewrites dflags - = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty + = liftIO $ do + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) | dopt Opt_D_dump_rule_firings dflags - = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty + = liftIO $ do + touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) | otherwise = return () log_rule dflags flag hdr details - = liftIO . dumpSDoc dflags alwaysQualify flag "" $ - sep [text hdr, nest 4 details] + = liftIO $ do + let sty = mkDumpStyle dflags alwaysQualify + dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ + sep [text hdr, nest 4 details] trySeqRules :: SimplEnv -> OutExpr -> InExpr -- Scrutinee and RHS diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs index 89b7d4205e..2b6eeded42 100644 --- a/compiler/simplStg/SimplStg.hs +++ b/compiler/simplStg/SimplStg.hs @@ -96,12 +96,12 @@ stg2stg dflags this_mod binds return binds' dump_when flag header binds - = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds) + = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings binds) end_pass what binds2 = liftIO $ do -- report verbosely, if required dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what - (vcat (map ppr binds2)) + FormatSTG (vcat (map ppr binds2)) stg_linter False what binds2 return binds2 diff --git a/compiler/stranal/DmdAnal.hs b/compiler/stranal/DmdAnal.hs index afde951e60..b1601f2fed 100644 --- a/compiler/stranal/DmdAnal.hs +++ b/compiler/stranal/DmdAnal.hs @@ -35,7 +35,7 @@ import Util import Maybes ( isJust ) import TysWiredIn import TysPrim ( realWorldStatePrimTy ) -import ErrUtils ( dumpIfSet_dyn ) +import ErrUtils ( dumpIfSet_dyn, DumpFormat (..) ) import Name ( getName, stableNameCmp ) import Data.Function ( on ) import UniqSet @@ -53,8 +53,8 @@ dmdAnalProgram dflags fam_envs binds = do { let { binds_plus_dmds = do_prog binds } ; dumpIfSet_dyn dflags Opt_D_dump_str_signatures - "Strictness signatures" $ - dumpStrSig binds_plus_dmds ; + "Strictness signatures" FormatSTG + (dumpStrSig binds_plus_dmds) ; -- See Note [Stamp out space leaks in demand analysis] seqBinds binds_plus_dmds `seq` return binds_plus_dmds } diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index d43afe32bc..9761120016 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -235,6 +235,7 @@ tcDeriving deriv_infos deriv_decls ; unless (isEmptyBag inst_info) $ liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + FormatHaskell (ddump_deriving inst_info rn_binds famInsts)) ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info)) diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index ff71a6f430..822c557153 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -1918,6 +1918,7 @@ mkDefMethBind clas inst_tys sel_id dm_name [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" + FormatHaskell (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index d2235e5bd8..19b074954d 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -2711,9 +2711,9 @@ loadUnqualIfaces hsc_env ictxt ************************************************************************ -} +-- | Dump, with a banner, if -ddump-rn rnDump :: (Outputable a, Data a) => a -> TcRn () --- Dump, with a banner, if -ddump-rn -rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) } +rnDump rn = dumpOptTcRn Opt_D_dump_rn "Renamer" FormatHaskell (ppr rn) tcDump :: TcGblEnv -> TcRn () tcDump env @@ -2721,13 +2721,14 @@ tcDump env -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (traceTcRnForUser Opt_D_dump_types short_dump) ; + (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) + "" FormatText short_dump) ; -- Dump bindings if -ddump-tc - traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump); + dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump; -- Dump bindings as an hsSyn AST if -ddump-tc-ast - traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump) + dumpOptTcRn Opt_D_dump_tc_ast "Typechecker AST" FormatHaskell ast_dump } where short_dump = pprTcGblEnv env diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index c2a1cc2721..abc9c02eec 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -42,8 +42,8 @@ module TcRnMonad( newTcRef, readTcRef, writeTcRef, updTcRef, -- * Debugging - traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser, - traceTcRnWithStyle, + traceTc, traceRn, traceOptTcRn, dumpOptTcRn, + dumpTcRn, getPrintUnqualified, printForUserTcRn, traceIf, traceHiDiffs, traceOptIf, @@ -684,58 +684,48 @@ labelledTraceOptTcRn flag herald doc = do formatTraceMsg :: String -> SDoc -> SDoc formatTraceMsg herald doc = hang (text herald) 2 doc --- | Output a doc if the given 'DumpFlag' is set. --- --- By default this logs to stdout --- However, if the `-ddump-to-file` flag is set, --- then this will dump output to a file --- --- Just a wrapper for 'dumpSDoc' +-- | Trace if the given 'DumpFlag' is set. traceOptTcRn :: DumpFlag -> SDoc -> TcRn () -traceOptTcRn flag doc - = do { dflags <- getDynFlags - ; when (dopt flag dflags) - (traceTcRn flag doc) - } - +traceOptTcRn flag doc = do + dflags <- getDynFlags + when (dopt flag dflags) $ + dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc + +-- | Dump if the given 'DumpFlag' is set. +dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () +dumpOptTcRn flag title fmt doc = do + dflags <- getDynFlags + when (dopt flag dflags) $ + dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc + +-- | Unconditionally dump some trace output +-- -- Certain tests (T3017, Roles3, T12763 etc.) expect part of the -- output generated by `-ddump-types` to be in 'PprUser' style. However, -- generally we want all other debugging output to use 'PprDump' --- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this. - --- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style. -traceTcRn :: DumpFlag -> SDoc -> TcRn () -traceTcRn flag doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; let dump_style = mkDumpStyle dflags printer - ; traceTcRnWithStyle dump_style dflags flag doc } - --- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style. -traceTcRnForUser :: DumpFlag -> SDoc -> TcRn () --- Used by 'TcRnDriver.tcDump'. -traceTcRnForUser flag doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified dflags - ; let user_style = mkUserStyle dflags printer AllTheWay - ; traceTcRnWithStyle user_style dflags flag doc } - -traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn () --- ^ Unconditionally dump some trace output +-- style. We 'PprUser' style if 'useUserStyle' is True. -- --- The DumpFlag is used only to set the output filename --- for --dump-to-file, not to decide whether or not to output --- That part is done by the caller -traceTcRnWithStyle sty dflags flag doc - = do { real_doc <- prettyDoc dflags doc - ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc } - where - -- Add current location if -dppr-debug - prettyDoc :: DynFlags -> SDoc -> TcRn SDoc - prettyDoc dflags doc = if hasPprDebug dflags - then do { loc <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc } - else return doc -- The full location is usually way too much - +dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () +dumpTcRn useUserStyle dumpOpt title fmt doc = do + dflags <- getDynFlags + printer <- getPrintUnqualified dflags + real_doc <- wrapDocLoc doc + let sty = if useUserStyle + then mkUserStyle dflags printer AllTheWay + else mkDumpStyle dflags printer + liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc + +-- | Add current location if -dppr-debug +-- (otherwise the full location is usually way too much) +wrapDocLoc :: SDoc -> TcRn SDoc +wrapDocLoc doc = do + dflags <- getDynFlags + if hasPprDebug dflags + then do + loc <- getSrcSpanM + return (mkLocMessage SevOutput loc doc) + else + return doc getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified getPrintUnqualified dflags diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index eb940aa1ee..eb4f5027fb 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -146,6 +146,7 @@ import Type import Coercion import Unify +import ErrUtils import TcEvidence import Class import TyCon @@ -2733,7 +2734,10 @@ csTraceTcM mk_doc ; when ( dopt Opt_D_dump_cs_trace dflags || dopt Opt_D_dump_tc_trace dflags ) ( do { msg <- mk_doc - ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) } + ; TcM.dumpTcRn False + (dumpOptionsFromFlag Opt_D_dump_cs_trace) + "" FormatText + msg }) } runTcS :: TcS a -- What to run -> TcM (a, EvBindMap) diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index 0dda99020f..b200bd79db 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -82,7 +82,7 @@ module Outputable ( -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPgmError, pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace, - pprSTrace, pprTraceException, pprTraceM, + pprSTrace, pprTraceException, pprTraceM, pprTraceWithFlags, trace, pgmError, panic, sorry, assertPanic, pprDebugAndThen, callStackDoc, ) where @@ -1186,12 +1186,15 @@ pprTraceDebug str doc x | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x | otherwise = x +-- | If debug output is on, show some 'SDoc' on the screen pprTrace :: String -> SDoc -> a -> a --- ^ If debug output is on, show some 'SDoc' on the screen -pprTrace str doc x - | hasNoDebugOutput unsafeGlobalDynFlags = x - | otherwise = - pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x +pprTrace str doc x = pprTraceWithFlags unsafeGlobalDynFlags str doc x + +-- | If debug output is on, show some 'SDoc' on the screen +pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a +pprTraceWithFlags dflags str doc x + | hasNoDebugOutput dflags = x + | otherwise = pprDebugAndThen dflags trace (text str) doc x pprTraceM :: Applicative f => String -> SDoc -> f () pprTraceM str doc = pprTrace str doc (pure ()) diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 6aa8aa4578..5282c9f62a 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -1,5 +1,5 @@ -==================== Typechecker ==================== +==================== Typechecker AST ==================== {Bag(Located (HsBind Var)): [({ <no location info> } |