More DynFlags + SDoc
authorIan Lynagh <igloo@earth.li>
Wed, 25 May 2011 14:33:01 +0000 (15:33 +0100)
committerIan Lynagh <igloo@earth.li>
Wed, 25 May 2011 18:10:04 +0000 (19:10 +0100)
12 files changed:
compiler/deSugar/Coverage.lhs
compiler/ghci/Linker.lhs
compiler/iface/LoadIface.lhs
compiler/main/CodeOutput.lhs
compiler/main/ErrUtils.lhs
compiler/main/HscMain.lhs
compiler/main/TidyPgm.lhs
compiler/simplCore/CoreMonad.lhs
compiler/simplCore/SimplCore.lhs
compiler/simplStg/SimplStg.lhs
compiler/utils/Outputable.lhs
ghc/InteractiveUI.hs

index 37cbc2d..3635710 100644 (file)
@@ -128,7 +128,7 @@ addCoverageTicksToBinds dflags mod mod_loc tyCons binds =
                   } 
 
   doIfSet_dyn dflags  Opt_D_dump_hpc $ do
-         printDump (pprLHsBinds binds1)
+         printDump dflags (pprLHsBinds binds1)
 
   return (binds1, HpcInfo (tickBoxCount st) hashNo, modBreaks)
 \end{code}
index eaf4521..f9daa00 100644 (file)
@@ -331,13 +331,13 @@ filterNameMap mods env
 
 \begin{code}
 -- | Display the persistent linker state.
-showLinkerState :: IO ()
-showLinkerState
+showLinkerState :: DynFlags -> IO ()
+showLinkerState dflags
   = do pls <- readMVar v_PersistentLinkerState
-       printDump (vcat [text "----- Linker state -----",
-                       text "Pkgs:" <+> ppr (pkgs_loaded pls),
-                       text "Objs:" <+> ppr (objs_loaded pls),
-                       text "BCOs:" <+> ppr (bcos_loaded pls)])
+       printDump dflags (vcat [text "----- Linker state -----",
+                               text "Pkgs:" <+> ppr (pkgs_loaded pls),
+                               text "Objs:" <+> ppr (objs_loaded pls),
+                               text "BCOs:" <+> ppr (bcos_loaded pls)])
 \end{code}
                        
        
index e92a160..7f36ac1 100644 (file)
@@ -638,7 +638,7 @@ showIface hsc_env filename = do
    -- non-profiled interfaces, for example.
    iface <- initTcRnIf 's' hsc_env () () $
        readBinIface IgnoreHiWay TraceBinIFaceReading filename
-   printDump (pprModIface iface)
+   printDump (hsc_dflags hsc_env) (pprModIface iface)
 \end{code}
 
 \begin{code}
index f5e3394..6091b91 100644 (file)
@@ -69,7 +69,7 @@ codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
                { showPass dflags "CmmLint"
                ; let lints = map cmmLint flat_abstractC
                ; case firstJusts lints of
-                       Just err -> do { printDump err
+                       Just err -> do { printDump dflags err
                                       ; ghcExit dflags 1
                                       }
                        Nothing  -> return ()
index 878c3e6..4905ceb 100644 (file)
@@ -177,10 +177,12 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
 -- -----------------------------------------------------------------------------
 -- Dumping
 
-dumpIfSet :: Bool -> String -> SDoc -> IO ()
-dumpIfSet flag hdr doc
+-- TODO: Now that this function has access to DynFlags, should we
+-- check verbosity dflags >= 4?
+dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
+dumpIfSet dflags flag hdr doc
   | not flag   = return ()
-  | otherwise  = printDump (mkDumpDoc hdr doc)
+  | otherwise  = printDump dflags (mkDumpDoc hdr doc)
 
 dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO ()
 dumpIfSet_dyn dflags flag hdr doc
@@ -193,7 +195,7 @@ dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
 dumpIfSet_dyn_or dflags flags hdr doc
   | or [dopt flag dflags | flag <- flags]
   || verbosity dflags >= 4 
-  = printDump (mkDumpDoc hdr doc)
+  = printDump dflags (mkDumpDoc hdr doc)
   | otherwise = return ()
 
 mkDumpDoc :: String -> SDoc -> SDoc
@@ -225,12 +227,12 @@ dumpSDoc dflags dflag hdr doc
                         when (not append) $
                             writeIORef gdref (Set.insert fileName gd)
                         handle <- openFile fileName mode
-                        hPrintDump handle doc
+                        hPrintDump dflags handle doc
                         hClose handle
 
             -- write the dump to stdout
             Nothing
-                 -> printDump (mkDumpDoc hdr doc)
+                 -> printDump dflags (mkDumpDoc hdr doc)
 
 
 -- | Choose where to put a dump file based on DynFlags
index 6a5552f..a7f55aa 100644 (file)
@@ -1303,9 +1303,9 @@ 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)
-                   "Interface statistics"
-                   (ifaceStats eps) }
+        ; dumpIfSet dflags (dump_if_trace || dump_rn_stats)
+                    "Interface statistics"
+                    (ifaceStats eps) }
   where
     dflags = hsc_dflags hsc_env
     dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
