Commit 58655b9d authored by Sylvain Henry's avatar Sylvain Henry

Add GHC-API logging hooks

* Add 'dumpAction' hook to DynFlags.

It allows GHC API users to catch dumped intermediate codes and
information. The format of the dump (Core, Stg, raw text, etc.) is now
reported allowing easier automatic handling.

* Add 'traceAction' hook to DynFlags.

Some dumps go through the trace mechanism (for instance unfoldings that
have been considered for inlining). This is problematic because:
1) dumps aren't written into files even with -ddump-to-file on
2) dumps are written on stdout even with GHC API
3) in this specific case, dumping depends on unsafe globally stored
DynFlags which is bad for GHC API users

We introduce 'traceAction' hook which allows GHC API to catch those
traces and to avoid using globally stored DynFlags.

* Avoid dumping empty logs via dumpAction/traceAction (but still write
empty files to keep the existing behavior)
parent a8f7ecd5
......@@ -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
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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) }
......
......@@ -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
......
......@@ -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'])
......
......@@ -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,
......
......@@ -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
......
......@@ -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"
......
......@@ -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
......
{-# 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,
......
......@@ -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
{-# 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
......@@ -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