getCoreToDo, dumpSimplPhase,
-- * Counting
- SimplCount, doSimplTick, doFreeSimplTick,
+ SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
-- * The monad
getAnnotations, getFirstAnnotations,
-- ** Debug output
- endPass, endPassIf, endIteration,
+ showPass, endPass, endIteration, dumpIfSet,
-- ** Screen output
putMsg, putMsgS, errorMsg, errorMsgS,
fatalErrorMsg, fatalErrorMsgS,
debugTraceMsg, debugTraceMsgS,
- dumpIfSet_dyn,
+ dumpIfSet_dyn,
#ifdef GHCI
-- * Getting 'Name's
import Outputable
import FastString
import qualified ErrUtils as Err
+import Bag
import Maybes
import UniqSupply
-import LazyUniqFM ( UniqFM, mapUFM, filterUFM )
-import FiniteMap
+import UniqFM ( UniqFM, mapUFM, filterUFM )
+import MonadUtils
import Util ( split )
import Data.List ( intersperse )
import Data.Dynamic
import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
import Data.Word
import Control.Monad
stuff before and after core passes, and do Core Lint when necessary.
\begin{code}
-endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endPass = dumpAndLint Err.dumpIfSet_core
+showPass :: DynFlags -> CoreToDo -> IO ()
+showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass))
-endPassIf :: Bool -> DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endPassIf cond = dumpAndLint (Err.dumpIf_core cond)
+endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO ()
+endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass)
-- Same as endPass but doesn't dump Core even with -dverbose-core2core
-endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> [CoreRule] -> IO ()
-endIteration = dumpAndLint Err.dumpIfSet_dyn
+endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO ()
+endIteration dflags pass n
+ = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n)
+ (Just Opt_D_dump_simpl_iterations)
-dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
- -> DynFlags -> String -> DynFlag
+dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO ()
+dumpIfSet dump_me pass extra_info doc
+ = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc
+
+dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag
-> [CoreBind] -> [CoreRule] -> IO ()
-dumpAndLint dump dflags pass_name dump_flag binds rules
+-- The "show_all" parameter says to print dump if -dverbose-core2core is on
+dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules
= do { -- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
; Err.debugTraceMsg dflags 2 $
(text " Result size =" <+> int (coreBindsSize binds))
-- Report verbosely, if required
- ; dump dflags dump_flag pass_name
- (pprCoreBindings binds $$ ppUnless (null rules) pp_rules)
+ ; let pass_name = showSDoc (ppr pass <+> extra_info)
+ dump_doc = pprCoreBindings binds
+ $$ ppUnless (null rules) pp_rules
+
+ ; case mb_dump_flag of
+ Nothing -> return ()
+ Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc
+ where
+ dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core]
+ | otherwise = [dump_flag]
-- Type check
- ; lintCoreBindings dflags pass_name binds }
+ ; when (dopt Opt_DoCoreLinting dflags) $
+ do { let (warns, errs) = lintCoreBindings binds
+ ; Err.showPass dflags ("Core Linted result of " ++ pass_name)
+ ; displayLintResults dflags pass warns errs binds } }
where
pp_rules = vcat [ blankLine
, ptext (sLit "------ Local rules for imported ids --------")
, pprRules rules ]
+
+displayLintResults :: DynFlags -> CoreToDo
+ -> Bag Err.Message -> Bag Err.Message -> [CoreBind]
+ -> 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 ***") ])
+ ; Err.ghcExit dflags 1 }
+
+ | not (isEmptyBag warns)
+ , not (case pass of { CoreDesugar -> True; _ -> False })
+ -- Suppress warnings after desugaring pass because some
+ -- are legitimate. Notably, the desugarer generates instance
+ -- methods with INLINE pragmas that form a mutually recursive
+ -- group. Only afer a round of simplification are they unravelled.
+ , not opt_NoDebugOutput
+ , showLintWarnings pass
+ = printDump (banner "warnings" $$ Err.pprMessageBag warns)
+
+ | otherwise = return ()
+ where
+ banner string = ptext (sLit "*** Core Lint") <+> text string
+ <+> ptext (sLit ": in result of") <+> ppr pass
+ <+> ptext (sLit "***")
+
+showLintWarnings :: CoreToDo -> Bool
+-- Disable Lint warnings on the first simplifier pass, because
+-- there may be some INLINE knots still tied, which is tiresomely noisy
+showLintWarnings (CoreDoSimplify (SimplGently {}) _ _) = False
+showLintWarnings _ = True
\end{code}
= CoreDoSimplify -- The core-to-core simplifier.
SimplifierMode
- [SimplifierSwitch]
- -- Each run of the simplifier can take a different
- -- set of simplifier-specific flags.
+ Int -- Max iterations
+ [SimplifierSwitch] -- Each run of the simplifier can take a different
+ -- set of simplifier-specific flags.
| CoreDoFloatInwards
| CoreDoFloatOutwards FloatOutSwitches
| CoreLiberateCase
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoSpecConstr
- | CoreDoOldStrictness
| CoreDoGlomBinds
| CoreCSE
| CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules
| CoreDoNothing -- Useful when building up
| CoreDoPasses [CoreToDo] -- lists of these things
+ | CoreDesugar -- Not strictly a core-to-core pass, but produces
+ -- Core output, and hence useful to pass to endPass
+
+ | CoreTidy
+ | CorePrep
+
+coreDumpFlag :: CoreToDo -> Maybe DynFlag
+coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases
+coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core
+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core
+coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core
+coreDumpFlag CoreDoStrictness = Just Opt_D_dump_stranal
+coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper
+coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec
+coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec
+coreDumpFlag CoreCSE = Just Opt_D_dump_cse
+coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect
+coreDumpFlag CoreDesugar = Just Opt_D_dump_ds
+coreDumpFlag CoreTidy = Just Opt_D_dump_simpl
+coreDumpFlag CorePrep = Just Opt_D_dump_prep
+
+coreDumpFlag CoreDoPrintCore = Nothing
+coreDumpFlag (CoreDoRuleCheck {}) = Nothing
+coreDumpFlag CoreDoNothing = Nothing
+coreDumpFlag CoreDoGlomBinds = Nothing
+coreDumpFlag (CoreDoPasses {}) = Nothing
+
+instance Outputable CoreToDo where
+ ppr (CoreDoSimplify md n _) = ptext (sLit "Simplifier")
+ <+> ppr md
+ <+> ptext (sLit "max-iterations=") <> int n
+ ppr CoreDoFloatInwards = ptext (sLit "Float inwards")
+ ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f)
+ ppr CoreLiberateCase = ptext (sLit "Liberate case")
+ ppr CoreDoStaticArgs = ptext (sLit "Static argument")
+ ppr CoreDoStrictness = ptext (sLit "Demand analysis")
+ ppr CoreDoWorkerWrapper = ptext (sLit "Worker Wrapper binds")
+ ppr CoreDoSpecialising = ptext (sLit "Specialise")
+ ppr CoreDoSpecConstr = ptext (sLit "SpecConstr")
+ ppr CoreCSE = ptext (sLit "Common sub-expression")
+ ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation")
+ ppr CoreDesugar = ptext (sLit "Desugar")
+ ppr CoreTidy = ptext (sLit "Tidy Core")
+ ppr CorePrep = ptext (sLit "CorePrep")
+ ppr CoreDoPrintCore = ptext (sLit "Print core")
+ ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check")
+ ppr CoreDoGlomBinds = ptext (sLit "Glom binds")
+ ppr CoreDoNothing = ptext (sLit "CoreDoNothing")
+ ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses")
+\end{code}
+\begin{code}
data SimplifierMode -- See comments in SimplMonad
= SimplGently
{ sm_rules :: Bool -- Whether RULES are enabled
instance Outputable SimplifierMode where
ppr (SimplPhase { sm_num = n, sm_names = ss })
- = int n <+> brackets (text (concat $ intersperse "," ss))
+ = ptext (sLit "Phase") <+> int n <+> brackets (text (concat $ intersperse "," ss))
ppr (SimplGently { sm_rules = r, sm_inline = i })
= ptext (sLit "gentle") <>
brackets (pp_flag r (sLit "rules") <> comma <>
pp_flag f s = ppUnless f (ptext (sLit "no")) <+> ptext s
data SimplifierSwitch
- = MaxSimplifierIterations Int
- | NoCaseOfCase
+ = NoCaseOfCase
+\end{code}
+
+\begin{code}
data FloatOutSwitches = FloatOutSwitches {
floatOutLambdas :: Bool, -- ^ True <=> float lambdas to top level
- floatOutConstants :: Bool -- ^ True <=> float constants to top level,
+ floatOutConstants :: Bool, -- ^ True <=> float constants to top level,
-- even if they do not escape a lambda
+ floatOutPartialApplications :: Bool -- ^ True <=> float out partial applications
+ -- based on arity information.
}
-
instance Outputable FloatOutSwitches where
ppr = pprFloatOutSwitches
-- | Switches that specify the minimum amount of floating out
-- gentleFloatOutSwitches :: FloatOutSwitches
-- gentleFloatOutSwitches = FloatOutSwitches False False
-
--- | Switches that do not specify floating out of lambdas, just of constants
-constantsOnlyFloatOutSwitches :: FloatOutSwitches
-constantsOnlyFloatOutSwitches = FloatOutSwitches False True
\end{code}
simpl_phase phase names iter
= CoreDoPasses
- [ maybe_strictness_before phase,
- CoreDoSimplify (SimplPhase phase names) [
- MaxSimplifierIterations iter
- ],
- maybe_rule_check phase
+ [ maybe_strictness_before phase
+ , CoreDoSimplify (SimplPhase phase names)
+ iter []
+ , maybe_rule_check phase
]
vectorisation
-- initial simplify: mk specialiser happy: minimum effort please
simpl_gently = CoreDoSimplify
(SimplGently { sm_rules = True, sm_inline = False })
+ -- See Note [Gentle mode] and
+ -- Note [RULEs enabled in SimplGently] in SimplUtils
+ max_iter
[
- -- Simplify "gently"
- -- Don't inline anything till full laziness has bitten
- -- In particular, inlining wrappers inhibits floating
- -- e.g. ...(case f x of ...)...
- -- ==> ...(case (case x of I# x# -> fw x#) of ...)...
- -- ==> ...(case x of I# x# -> case fw x# of ...)...
- -- and now the redex (f x) isn't floatable any more
- -- Similarly, don't apply any rules until after full
- -- laziness. Notably, list fusion can prevent floating.
-
- NoCaseOfCase, -- Don't do case-of-case transformations.
+
+
+ NoCaseOfCase -- Don't do case-of-case transformations.
-- This makes full laziness work better
- MaxSimplifierIterations max_iter
]
core_todo =
-- so that overloaded functions have all their dictionary lambdas manifest
runWhen do_specialise CoreDoSpecialising,
- runWhen full_laziness (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
+ runWhen full_laziness $
+ CoreDoFloatOutwards FloatOutSwitches {
+ floatOutLambdas = False,
+ floatOutConstants = True,
+ floatOutPartialApplications = False },
-- Was: gentleFloatOutSwitches
- -- I have no idea why, but not floating constants to top level is
- -- very bad in some cases.
+ --
+ -- I have no idea why, but not floating constants to
+ -- top level is very bad in some cases.
+ --
-- Notably: p_ident in spectral/rewrite
- -- Changing from "gentle" to "constantsOnly" improved
- -- rewrite's allocation by 19%, and made 0.0% difference
- -- to any other nofib benchmark
+ -- Changing from "gentle" to "constantsOnly"
+ -- improved rewrite's allocation by 19%, and
+ -- made 0.0% difference to any other nofib
+ -- benchmark
+ --
+ -- Not doing floatOutPartialApplications yet, we'll do
+ -- that later on when we've had a chance to get more
+ -- accurate arity information. In fact it makes no
+ -- difference at all to performance if we do it here,
+ -- but maybe we save some unnecessary to-and-fro in
+ -- the simplifier.
runWhen do_float_in CoreDoFloatInwards,
simpl_phase 0 ["post-worker-wrapper"] max_iter
]),
- runWhen full_laziness
- (CoreDoFloatOutwards constantsOnlyFloatOutSwitches),
+ runWhen full_laziness $
+ CoreDoFloatOutwards FloatOutSwitches {
+ floatOutLambdas = False,
+ floatOutConstants = True,
+ floatOutPartialApplications = True },
-- nofib/spectral/hartel/wang doubles in speed if you
-- do full laziness late in the day. It only happens
-- after fusion and other stuff, so the early pass doesn't
\begin{code}
data SimplCount
- = VerySimplZero -- These two are used when
- | VerySimplNonZero -- we are only interested in
- -- termination info
+ = VerySimplCount !Int -- Used when don't want detailed stats
| SimplCount {
ticks :: !Int, -- Total ticks
-- recent history reasonably efficiently
}
-type TickCounts = FiniteMap Tick Int
+type TickCounts = Map Tick Int
+
+simplCountN :: SimplCount -> Int
+simplCountN (VerySimplCount n) = n
+simplCountN (SimplCount { ticks = n }) = n
zeroSimplCount dflags
-- This is where we decide whether to do
-- the VerySimpl version or the full-stats version
| dopt Opt_D_dump_simpl_stats dflags
- = SimplCount {ticks = 0, details = emptyFM,
+ = SimplCount {ticks = 0, details = Map.empty,
n_log = 0, log1 = [], log2 = []}
| otherwise
- = VerySimplZero
+ = VerySimplCount 0
-isZeroSimplCount VerySimplZero = True
-isZeroSimplCount (SimplCount { ticks = 0 }) = True
-isZeroSimplCount _ = False
+isZeroSimplCount (VerySimplCount n) = n==0
+isZeroSimplCount (SimplCount { ticks = n }) = n==0
doFreeSimplTick tick sc@SimplCount { details = dts }
= sc { details = dts `addTick` tick }
where
sc1 = sc { ticks = tks+1, details = dts `addTick` tick }
-doSimplTick _ _ = VerySimplNonZero -- The very simple case
+doSimplTick _ (VerySimplCount n) = VerySimplCount (n+1)
--- Don't use plusFM_C because that's lazy, and we want to
+-- Don't use Map.unionWith because that's lazy, and we want to
-- be pretty strict here!
addTick :: TickCounts -> Tick -> TickCounts
-addTick fm tick = case lookupFM fm tick of
- Nothing -> addToFM fm tick 1
- Just n -> n1 `seq` addToFM fm tick n1
+addTick fm tick = case Map.lookup tick fm of
+ Nothing -> Map.insert tick 1 fm
+ Just n -> n1 `seq` Map.insert tick n1 fm
where
n1 = n+1
plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })
sc2@(SimplCount { ticks = tks2, details = dts2 })
- = log_base { ticks = tks1 + tks2, details = plusFM_C (+) dts1 dts2 }
+ = log_base { ticks = tks1 + tks2, details = Map.unionWith (+) dts1 dts2 }
where
-- A hackish way of getting recent log info
log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2
| null (log2 sc2) = sc2 { log2 = log1 sc1 }
| otherwise = sc2
-plusSimplCount VerySimplZero VerySimplZero = VerySimplZero
-plusSimplCount _ _ = VerySimplNonZero
+plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)
+plusSimplCount _ _ = panic "plusSimplCount"
+ -- We use one or the other consistently
-pprSimplCount VerySimplZero = ptext (sLit "Total ticks: ZERO!")
-pprSimplCount VerySimplNonZero = ptext (sLit "Total ticks: NON-ZERO!")
+pprSimplCount (VerySimplCount n) = ptext (sLit "Total ticks:") <+> int n
pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
= vcat [ptext (sLit "Total ticks: ") <+> int tks,
blankLine,
- pprTickCounts (fmToList dts),
+ pprTickCounts (Map.toList dts),
if verboseSimplStats then
vcat [blankLine,
ptext (sLit "Log (most recent first)"),
projects / ghc-hetmet.git / blobdiff