index b4296cb..17e2809 100644 (file)
@@ -346,9 +346,10 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
 
        ; endPass dflags CoreTidy all_tidy_binds tidy_rules
 
-         -- If the endPass didn't print the rules, but ddump-rules is on, print now
-       ; dumpIfSet (dopt Opt_D_dump_rules dflags 
-                     && (not (dopt Opt_D_dump_simpl dflags))) 
+          -- If the endPass didn't print the rules, but ddump-rules is
+          -- on, print now
+        ; dumpIfSet dflags (dopt Opt_D_dump_rules dflags
+                            && (not (dopt Opt_D_dump_simpl dflags)))
                    CoreTidy
                     (ptext (sLit "rules"))
                     (pprRulesForUser tidy_rules)
@@ -356,11 +357,11 @@ tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports,
           -- 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)") 
-                           <+> ppr (moduleName mod) <> colon 
-                           <+> int (cs_tm cs) 
-                           <+> int (cs_ty cs) 
-                           <+> int (cs_co cs) ))
+               (printDump dflags (ptext (sLit "Tidy size (terms,types,coercions)")
+                                  <+> ppr (moduleName mod) <> colon
+                                  <+> int (cs_tm cs)
+                                  <+> int (cs_ty cs)
+                                  <+> int (cs_co cs) ))
 
         ; return (CgGuts { cg_module   = mod,
                            cg_tycons   = alg_tycons,
index 6ddcff2..e253f39 100644 (file)
@@ -120,9 +120,9 @@ endIteration dflags pass n
   = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
                 (Just Opt_D_dump_simpl_iterations)
 
-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
 
 dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
             -> [CoreBind] -> [CoreRule] -> IO ()
@@ -160,10 +160,10 @@ 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 { printDump dflags (vcat [ banner "errors", Err.pprMessageBag errs
+                                , ptext (sLit "*** Offending Program ***")
+                                , pprCoreBindings binds
+                                , ptext (sLit "*** End of Offense ***") ])
        ; Err.ghcExit dflags 1 }
 
   | not (isEmptyBag warns)
@@ -174,7 +174,7 @@ 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)
+  = printDump dflags (banner "warnings" $$ Err.pprMessageBag warns)
 
   | otherwise = return ()
   where
index ea81317..b7466dc 100644 (file)
@@ -141,15 +141,15 @@ doCorePass pass = pprPanic "doCorePass" (ppr pass)
 %************************************************************************
 
 \begin{code}
-printCore :: a -> [CoreBind] -> IO ()
-printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
+printCore :: DynFlags -> [CoreBind] -> IO ()
+printCore dflags binds = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)
 
 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
 ruleCheck 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 $ printDump dflags (ruleCheckProgram current_phase pat rb (mg_binds guts))
     return guts
 
 
@@ -314,7 +314,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,
@@ -431,7 +431,7 @@ end_iteration :: DynFlags -> CoreToDo -> Int
              -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
 -- Same as endIteration but with simplifier counts
 end_iteration dflags pass iteration_no counts binds rules
-  = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
+  = do { dumpIfSet dflags (dopt Opt_D_dump_simpl_iterations dflags)
                    pass (ptext (sLit "Simplifier counts"))
                   (pprSimplCount counts)
 
index 4c240e2..38f8eae 100644 (file)
@@ -37,7 +37,7 @@ stg2stg dflags module_name binds
        ; us <- mkSplitUniqSupply 'g'
 
        ; doIfSet_dyn dflags Opt_D_verbose_stg2stg 
-                     (printDump (text "VERBOSE STG-TO-STG:"))
+                     (printDump dflags (text "VERBOSE STG-TO-STG:"))
 
        ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
 
index f825133..bd33dda 100644 (file)
@@ -336,13 +336,13 @@ printErrs dflags doc sty = do
 printOutput :: Doc -> IO ()
 printOutput doc = Pretty.printDoc PageMode stdout doc
 
-printDump :: SDoc -> IO ()
-printDump doc = hPrintDump stdout doc
+printDump :: DynFlags -> SDoc -> IO ()
+printDump dflags doc = hPrintDump dflags stdout doc
 
-hPrintDump :: Handle -> SDoc -> IO ()
-hPrintDump h doc = do
+hPrintDump :: DynFlags -> Handle -> SDoc -> IO ()
+hPrintDump dflags h doc = do
    Pretty.printDoc PageMode h
-     (runSDoc better_doc (initSDocContext defaultDumpStyle))
+     (runSDoc better_doc (initSDocContext' dflags defaultDumpStyle))
    hFlush h
  where
    better_doc = doc $$ blankLine
index 0f68607..4c43d20 100644 (file)
@@ -1708,7 +1708,8 @@ showCmd str = do
         ["stop"]     -> liftIO $ putStrLn (show (stop st))
        ["modules" ] -> showModules
        ["bindings"] -> showBindings
-       ["linker"]   -> liftIO showLinkerState
+        ["linker"]   -> do dflags <- getDynFlags
+                           liftIO $ showLinkerState dflags
         ["breaks"]   -> showBkptTable
         ["context"]  -> showContext
         ["packages"]  -> showPackages