2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 module SimplCore ( core2core, simplifyExpr ) where
9 #include "HsVersions.h"
11 import DynFlags ( CoreToDo(..), SimplifierSwitch(..),
12 SimplifierMode(..), DynFlags, DynFlag(..), dopt,
15 import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
16 Dependencies( dep_mods ),
18 import CSE ( cseProgram )
19 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
20 extendRuleBaseList, pprRuleBase, ruleCheckProgram,
21 addSpecInfo, addIdSpecialisations )
22 import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
23 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
24 import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
25 setWorkerInfo, workerInfo,
26 setInlinePragInfo, inlinePragInfo,
27 setSpecInfo, specInfo, specInfoRules )
28 import CoreUtils ( coreBindsSize )
29 import Simplify ( simplTopBinds, simplExpr )
30 import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
32 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
33 import CoreLint ( endPass )
34 import FloatIn ( floatInwards )
35 import FloatOut ( floatOutwards )
36 import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
37 idSpecialisation, idName )
40 import NameEnv ( lookupNameEnv )
41 import LiberateCase ( liberateCase )
42 import SAT ( doStaticArgs )
43 import Specialise ( specProgram)
44 import SpecConstr ( specConstrProgram)
45 import DmdAnal ( dmdAnalPgm )
46 import WorkWrap ( wwTopBinds )
48 import StrictAnal ( saBinds )
49 import CprAnalyse ( cprAnalyse )
52 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
53 import IO ( hPutStr, stderr )
55 import List ( partition )
56 import Maybes ( orElse )
59 %************************************************************************
61 \subsection{The driver for the simplifier}
63 %************************************************************************
70 core2core hsc_env guts
72 let dflags = hsc_dflags hsc_env
73 core_todos = getCoreToDo dflags
75 us <- mkSplitUniqSupply 's'
76 let (cp_us, ru_us) = splitUniqSupply us
78 -- COMPUTE THE RULE BASE TO USE
79 (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
82 (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
83 (zeroSimplCount dflags)
86 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
87 "Grand total simplifier statistics"
93 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
96 -- simplifyExpr is called by the driver to simplify an
97 -- expression typed in at the interactive prompt
98 simplifyExpr dflags expr
100 ; showPass dflags "Simplify"
102 ; us <- mkSplitUniqSupply 's'
104 ; let (expr', _counts) = initSmpl dflags us $
105 simplExprGently gentleSimplEnv expr
107 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
113 gentleSimplEnv :: SimplEnv
114 gentleSimplEnv = mkSimplEnv SimplGently
118 doCorePasses :: HscEnv
119 -> RuleBase -- the imported main rule base
120 -> UniqSupply -- uniques
121 -> SimplCount -- simplifier stats
122 -> ModGuts -- local binds in (with rules attached)
123 -> [CoreToDo] -- which passes to do
124 -> IO (SimplCount, ModGuts)
126 doCorePasses hsc_env rb us stats guts []
127 = return (stats, guts)
129 doCorePasses hsc_env rb us stats guts (to_do : to_dos)
131 let (us1, us2) = splitUniqSupply us
132 (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
133 doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
135 doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws
136 doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram
137 doCorePass CoreLiberateCase = _scc_ "LiberateCase" liberateCase
138 doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards
139 doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
140 doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds doStaticArgs
141 doCorePass CoreDoStrictness = _scc_ "Stranal" trBinds dmdAnalPgm
142 doCorePass CoreDoWorkerWrapper = _scc_ "WorkWrap" trBindsU wwTopBinds
143 doCorePass CoreDoSpecialising = _scc_ "Specialise" trBindsU specProgram
144 doCorePass CoreDoSpecConstr = _scc_ "SpecConstr" trBindsU specConstrProgram
145 doCorePass CoreDoGlomBinds = trBinds glomBinds
146 doCorePass CoreDoPrintCore = observe printCore
147 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
148 doCorePass CoreDoNothing = observe (\ _ _ -> return ())
149 #ifdef OLD_STRICTNESS
150 doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness
152 doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness"
155 #ifdef OLD_STRICTNESS
156 doOldStrictness dfs binds
157 = do binds1 <- saBinds dfs binds
158 binds2 <- cprAnalyse dfs binds1
162 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
164 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
165 printDump (ruleCheckProgram phase pat binds)
167 -- Most passes return no stats and don't change rules
168 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
169 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
170 -> IO (SimplCount, ModGuts)
171 trBinds do_pass hsc_env us rb guts
172 = do { binds' <- do_pass dflags (mg_binds guts)
173 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
175 dflags = hsc_dflags hsc_env
177 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
178 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
179 -> IO (SimplCount, ModGuts)
180 trBindsU do_pass hsc_env us rb guts
181 = do { binds' <- do_pass dflags us (mg_binds guts)
182 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
184 dflags = hsc_dflags hsc_env
186 -- Observer passes just peek; don't modify the bindings at all
187 observe :: (DynFlags -> [CoreBind] -> IO a)
188 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
189 -> IO (SimplCount, ModGuts)
190 observe do_pass hsc_env us rb guts
191 = do { binds <- do_pass dflags (mg_binds guts)
192 ; return (zeroSimplCount dflags, guts) }
194 dflags = hsc_dflags hsc_env
199 %************************************************************************
201 \subsection{Dealing with rules}
203 %************************************************************************
205 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
206 -- It attaches those rules that are for local Ids to their binders, and
207 -- returns the remainder attached to Ids in an IdSet.
210 prepareRules :: HscEnv
213 -> IO (RuleBase, -- Rule base for imported things, incl
214 -- (a) rules defined in this module (orphans)
215 -- (b) rules from other modules in home package
216 -- but not things from other packages
218 ModGuts) -- Modified fields are
219 -- (a) Bindings have rules attached,
220 -- (b) Rules are now just orphan rules
222 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
223 guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
225 = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
226 -- from the local binders, to avoid warnings from Simplify.simplVar
227 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
228 env = setInScopeSet gentleSimplEnv local_ids
229 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
230 home_pkg_rules = hptRules hsc_env (dep_mods deps)
232 -- Find the rules for locally-defined Ids; then we can attach them
233 -- to the binders in the top-level bindings
236 -- - It makes the rules easier to look up
237 -- - It means that transformation rules and specialisations for
238 -- locally defined Ids are handled uniformly
239 -- - It keeps alive things that are referred to only from a rule
240 -- (the occurrence analyser knows about rules attached to Ids)
241 -- - It makes sure that, when we apply a rule, the free vars
242 -- of the RHS are more likely to be in scope
243 -- - The imported rules are carried in the in-scope set
244 -- which is extended on each iteration by the new wave of
245 -- local binders; any rules which aren't on the binding will
246 -- thereby get dropped
247 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
248 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
249 binds_w_rules = updateBinders local_rule_base binds
251 hpt_rule_base = mkRuleBase home_pkg_rules
252 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
254 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
255 (vcat [text "Local rules", pprRules better_rules,
257 text "Imported rules", pprRuleBase imp_rule_base])
259 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
260 mg_rules = rules_for_imps })
263 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
264 updateBinders local_rules binds
265 = map update_bndrs binds
267 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
268 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
270 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
272 Just rules -> bndr `addIdSpecialisations` rules
273 -- The binder might have some existing rules,
274 -- arising from specialisation pragmas
278 We must do some gentle simplification on the template (but not the RHS)
279 of each rule. The case that forced me to add this was the fold/build rule,
280 which without simplification looked like:
281 fold k z (build (/\a. g a)) ==> ...
282 This doesn't match unless you do eta reduction on the build argument.
285 simplRule env rule@(BuiltinRule {})
287 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
288 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
289 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
290 simplExprGently env rhs `thenSmpl` \ rhs' ->
291 returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
293 -- It's important that simplExprGently does eta reduction.
294 -- For example, in a rule like:
295 -- augment g (build h)
296 -- we do not want to get
297 -- augment (\a. g a) (build h)
298 -- otherwise we don't match when given an argument like
301 -- The simplifier does indeed do eta reduction (it's in
302 -- Simplify.completeLam) but only if -O is on.
306 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
307 -- Simplifies an expression
308 -- does occurrence analysis, then simplification
309 -- and repeats (twice currently) because one pass
310 -- alone leaves tons of crud.
311 -- Used (a) for user expressions typed in at the interactive prompt
312 -- (b) the LHS and RHS of a RULE
314 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
315 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
316 -- enforce that; it just simplifies the expression twice
318 simplExprGently env expr
319 = simplExpr env (occurAnalyseExpr expr) `thenSmpl` \ expr1 ->
320 simplExpr env (occurAnalyseExpr expr1)
324 %************************************************************************
326 \subsection{Glomming}
328 %************************************************************************
331 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
332 -- Glom all binds together in one Rec, in case any
333 -- transformations have introduced any new dependencies
335 -- NB: the global invariant is this:
336 -- *** the top level bindings are never cloned, and are always unique ***
338 -- We sort them into dependency order, but applying transformation rules may
339 -- make something at the top refer to something at the bottom:
343 -- RULE: p (q x) = h x
345 -- Applying this rule makes f refer to h,
346 -- although it doesn't appear to in the source program.
347 -- This pass lets us control where it happens.
349 -- NOTICE that this cannot happen for rules whose head is a locally-defined
350 -- function. It only happens for rules whose head is an imported function
351 -- (p in the example above). So, for example, the rule had been
352 -- RULE: f (p x) = h x
353 -- then the rule for f would be attached to f itself (in its IdInfo)
354 -- by prepareLocalRuleBase and h would be regarded by the occurrency
355 -- analyser as free in f.
357 glomBinds dflags binds
358 = do { showPass dflags "GlomBinds" ;
359 let { recd_binds = [Rec (flattenBinds binds)] } ;
361 -- Not much point in printing the result...
362 -- just consumes output bandwidth
366 %************************************************************************
368 \subsection{The driver for the simplifier}
370 %************************************************************************
373 simplifyPgm :: SimplifierMode
374 -> [SimplifierSwitch]
379 -> IO (SimplCount, ModGuts) -- New bindings
381 simplifyPgm mode switches hsc_env us imp_rule_base guts
383 showPass dflags "Simplify";
385 (termination_msg, it_count, counts_out, binds')
386 <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
388 dumpIfSet (dopt Opt_D_verbose_core2core dflags
389 && dopt Opt_D_dump_simpl_stats dflags)
390 "Simplifier statistics"
391 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
393 pprSimplCount counts_out]);
395 endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
397 return (counts_out, guts { mg_binds = binds' })
400 dflags = hsc_dflags hsc_env
401 phase_info = case mode of
402 SimplGently -> "gentle"
403 SimplPhase n -> show n
405 sw_chkr = isAmongSimpl switches
406 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
408 do_iteration us iteration_no counts binds
409 -- iteration_no is the number of the iteration we are
410 -- about to begin, with '1' for the first
411 | iteration_no > max_iterations -- Stop if we've run out of iterations
414 if max_iterations > 2 then
415 hPutStr stderr ("NOTE: Simplifier still going after " ++
416 show max_iterations ++
417 " iterations; bailing out.\n")
421 -- Subtract 1 from iteration_no to get the
422 -- number of iterations we actually completed
423 return ("Simplifier baled out", iteration_no - 1, counts, binds)
426 -- Try and force thunks off the binds; significantly reduces
427 -- space usage, especially with -O. JRS, 000620.
428 | let sz = coreBindsSize binds in sz == sz
430 -- Occurrence analysis
431 let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ;
432 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
433 (pprCoreBindings tagged_binds);
435 -- Get any new rules, and extend the rule base
436 -- We need to do this regularly, because simplification can
437 -- poke on IdInfo thunks, which in turn brings in new rules
438 -- behind the scenes. Otherwise there's a danger we'll simply
439 -- miss the rules for Ids hidden inside imported inlinings
440 eps <- hscEPS hsc_env ;
441 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
442 ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
444 -- Simplify the program
445 -- We do this with a *case* not a *let* because lazy pattern
446 -- matching bit us with bad space leak!
447 -- With a let, we ended up with
452 -- case t of {(_,counts') -> if counts'=0 then ... }
453 -- So the conditional didn't force counts', because the
454 -- selection got duplicated. Sigh!
455 case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
456 (binds', counts') -> do {
458 let { all_counts = counts `plusSimplCount` counts'
459 ; herald = "Simplifier phase " ++ phase_info ++
460 ", iteration " ++ show iteration_no ++
461 " out of " ++ show max_iterations
464 -- Stop if nothing happened; don't dump output
465 if isZeroSimplCount counts' then
466 return ("Simplifier reached fixed point", iteration_no,
469 -- Short out indirections
470 -- We do this *after* at least one run of the simplifier
471 -- because indirection-shorting uses the export flag on *occurrences*
472 -- and that isn't guaranteed to be ok until after the first run propagates
473 -- stuff from the binding site to its occurrences
475 -- ToDo: alas, this means that indirection-shorting does not happen at all
476 -- if the simplifier does nothing (not common, I know, but unsavoury)
477 let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
479 -- Dump the result of this iteration
480 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
481 (pprSimplCount counts') ;
482 endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
485 do_iteration us2 (iteration_no + 1) all_counts binds''
488 (us1, us2) = splitUniqSupply us
492 %************************************************************************
494 Shorting out indirections
496 %************************************************************************
500 x_local = <expression>
504 where x_exported is exported, and x_local is not, then we replace it with this:
506 x_exported = <expression>
510 Without this we never get rid of the x_exported = x_local thing. This
511 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
512 makes strictness information propagate better. This used to happen in
513 the final phase, but it's tidier to do it here.
515 STRICTNESS: if we have done strictness analysis, we want the strictness info on
516 x_local to transfer to x_exported. Hence the copyIdInfo call.
518 RULES: we want to *add* any RULES for x_local to x_exported.
520 Note [Rules and indirection-zapping]
521 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
522 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
523 Then the things mentioned can be out of scope! Solution
524 a) Make sure that in this pass the usage-info from x_exported is
525 available for ...bindings...
526 b) If there are any such RULES, rec-ify the entire top-level.
527 It'll get sorted out next time round
531 The example that went bad on me at one stage was this one:
533 iterate :: (a -> a) -> a -> [a]
535 iterate = iterateList
537 iterateFB c f x = x `c` iterateFB c f (f x)
538 iterateList f x = x : iterateList f (f x)
542 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
543 "iterateFB" iterateFB (:) = iterateList
546 This got shorted out to:
548 iterateList :: (a -> a) -> a -> [a]
549 iterateList = iterate
551 iterateFB c f x = x `c` iterateFB c f (f x)
552 iterate f x = x : iterate f (f x)
555 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
556 "iterateFB" iterateFB (:) = iterate
559 And now we get an infinite loop in the rule system
560 iterate f x -> build (\cn -> iterateFB c f x)
564 Tiresome old solution:
565 don't do shorting out if f has rewrite rules (see shortableIdInfo)
567 New solution (I think):
568 use rule switching-off pragmas to get rid
569 of iterateList in the first place
574 If more than one exported thing is equal to a local thing (i.e., the
575 local thing really is shared), then we do one only:
578 x_exported1 = x_local
579 x_exported2 = x_local
583 x_exported2 = x_exported1
586 We rely on prior eta reduction to simplify things like
588 x_exported = /\ tyvars -> x_local tyvars
592 Hence,there's a possibility of leaving unchanged something like this:
595 x_exported1 = x_local Int
597 By the time we've thrown away the types in STG land this
598 could be eliminated. But I don't think it's very common
599 and it's dangerous to do this fiddling in STG land
600 because we might elminate a binding that's mentioned in the
601 unfolding for something.
604 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
606 shortOutIndirections :: [CoreBind] -> [CoreBind]
607 shortOutIndirections binds
608 | isEmptyVarEnv ind_env = binds
609 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
610 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
612 ind_env = makeIndEnv binds
613 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
614 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
615 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
616 binds' = concatMap zap binds
618 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
619 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
622 | bndr `elemVarSet` exp_id_set = []
623 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
625 | otherwise = [(bndr,rhs)]
627 makeIndEnv :: [CoreBind] -> IndEnv
629 = foldr add_bind emptyVarEnv binds
631 add_bind :: CoreBind -> IndEnv -> IndEnv
632 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
633 add_bind (Rec pairs) env = foldr add_pair env pairs
635 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
636 add_pair (exported_id, Var local_id) env
637 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
638 add_pair (exported_id, rhs) env
641 shortMeOut ind_env exported_id local_id
642 -- The if-then-else stuff is just so I can get a pprTrace to see
643 -- how often I don't get shorting out becuase of IdInfo stuff
644 = if isExportedId exported_id && -- Only if this is exported
646 isLocalId local_id && -- Only if this one is defined in this
647 -- module, so that we *can* change its
648 -- binding to be the exported thing!
650 not (isExportedId local_id) && -- Only if this one is not itself exported,
651 -- since the transformation will nuke it
653 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
658 if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
659 then True -- See note on "Messing up rules"
662 pprTrace "shortMeOut:" (ppr exported_id)
671 transferIdInfo :: Id -> Id -> Id
673 -- lcl_id = e; exp_id = lcl_id
674 -- and lcl_id has useful IdInfo, we don't want to discard it by going
675 -- gbl_id = e; lcl_id = gbl_id
676 -- Instead, transfer IdInfo from lcl_id to exp_id
677 -- Overwriting, rather than merging, seems to work ok.
678 transferIdInfo exported_id local_id
679 = modifyIdInfo transfer exported_id
681 local_info = idInfo local_id
682 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
683 `setWorkerInfo` workerInfo local_info
684 `setInlinePragInfo` inlinePragInfo local_info
685 `setSpecInfo` addSpecInfo (specInfo exp_info)
686 (specInfo local_info)