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 )
62 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
63 import IO ( hPutStr, stderr )
66 import List ( partition, intersperse )
70 %************************************************************************
72 \subsection{The driver for the simplifier}
74 %************************************************************************
81 core2core hsc_env guts
83 ; let dflags = hsc_dflags hsc_env
84 core_todos = getCoreToDo dflags
86 ; us <- mkSplitUniqSupply 's'
87 ; let (cp_us, ru_us) = splitUniqSupply us
89 -- COMPUTE THE RULE BASE TO USE
90 ; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
92 -- Note [Injecting implicit bindings]
93 ; let implicit_binds = getImplicitBinds (mg_types guts1)
94 guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
97 ; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us
98 (zeroSimplCount dflags)
101 ; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
102 "Grand total simplifier statistics"
103 (pprSimplCount stats)
108 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
111 -- simplifyExpr is called by the driver to simplify an
112 -- expression typed in at the interactive prompt
113 simplifyExpr dflags expr
115 ; showPass dflags "Simplify"
117 ; us <- mkSplitUniqSupply 's'
119 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
120 simplExprGently gentleSimplEnv expr
122 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
128 gentleSimplEnv :: SimplEnv
129 gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
131 doCorePasses :: HscEnv
132 -> RuleBase -- the imported main rule base
133 -> UniqSupply -- uniques
134 -> SimplCount -- simplifier stats
135 -> ModGuts -- local binds in (with rules attached)
136 -> [CoreToDo] -- which passes to do
137 -> IO (SimplCount, ModGuts)
139 doCorePasses hsc_env rb us stats guts []
140 = return (stats, guts)
142 doCorePasses hsc_env rb us stats guts (CoreDoPasses to_dos1 : to_dos2)
143 = doCorePasses hsc_env rb us stats guts (to_dos1 ++ to_dos2)
145 doCorePasses hsc_env rb us stats guts (to_do : to_dos)
147 let (us1, us2) = splitUniqSupply us
148 (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts
149 doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos
151 doCorePass :: CoreToDo -> HscEnv -> UniqSupply -> RuleBase
152 -> ModGuts -> IO (SimplCount, ModGuts)
153 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-} simplifyPgm mode sws
154 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} trBinds cseProgram
155 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} liberateCase
156 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} trBinds floatInwards
157 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} trBindsU (floatOutwards f)
158 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} trBindsU doStaticArgs
159 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-} trBinds dmdAnalPgm
160 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} trBindsU wwTopBinds
161 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} trBindsU specProgram
162 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} trBindsU specConstrProgram
163 doCorePass CoreDoGlomBinds = trBinds glomBinds
164 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} vectorise be
165 doCorePass CoreDoPrintCore = observe printCore
166 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
167 doCorePass CoreDoNothing = observe (\ _ _ -> return ())
168 #ifdef OLD_STRICTNESS
169 doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} trBinds doOldStrictness
171 doCorePass CoreDoOldStrictness = panic "CoreDoOldStrictness"
173 doCorePass (CoreDoPasses _) = panic "CoreDoPasses"
175 #ifdef OLD_STRICTNESS
176 doOldStrictness dfs binds
177 = do binds1 <- saBinds dfs binds
178 binds2 <- cprAnalyse dfs binds1
182 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
184 ruleCheck phase pat hsc_env us rb guts
185 = do let dflags = hsc_dflags hsc_env
186 showPass dflags "RuleCheck"
187 printDump (ruleCheckProgram phase pat rb (mg_binds guts))
188 return (zeroSimplCount dflags, guts)
190 -- Most passes return no stats and don't change rules
191 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
192 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
193 -> IO (SimplCount, ModGuts)
194 trBinds do_pass hsc_env us rb guts
195 = do { binds' <- do_pass dflags (mg_binds guts)
196 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
198 dflags = hsc_dflags hsc_env
200 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
201 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
202 -> IO (SimplCount, ModGuts)
203 trBindsU do_pass hsc_env us rb guts
204 = do { binds' <- do_pass dflags us (mg_binds guts)
205 ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) }
207 dflags = hsc_dflags hsc_env
209 -- Observer passes just peek; don't modify the bindings at all
210 observe :: (DynFlags -> [CoreBind] -> IO a)
211 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
212 -> IO (SimplCount, ModGuts)
213 observe do_pass hsc_env us rb guts
214 = do { binds <- do_pass dflags (mg_binds guts)
215 ; return (zeroSimplCount dflags, guts) }
217 dflags = hsc_dflags hsc_env
221 %************************************************************************
225 %************************************************************************
227 Note [Injecting implicit bindings]
228 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
229 We used to inject the implict bindings right at the end, in CoreTidy.
230 But some of these bindings, notably record selectors, are not
231 constructed in an optimised form. E.g. record selector for
232 data T = MkT { x :: {-# UNPACK #-} !Int }
233 Then the unfolding looks like
234 x = \t. case t of MkT x1 -> let x = I# x1 in x
235 This generates bad code unless it's first simplified a bit.
236 (Only matters when the selector is used curried; eg map x ys.)
240 getImplicitBinds :: TypeEnv -> [CoreBind]
241 getImplicitBinds type_env
242 = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
243 ++ concatMap other_implicit_ids (typeEnvElts type_env))
244 -- Put the constructor wrappers first, because
245 -- other implicit bindings (notably the fromT functions arising
246 -- from generics) use the constructor wrappers. At least that's
247 -- what External Core likes
249 implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
251 other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
252 -- The "naughty" ones are not real functions at all
253 -- They are there just so we can get decent error messages
254 -- See Note [Naughty record selectors] in MkId.lhs
255 other_implicit_ids (AClass cl) = classSelIds cl
256 other_implicit_ids _other = []
258 get_defn :: Id -> CoreBind
259 get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
263 %************************************************************************
267 %************************************************************************
269 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
270 -- It attaches those rules that are for local Ids to their binders, and
271 -- returns the remainder attached to Ids in an IdSet.
274 prepareRules :: HscEnv
277 -> IO (RuleBase, -- Rule base for imported things, incl
278 -- (a) rules defined in this module (orphans)
279 -- (b) rules from other modules in home package
280 -- but not things from other packages
282 ModGuts) -- Modified fields are
283 -- (a) Bindings have rules attached,
284 -- (b) Rules are now just orphan rules
286 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
287 guts@(ModGuts { mg_binds = binds, mg_deps = deps
288 , mg_rules = local_rules, mg_rdr_env = rdr_env })
290 = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
291 -- from the local binders, to avoid warnings from Simplify.simplVar
292 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
293 env = setInScopeSet gentleSimplEnv local_ids
294 (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
295 (mapM (simplRule env) local_rules)
296 home_pkg_rules = hptRules hsc_env (dep_mods deps)
298 -- Find the rules for locally-defined Ids; then we can attach them
299 -- to the binders in the top-level bindings
302 -- - It makes the rules easier to look up
303 -- - It means that transformation rules and specialisations for
304 -- locally defined Ids are handled uniformly
305 -- - It keeps alive things that are referred to only from a rule
306 -- (the occurrence analyser knows about rules attached to Ids)
307 -- - It makes sure that, when we apply a rule, the free vars
308 -- of the RHS are more likely to be in scope
309 -- - The imported rules are carried in the in-scope set
310 -- which is extended on each iteration by the new wave of
311 -- local binders; any rules which aren't on the binding will
312 -- thereby get dropped
313 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
314 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
315 binds_w_rules = updateBinders local_rule_base binds
317 hpt_rule_base = mkRuleBase home_pkg_rules
318 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
320 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
321 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
322 vcat [text "Local rules", pprRules better_rules,
324 text "Imported rules", pprRuleBase imp_rule_base])
326 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
327 mg_rules = rules_for_imps })
330 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
331 updateBinders local_rules binds
332 = map update_bndrs binds
334 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
335 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
337 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
339 Just rules -> bndr `addIdSpecialisations` rules
340 -- The binder might have some existing rules,
341 -- arising from specialisation pragmas
344 Note [Simplifying the left-hand side of a RULE]
345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
346 We must do some gentle simplification on the lhs (template) of each
347 rule. The case that forced me to add this was the fold/build rule,
348 which without simplification looked like:
349 fold k z (build (/\a. g a)) ==> ...
350 This doesn't match unless you do eta reduction on the build argument.
351 Similarly for a LHS like
353 we do not want to get
354 augment (\a. g a) (build h)
355 otherwise we don't match when given an argument like
356 augment (\a. h a a) (build h)
359 simplRule env rule@(BuiltinRule {})
361 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
362 = do (env, bndrs') <- simplBinders env bndrs
363 args' <- mapM (simplExprGently env) args
364 rhs' <- simplExprGently env rhs
365 return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
367 -- It's important that simplExprGently does eta reduction.
368 -- For example, in a rule like:
369 -- augment g (build h)
370 -- we do not want to get
371 -- augment (\a. g a) (build h)
372 -- otherwise we don't match when given an argument like
375 -- The simplifier does indeed do eta reduction (it's in
376 -- Simplify.completeLam) but only if -O is on.
380 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
381 -- Simplifies an expression
382 -- does occurrence analysis, then simplification
383 -- and repeats (twice currently) because one pass
384 -- alone leaves tons of crud.
385 -- Used (a) for user expressions typed in at the interactive prompt
386 -- (b) the LHS and RHS of a RULE
387 -- (c) Template Haskell splices
389 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
390 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
391 -- enforce that; it just simplifies the expression twice
393 -- It's important that simplExprGently does eta reduction; see
394 -- Note [Simplifying the left-hand side of a RULE] above. The
395 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
396 -- but only if -O is on.
398 simplExprGently env expr = do
399 expr1 <- simplExpr env (occurAnalyseExpr expr)
400 simplExpr env (occurAnalyseExpr expr1)
404 %************************************************************************
406 \subsection{Glomming}
408 %************************************************************************
411 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
412 -- Glom all binds together in one Rec, in case any
413 -- transformations have introduced any new dependencies
415 -- NB: the global invariant is this:
416 -- *** the top level bindings are never cloned, and are always unique ***
418 -- We sort them into dependency order, but applying transformation rules may
419 -- make something at the top refer to something at the bottom:
423 -- RULE: p (q x) = h x
425 -- Applying this rule makes f refer to h,
426 -- although it doesn't appear to in the source program.
427 -- This pass lets us control where it happens.
429 -- NOTICE that this cannot happen for rules whose head is a locally-defined
430 -- function. It only happens for rules whose head is an imported function
431 -- (p in the example above). So, for example, the rule had been
432 -- RULE: f (p x) = h x
433 -- then the rule for f would be attached to f itself (in its IdInfo)
434 -- by prepareLocalRuleBase and h would be regarded by the occurrency
435 -- analyser as free in f.
437 glomBinds dflags binds
438 = do { showPass dflags "GlomBinds" ;
439 let { recd_binds = [Rec (flattenBinds binds)] } ;
441 -- Not much point in printing the result...
442 -- just consumes output bandwidth
446 %************************************************************************
448 \subsection{The driver for the simplifier}
450 %************************************************************************
453 simplifyPgm :: SimplifierMode
454 -> [SimplifierSwitch]
459 -> IO (SimplCount, ModGuts) -- New bindings
461 simplifyPgm mode switches hsc_env us imp_rule_base guts
463 showPass dflags "Simplify";
465 (termination_msg, it_count, counts_out, binds')
466 <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ;
468 dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
469 "Simplifier statistics"
470 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
472 pprSimplCount counts_out]);
474 endPassIf dump_phase dflags
475 ("Simplify phase " ++ phase_info ++ " done")
476 Opt_D_dump_simpl_phases binds';
478 return (counts_out, guts { mg_binds = binds' })
481 dflags = hsc_dflags hsc_env
482 phase_info = case mode of
483 SimplGently -> "gentle"
484 SimplPhase n ss -> shows n
486 . showString (concat $ intersperse "," ss)
489 dump_phase = shouldDumpSimplPhase dflags mode
491 sw_chkr = isAmongSimpl switches
492 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
494 do_iteration us iteration_no counts binds
495 -- iteration_no is the number of the iteration we are
496 -- about to begin, with '1' for the first
497 | iteration_no > max_iterations -- Stop if we've run out of iterations
498 = WARN(debugIsOn && (max_iterations > 2),
499 text ("Simplifier still going after " ++
500 show max_iterations ++
501 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
502 -- Subtract 1 from iteration_no to get the
503 -- number of iterations we actually completed
504 return ("Simplifier bailed out", iteration_no - 1, counts, binds)
506 -- Try and force thunks off the binds; significantly reduces
507 -- space usage, especially with -O. JRS, 000620.
508 | let sz = coreBindsSize binds in sz == sz
510 -- Occurrence analysis
511 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
512 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
513 (pprCoreBindings tagged_binds);
515 -- Get any new rules, and extend the rule base
516 -- We need to do this regularly, because simplification can
517 -- poke on IdInfo thunks, which in turn brings in new rules
518 -- behind the scenes. Otherwise there's a danger we'll simply
519 -- miss the rules for Ids hidden inside imported inlinings
520 eps <- hscEPS hsc_env ;
521 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
522 ; simpl_env = mkSimplEnv mode sw_chkr
523 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
524 simplTopBinds simpl_env tagged_binds
525 ; fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) } ;
527 -- Simplify the program
528 -- We do this with a *case* not a *let* because lazy pattern
529 -- matching bit us with bad space leak!
530 -- With a let, we ended up with
535 -- case t of {(_,counts') -> if counts'=0 then ... }
536 -- So the conditional didn't force counts', because the
537 -- selection got duplicated. Sigh!
538 case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
539 (binds', counts') -> do {
541 let { all_counts = counts `plusSimplCount` counts'
542 ; herald = "Simplifier phase " ++ phase_info ++
543 ", iteration " ++ show iteration_no ++
544 " out of " ++ show max_iterations
547 -- Stop if nothing happened; don't dump output
548 if isZeroSimplCount counts' then
549 return ("Simplifier reached fixed point", iteration_no,
552 -- Short out indirections
553 -- We do this *after* at least one run of the simplifier
554 -- because indirection-shorting uses the export flag on *occurrences*
555 -- and that isn't guaranteed to be ok until after the first run propagates
556 -- stuff from the binding site to its occurrences
558 -- ToDo: alas, this means that indirection-shorting does not happen at all
559 -- if the simplifier does nothing (not common, I know, but unsavoury)
560 let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
562 -- Dump the result of this iteration
563 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
564 (pprSimplCount counts') ;
565 endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
568 do_iteration us2 (iteration_no + 1) all_counts binds''
571 (us1, us2) = splitUniqSupply us
575 %************************************************************************
577 Shorting out indirections
579 %************************************************************************
583 x_local = <expression>
587 where x_exported is exported, and x_local is not, then we replace it with this:
589 x_exported = <expression>
593 Without this we never get rid of the x_exported = x_local thing. This
594 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
595 makes strictness information propagate better. This used to happen in
596 the final phase, but it's tidier to do it here.
598 STRICTNESS: if we have done strictness analysis, we want the strictness info on
599 x_local to transfer to x_exported. Hence the copyIdInfo call.
601 RULES: we want to *add* any RULES for x_local to x_exported.
603 Note [Rules and indirection-zapping]
604 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
605 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
606 Then the things mentioned can be out of scope! Solution
607 a) Make sure that in this pass the usage-info from x_exported is
608 available for ...bindings...
609 b) If there are any such RULES, rec-ify the entire top-level.
610 It'll get sorted out next time round
614 The example that went bad on me at one stage was this one:
616 iterate :: (a -> a) -> a -> [a]
618 iterate = iterateList
620 iterateFB c f x = x `c` iterateFB c f (f x)
621 iterateList f x = x : iterateList f (f x)
625 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
626 "iterateFB" iterateFB (:) = iterateList
629 This got shorted out to:
631 iterateList :: (a -> a) -> a -> [a]
632 iterateList = iterate
634 iterateFB c f x = x `c` iterateFB c f (f x)
635 iterate f x = x : iterate f (f x)
638 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
639 "iterateFB" iterateFB (:) = iterate
642 And now we get an infinite loop in the rule system
643 iterate f x -> build (\cn -> iterateFB c f x)
647 Tiresome old solution:
648 don't do shorting out if f has rewrite rules (see shortableIdInfo)
650 New solution (I think):
651 use rule switching-off pragmas to get rid
652 of iterateList in the first place
657 If more than one exported thing is equal to a local thing (i.e., the
658 local thing really is shared), then we do one only:
661 x_exported1 = x_local
662 x_exported2 = x_local
666 x_exported2 = x_exported1
669 We rely on prior eta reduction to simplify things like
671 x_exported = /\ tyvars -> x_local tyvars
675 Hence,there's a possibility of leaving unchanged something like this:
678 x_exported1 = x_local Int
680 By the time we've thrown away the types in STG land this
681 could be eliminated. But I don't think it's very common
682 and it's dangerous to do this fiddling in STG land
683 because we might elminate a binding that's mentioned in the
684 unfolding for something.
687 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
689 shortOutIndirections :: [CoreBind] -> [CoreBind]
690 shortOutIndirections binds
691 | isEmptyVarEnv ind_env = binds
692 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
693 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
695 ind_env = makeIndEnv binds
696 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
697 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
698 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
699 binds' = concatMap zap binds
701 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
702 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
705 | bndr `elemVarSet` exp_id_set = []
706 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
708 | otherwise = [(bndr,rhs)]
710 makeIndEnv :: [CoreBind] -> IndEnv
712 = foldr add_bind emptyVarEnv binds
714 add_bind :: CoreBind -> IndEnv -> IndEnv
715 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
716 add_bind (Rec pairs) env = foldr add_pair env pairs
718 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
719 add_pair (exported_id, Var local_id) env
720 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
721 add_pair (exported_id, rhs) env
724 shortMeOut ind_env exported_id local_id
725 -- The if-then-else stuff is just so I can get a pprTrace to see
726 -- how often I don't get shorting out becuase of IdInfo stuff
727 = if isExportedId exported_id && -- Only if this is exported
729 isLocalId local_id && -- Only if this one is defined in this
730 -- module, so that we *can* change its
731 -- binding to be the exported thing!
733 not (isExportedId local_id) && -- Only if this one is not itself exported,
734 -- since the transformation will nuke it
736 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
741 if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
742 then True -- See note on "Messing up rules"
745 pprTrace "shortMeOut:" (ppr exported_id)
754 transferIdInfo :: Id -> Id -> Id
756 -- lcl_id = e; exp_id = lcl_id
757 -- and lcl_id has useful IdInfo, we don't want to discard it by going
758 -- gbl_id = e; lcl_id = gbl_id
759 -- Instead, transfer IdInfo from lcl_id to exp_id
760 -- Overwriting, rather than merging, seems to work ok.
761 transferIdInfo exported_id local_id
762 = modifyIdInfo transfer exported_id
764 local_info = idInfo local_id
765 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
766 `setWorkerInfo` workerInfo local_info
767 `setInlinePragInfo` inlinePragInfo local_info
768 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
769 new_info = setSpecInfoHead (idName exported_id)
770 (specInfo local_info)
771 -- Remember to set the function-name field of the
772 -- rules as we transfer them from one function to another