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 setSpecInfo, specInfo, specInfoRules )
27 import CoreUtils ( coreBindsSize )
28 import Simplify ( simplTopBinds, simplExpr )
29 import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
31 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
32 import CoreLint ( endPass )
33 import FloatIn ( floatInwards )
34 import FloatOut ( floatOutwards )
35 import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId,
36 idSpecialisation, idName )
39 import NameEnv ( lookupNameEnv )
40 import LiberateCase ( liberateCase )
41 import SAT ( doStaticArgs )
42 import Specialise ( specProgram)
43 import SpecConstr ( specConstrProgram)
44 import DmdAnal ( dmdAnalPgm )
45 import WorkWrap ( wwTopBinds )
47 import StrictAnal ( saBinds )
48 import CprAnalyse ( cprAnalyse )
51 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
52 import IO ( hPutStr, stderr )
54 import List ( partition )
55 import Maybes ( orElse )
58 %************************************************************************
60 \subsection{The driver for the simplifier}
62 %************************************************************************
69 core2core hsc_env guts
71 let dflags = hsc_dflags hsc_env
72 core_todos = getCoreToDo dflags
74 us <- mkSplitUniqSupply 's'
75 let (cp_us, ru_us) = splitUniqSupply us
77 -- COMPUTE THE RULE BASE TO USE
78 (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
81 (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us
82 (zeroSimplCount dflags)
85 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
86 "Grand total simplifier statistics"
92 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
95 -- simplifyExpr is called by the driver to simplify an
96 -- expression typed in at the interactive prompt
97 simplifyExpr dflags expr
99 ; showPass dflags "Simplify"
101 ; us <- mkSplitUniqSupply 's'
103 ; let (expr', _counts) = initSmpl dflags us $
104 simplExprGently gentleSimplEnv expr
106 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
112 gentleSimplEnv :: SimplEnv
113 gentleSimplEnv = mkSimplEnv SimplGently
117 doCorePasses :: HscEnv
118 -> RuleBase -- the imported main rule base
119 -> UniqSupply -- uniques
120 -> SimplCount -- simplifier stats
121 -> ModGuts -- local binds in (with rules attached)
122 -> [CoreToDo] -- which passes to do
123 -> IO (SimplCount, ModGuts)
125 doCorePasses hsc_env rb us stats guts []
126 = return (stats, guts)
128 doCorePasses hsc_env rb us stats guts (to_do : to_dos)
130 let (us1, us2) = splitUniqSupply us
131 (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
132 doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
134 doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws
135 doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram
136 doCorePass CoreLiberateCase = _scc_ "LiberateCase" trBinds liberateCase
137 doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards
138 doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
139 doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds doStaticArgs
140 doCorePass CoreDoStrictness = _scc_ "Stranal" trBinds dmdAnalPgm
141 doCorePass CoreDoWorkerWrapper = _scc_ "WorkWrap" trBindsU wwTopBinds
142 doCorePass CoreDoSpecialising = _scc_ "Specialise" trBindsU specProgram
143 doCorePass CoreDoSpecConstr = _scc_ "SpecConstr" trBindsU specConstrProgram
144 doCorePass CoreDoGlomBinds = trBinds glomBinds
145 doCorePass CoreDoPrintCore = observe printCore
146 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
147 doCorePass CoreDoNothing = observe (\ _ _ -> return ())
148 #ifdef OLD_STRICTNESS
149 doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness
152 #ifdef OLD_STRICTNESS
153 doOldStrictness dfs binds
154 = do binds1 <- saBinds dfs binds
155 binds2 <- cprAnalyse dfs binds1
159 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
161 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
162 printDump (ruleCheckProgram phase pat binds)
164 -- Most passes return no stats and don't change rules
165 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
166 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
167 -> IO (SimplCount, ModGuts)
168 trBinds do_pass hsc_env us rb guts
169 = do { binds' <- do_pass dflags (mg_binds guts)
170 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
172 dflags = hsc_dflags hsc_env
174 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
175 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
176 -> IO (SimplCount, ModGuts)
177 trBindsU do_pass hsc_env us rb guts
178 = do { binds' <- do_pass dflags us (mg_binds guts)
179 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
181 dflags = hsc_dflags hsc_env
183 -- Observer passes just peek; don't modify the bindings at all
184 observe :: (DynFlags -> [CoreBind] -> IO a)
185 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
186 -> IO (SimplCount, ModGuts)
187 observe do_pass hsc_env us rb guts
188 = do { binds <- do_pass dflags (mg_binds guts)
189 ; return (zeroSimplCount dflags, guts) }
191 dflags = hsc_dflags hsc_env
196 %************************************************************************
198 \subsection{Dealing with rules}
200 %************************************************************************
202 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
203 -- It attaches those rules that are for local Ids to their binders, and
204 -- returns the remainder attached to Ids in an IdSet.
207 prepareRules :: HscEnv
210 -> IO (RuleBase, -- Rule base for imported things, incl
211 -- (a) rules defined in this module (orphans)
212 -- (b) rules from other modules in home package
213 -- but not things from other packages
215 ModGuts) -- Modified fields are
216 -- (a) Bindings have rules attached,
217 -- (b) Rules are now just orphan rules
219 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
220 guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
222 = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
223 -- from the local binders, to avoid warnings from Simplify.simplVar
224 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
225 env = setInScopeSet gentleSimplEnv local_ids
226 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
227 home_pkg_rules = hptRules hsc_env (dep_mods deps)
229 -- Find the rules for locally-defined Ids; then we can attach them
230 -- to the binders in the top-level bindings
233 -- - It makes the rules easier to look up
234 -- - It means that transformation rules and specialisations for
235 -- locally defined Ids are handled uniformly
236 -- - It keeps alive things that are referred to only from a rule
237 -- (the occurrence analyser knows about rules attached to Ids)
238 -- - It makes sure that, when we apply a rule, the free vars
239 -- of the RHS are more likely to be in scope
240 -- - The imported rules are carried in the in-scope set
241 -- which is extended on each iteration by the new wave of
242 -- local binders; any rules which aren't on the binding will
243 -- thereby get dropped
244 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
245 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
246 binds_w_rules = updateBinders local_rule_base binds
248 hpt_rule_base = mkRuleBase home_pkg_rules
249 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
251 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
252 (vcat [text "Local rules", pprRules better_rules,
254 text "Imported rules", pprRuleBase imp_rule_base])
256 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
257 mg_rules = rules_for_imps })
260 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
261 updateBinders local_rules binds
262 = map update_bndrs binds
264 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
265 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
267 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
269 Just rules -> bndr `addIdSpecialisations` rules
270 -- The binder might have some existing rules,
271 -- arising from specialisation pragmas
275 We must do some gentle simplification on the template (but not the RHS)
276 of each rule. The case that forced me to add this was the fold/build rule,
277 which without simplification looked like:
278 fold k z (build (/\a. g a)) ==> ...
279 This doesn't match unless you do eta reduction on the build argument.
282 simplRule env rule@(BuiltinRule {})
284 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
285 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
286 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
287 simplExprGently env rhs `thenSmpl` \ rhs' ->
288 returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
290 -- It's important that simplExprGently does eta reduction.
291 -- For example, in a rule like:
292 -- augment g (build h)
293 -- we do not want to get
294 -- augment (\a. g a) (build h)
295 -- otherwise we don't match when given an argument like
298 -- The simplifier does indeed do eta reduction (it's in
299 -- Simplify.completeLam) but only if -O is on.
303 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
304 -- Simplifies an expression
305 -- does occurrence analysis, then simplification
306 -- and repeats (twice currently) because one pass
307 -- alone leaves tons of crud.
308 -- Used (a) for user expressions typed in at the interactive prompt
309 -- (b) the LHS and RHS of a RULE
311 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
312 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
313 -- enforce that; it just simplifies the expression twice
315 simplExprGently env expr
316 = simplExpr env (occurAnalyseExpr expr) `thenSmpl` \ expr1 ->
317 simplExpr env (occurAnalyseExpr expr1)
321 %************************************************************************
323 \subsection{Glomming}
325 %************************************************************************
328 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
329 -- Glom all binds together in one Rec, in case any
330 -- transformations have introduced any new dependencies
332 -- NB: the global invariant is this:
333 -- *** the top level bindings are never cloned, and are always unique ***
335 -- We sort them into dependency order, but applying transformation rules may
336 -- make something at the top refer to something at the bottom:
340 -- RULE: p (q x) = h x
342 -- Applying this rule makes f refer to h,
343 -- although it doesn't appear to in the source program.
344 -- This pass lets us control where it happens.
346 -- NOTICE that this cannot happen for rules whose head is a locally-defined
347 -- function. It only happens for rules whose head is an imported function
348 -- (p in the example above). So, for example, the rule had been
349 -- RULE: f (p x) = h x
350 -- then the rule for f would be attached to f itself (in its IdInfo)
351 -- by prepareLocalRuleBase and h would be regarded by the occurrency
352 -- analyser as free in f.
354 glomBinds dflags binds
355 = do { showPass dflags "GlomBinds" ;
356 let { recd_binds = [Rec (flattenBinds binds)] } ;
358 -- Not much point in printing the result...
359 -- just consumes output bandwidth
363 %************************************************************************
365 \subsection{The driver for the simplifier}
367 %************************************************************************
370 simplifyPgm :: SimplifierMode
371 -> [SimplifierSwitch]
376 -> IO (SimplCount, ModGuts) -- New bindings
378 simplifyPgm mode switches hsc_env us imp_rule_base guts
380 showPass dflags "Simplify";
382 (termination_msg, it_count, counts_out, binds')
383 <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
385 dumpIfSet (dopt Opt_D_verbose_core2core dflags
386 && dopt Opt_D_dump_simpl_stats dflags)
387 "Simplifier statistics"
388 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
390 pprSimplCount counts_out]);
392 endPass dflags "Simplify" Opt_D_verbose_core2core binds';
394 return (counts_out, guts { mg_binds = binds' })
397 dflags = hsc_dflags hsc_env
398 phase_info = case mode of
399 SimplGently -> "gentle"
400 SimplPhase n -> show n
402 sw_chkr = isAmongSimpl switches
403 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
405 do_iteration us iteration_no counts binds
406 -- iteration_no is the number of the iteration we are
407 -- about to begin, with '1' for the first
408 | iteration_no > max_iterations -- Stop if we've run out of iterations
411 if max_iterations > 2 then
412 hPutStr stderr ("NOTE: Simplifier still going after " ++
413 show max_iterations ++
414 " iterations; bailing out.\n")
418 -- Subtract 1 from iteration_no to get the
419 -- number of iterations we actually completed
420 return ("Simplifier baled out", iteration_no - 1, counts, binds)
423 -- Try and force thunks off the binds; significantly reduces
424 -- space usage, especially with -O. JRS, 000620.
425 | let sz = coreBindsSize binds in sz == sz
427 -- Occurrence analysis
428 let { tagged_binds = _scc_ "OccAnal" occurAnalysePgm binds } ;
429 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
430 (pprCoreBindings tagged_binds);
432 -- Get any new rules, and extend the rule base
433 -- We need to do this regularly, because simplification can
434 -- poke on IdInfo thunks, which in turn brings in new rules
435 -- behind the scenes. Otherwise there's a danger we'll simply
436 -- miss the rules for Ids hidden inside imported inlinings
437 eps <- hscEPS hsc_env ;
438 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
439 ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
441 -- Simplify the program
442 -- We do this with a *case* not a *let* because lazy pattern
443 -- matching bit us with bad space leak!
444 -- With a let, we ended up with
449 -- case t of {(_,counts') -> if counts'=0 then ... }
450 -- So the conditional didn't force counts', because the
451 -- selection got duplicated. Sigh!
452 case initSmpl dflags us1 (_scc_ "SimplTopBinds" simplTopBinds simpl_env tagged_binds) of {
453 (binds', counts') -> do {
455 let { all_counts = counts `plusSimplCount` counts'
456 ; herald = "Simplifier phase " ++ phase_info ++
457 ", iteration " ++ show iteration_no ++
458 " out of " ++ show max_iterations
461 -- Stop if nothing happened; don't dump output
462 if isZeroSimplCount counts' then
463 return ("Simplifier reached fixed point", iteration_no,
466 -- Short out indirections
467 -- We do this *after* at least one run of the simplifier
468 -- because indirection-shorting uses the export flag on *occurrences*
469 -- and that isn't guaranteed to be ok until after the first run propagates
470 -- stuff from the binding site to its occurrences
471 let { binds'' = _scc_ "ZapInd" shortOutIndirections binds' } ;
473 -- Dump the result of this iteration
474 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
475 (pprSimplCount counts') ;
476 endPass dflags herald Opt_D_dump_simpl_iterations binds'' ;
479 do_iteration us2 (iteration_no + 1) all_counts binds''
482 (us1, us2) = splitUniqSupply us
486 %************************************************************************
488 Shorting out indirections
490 %************************************************************************
494 x_local = <expression>
498 where x_exported is exported, and x_local is not, then we replace it with this:
500 x_exported = <expression>
504 Without this we never get rid of the x_exported = x_local thing. This
505 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
506 makes strictness information propagate better. This used to happen in
507 the final phase, but it's tidier to do it here.
509 STRICTNESS: if we have done strictness analysis, we want the strictness info on
510 x_local to transfer to x_exported. Hence the copyIdInfo call.
512 RULES: we want to *add* any RULES for x_local to x_exported.
514 Note [Rules and indirection-zapping]
515 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
516 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
517 Then the things mentioned can be out of scope! Solution
518 a) Make sure that in this pass the usage-info from x_exported is
519 available for ...bindings...
520 b) If there are any such RULES, rec-ify the entire top-level.
521 It'll get sorted out next time round
525 The example that went bad on me at one stage was this one:
527 iterate :: (a -> a) -> a -> [a]
529 iterate = iterateList
531 iterateFB c f x = x `c` iterateFB c f (f x)
532 iterateList f x = x : iterateList f (f x)
536 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
537 "iterateFB" iterateFB (:) = iterateList
540 This got shorted out to:
542 iterateList :: (a -> a) -> a -> [a]
543 iterateList = iterate
545 iterateFB c f x = x `c` iterateFB c f (f x)
546 iterate f x = x : iterate f (f x)
549 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
550 "iterateFB" iterateFB (:) = iterate
553 And now we get an infinite loop in the rule system
554 iterate f x -> build (\cn -> iterateFB c f x)
558 Tiresome old solution:
559 don't do shorting out if f has rewrite rules (see shortableIdInfo)
561 New solution (I think):
562 use rule switching-off pragmas to get rid
563 of iterateList in the first place
568 If more than one exported thing is equal to a local thing (i.e., the
569 local thing really is shared), then we do one only:
572 x_exported1 = x_local
573 x_exported2 = x_local
577 x_exported2 = x_exported1
580 We rely on prior eta reduction to simplify things like
582 x_exported = /\ tyvars -> x_local tyvars
586 Hence,there's a possibility of leaving unchanged something like this:
589 x_exported1 = x_local Int
591 By the time we've thrown away the types in STG land this
592 could be eliminated. But I don't think it's very common
593 and it's dangerous to do this fiddling in STG land
594 because we might elminate a binding that's mentioned in the
595 unfolding for something.
598 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
600 shortOutIndirections :: [CoreBind] -> [CoreBind]
601 shortOutIndirections binds
602 | isEmptyVarEnv ind_env = binds
603 | no_need_to_flatten = binds'
604 | otherwise = [Rec (flattenBinds binds')] -- See Note [Rules and indirect-zapping]
606 ind_env = makeIndEnv binds
607 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
608 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
609 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
610 binds' = concatMap zap binds
612 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
613 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
616 | bndr `elemVarSet` exp_id_set = []
617 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
619 | otherwise = [(bndr,rhs)]
621 makeIndEnv :: [CoreBind] -> IndEnv
623 = foldr add_bind emptyVarEnv binds
625 add_bind :: CoreBind -> IndEnv -> IndEnv
626 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
627 add_bind (Rec pairs) env = foldr add_pair env pairs
629 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
630 add_pair (exported_id, Var local_id) env
631 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
632 add_pair (exported_id, rhs) env
635 shortMeOut ind_env exported_id local_id
636 -- The if-then-else stuff is just so I can get a pprTrace to see
637 -- how often I don't get shorting out becuase of IdInfo stuff
638 = if isExportedId exported_id && -- Only if this is exported
640 isLocalId local_id && -- Only if this one is defined in this
641 -- module, so that we *can* change its
642 -- binding to be the exported thing!
644 not (isExportedId local_id) && -- Only if this one is not itself exported,
645 -- since the transformation will nuke it
647 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
652 if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
653 then True -- See note on "Messing up rules"
656 pprTrace "shortMeOut:" (ppr exported_id)
665 transferIdInfo :: Id -> Id -> Id
666 transferIdInfo exported_id local_id
667 = modifyIdInfo transfer exported_id
669 local_info = idInfo local_id
670 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
671 `setWorkerInfo` workerInfo local_info
672 `setSpecInfo` addSpecInfo (specInfo exp_info)
673 (specInfo local_info)