Commit 78252479 authored by Ian Lynagh's avatar Ian Lynagh
Browse files

Replace printDump with a new Severity

We now use log_action with severity SevDump, rather than calling
printDump. This means that what happens to dumped info is now under
the control of the GHC API user, rather than always going to stdout.
parent cd700473
......@@ -109,7 +109,9 @@ addTicksToBinds dflags mod mod_loc exports tyCons binds =
hashNo <- writeMixEntries dflags mod count entries orig_file2
modBreaks <- mkModBreaks count entries
doIfSet_dyn dflags Opt_D_dump_ticked $ printDump (pprLHsBinds binds1)
doIfSet_dyn dflags Opt_D_dump_ticked $
log_action dflags SevDump noSrcSpan defaultDumpStyle
(pprLHsBinds binds1)
return (binds1, HpcInfo count hashNo, modBreaks)
......
......@@ -231,10 +231,11 @@ filterNameMap mods env
-- | Display the persistent linker state.
showLinkerState :: IO ()
showLinkerState
showLinkerState :: DynFlags -> IO ()
showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar
printDump (vcat [text "----- Linker state -----",
log_action dflags SevDump noSrcSpan defaultDumpStyle
(vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
text "BCOs:" <+> ppr (bcos_loaded pls)])
......
......@@ -49,6 +49,7 @@ import Maybes
import ErrUtils
import Finder
import UniqFM
import SrcLoc
import StaticFlags
import Outputable
import BinIface
......@@ -643,7 +644,8 @@ showIface hsc_env filename = do
-- non-profiled interfaces, for example.
iface <- initTcRnIf 's' hsc_env () () $
readBinIface IgnoreHiWay TraceBinIFaceReading filename
printDump (pprModIface iface)
let dflags = hsc_dflags hsc_env
log_action dflags SevDump noSrcSpan defaultDumpStyle (pprModIface iface)
\end{code}
\begin{code}
......
......@@ -23,10 +23,11 @@ import DynFlags
import Config
import SysTools
import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import ErrUtils
import Outputable
import Module
import Maybes ( firstJusts )
import SrcLoc
import Control.Exception
import Control.Monad
......@@ -56,7 +57,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
{ showPass dflags "CmmLint"
; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC
; case firstJusts lints of
Just err -> do { printDump err
Just err -> do { log_action dflags SevDump noSrcSpan defaultDumpStyle err
; ghcExit dflags 1
}
Nothing -> return ()
......
......@@ -969,6 +969,7 @@ defaultLogAction :: LogAction
defaultLogAction severity srcSpan style msg
= case severity of
SevOutput -> printSDoc msg style
SevDump -> hPrintDump stdout msg
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n'
......
......@@ -71,6 +71,7 @@ type MsgDoc = SDoc
data Severity
= SevOutput
| SevDump
| SevInfo
| SevWarning
| SevError
......@@ -193,10 +194,10 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
-- -----------------------------------------------------------------------------
-- Dumping
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
| not flag = return ()
| otherwise = printDump (mkDumpDoc hdr doc)
| otherwise = log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc
......@@ -247,7 +248,7 @@ dumpSDoc dflags dflag hdr doc
-- write the dump to stdout
Nothing
-> printDump (mkDumpDoc hdr doc)
-> log_action dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
-- | Choose where to put a dump file based on DynFlags
......
......@@ -6,6 +6,7 @@ import SrcLoc (SrcSpan)
data Severity
= SevOutput
| SevDump
| SevInfo
| SevWarning
| SevError
......
......@@ -1706,7 +1706,7 @@ hscCompileCoreExpr hsc_env srcspan ds_expr
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env = do
eps <- readIORef (hsc_EPS hsc_env)
dumpIfSet (dump_if_trace || dump_rn_stats)
dumpIfSet dflags (dump_if_trace || dump_rn_stats)
"Interface statistics"
(ifaceStats eps)
where
......
......@@ -51,8 +51,10 @@ import Packages( isDllName )
import HscTypes
import Maybes
import UniqSupply
import ErrUtils (Severity(..))
import Outputable
import FastBool hiding ( fastOr )
import SrcLoc
import Util
import FastString
......@@ -372,7 +374,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- If the endPass didn't print the rules, but ddump-rules is
-- on, print now
; dumpIfSet (dopt Opt_D_dump_rules dflags
; dumpIfSet dflags (dopt Opt_D_dump_rules dflags
&& (not (dopt Opt_D_dump_simpl dflags)))
CoreTidy
(ptext (sLit "rules"))
......@@ -381,7 +383,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
; when (dopt Opt_D_dump_core_stats dflags)
(printDump (ptext (sLit "Tidy size (terms,types,coercions)")
(log_action dflags SevDump noSrcSpan defaultDumpStyle
(ptext (sLit "Tidy size (terms,types,coercions)")
<+> ppr (moduleName mod) <> colon
<+> int (cs_tm cs)
<+> int (cs_ty cs)
......
......@@ -91,6 +91,7 @@ import FastString
import qualified ErrUtils as Err
import Bag
import Maybes
import SrcLoc
import UniqSupply
import UniqFM ( UniqFM, mapUFM, filterUFM )
import MonadUtils
......@@ -145,9 +146,9 @@ endPass dflags pass binds rules
| dopt Opt_D_verbose_core2core dflags -> Just dflag
_ -> Nothing
dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dump_me pass extra_info doc
= Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
dumpIfSet dflags dump_me pass extra_info doc
= Err.dumpIfSet dflags dump_me (showSDoc (ppr pass <+> extra_info)) doc
dumpPassResult :: DynFlags
-> Maybe DynFlag -- Just df => show details in a file whose
......@@ -189,10 +190,11 @@ displayLintResults :: DynFlags -> CoreToDo
-> IO ()
displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs)
= do { printDump (vcat [ banner "errors", Err.pprMessageBag errs
, ptext (sLit "*** Offending Program ***")
, pprCoreBindings binds
, ptext (sLit "*** End of Offense ***") ])
= do { log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
(vcat [ banner "errors", Err.pprMessageBag errs
, ptext (sLit "*** Offending Program ***")
, pprCoreBindings binds
, ptext (sLit "*** End of Offense ***") ])
; Err.ghcExit dflags 1 }
| not (isEmptyBag warns)
......@@ -203,7 +205,8 @@ displayLintResults dflags pass warns errs binds
-- group. Only afer a round of simplification are they unravelled.
, not opt_NoDebugOutput
, showLintWarnings pass
= printDump (banner "warnings" $$ Err.pprMessageBag warns)
= log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
(banner "warnings" $$ Err.pprMessageBag warns)
| otherwise = return ()
where
......
......@@ -47,6 +47,7 @@ import DmdAnal ( dmdAnalPgm )
import WorkWrap ( wwTopBinds )
import Vectorise ( vectorise )
import FastString
import SrcLoc
import Util
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
......@@ -419,15 +420,17 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass)
%************************************************************************
\begin{code}
printCore :: a -> CoreProgram -> IO ()
printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
printCore :: DynFlags -> CoreProgram -> IO ()
printCore dflags binds
= Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts = do
rb <- getRuleBase
dflags <- getDynFlags
liftIO $ Err.showPass dflags "RuleCheck"
liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
liftIO $ log_action dflags Err.SevDump noSrcSpan defaultDumpStyle
(ruleCheckProgram current_phase pat rb (mg_binds guts))
return guts
......@@ -492,8 +495,8 @@ simplifyExpr dflags expr
(expr', counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
simplExprGently (simplEnvForGHCi dflags) expr
; Err.dumpIfSet (dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics" (pprSimplCount counts)
; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics" (pprSimplCount counts)
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
(pprCoreExpr expr')
......@@ -555,7 +558,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
= do { (termination_msg, it_count, counts_out, guts')
<- do_iteration us 1 [] binds rules
; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
; Err.dumpIfSet dflags (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics for following pass"
(vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
blankLine,
......
......@@ -27,7 +27,8 @@ import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
getStgToDo )
import Id ( Id )
import Module ( Module )
import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass )
import ErrUtils
import SrcLoc
import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
import Outputable
\end{code}
......@@ -44,7 +45,7 @@ stg2stg dflags module_name binds
; us <- mkSplitUniqSupply 'g'
; doIfSet_dyn dflags Opt_D_verbose_stg2stg
(printDump (text "VERBOSE STG-TO-STG:"))
(log_action dflags SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
......
......@@ -39,7 +39,7 @@ module Outputable (
colBinder, bold, keyword,
-- * Converting 'SDoc' into strings and outputing it
hPrintDump, printDump,
hPrintDump,
printForC, printForAsm, printForUser, printForUserPartWay,
pprCode, mkCodeStyle,
showSDoc, showSDocOneLine,
......@@ -88,7 +88,7 @@ import qualified Data.IntMap as IM
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word
import System.IO ( Handle, stdout, hFlush )
import System.IO ( Handle, hFlush )
import System.FilePath
......@@ -318,9 +318,6 @@ ifPprDebug d = SDoc $ \ctx ->
\end{code}
\begin{code}
printDump :: SDoc -> IO ()
printDump doc = hPrintDump stdout doc
hPrintDump :: Handle -> SDoc -> IO ()
hPrintDump h doc = do
Pretty.printDoc PageMode h
......
......@@ -2078,7 +2078,9 @@ showCmd str = do
["imports"] -> showImports
["modules" ] -> showModules
["bindings"] -> showBindings
["linker"] -> liftIO showLinkerState
["linker"] ->
do dflags <- getDynFlags
liftIO $ showLinkerState dflags
["breaks"] -> showBkptTable
["context"] -> showContext
["packages"] -> showPackages
......
Supports Markdown
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