Commit c8c18a10 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Some refactoring around endPass and debug dumping

I forget all the details, but I spent some time trying to
understand the current setup, and tried to simplify it a bit
parent 27ba070c
...@@ -21,7 +21,7 @@ import PrelNames ...@@ -21,7 +21,7 @@ import PrelNames
import CoreUtils import CoreUtils
import CoreArity import CoreArity
import CoreFVs import CoreFVs
import CoreMonad ( endPass, CoreToDo(..) ) import CoreMonad ( endPassIO, CoreToDo(..) )
import CoreSyn import CoreSyn
import CoreSubst import CoreSubst
import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here import MkCore hiding( FloatBind(..) ) -- We use our own FloatBind here
...@@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do ...@@ -172,7 +172,7 @@ corePrepPgm dflags hsc_env binds data_tycons = do
floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds
return (deFloatTop (floats1 `appendFloats` floats2)) return (deFloatTop (floats1 `appendFloats` floats2))
endPass hsc_env CorePrep binds_out [] endPassIO hsc_env alwaysQualify CorePrep binds_out []
return binds_out return binds_out
corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr
......
...@@ -39,7 +39,7 @@ import Rules ...@@ -39,7 +39,7 @@ import Rules
import TysPrim (eqReprPrimTyCon) import TysPrim (eqReprPrimTyCon)
import TysWiredIn (coercibleTyCon ) import TysWiredIn (coercibleTyCon )
import BasicTypes ( Activation(.. ) ) import BasicTypes ( Activation(.. ) )
import CoreMonad ( endPass, CoreToDo(..) ) import CoreMonad ( endPassIO, CoreToDo(..) )
import MkCore import MkCore
import FastString import FastString
import ErrUtils import ErrUtils
...@@ -94,6 +94,7 @@ deSugar hsc_env ...@@ -94,6 +94,7 @@ deSugar hsc_env
tcg_hpc = other_hpc_info }) tcg_hpc = other_hpc_info })
= do { let dflags = hsc_dflags hsc_env = do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
; showPass dflags "Desugar" ; showPass dflags "Desugar"
-- Desugar the program -- Desugar the program
...@@ -147,14 +148,14 @@ deSugar hsc_env ...@@ -147,14 +148,14 @@ deSugar hsc_env
#ifdef DEBUG #ifdef DEBUG
-- Debug only as pre-simple-optimisation program may be really big -- Debug only as pre-simple-optimisation program may be really big
; endPass hsc_env CoreDesugar final_pgm rules_for_imps ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps
#endif #endif
; (ds_binds, ds_rules_for_imps, ds_vects) ; (ds_binds, ds_rules_for_imps, ds_vects)
<- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0
-- The simpleOptPgm gets rid of type -- The simpleOptPgm gets rid of type
-- bindings plus any stupid dead code -- bindings plus any stupid dead code
; endPass hsc_env CoreDesugarOpt ds_binds ds_rules_for_imps ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps
; let used_names = mkUsedNames tcg_env ; let used_names = mkUsedNames tcg_env
; deps <- mkDependencies tcg_env ; deps <- mkDependencies tcg_env
......
...@@ -29,6 +29,7 @@ import Kind ...@@ -29,6 +29,7 @@ import Kind
import GHC import GHC
import Outputable import Outputable
import PprTyThing import PprTyThing
import ErrUtils
import MonadUtils import MonadUtils
import DynFlags import DynFlags
import Exception import Exception
......
...@@ -52,8 +52,6 @@ module DynFlags ( ...@@ -52,8 +52,6 @@ module DynFlags (
tablesNextToCode, mkTablesNextToCode, tablesNextToCode, mkTablesNextToCode,
SigOf(..), getSigOf, SigOf(..), getSigOf,
printOutputForUser, printInfoForUser,
Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays,
wayGeneralFlags, wayUnsetGeneralFlags, wayGeneralFlags, wayUnsetGeneralFlags,
...@@ -1557,16 +1555,6 @@ newtype FlushErr = FlushErr (IO ()) ...@@ -1557,16 +1555,6 @@ newtype FlushErr = FlushErr (IO ())
defaultFlushErr :: FlushErr defaultFlushErr :: FlushErr
defaultFlushErr = FlushErr $ hFlush stderr defaultFlushErr = FlushErr $ hFlush stderr
printOutputForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
printOutputForUser = printSevForUser SevOutput
printInfoForUser :: DynFlags -> PrintUnqualified -> SDoc -> IO ()
printInfoForUser = printSevForUser SevInfo
printSevForUser :: Severity -> DynFlags -> PrintUnqualified -> SDoc -> IO ()
printSevForUser sev dflags unqual doc
= log_action dflags dflags sev noSrcSpan (mkUserStyle unqual AllTheWay) doc
{- {-
Note [Verbosity levels] Note [Verbosity levels]
~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -27,7 +27,8 @@ module ErrUtils ( ...@@ -27,7 +27,8 @@ module ErrUtils (
mkDumpDoc, dumpSDoc, mkDumpDoc, dumpSDoc,
-- * Messages during compilation -- * Messages during compilation
putMsg, putMsgWith, putMsg, printInfoForUser, printOutputForUser,
logInfo, logOutput,
errorMsg, errorMsg,
fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'', fatalErrorMsg, fatalErrorMsg', fatalErrorMsg'',
compilationProgressMsg, compilationProgressMsg,
...@@ -237,7 +238,7 @@ dumpIfSet dflags flag hdr doc ...@@ -237,7 +238,7 @@ dumpIfSet dflags flag hdr doc
dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
dumpIfSet_dyn dflags flag hdr doc dumpIfSet_dyn dflags flag hdr doc
| dopt flag dflags | dopt flag dflags
= dumpSDoc dflags flag hdr doc = dumpSDoc dflags alwaysQualify flag hdr doc
| otherwise | otherwise
= return () = return ()
...@@ -254,12 +255,13 @@ mkDumpDoc hdr doc ...@@ -254,12 +255,13 @@ mkDumpDoc hdr doc
-- | Write out a dump. -- | Write out a dump.
-- If --dump-to-file is set then this goes to a file. -- If --dump-to-file is set then this goes to a file.
-- otherwise emit to stdout. -- otherwise emit to stdout.
-- --
-- When hdr is empty, we print in a more compact format (no separators and -- When hdr is empty, we print in a more compact format (no separators and
-- blank lines) -- blank lines)
dumpSDoc :: DynFlags -> DumpFlag -> String -> SDoc -> IO () dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO ()
dumpSDoc dflags flag hdr doc dumpSDoc dflags print_unqual flag hdr doc
= do let mFile = chooseDumpFile dflags flag = do let mFile = chooseDumpFile dflags flag
dump_style = mkDumpStyle print_unqual
case mFile of case mFile of
Just fileName Just fileName
-> do -> do
...@@ -278,7 +280,7 @@ dumpSDoc dflags flag hdr doc ...@@ -278,7 +280,7 @@ dumpSDoc dflags flag hdr doc
$$ blankLine $$ blankLine
$$ doc $$ doc
return $ mkDumpDoc hdr d return $ mkDumpDoc hdr d
defaultLogActionHPrintDoc dflags handle doc' defaultDumpStyle defaultLogActionHPrintDoc dflags handle doc' dump_style
hClose handle hClose handle
-- write the dump to stdout -- write the dump to stdout
...@@ -286,7 +288,7 @@ dumpSDoc dflags flag hdr doc ...@@ -286,7 +288,7 @@ dumpSDoc dflags flag hdr doc
let (doc', severity) let (doc', severity)
| null hdr = (doc, SevOutput) | null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump) | otherwise = (mkDumpDoc hdr doc, SevDump)
log_action dflags dflags severity noSrcSpan defaultDumpStyle doc' log_action dflags dflags severity noSrcSpan dump_style doc'
-- | Choose where to put a dump file based on DynFlags -- | Choose where to put a dump file based on DynFlags
...@@ -340,18 +342,9 @@ ifVerbose dflags val act ...@@ -340,18 +342,9 @@ ifVerbose dflags val act
| verbosity dflags >= val = act | verbosity dflags >= val = act
| otherwise = return () | otherwise = return ()
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
putMsgWith :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
putMsgWith dflags print_unqual msg
= log_action dflags dflags SevInfo noSrcSpan sty msg
where
sty = mkUserStyle print_unqual AllTheWay
errorMsg :: DynFlags -> MsgDoc -> IO () errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg = errorMsg dflags msg
log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO () fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
...@@ -365,25 +358,45 @@ fatalErrorMsg'' fm msg = fm msg ...@@ -365,25 +358,45 @@ fatalErrorMsg'' fm msg = fm msg
compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg compilationProgressMsg dflags msg
= ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg)) = ifVerbose dflags 1 $
logOutput dflags defaultUserStyle (text msg)
showPass :: DynFlags -> String -> IO () showPass :: DynFlags -> String -> IO ()
showPass dflags what showPass dflags what
= ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon)) = ifVerbose dflags 2 $
logInfo dflags defaultUserStyle (text "***" <+> text what <> colon)
debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()
debugTraceMsg dflags val msg debugTraceMsg dflags val msg = ifVerbose dflags val $
= ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg) logInfo dflags defaultDumpStyle msg
putMsg :: DynFlags -> MsgDoc -> IO ()
putMsg dflags msg = logInfo dflags defaultUserStyle msg
printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printInfoForUser dflags print_unqual msg
= logInfo dflags (mkUserStyle print_unqual AllTheWay) msg
printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()
printOutputForUser dflags print_unqual msg
= logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg
logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- Like logInfo but with SevOutput rather then SevInfo
logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags prettyPrintGhcErrors dflags
= ghandle $ \e -> case e of = ghandle $ \e -> case e of
PprPanic str doc -> PprPanic str doc ->
pprDebugAndThen dflags panic str doc pprDebugAndThen dflags panic (text str) doc
PprSorry str doc -> PprSorry str doc ->
pprDebugAndThen dflags sorry str doc pprDebugAndThen dflags sorry (text str) doc
PprProgramError str doc -> PprProgramError str doc ->
pprDebugAndThen dflags pgmError str doc pprDebugAndThen dflags pgmError (text str) doc
_ -> _ ->
liftIO $ throwIO e liftIO $ throwIO e
\end{code} \end{code}
......
...@@ -141,7 +141,7 @@ mkBootModDetailsTc hsc_env ...@@ -141,7 +141,7 @@ mkBootModDetailsTc hsc_env
tcg_fam_insts = fam_insts tcg_fam_insts = fam_insts
} }
= do { let dflags = hsc_dflags hsc_env = do { let dflags = hsc_dflags hsc_env
; showPass dflags CoreTidy ; showPassIO dflags CoreTidy
; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts ; let { insts' = map (tidyClsInstDFun globaliseAndTidyId) insts
; type_env1 = mkBootTypeEnv (availsToNameSet exports) ; type_env1 = mkBootTypeEnv (availsToNameSet exports)
...@@ -302,6 +302,7 @@ RHSs, so that they print nicely in interfaces. ...@@ -302,6 +302,7 @@ RHSs, so that they print nicely in interfaces.
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram hsc_env (ModGuts { mg_module = mod tidyProgram hsc_env (ModGuts { mg_module = mod
, mg_exports = exports , mg_exports = exports
, mg_rdr_env = rdr_env
, mg_tcs = tcs , mg_tcs = tcs
, mg_insts = insts , mg_insts = insts
, mg_fam_insts = fam_insts , mg_fam_insts = fam_insts
...@@ -319,8 +320,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -319,8 +320,9 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
= do { let { dflags = hsc_dflags hsc_env = do { let { dflags = hsc_dflags hsc_env
; omit_prags = gopt Opt_OmitInterfacePragmas dflags ; omit_prags = gopt Opt_OmitInterfacePragmas dflags
; expose_all = gopt Opt_ExposeAllUnfoldings dflags ; expose_all = gopt Opt_ExposeAllUnfoldings dflags
; print_unqual = mkPrintUnqualified dflags rdr_env
} }
; showPass dflags CoreTidy ; showPassIO dflags CoreTidy
; let { type_env = typeEnvFromEntities [] tcs fam_insts ; let { type_env = typeEnvFromEntities [] tcs fam_insts
...@@ -378,7 +380,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ...@@ -378,7 +380,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
} }
; endPass hsc_env CoreTidy all_tidy_binds tidy_rules ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
-- If the endPass didn't print the rules, but ddump-rules is -- If the endPass didn't print the rules, but ddump-rules is
-- on, print now -- on, print now
......
...@@ -316,8 +316,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof) ...@@ -316,8 +316,7 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
$ [ Color.raGraph stat $ [ Color.raGraph stat
| stat@Color.RegAllocStatsStart{} <- stats] | stat@Color.RegAllocStatsStart{} <- stats]
dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" dump_stats (Color.pprStats stats graphGlobal)
$ Color.pprStats stats graphGlobal
dumpIfSet_dyn dflags dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph" Opt_D_dump_asm_conflicts "Register conflict graph"
...@@ -332,13 +331,14 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof) ...@@ -332,13 +331,14 @@ finishNativeGen dflags ncgImpl bufh@(BufHandle _ _ h) (imports, prof)
-- dump global NCG stats for linear allocator -- dump global NCG stats for linear allocator
(case concat $ catMaybes linearStats of (case concat $ catMaybes linearStats of
[] -> return () [] -> return ()
stats -> dumpSDoc dflags Opt_D_dump_asm_stats "NCG stats" stats -> dump_stats (Linear.pprStats (concat native) stats))
$ Linear.pprStats (concat native) stats)
-- write out the imports -- write out the imports
Pretty.printDoc Pretty.LeftMode (pprCols dflags) h Pretty.printDoc Pretty.LeftMode (pprCols dflags) h
$ withPprStyleDoc dflags (mkCodeStyle AsmStyle) $ withPprStyleDoc dflags (mkCodeStyle AsmStyle)
$ makeImportsDoc dflags (concat imports) $ makeImportsDoc dflags (concat imports)
where
dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr) cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
=> DynFlags => DynFlags
......
...@@ -28,6 +28,7 @@ module CoreMonad ( ...@@ -28,6 +28,7 @@ module CoreMonad (
-- ** Reading from the monad -- ** Reading from the monad
getHscEnv, getRuleBase, getModule, getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache, getPackageFamInstEnv, getDynFlags, getOrigNameCache, getPackageFamInstEnv,
getPrintUnqualified,
-- ** Writing to the monad -- ** Writing to the monad
addSimplCount, addSimplCount,
...@@ -43,7 +44,7 @@ module CoreMonad ( ...@@ -43,7 +44,7 @@ module CoreMonad (
getAnnotations, getFirstAnnotations, getAnnotations, getFirstAnnotations,
-- ** Debug output -- ** Debug output
showPass, endPass, dumpPassResult, lintPassResult, showPass, showPassIO, endPass, endPassIO, dumpPassResult, lintPassResult,
lintInteractiveExpr, dumpIfSet, lintInteractiveExpr, dumpIfSet,
-- ** Screen output -- ** Screen output
...@@ -132,15 +133,28 @@ be, and it makes a conveneint place. place for them. They print out ...@@ -132,15 +133,28 @@ be, and it makes a conveneint place. place for them. They print out
stuff before and after core passes, and do Core Lint when necessary. stuff before and after core passes, and do Core Lint when necessary.
\begin{code} \begin{code}
showPass :: DynFlags -> CoreToDo -> IO () showPass :: CoreToDo -> CoreM ()
showPass dflags pass = Err.showPass dflags (showPpr dflags pass) showPass pass = do { dflags <- getDynFlags
; liftIO $ showPassIO dflags pass }
endPass :: HscEnv -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPass hsc_env pass binds rules showPassIO :: DynFlags -> CoreToDo -> IO ()
= do { dumpPassResult dflags mb_flag (ppr pass) (pprPassDetails pass) binds rules showPassIO dflags pass = Err.showPass dflags (showPpr dflags pass)
endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()
endPass pass binds rules
= do { hsc_env <- getHscEnv
; print_unqual <- getPrintUnqualified
; liftIO $ endPassIO hsc_env print_unqual pass binds rules }
endPassIO :: HscEnv -> PrintUnqualified
-> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
-- Used by the IO-is CorePrep too
endPassIO hsc_env print_unqual pass binds rules
= do { dumpPassResult dflags print_unqual mb_flag
(ppr pass) (pprPassDetails pass) binds rules
; lintPassResult hsc_env pass binds } ; lintPassResult hsc_env pass binds }
where where
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
mb_flag = case coreDumpFlag pass of mb_flag = case coreDumpFlag pass of
Just flag | dopt flag dflags -> Just flag Just flag | dopt flag dflags -> Just flag
| dopt Opt_D_verbose_core2core dflags -> Just flag | dopt Opt_D_verbose_core2core dflags -> Just flag
...@@ -151,15 +165,16 @@ dumpIfSet dflags dump_me pass extra_info doc ...@@ -151,15 +165,16 @@ dumpIfSet dflags dump_me pass extra_info doc
= Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc
dumpPassResult :: DynFlags dumpPassResult :: DynFlags
-> Maybe DumpFlag -- Just df => show details in a file whose -> PrintUnqualified
-> Maybe DumpFlag -- Just df => show details in a file whose
-- name is specified by df -- name is specified by df
-> SDoc -- Header -> SDoc -- Header
-> SDoc -- Extra info to appear after header -> SDoc -- Extra info to appear after header
-> CoreProgram -> [CoreRule] -> CoreProgram -> [CoreRule]
-> IO () -> IO ()
dumpPassResult dflags mb_flag hdr extra_info binds rules dumpPassResult dflags unqual mb_flag hdr extra_info binds rules
| Just flag <- mb_flag | Just flag <- mb_flag
= Err.dumpSDoc dflags flag (showSDoc dflags hdr) dump_doc = Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc
| otherwise | otherwise
= Err.debugTraceMsg dflags 2 size_doc = Err.debugTraceMsg dflags 2 size_doc
...@@ -781,6 +796,7 @@ data CoreReader = CoreReader { ...@@ -781,6 +796,7 @@ data CoreReader = CoreReader {
cr_hsc_env :: HscEnv, cr_hsc_env :: HscEnv,
cr_rule_base :: RuleBase, cr_rule_base :: RuleBase,
cr_module :: Module, cr_module :: Module,
cr_print_unqual :: PrintUnqualified,
#ifdef GHCI #ifdef GHCI
cr_globals :: (MVar PersistentLinkerState, Bool) cr_globals :: (MVar PersistentLinkerState, Bool)
#else #else
...@@ -854,9 +870,10 @@ runCoreM :: HscEnv ...@@ -854,9 +870,10 @@ runCoreM :: HscEnv
-> RuleBase -> RuleBase
-> UniqSupply -> UniqSupply
-> Module -> Module
-> PrintUnqualified
-> CoreM a -> CoreM a
-> IO (a, SimplCount) -> IO (a, SimplCount)
runCoreM hsc_env rule_base us mod m = do runCoreM hsc_env rule_base us mod print_unqual m = do
glbls <- saveLinkerGlobals glbls <- saveLinkerGlobals
liftM extract $ runIOEnv (reader glbls) $ unCoreM m state liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
where where
...@@ -864,7 +881,8 @@ runCoreM hsc_env rule_base us mod m = do ...@@ -864,7 +881,8 @@ runCoreM hsc_env rule_base us mod m = do
cr_hsc_env = hsc_env, cr_hsc_env = hsc_env,
cr_rule_base = rule_base, cr_rule_base = rule_base,
cr_module = mod, cr_module = mod,
cr_globals = glbls cr_globals = glbls,
cr_print_unqual = print_unqual
} }
state = CoreState { state = CoreState {
cs_uniq_supply = us cs_uniq_supply = us
...@@ -934,6 +952,9 @@ getHscEnv = read cr_hsc_env ...@@ -934,6 +952,9 @@ getHscEnv = read cr_hsc_env
getRuleBase :: CoreM RuleBase getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base getRuleBase = read cr_rule_base
getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified = read cr_print_unqual
addSimplCount :: SimplCount -> CoreM () addSimplCount :: SimplCount -> CoreM ()
addSimplCount count = write (CoreWriter { cw_simpl_count = count }) addSimplCount count = write (CoreWriter { cw_simpl_count = count })
......
...@@ -76,9 +76,9 @@ core2core hsc_env guts ...@@ -76,9 +76,9 @@ core2core hsc_env guts
; let builtin_passes = getCoreToDo dflags ; let builtin_passes = getCoreToDo dflags
; ;
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
do { all_passes <- addPluginPasses dflags builtin_passes do { all_passes <- addPluginPasses dflags builtin_passes
; runCorePasses all_passes guts } ; runCorePasses all_passes guts }
{-- {--
; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline
...@@ -99,6 +99,7 @@ core2core hsc_env guts ...@@ -99,6 +99,7 @@ core2core hsc_env guts
-- consume the ModGuts to find the module) but somewhat ugly because mg_module may -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
-- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
-- would mean our cached value would go out of date. -- would mean our cached value would go out of date.
print_unqual = mkPrintUnqualified dflags (mg_rdr_env guts)
\end{code} \end{code}
...@@ -384,11 +385,9 @@ runCorePasses passes guts ...@@ -384,11 +385,9 @@ runCorePasses passes guts
do_pass guts CoreDoNothing = return guts do_pass guts CoreDoNothing = return guts
do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts
do_pass guts pass do_pass guts pass
= do { hsc_env <- getHscEnv = do { showPass pass
; let dflags = hsc_dflags hsc_env
; liftIO $ showPass dflags pass
; guts' <- doCorePass pass guts ; guts' <- doCorePass pass guts
; liftIO $ endPass hsc_env pass (mg_binds guts') (mg_rules guts') ; endPass pass (mg_binds guts') (mg_rules guts')
; return guts' } ; return guts' }
doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts
...@@ -596,6 +595,7 @@ simplifyPgmIO :: CoreToDo ...@@ -596,6 +595,7 @@ simplifyPgmIO :: CoreToDo
simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
hsc_env us hpt_rule_base hsc_env us hpt_rule_base
guts@(ModGuts { mg_module = this_mod guts@(ModGuts { mg_module = this_mod
, mg_rdr_env = rdr_env
, mg_binds = binds, mg_rules = rules , mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env }) , mg_fam_inst_env = fam_inst_env })
= do { (termination_msg, it_count, counts_out, guts') = do { (termination_msg, it_count, counts_out, guts')
...@@ -610,10 +610,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) ...@@ -610,10 +610,11 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
; return (counts_out, guts') ; return (counts_out, guts')
} }
where where
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
dump_phase = dumpSimplPhase dflags mode print_unqual = mkPrintUnqualified dflags rdr_env
simpl_env = mkSimplEnv mode dump_phase = dumpSimplPhase dflags mode
active_rule = activeRule simpl_env simpl_env = mkSimplEnv mode
active_rule = activeRule simpl_env
do_iteration :: UniqSupply do_iteration :: UniqSupply
-> Int -- Counts iterations -> Int -- Counts iterations
...@@ -709,7 +710,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) ...@@ -709,7 +710,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
-- Dump the result of this iteration -- Dump the result of this iteration
dump_end_iteration dflags iteration_no counts1 binds2 rules1 ; dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;
lintPassResult hsc_env pass binds2 ; lintPassResult hsc_env pass binds2 ;