getCoreToDo, dumpSimplPhase,
-- * Counting
- SimplCount, doSimplTick, doFreeSimplTick,
+ SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
pprSimplCount, plusSimplCount, zeroSimplCount, isZeroSimplCount, Tick(..),
-- * The monad
\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
type TickCounts = FiniteMap 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
= SimplCount {ticks = 0, details = emptyFM,
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
| 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,
hsc_env us hpt_rule_base
guts@(ModGuts { mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
- = do {
- (termination_msg, it_count, counts_out, guts')
- <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
+ = 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 (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,
- pprSimplCount counts_out]);
+ pprSimplCount counts_out])
- return (counts_out, guts')
+ ; return (counts_out, guts')
}
where
dflags = hsc_dflags hsc_env
dump_phase = dumpSimplPhase dflags mode
sw_chkr = isAmongSimpl switches
do_iteration :: UniqSupply
- -> Int -- Counts iterations
- -> SimplCount -- Logs optimisations performed
- -> [CoreBind] -- Bindings in
- -> [CoreRule] -- and orphan rules
+ -> Int -- Counts iterations
+ -> [SimplCount] -- Counts from earlier iterations, reversed
+ -> [CoreBind] -- Bindings in
+ -> [CoreRule] -- and orphan rules
-> IO (String, Int, SimplCount, ModGuts)
- do_iteration us iteration_no counts binds rules
+ do_iteration us iteration_no counts_so_far binds rules
-- iteration_no is the number of the iteration we are
-- about to begin, with '1' for the first
| iteration_no > max_iterations -- Stop if we've run out of iterations
- = WARN(debugIsOn && (max_iterations > 2),
- text ("Simplifier still going after " ++
- show max_iterations ++
- " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
+ = WARN( debugIsOn && (max_iterations > 2)
+ , ptext (sLit "Simplifier baling out after") <+> int max_iterations
+ <+> ptext (sLit "iterations")
+ <+> brackets (pprWithCommas (int . simplCountN) (reverse counts_so_far))
+ <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
+
-- Subtract 1 from iteration_no to get the
-- number of iterations we actually completed
- return ("Simplifier bailed out", iteration_no - 1, counts,
- guts { mg_binds = binds, mg_rules = rules })
+ return ("Simplifier baled out", iteration_no - 1, total_counts,
+ guts { mg_binds = binds, mg_rules = rules })
-- Try and force thunks off the binds; significantly reduces
-- space usage, especially with -O. JRS, 000620.
-- With a let, we ended up with
-- let
-- t = initSmpl ...
- -- counts' = snd t
+ -- counts1 = snd t
-- in
- -- case t of {(_,counts') -> if counts'=0 then ... }
- -- So the conditional didn't force counts', because the
+ -- case t of {(_,counts1) -> if counts1=0 then ... }
+ -- So the conditional didn't force counts1, because the
-- selection got duplicated. Sigh!
case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
(env1, counts1) -> do {
- let { all_counts = counts `plusSimplCount` counts1
- ; binds1 = getFloats env1
+ let { binds1 = getFloats env1
; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
} ;
-- Stop if nothing happened; don't dump output
if isZeroSimplCount counts1 then
- return ("Simplifier reached fixed point", iteration_no, all_counts,
+ return ("Simplifier reached fixed point", iteration_no, total_counts,
guts { mg_binds = binds1, mg_rules = rules1 })
else do {
-- Short out indirections
end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
-- Loop
- do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
+ do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
} } } }
where
- (us1, us2) = splitUniqSupply us
+ (us1, us2) = splitUniqSupply us
+
+ -- Remember the counts_so_far are reversed
+ total_counts = foldr (\c acc -> acc `plusSimplCount` c)
+ (zeroSimplCount dflags) counts_so_far
-------------------
end_iteration :: DynFlags -> CoreToDo -> Int
projects / ghc-hetmet.git / commitdiff