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" trBinds 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
153 #ifdef OLD_STRICTNESS
154 doOldStrictness dfs binds
155 = do binds1 <- saBinds dfs binds
156 binds2 <- cprAnalyse dfs binds1
160 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
162 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
163 printDump (ruleCheckProgram phase pat binds)
165 -- Most passes return no stats and don't change rules
166 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
167 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
168 -> IO (SimplCount, ModGuts)
169 trBinds do_pass hsc_env us rb guts
170 = do { binds' <- do_pass dflags (mg_binds guts)
171 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
173 dflags = hsc_dflags hsc_env
175 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
176 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
177 -> IO (SimplCount, ModGuts)
178 trBindsU do_pass hsc_env us rb guts
179 = do { binds' <- do_pass dflags us (mg_binds guts)
180 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
182 dflags = hsc_dflags hsc_env
184 -- Observer passes just peek; don't modify the bindings at all
185 observe :: (DynFlags -> [CoreBind] -> IO a)
186 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
187 -> IO (SimplCount, ModGuts)
188 observe do_pass hsc_env us rb guts
189 = do { binds <- do_pass dflags (mg_binds guts)
190 ; return (zeroSimplCount dflags, guts) }
192 dflags = hsc_dflags hsc_env
197 %************************************************************************
199 \subsection{Dealing with rules}
201 %************************************************************************
203 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
204 -- It attaches those rules that are for local Ids to their binders, and
205 -- returns the remainder attached to Ids in an IdSet.
208 prepareRules :: HscEnv
211 -> IO (RuleBase, -- Rule base for imported things, incl
212 -- (a) rules defined in this module (orphans)
213 -- (b) rules from other modules in home package
214 -- but not things from other packages
216 ModGuts) -- Modified fields are
217 -- (a) Bindings have rules attached,
218 -- (b) Rules are now just orphan rules
220 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
221 guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
223 = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
224 -- from the local binders, to avoid warnings from Simplify.simplVar
225 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
226 env = setInScopeSet gentleSimplEnv local_ids
227 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
228 home_pkg_rules = hptRules hsc_env (dep_mods deps)
230 -- Find the rules for locally-defined Ids; then we can attach them
231 -- to the binders in the top-level bindings
234 -- - It makes the rules easier to look up
235 -- - It means that transformation rules and specialisations for
236 -- locally defined Ids are handled uniformly
237 -- - It keeps alive things that are referred to only from a rule
238 -- (the occurrence analyser knows about rules attached to Ids)
239 -- - It makes sure that, when we apply a rule, the free vars
240 -- of the RHS are more likely to be in scope
241 -- - The imported rules are carried in the in-scope set
242 -- which is extended on each iteration by the new wave of
243 -- local binders; any rules which aren't on the binding will
244 -- thereby get dropped
245 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
246 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
247 binds_w_rules = updateBinders local_rule_base binds
249 hpt_rule_base = mkRuleBase home_pkg_rules
250 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
252 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
253 (vcat [text "Local rules", pprRules better_rules,
255 text "Imported rules", pprRuleBase imp_rule_base])
257 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
258 mg_rules = rules_for_imps })
261 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
262 updateBinders local_rules binds
263 = map update_bndrs binds
265 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
266 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
268 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
270 Just rules -> bndr `addIdSpecialisations` rules
271 -- The binder might have some existing rules,
272 -- arising from specialisation pragmas
276 We must do some gentle simplification on the template (but not the RHS)
277 of each rule. The case that forced me to add this was the fold/build rule,
278 which without simplification looked like:
279 fold k z (build (/\a. g a)) ==> ...
280 This doesn't match unless you do eta reduction on the build argument.
283 simplRule env rule@(BuiltinRule {})
285 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
286 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
287 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
288 simplExprGently env rhs `thenSmpl` \ rhs' ->
289 returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
291 -- It's important that simplExprGently does eta reduction.
292 -- For example, in a rule like:
293 -- augment g (build h)
294 -- we do not want to get
295 -- augment (\a. g a) (build h)
296 -- otherwise we don't match when given an argument like
299 -- The simplifier does indeed do eta reduction (it's in
300 -- Simplify.completeLam) but only if -O is on.
304 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
305 -- Simplifies an expression
306 -- does occurrence analysis, then simplification
307 -- and repeats (twice currently) because one pass
308 -- alone leaves tons of crud.
309 -- Used (a) for user expressions typed in at the interactive prompt
310 -- (b) the LHS and RHS of a RULE
312 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
313 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
314 -- enforce that; it just simplifies the expression twice
316 simplExprGently env expr
317 = simplExpr env (occurAnalyseExpr expr) `thenSmpl` \ expr1 ->
318 simplExpr env (occurAnalyseExpr expr1)
322 %************************************************************************
324 \subsection{Glomming}
326 %************************************************************************
329 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
330 -- Glom all binds together in one Rec, in case any
331 -- transformations have introduced any new dependencies
333 -- NB: the global invariant is this:
334 -- *** the top level bindings are never cloned, and are always unique ***
336 -- We sort them into dependency order, but applying transformation rules may
337 -- make something at the top refer to something at the bottom:
341 -- RULE: p (q x) = h x
343 -- Applying this rule makes f refer to h,
344 -- although it doesn't appear to in the source program.
345 -- This pass lets us control where it happens.
347 -- NOTICE that this cannot happen for rules whose head is a locally-defined
348 -- function. It only happens for rules whose head is an imported function
349 -- (p in the example above). So, for example, the rule had been
350 -- RULE: f (p x) = h x
351 -- then the rule for f would be attached to f itself (in its IdInfo)
352 -- by prepareLocalRuleBase and h would be regarded by the occurrency
353 -- analyser as free in f.
355 glomBinds dflags binds
356 = do { showPass dflags "GlomBinds" ;
357 let { recd_binds = [Rec (flattenBinds binds)] } ;
359 -- Not much point in printing the result...
360 -- just consumes output bandwidth
364 %************************************************************************
366 \subsection{The driver for the simplifier}
368 %************************************************************************
371 simplifyPgm :: SimplifierMode
372 -> [SimplifierSwitch]
377 -> IO (SimplCount, ModGuts) -- New bindings
379 simplifyPgm mode switches hsc_env us imp_rule_base guts
381 showPass dflags "Simplify";
383 (termination_msg, it_count, counts_out, binds')
384 <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
386 dumpIfSet (dopt Opt_D_verbose_core2core dflags
387 && dopt Opt_D_dump_simpl_stats dflags)
388 "Simplifier statistics"
389 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
391 pprSimplCount counts_out]);
393 endPass dflags ("Simplify phase " ++ phase_info ++ " done") Opt_D_verbose_core2core binds';
395 return (counts_out, guts { mg_binds = binds' })
398 dflags = hsc_dflags hsc_env
399 phase_info = case mode of
400 SimplGently -> "gentle"
401 SimplPhase n -> show n
403 sw_chkr = isAmongSimpl switches
404 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
406 do_iteration us iteration_no counts binds
407 -- iteration_no is the number of the iteration we are
408 -- about to begin, with '1' for the first
409 | iteration_no > max_iterations -- Stop if we've run out of iterations
412 if max_iterations > 2 then
413 hPutStr stderr ("NOTE: Simplifier still going after " ++
414 show max_iterations ++
415 " iterations; bailing out.\n")
419 -- Subtract 1 from iteration_no to get the
420 -- number of iterations we actually completed
421 return ("Simplifier baled out", iteration_no - 1, counts, binds)
424 -- Try and force thunks off the binds; significantly reduces
425 -- space usage, especially with -O. JRS, 000620.
426 | let sz = coreBindsSize binds in sz == sz
428 -- Occurrence analysis
429 let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ;
430 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
431 (pprCoreBindings tagged_binds);
433 -- Get any new rules, and extend the rule base
434 -- We need to do this regularly, because simplification can
435 -- poke on IdInfo thunks, which in turn brings in new rules
436 -- behind the scenes. Otherwise there's a danger we'll simply
437 -- miss the rules for Ids hidden inside imported inlinings
438 eps <- hscEPS hsc_env ;
439 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
440 ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
442 -- Simplify the program
443 -- We do this with a *case* not a *let* because lazy pattern
444 -- matching bit us with bad space leak!
445 -- With a let, we ended up with
450 -- case t of {(_,counts') -> if counts'=0 then ... }
451 -- So the conditional didn't force counts', because the
452 -- selection got duplicated. Sigh!
453 case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
454 (binds', counts') -> do {
456 let { all_counts = counts `plusSimplCount` counts'
457 ; herald = "Simplifier phase " ++ phase_info ++
458 ", iteration " ++ show iteration_no ++
459 " out of " ++ show max_iterations
462 -- Stop if nothing happened; don't dump output
463 if isZeroSimplCount counts' then
464 return ("Simplifier reached fixed point", iteration_no,
467 -- Short out indirections
468 -- We do this *after* at least one run of the simplifier
469 -- because indirection-shorting uses the export flag on *occurrences*
470 -- and that isn't guaranteed to be ok until after the first run propagates
471 -- stuff from the binding site to its occurrences
473 -- ToDo: alas, this means that indirection-shorting does not happen at all
474 -- if the simplifier does nothing (not common, I know, but unsavoury)
475 let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
477 -- Dump the result of this iteration
478 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
479 (pprSimplCount counts') ;
480 endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
483 do_iteration us2 (iteration_no + 1) all_counts binds''
486 (us1, us2) = splitUniqSupply us
490 %************************************************************************
492 Shorting out indirections
494 %************************************************************************
498 x_local = <expression>
502 where x_exported is exported, and x_local is not, then we replace it with this:
504 x_exported = <expression>
508 Without this we never get rid of the x_exported = x_local thing. This
509 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
510 makes strictness information propagate better. This used to happen in
511 the final phase, but it's tidier to do it here.
513 STRICTNESS: if we have done strictness analysis, we want the strictness info on
514 x_local to transfer to x_exported. Hence the copyIdInfo call.
516 RULES: we want to *add* any RULES for x_local to x_exported.
518 Note [Rules and indirection-zapping]
519 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
520 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
521 Then the things mentioned can be out of scope! Solution
522 a) Make sure that in this pass the usage-info from x_exported is
523 available for ...bindings...
524 b) If there are any such RULES, rec-ify the entire top-level.
525 It'll get sorted out next time round
529 The example that went bad on me at one stage was this one:
531 iterate :: (a -> a) -> a -> [a]
533 iterate = iterateList
535 iterateFB c f x = x `c` iterateFB c f (f x)
536 iterateList f x = x : iterateList f (f x)
540 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
541 "iterateFB" iterateFB (:) = iterateList
544 This got shorted out to:
546 iterateList :: (a -> a) -> a -> [a]
547 iterateList = iterate
549 iterateFB c f x = x `c` iterateFB c f (f x)
550 iterate f x = x : iterate f (f x)
553 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
554 "iterateFB" iterateFB (:) = iterate
557 And now we get an infinite loop in the rule system
558 iterate f x -> build (\cn -> iterateFB c f x)
562 Tiresome old solution:
563 don't do shorting out if f has rewrite rules (see shortableIdInfo)
565 New solution (I think):
566 use rule switching-off pragmas to get rid
567 of iterateList in the first place
572 If more than one exported thing is equal to a local thing (i.e., the
573 local thing really is shared), then we do one only:
576 x_exported1 = x_local
577 x_exported2 = x_local
581 x_exported2 = x_exported1
584 We rely on prior eta reduction to simplify things like
586 x_exported = /\ tyvars -> x_local tyvars
590 Hence,there's a possibility of leaving unchanged something like this:
593 x_exported1 = x_local Int
595 By the time we've thrown away the types in STG land this
596 could be eliminated. But I don't think it's very common
597 and it's dangerous to do this fiddling in STG land
598 because we might elminate a binding that's mentioned in the
599 unfolding for something.
602 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
604 shortOutIndirections :: [CoreBind] -> [CoreBind]
605 shortOutIndirections binds
606 | isEmptyVarEnv ind_env = binds
607 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
608 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
610 ind_env = makeIndEnv binds
611 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
612 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
613 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
614 binds' = concatMap zap binds
616 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
617 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
620 | bndr `elemVarSet` exp_id_set = []
621 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
623 | otherwise = [(bndr,rhs)]
625 makeIndEnv :: [CoreBind] -> IndEnv
627 = foldr add_bind emptyVarEnv binds
629 add_bind :: CoreBind -> IndEnv -> IndEnv
630 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
631 add_bind (Rec pairs) env = foldr add_pair env pairs
633 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
634 add_pair (exported_id, Var local_id) env
635 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
636 add_pair (exported_id, rhs) env
639 shortMeOut ind_env exported_id local_id
640 -- The if-then-else stuff is just so I can get a pprTrace to see
641 -- how often I don't get shorting out becuase of IdInfo stuff
642 = if isExportedId exported_id && -- Only if this is exported
644 isLocalId local_id && -- Only if this one is defined in this
645 -- module, so that we *can* change its
646 -- binding to be the exported thing!
648 not (isExportedId local_id) && -- Only if this one is not itself exported,
649 -- since the transformation will nuke it
651 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
656 if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
657 then True -- See note on "Messing up rules"
660 pprTrace "shortMeOut:" (ppr exported_id)
669 transferIdInfo :: Id -> Id -> Id
671 -- lcl_id = e; exp_id = lcl_id
672 -- and lcl_id has useful IdInfo, we don't want to discard it by going
673 -- gbl_id = e; lcl_id = gbl_id
674 -- Instead, transfer IdInfo from lcl_id to exp_id
675 -- Overwriting, rather than merging, seems to work ok.
676 transferIdInfo exported_id local_id
677 = modifyIdInfo transfer exported_id
679 local_info = idInfo local_id
680 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
681 `setWorkerInfo` workerInfo local_info
682 `setInlinePragInfo` inlinePragInfo local_info
683 `setSpecInfo` addSpecInfo (specInfo exp_info)
684 (specInfo local_info)