Replace printDump with a new Severity
authorIan Lynagh <igloo@earth.li>
Tue, 29 May 2012 00:46:07 +0000 (01:46 +0100)
committerIan Lynagh <igloo@earth.li>
Tue, 29 May 2012 00:46:07 +0000 (01:46 +0100)
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.

14 files changed:
compiler/deSugar/Coverage.lhs
compiler/ghci/Linker.lhs
compiler/iface/LoadIface.lhs
compiler/main/CodeOutput.lhs
compiler/main/DynFlags.hs
compiler/main/ErrUtils.lhs
compiler/main/ErrUtils.lhs-boot
compiler/main/HscMain.hs
compiler/main/TidyPgm.lhs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplStg/SimplStg.lhs
compiler/utils/Outputable.lhs
ghc/InteractiveUI.hs

index ec7adf5..ca5ef9a 100644 (file)
@@ -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)
 
index f91ee14..ca7d538 100644 (file)
@@ -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)])
index aef9a32..9445808 100644 (file)
@@ -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}
index 88ba0b5..c869ded 100644 (file)
@@ -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 ()
index 1f72f8e..aa646ec 100644 (file)
@@ -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'
index dc73257..5eaaa8d 100644 (file)
@@ -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
index 7718cbe..6f4a373 100644 (file)
@@ -6,6 +6,7 @@ import SrcLoc (SrcSpan)
 
 data Severity
   = SevOutput
+  | SevDump
   | SevInfo
   | SevWarning
   | SevError
index 4a54c89..8d190d4 100644 (file)
@@ -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
index 15f68d3..215d6c9 100644 (file)
@@ -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) 
index c3a3dce..edc5a65 100644 (file)
@@ -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
index 0ebde64..a90fc0c 100644 (file)
@@ -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,
index 8ade2d5..1bec392 100644 (file)
@@ -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
 
index c8188d7..3130f71 100644 (file)
@@ -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
index f29fa06..8c1f5ec 100644 (file)
@@ -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