2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 module SimplCore ( core2core, simplifyExpr ) where
16 #include "HsVersions.h"
18 import DynFlags ( CoreToDo(..), SimplifierSwitch(..),
19 SimplifierMode(..), DynFlags, DynFlag(..), dopt,
20 getCoreToDo, shouldDumpSimplPhase )
23 import CSE ( cseProgram )
24 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
25 extendRuleBaseList, pprRuleBase, ruleCheckProgram,
26 addSpecInfo, addIdSpecialisations )
27 import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
28 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
29 import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
30 setWorkerInfo, workerInfo, setSpecInfoHead,
31 setInlinePragInfo, inlinePragInfo,
32 setSpecInfo, specInfo, specInfoRules )
33 import CoreUtils ( coreBindsSize )
34 import Simplify ( simplTopBinds, simplExpr )
35 import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
37 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
38 import CoreLint ( endPassIf, endIteration )
39 import FloatIn ( floatInwards )
40 import FloatOut ( floatOutwards )
44 import TyCon ( tyConSelIds, tyConDataCons )
45 import Class ( classSelIds )
48 import NameEnv ( lookupNameEnv )
49 import LiberateCase ( liberateCase )
50 import SAT ( doStaticArgs )
51 import Specialise ( specProgram)
52 import SpecConstr ( specConstrProgram)
53 import DmdAnal ( dmdAnalPgm )
54 import WorkWrap ( wwTopBinds )
56 import StrictAnal ( saBinds )
57 import CprAnalyse ( cprAnalyse )
59 import Vectorise ( vectorise )
61 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
62 import IO ( hPutStr, stderr )
64 import List ( partition, intersperse )
68 %************************************************************************
70 \subsection{The driver for the simplifier}
72 %************************************************************************
79 core2core hsc_env guts
81 ; let dflags = hsc_dflags hsc_env
82 core_todos = getCoreToDo dflags
84 ; us <- mkSplitUniqSupply 's'
85 ; let (cp_us, ru_us) = splitUniqSupply us
87 -- COMPUTE THE RULE BASE TO USE
88 ; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
90 -- Note [Injecting implicit bindings]
91 ; let implicit_binds = getImplicitBinds (mg_types guts1)
92 guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
95 ; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us
96 (zeroSimplCount dflags)
99 ; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
100 "Grand total simplifier statistics"
101 (pprSimplCount stats)
106 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
109 -- simplifyExpr is called by the driver to simplify an
110 -- expression typed in at the interactive prompt
111 simplifyExpr dflags expr
113 ; showPass dflags "Simplify"
115 ; us <- mkSplitUniqSupply 's'
117 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
118 simplExprGently gentleSimplEnv expr
120 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
126 gentleSimplEnv :: SimplEnv
127 gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
129 doCorePasses :: HscEnv
130 -> RuleBase -- the imported main rule base
131 -> UniqSupply -- uniques
132 -> SimplCount -- simplifier stats
133 -> ModGuts -- local binds in (with rules attached)
134 -> [CoreToDo] -- which passes to do
135 -> IO (SimplCount, ModGuts)
137 doCorePasses hsc_env rb us stats guts []
138 = return (stats, guts)
140 doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2)
141 = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2)
143 doCorePasses hsc_env rb us stats guts (to_do : to_dos)
145 let (us1, us2) = splitUniqSupply us
146 (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
147 doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
149 doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
150 -> ModGuts -> IO (SimplCount, ModGuts)
151 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} simplifyPgm mode sws
152 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} trBinds cseProgram
153 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} liberateCase
154 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} trBinds floatInwards
155 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
156 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBinds doStaticArgs
157 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} trBinds dmdAnalPgm
158 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU wwTopBinds
159 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram
160 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram
161 doCorePass CoreDoGlomBinds = trBinds glomBinds
162 doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} vectorise
163 doCorePass CoreDoPrintCore = observe printCore
164 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
165 doCorePass CoreDoNothing = observe (\ _ _ -> return ())
166 #ifdef OLD_STRICTNESS
167 doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
169 doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness"
171 doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
173 #ifdef OLD_STRICTNESS
174 doOldStrictness dfs binds
175 = do binds1 <- saBinds dfs binds
176 binds2 <- cprAnalyse dfs binds1
180 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
182 ruleCheck phase pat hsc_env us rb guts
183 = do let dflags = hsc_dflags hsc_env
184 showPass dflags "RuleCheck"
185 printDump (ruleCheckProgram phase pat rb (mg_binds guts))
186 return (zeroSimplCount dflags, guts)
188 -- Most passes return no stats and don't change rules
189 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
190 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
191 -> IO (SimplCount, ModGuts)
192 trBinds do_pass hsc_env us rb guts
193 = do { binds' <- do_pass dflags (mg_binds guts)
194 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
196 dflags = hsc_dflags hsc_env
198 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
199 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
200 -> IO (SimplCount, ModGuts)
201 trBindsU do_pass hsc_env us rb guts
202 = do { binds' <- do_pass dflags us (mg_binds guts)
203 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
205 dflags = hsc_dflags hsc_env
207 -- Observer passes just peek; don't modify the bindings at all
208 observe :: (DynFlags -> [CoreBind] -> IO a)
209 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
210 -> IO (SimplCount, ModGuts)
211 observe do_pass hsc_env us rb guts
212 = do { binds <- do_pass dflags (mg_binds guts)
213 ; return (zeroSimplCount dflags, guts) }
215 dflags = hsc_dflags hsc_env
219 %************************************************************************
223 %************************************************************************
225 Note [Injecting implicit bindings]
226 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
227 We used to inject the implict bindings right at the end, in CoreTidy.
228 But some of these bindings, notably record selectors, are not
229 constructed in an optimised form. E.g. record selector for
230 data T = MkT { x :: {-# UNPACK #-} !Int }
231 Then the unfolding looks like
232 x = \t. case t of MkT x1 -> let x = I# x1 in x
233 This generates bad code unless it's first simplified a bit.
234 (Only matters when the selector is used curried; eg map x ys.)
238 getImplicitBinds :: TypeEnv -> [CoreBind]
239 getImplicitBinds type_env
240 = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
241 ++ concatMap other_implicit_ids (typeEnvElts type_env))
242 -- Put the constructor wrappers first, because
243 -- other implicit bindings (notably the fromT functions arising
244 -- from generics) use the constructor wrappers. At least that's
245 -- what External Core likes
247 implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
249 other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
250 -- The "naughty" ones are not real functions at all
251 -- They are there just so we can get decent error messages
252 -- See Note [Naughty record selectors] in MkId.lhs
253 other_implicit_ids (AClass cl) = classSelIds cl
254 other_implicit_ids _other = []
256 get_defn :: Id -> CoreBind
257 get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
261 %************************************************************************
265 %************************************************************************
267 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
268 -- It attaches those rules that are for local Ids to their binders, and
269 -- returns the remainder attached to Ids in an IdSet.
272 prepareRules :: HscEnv
275 -> IO (RuleBase, -- Rule base for imported things, incl
276 -- (a) rules defined in this module (orphans)
277 -- (b) rules from other modules in home package
278 -- but not things from other packages
280 ModGuts) -- Modified fields are
281 -- (a) Bindings have rules attached,
282 -- (b) Rules are now just orphan rules
284 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
285 guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
287 = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
288 -- from the local binders, to avoid warnings from Simplify.simplVar
289 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
290 env = setInScopeSet gentleSimplEnv local_ids
291 (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
292 (mapM (simplRule env) local_rules)
293 home_pkg_rules = hptRules hsc_env (dep_mods deps)
295 -- Find the rules for locally-defined Ids; then we can attach them
296 -- to the binders in the top-level bindings
299 -- - It makes the rules easier to look up
300 -- - It means that transformation rules and specialisations for
301 -- locally defined Ids are handled uniformly
302 -- - It keeps alive things that are referred to only from a rule
303 -- (the occurrence analyser knows about rules attached to Ids)
304 -- - It makes sure that, when we apply a rule, the free vars
305 -- of the RHS are more likely to be in scope
306 -- - The imported rules are carried in the in-scope set
307 -- which is extended on each iteration by the new wave of
308 -- local binders; any rules which aren't on the binding will
309 -- thereby get dropped
310 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
311 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
312 binds_w_rules = updateBinders local_rule_base binds
314 hpt_rule_base = mkRuleBase home_pkg_rules
315 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
317 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
318 (vcat [text "Local rules", pprRules better_rules,
320 text "Imported rules", pprRuleBase imp_rule_base])
322 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
323 mg_rules = rules_for_imps })
326 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
327 updateBinders local_rules binds
328 = map update_bndrs binds
330 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
331 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
333 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
335 Just rules -> bndr `addIdSpecialisations` rules
336 -- The binder might have some existing rules,
337 -- arising from specialisation pragmas
341 We must do some gentle simplification on the template (but not the RHS)
342 of each rule. The case that forced me to add this was the fold/build rule,
343 which without simplification looked like:
344 fold k z (build (/\a. g a)) ==> ...
345 This doesn't match unless you do eta reduction on the build argument.
348 simplRule env rule@(BuiltinRule {})
350 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
351 = do (env, bndrs') <- simplBinders env bndrs
352 args' <- mapM (simplExprGently env) args
353 rhs' <- simplExprGently env rhs
354 return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
356 -- It's important that simplExprGently does eta reduction.
357 -- For example, in a rule like:
358 -- augment g (build h)
359 -- we do not want to get
360 -- augment (\a. g a) (build h)
361 -- otherwise we don't match when given an argument like
364 -- The simplifier does indeed do eta reduction (it's in
365 -- Simplify.completeLam) but only if -O is on.
369 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
370 -- Simplifies an expression
371 -- does occurrence analysis, then simplification
372 -- and repeats (twice currently) because one pass
373 -- alone leaves tons of crud.
374 -- Used (a) for user expressions typed in at the interactive prompt
375 -- (b) the LHS and RHS of a RULE
377 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
378 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
379 -- enforce that; it just simplifies the expression twice
381 simplExprGently env expr = do
382 expr1 <- simplExpr env (occurAnalyseExpr expr)
383 simplExpr env (occurAnalyseExpr expr1)
387 %************************************************************************
389 \subsection{Glomming}
391 %************************************************************************
394 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
395 -- Glom all binds together in one Rec, in case any
396 -- transformations have introduced any new dependencies
398 -- NB: the global invariant is this:
399 -- *** the top level bindings are never cloned, and are always unique ***
401 -- We sort them into dependency order, but applying transformation rules may
402 -- make something at the top refer to something at the bottom:
406 -- RULE: p (q x) = h x
408 -- Applying this rule makes f refer to h,
409 -- although it doesn't appear to in the source program.
410 -- This pass lets us control where it happens.
412 -- NOTICE that this cannot happen for rules whose head is a locally-defined
413 -- function. It only happens for rules whose head is an imported function
414 -- (p in the example above). So, for example, the rule had been
415 -- RULE: f (p x) = h x
416 -- then the rule for f would be attached to f itself (in its IdInfo)
417 -- by prepareLocalRuleBase and h would be regarded by the occurrency
418 -- analyser as free in f.
420 glomBinds dflags binds
421 = do { showPass dflags "GlomBinds" ;
422 let { recd_binds = [Rec (flattenBinds binds)] } ;
424 -- Not much point in printing the result...
425 -- just consumes output bandwidth
429 %************************************************************************
431 \subsection{The driver for the simplifier}
433 %************************************************************************
436 simplifyPgm :: SimplifierMode
437 -> [SimplifierSwitch]
442 -> IO (SimplCount, ModGuts) -- New bindings
444 simplifyPgm mode switches hsc_env us imp_rule_base guts
446 showPass dflags "Simplify";
448 (termination_msg, it_count, counts_out, binds')
449 <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
451 dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
452 "Simplifier statistics"
453 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
455 pprSimplCount counts_out]);
457 endPassIf dump_phase dflags
458 ("Simplify phase " ++ phase_info ++ " done")
459 Opt_D_dump_simpl_phases binds';
461 return (counts_out, guts { mg_binds = binds' })
464 dflags = hsc_dflags hsc_env
465 phase_info = case mode of
466 SimplGently -> "gentle"
467 SimplPhase n ss -> shows n
469 . showString (concat $ intersperse "," ss)
472 dump_phase = shouldDumpSimplPhase dflags mode
474 sw_chkr = isAmongSimpl switches
475 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
477 do_iteration us iteration_no counts binds
478 -- iteration_no is the number of the iteration we are
479 -- about to begin, with '1' for the first
480 | iteration_no > max_iterations -- Stop if we've run out of iterations
483 if max_iterations > 2 then
484 hPutStr stderr ("NOTE: Simplifier still going after " ++
485 show max_iterations ++
486 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" )
490 -- Subtract 1 from iteration_no to get the
491 -- number of iterations we actually completed
492 return ("Simplifier bailed out", iteration_no - 1, counts, binds)
495 -- Try and force thunks off the binds; significantly reduces
496 -- space usage, especially with -O. JRS, 000620.
497 | let sz = coreBindsSize binds in sz == sz
499 -- Occurrence analysis
500 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
501 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
502 (pprCoreBindings tagged_binds);
504 -- Get any new rules, and extend the rule base
505 -- We need to do this regularly, because simplification can
506 -- poke on IdInfo thunks, which in turn brings in new rules
507 -- behind the scenes. Otherwise there's a danger we'll simply
508 -- miss the rules for Ids hidden inside imported inlinings
509 eps <- hscEPS hsc_env ;
510 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
511 ; simpl_env = mkSimplEnv mode sw_chkr
512 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
513 simplTopBinds simpl_env tagged_binds
514 ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
516 -- Simplify the program
517 -- We do this with a *case* not a *let* because lazy pattern
518 -- matching bit us with bad space leak!
519 -- With a let, we ended up with
524 -- case t of {(_,counts') -> if counts'=0 then ... }
525 -- So the conditional didn't force counts', because the
526 -- selection got duplicated. Sigh!
527 case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
528 (binds', counts') -> do {
530 let { all_counts = counts `plusSimplCount` counts'
531 ; herald = "Simplifier phase " ++ phase_info ++
532 ", iteration " ++ show iteration_no ++
533 " out of " ++ show max_iterations
536 -- Stop if nothing happened; don't dump output
537 if isZeroSimplCount counts' then
538 return ("Simplifier reached fixed point", iteration_no,
541 -- Short out indirections
542 -- We do this *after* at least one run of the simplifier
543 -- because indirection-shorting uses the export flag on *occurrences*
544 -- and that isn't guaranteed to be ok until after the first run propagates
545 -- stuff from the binding site to its occurrences
547 -- ToDo: alas, this means that indirection-shorting does not happen at all
548 -- if the simplifier does nothing (not common, I know, but unsavoury)
549 let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
551 -- Dump the result of this iteration
552 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
553 (pprSimplCount counts') ;
554 endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
557 do_iteration us2 (iteration_no + 1) all_counts binds''
560 (us1, us2) = splitUniqSupply us
564 %************************************************************************
566 Shorting out indirections
568 %************************************************************************
572 x_local = <expression>
576 where x_exported is exported, and x_local is not, then we replace it with this:
578 x_exported = <expression>
582 Without this we never get rid of the x_exported = x_local thing. This
583 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
584 makes strictness information propagate better. This used to happen in
585 the final phase, but it's tidier to do it here.
587 STRICTNESS: if we have done strictness analysis, we want the strictness info on
588 x_local to transfer to x_exported. Hence the copyIdInfo call.
590 RULES: we want to *add* any RULES for x_local to x_exported.
592 Note [Rules and indirection-zapping]
593 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
594 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
595 Then the things mentioned can be out of scope! Solution
596 a) Make sure that in this pass the usage-info from x_exported is
597 available for ...bindings...
598 b) If there are any such RULES, rec-ify the entire top-level.
599 It'll get sorted out next time round
603 The example that went bad on me at one stage was this one:
605 iterate :: (a -> a) -> a -> [a]
607 iterate = iterateList
609 iterateFB c f x = x `c` iterateFB c f (f x)
610 iterateList f x = x : iterateList f (f x)
614 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
615 "iterateFB" iterateFB (:) = iterateList
618 This got shorted out to:
620 iterateList :: (a -> a) -> a -> [a]
621 iterateList = iterate
623 iterateFB c f x = x `c` iterateFB c f (f x)
624 iterate f x = x : iterate f (f x)
627 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
628 "iterateFB" iterateFB (:) = iterate
631 And now we get an infinite loop in the rule system
632 iterate f x -> build (\cn -> iterateFB c f x)
636 Tiresome old solution:
637 don't do shorting out if f has rewrite rules (see shortableIdInfo)
639 New solution (I think):
640 use rule switching-off pragmas to get rid
641 of iterateList in the first place
646 If more than one exported thing is equal to a local thing (i.e., the
647 local thing really is shared), then we do one only:
650 x_exported1 = x_local
651 x_exported2 = x_local
655 x_exported2 = x_exported1
658 We rely on prior eta reduction to simplify things like
660 x_exported = /\ tyvars -> x_local tyvars
664 Hence,there's a possibility of leaving unchanged something like this:
667 x_exported1 = x_local Int
669 By the time we've thrown away the types in STG land this
670 could be eliminated. But I don't think it's very common
671 and it's dangerous to do this fiddling in STG land
672 because we might elminate a binding that's mentioned in the
673 unfolding for something.
676 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
678 shortOutIndirections :: [CoreBind] -> [CoreBind]
679 shortOutIndirections binds
680 | isEmptyVarEnv ind_env = binds
681 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
682 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
684 ind_env = makeIndEnv binds
685 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
686 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
687 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
688 binds' = concatMap zap binds
690 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
691 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
694 | bndr `elemVarSet` exp_id_set = []
695 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
697 | otherwise = [(bndr,rhs)]
699 makeIndEnv :: [CoreBind] -> IndEnv
701 = foldr add_bind emptyVarEnv binds
703 add_bind :: CoreBind -> IndEnv -> IndEnv
704 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
705 add_bind (Rec pairs) env = foldr add_pair env pairs
707 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
708 add_pair (exported_id, Var local_id) env
709 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
710 add_pair (exported_id, rhs) env
713 shortMeOut ind_env exported_id local_id
714 -- The if-then-else stuff is just so I can get a pprTrace to see
715 -- how often I don't get shorting out becuase of IdInfo stuff
716 = if isExportedId exported_id && -- Only if this is exported
718 isLocalId local_id && -- Only if this one is defined in this
719 -- module, so that we *can* change its
720 -- binding to be the exported thing!
722 not (isExportedId local_id) && -- Only if this one is not itself exported,
723 -- since the transformation will nuke it
725 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
730 if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
731 then True -- See note on "Messing up rules"
734 pprTrace "shortMeOut:" (ppr exported_id)
743 transferIdInfo :: Id -> Id -> Id
745 -- lcl_id = e; exp_id = lcl_id
746 -- and lcl_id has useful IdInfo, we don't want to discard it by going
747 -- gbl_id = e; lcl_id = gbl_id
748 -- Instead, transfer IdInfo from lcl_id to exp_id
749 -- Overwriting, rather than merging, seems to work ok.
750 transferIdInfo exported_id local_id
751 = modifyIdInfo transfer exported_id
753 local_info = idInfo local_id
754 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
755 `setWorkerInfo` workerInfo local_info
756 `setInlinePragInfo` inlinePragInfo local_info
757 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
758 new_info = setSpecInfoHead (idName exported_id)
759 (specInfo local_info)
760 -- Remember to set the function-name field of the
761 -- rules as we transfer them from one function to another