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 ( DynFlags, DynFlag(..), dopt )
22 import CSE ( cseProgram )
23 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
24 extendRuleBaseList, pprRuleBase, pprRulesForUser,
25 ruleCheckProgram, rulesOfBinds,
26 addSpecInfo, addIdSpecialisations )
27 import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
28 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
30 import CoreUtils ( coreBindsSize )
31 import Simplify ( simplTopBinds, simplExpr )
32 import SimplUtils ( simplEnvForGHCi, simplEnvForRules )
36 import qualified ErrUtils as Err
38 import FloatIn ( floatInwards )
39 import FloatOut ( floatOutwards )
43 import TyCon ( tyConDataCons )
44 import Class ( classSelIds )
45 import BasicTypes ( CompilerPhase, isActive, isDefaultInlinePragma )
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 )
55 import Vectorise ( vectorise )
59 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
67 %************************************************************************
69 \subsection{The driver for the simplifier}
71 %************************************************************************
78 core2core hsc_env guts = do
79 let dflags = hsc_dflags hsc_env
81 us <- mkSplitUniqSupply 's'
82 let (cp_us, ru_us) = splitUniqSupply us
84 -- COMPUTE THE RULE BASE TO USE
85 -- See Note [Overall plumbing for rules] in Rules.lhs
86 (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
88 -- Get the module out of the current HscEnv so we can retrieve it from the monad.
89 -- This is very convienent for the users of the monad (e.g. plugins do not have to
90 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
91 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
92 -- would mean our cached value would go out of date.
93 let mod = mg_module guts
94 (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do
95 -- FIND BUILT-IN PASSES
96 let builtin_core_todos = getCoreToDo dflags
99 doCorePasses builtin_core_todos guts1
101 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
102 "Grand total simplifier statistics"
103 (pprSimplCount stats)
108 type CorePass = CoreToDo
110 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
113 -- simplifyExpr is called by the driver to simplify an
114 -- expression typed in at the interactive prompt
116 -- Also used by Template Haskell
117 simplifyExpr dflags expr
119 ; Err.showPass dflags "Simplify"
121 ; us <- mkSplitUniqSupply 's'
123 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
124 simplExprGently simplEnvForGHCi expr
126 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
132 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
133 doCorePasses passes guts
134 = foldM do_pass guts passes
136 do_pass guts CoreDoNothing = return guts
137 do_pass guts (CoreDoPasses ps) = doCorePasses ps guts
139 = do { dflags <- getDynFlags
140 ; liftIO $ showPass dflags pass
141 ; guts' <- doCorePass pass guts
142 ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts')
145 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
146 doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-}
149 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
152 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
155 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
158 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
159 doPassDUM (floatOutwards f)
161 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
164 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
167 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
170 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
173 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
176 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
179 doCorePass CoreDoGlomBinds = doPassDM glomBinds
180 doCorePass CoreDoPrintCore = observe printCore
181 doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat
182 doCorePass CoreDoNothing = return
183 doCorePass (CoreDoPasses passes) = doCorePasses passes
186 %************************************************************************
188 \subsection{Core pass combinators}
190 %************************************************************************
193 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
195 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
196 ruleCheck current_phase pat guts = do
198 dflags <- getDynFlags
199 liftIO $ Err.showPass dflags "RuleCheck"
200 liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
204 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
205 doPassDMS do_pass = doPassM $ \binds -> do
206 dflags <- getDynFlags
207 liftIOWithCount $ do_pass dflags binds
209 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
210 doPassDUM do_pass = doPassM $ \binds -> do
211 dflags <- getDynFlags
212 us <- getUniqueSupplyM
213 liftIO $ do_pass dflags us binds
215 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
216 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
218 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
219 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
221 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
222 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
224 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
225 doPassU do_pass = doPassDU (const do_pass)
227 -- Most passes return no stats and don't change rules: these combinators
228 -- let us lift them to the full blown ModGuts+CoreM world
229 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
230 doPassM bind_f guts = do
231 binds' <- bind_f (mg_binds guts)
232 return (guts { mg_binds = binds' })
234 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
235 doPassMG bind_f guts = do
236 binds' <- bind_f guts
237 return (guts { mg_binds = binds' })
239 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
240 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
242 -- Observer passes just peek; don't modify the bindings at all
243 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
244 observe do_pass = doPassM $ \binds -> do
245 dflags <- getDynFlags
246 liftIO $ do_pass dflags binds
251 %************************************************************************
255 %************************************************************************
257 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
258 -- It attaches those rules that are for local Ids to their binders, and
259 -- returns the remainder attached to Ids in an IdSet.
262 prepareRules :: HscEnv
265 -> IO (RuleBase, -- Rule base for imported things, incl
266 -- (a) rules defined in this module (orphans)
267 -- (b) rules from other modules in home package
268 -- but not things from other packages
270 ModGuts) -- Modified fields are
271 -- (a) Bindings have rules attached,
272 -- and INLINE rules simplified
273 -- (b) Rules are now just orphan rules
275 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
276 guts@(ModGuts { mg_binds = binds, mg_deps = deps
277 , mg_rules = local_rules, mg_rdr_env = rdr_env })
279 = do { us <- mkSplitUniqSupply 'w'
281 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
282 -- from the local binders, to avoid warnings from Simplify.simplVar
283 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
284 env = setInScopeSet simplEnvForRules local_ids
285 (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
286 mapM (simplRule env) local_rules
288 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
290 home_pkg_rules = hptRules hsc_env (dep_mods deps)
291 hpt_rule_base = mkRuleBase home_pkg_rules
292 binds_w_rules = updateBinders rules_for_locals binds
295 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
296 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
297 vcat [text "Local rules for local Ids", pprRules simpl_rules,
299 text "Local rules for imported Ids", pprRuleBase hpt_rule_base])
301 ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
302 mg_rules = rules_for_imps })
305 -- Note [Attach rules to local ids]
306 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
307 -- Find the rules for locally-defined Ids; then we can attach them
308 -- to the binders in the top-level bindings
311 -- - It makes the rules easier to look up
312 -- - It means that transformation rules and specialisations for
313 -- locally defined Ids are handled uniformly
314 -- - It keeps alive things that are referred to only from a rule
315 -- (the occurrence analyser knows about rules attached to Ids)
316 -- - It makes sure that, when we apply a rule, the free vars
317 -- of the RHS are more likely to be in scope
318 -- - The imported rules are carried in the in-scope set
319 -- which is extended on each iteration by the new wave of
320 -- local binders; any rules which aren't on the binding will
321 -- thereby get dropped
323 updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
324 updateBinders rules_for_locals binds
325 = map update_bind binds
327 local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
329 update_bind (NonRec b r) = NonRec (add_rules b) r
330 update_bind (Rec prs) = Rec (mapFst add_rules prs)
332 -- See Note [Attach rules to local ids]
333 -- NB: the binder might have some existing rules,
334 -- arising from specialisation pragmas
336 | Just rules <- lookupNameEnv local_rules (idName bndr)
337 = bndr `addIdSpecialisations` rules
342 Note [Simplifying the left-hand side of a RULE]
343 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
344 We must do some gentle simplification on the lhs (template) of each
345 rule. The case that forced me to add this was the fold/build rule,
346 which without simplification looked like:
347 fold k z (build (/\a. g a)) ==> ...
348 This doesn't match unless you do eta reduction on the build argument.
349 Similarly for a LHS like
351 we do not want to get
352 augment (\a. g a) (build h)
353 otherwise we don't match when given an argument like
354 augment (\a. h a a) (build h)
356 The simplifier does indeed do eta reduction (it's in
357 Simplify.completeLam) but only if -O is on.
360 simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
361 simplRule env rule@(BuiltinRule {})
363 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
364 = do (env, bndrs') <- simplBinders env bndrs
365 args' <- mapM (simplExprGently env) args
366 rhs' <- simplExprGently env rhs
367 return (rule { ru_bndrs = bndrs', ru_args = args'
368 , ru_rhs = occurAnalyseExpr rhs' })
372 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
373 -- Simplifies an expression
374 -- does occurrence analysis, then simplification
375 -- and repeats (twice currently) because one pass
376 -- alone leaves tons of crud.
377 -- Used (a) for user expressions typed in at the interactive prompt
378 -- (b) the LHS and RHS of a RULE
379 -- (c) Template Haskell splices
381 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
382 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
383 -- enforce that; it just simplifies the expression twice
385 -- It's important that simplExprGently does eta reduction; see
386 -- Note [Simplifying the left-hand side of a RULE] above. The
387 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
388 -- but only if -O is on.
390 simplExprGently env expr = do
391 expr1 <- simplExpr env (occurAnalyseExpr expr)
392 simplExpr env (occurAnalyseExpr expr1)
396 %************************************************************************
398 \subsection{Glomming}
400 %************************************************************************
403 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
404 -- Glom all binds together in one Rec, in case any
405 -- transformations have introduced any new dependencies
407 -- NB: the global invariant is this:
408 -- *** the top level bindings are never cloned, and are always unique ***
410 -- We sort them into dependency order, but applying transformation rules may
411 -- make something at the top refer to something at the bottom:
415 -- RULE: p (q x) = h x
417 -- Applying this rule makes f refer to h,
418 -- although it doesn't appear to in the source program.
419 -- This pass lets us control where it happens.
421 -- NOTICE that this cannot happen for rules whose head is a locally-defined
422 -- function. It only happens for rules whose head is an imported function
423 -- (p in the example above). So, for example, the rule had been
424 -- RULE: f (p x) = h x
425 -- then the rule for f would be attached to f itself (in its IdInfo)
426 -- by prepareLocalRuleBase and h would be regarded by the occurrency
427 -- analyser as free in f.
429 glomBinds dflags binds
430 = do { Err.showPass dflags "GlomBinds" ;
431 let { recd_binds = [Rec (flattenBinds binds)] } ;
433 -- Not much point in printing the result...
434 -- just consumes output bandwidth
438 %************************************************************************
440 \subsection{The driver for the simplifier}
442 %************************************************************************
445 simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts
446 simplifyPgm pass guts
447 = do { hsc_env <- getHscEnv
448 ; us <- getUniqueSupplyM
451 simplifyPgmIO pass hsc_env us rb guts }
453 simplifyPgmIO :: CoreToDo
458 -> IO (SimplCount, ModGuts) -- New bindings
460 simplifyPgmIO pass@(CoreDoSimplify mode max_iterations switches)
461 hsc_env us hpt_rule_base
462 guts@(ModGuts { mg_binds = binds, mg_rules = rules
463 , mg_fam_inst_env = fam_inst_env })
464 = do { (termination_msg, it_count, counts_out, guts')
465 <- do_iteration us 1 [] binds rules
467 ; Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
468 "Simplifier statistics for following pass"
469 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
471 pprSimplCount counts_out])
473 ; return (counts_out, guts')
476 dflags = hsc_dflags hsc_env
477 dump_phase = dumpSimplPhase dflags mode
478 sw_chkr = isAmongSimpl switches
479 do_iteration :: UniqSupply
480 -> Int -- Counts iterations
481 -> [SimplCount] -- Counts from earlier iterations, reversed
482 -> [CoreBind] -- Bindings in
483 -> [CoreRule] -- and orphan rules
484 -> IO (String, Int, SimplCount, ModGuts)
486 do_iteration us iteration_no counts_so_far binds rules
487 -- iteration_no is the number of the iteration we are
488 -- about to begin, with '1' for the first
489 | iteration_no > max_iterations -- Stop if we've run out of iterations
490 = WARN( debugIsOn && (max_iterations > 2)
491 , ptext (sLit "Simplifier baling out after") <+> int max_iterations
492 <+> ptext (sLit "iterations")
493 <+> (brackets $ hsep $ punctuate comma $
494 map (int . simplCountN) (reverse counts_so_far))
495 <+> ptext (sLit "Size =") <+> int (coreBindsSize binds) )
497 -- Subtract 1 from iteration_no to get the
498 -- number of iterations we actually completed
499 return ("Simplifier baled out", iteration_no - 1, total_counts,
500 guts { mg_binds = binds, mg_rules = rules })
502 -- Try and force thunks off the binds; significantly reduces
503 -- space usage, especially with -O. JRS, 000620.
504 | let sz = coreBindsSize binds in sz == sz
506 -- Occurrence analysis
507 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
508 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
509 (pprCoreBindings tagged_binds);
511 -- Get any new rules, and extend the rule base
512 -- See Note [Overall plumbing for rules] in Rules.lhs
513 -- We need to do this regularly, because simplification can
514 -- poke on IdInfo thunks, which in turn brings in new rules
515 -- behind the scenes. Otherwise there's a danger we'll simply
516 -- miss the rules for Ids hidden inside imported inlinings
517 eps <- hscEPS hsc_env ;
518 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
519 ; rule_base2 = extendRuleBaseList rule_base1 rules
520 ; simpl_env = mkSimplEnv sw_chkr mode
521 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
522 simplTopBinds simpl_env tagged_binds
523 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
525 -- Simplify the program
526 -- We do this with a *case* not a *let* because lazy pattern
527 -- matching bit us with bad space leak!
528 -- With a let, we ended up with
533 -- case t of {(_,counts1) -> if counts1=0 then ... }
534 -- So the conditional didn't force counts1, because the
535 -- selection got duplicated. Sigh!
536 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
537 (env1, counts1) -> do {
539 let { binds1 = getFloats env1
540 ; rules1 = substRulesForImportedIds (mkCoreSubst (text "imp-rules") env1) rules
543 -- Stop if nothing happened; don't dump output
544 if isZeroSimplCount counts1 then
545 return ("Simplifier reached fixed point", iteration_no, total_counts,
546 guts { mg_binds = binds1, mg_rules = rules1 })
548 -- Short out indirections
549 -- We do this *after* at least one run of the simplifier
550 -- because indirection-shorting uses the export flag on *occurrences*
551 -- and that isn't guaranteed to be ok until after the first run propagates
552 -- stuff from the binding site to its occurrences
554 -- ToDo: alas, this means that indirection-shorting does not happen at all
555 -- if the simplifier does nothing (not common, I know, but unsavoury)
556 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
558 -- Dump the result of this iteration
559 end_iteration dflags pass iteration_no counts1 binds2 rules1 ;
562 do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1
565 (us1, us2) = splitUniqSupply us
567 -- Remember the counts_so_far are reversed
568 total_counts = foldr (\c acc -> acc `plusSimplCount` c)
569 (zeroSimplCount dflags) counts_so_far
572 end_iteration :: DynFlags -> CoreToDo -> Int
573 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
574 -- Same as endIteration but with simplifier counts
575 end_iteration dflags pass iteration_no counts binds rules
576 = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags)
577 pass (ptext (sLit "Simplifier counts"))
578 (pprSimplCount counts)
580 ; endIteration dflags pass iteration_no binds rules }
584 %************************************************************************
586 Shorting out indirections
588 %************************************************************************
592 x_local = <expression>
596 where x_exported is exported, and x_local is not, then we replace it with this:
598 x_exported = <expression>
602 Without this we never get rid of the x_exported = x_local thing. This
603 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
604 makes strictness information propagate better. This used to happen in
605 the final phase, but it's tidier to do it here.
607 Note [Transferring IdInfo]
608 ~~~~~~~~~~~~~~~~~~~~~~~~~~
609 We want to propagage any useful IdInfo on x_local to x_exported.
611 STRICTNESS: if we have done strictness analysis, we want the strictness info on
612 x_local to transfer to x_exported. Hence the copyIdInfo call.
614 RULES: we want to *add* any RULES for x_local to x_exported.
617 Note [Messing up the exported Id's RULES]
618 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
619 We must be careful about discarding (obviously) or even merging the
620 RULES on the exported Id. The example that went bad on me at one stage
623 iterate :: (a -> a) -> a -> [a]
625 iterate = iterateList
627 iterateFB c f x = x `c` iterateFB c f (f x)
628 iterateList f x = x : iterateList f (f x)
632 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
633 "iterateFB" iterateFB (:) = iterateList
636 This got shorted out to:
638 iterateList :: (a -> a) -> a -> [a]
639 iterateList = iterate
641 iterateFB c f x = x `c` iterateFB c f (f x)
642 iterate f x = x : iterate f (f x)
645 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
646 "iterateFB" iterateFB (:) = iterate
649 And now we get an infinite loop in the rule system
650 iterate f x -> build (\cn -> iterateFB c f x)
655 use rule switching-off pragmas to get rid
656 of iterateList in the first place
658 But in principle the user *might* want rules that only apply to the Id
659 he says. And inline pragmas are similar
663 Then we do not want to get rid of the NOINLINE.
665 Hence hasShortableIdinfo.
668 Note [Rules and indirection-zapping]
669 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
670 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
671 Then the things mentioned can be out of scope! Solution
672 a) Make sure that in this pass the usage-info from x_exported is
673 available for ...bindings...
674 b) If there are any such RULES, rec-ify the entire top-level.
675 It'll get sorted out next time round
679 If more than one exported thing is equal to a local thing (i.e., the
680 local thing really is shared), then we do one only:
683 x_exported1 = x_local
684 x_exported2 = x_local
688 x_exported2 = x_exported1
691 We rely on prior eta reduction to simplify things like
693 x_exported = /\ tyvars -> x_local tyvars
697 Hence,there's a possibility of leaving unchanged something like this:
700 x_exported1 = x_local Int
702 By the time we've thrown away the types in STG land this
703 could be eliminated. But I don't think it's very common
704 and it's dangerous to do this fiddling in STG land
705 because we might elminate a binding that's mentioned in the
706 unfolding for something.
709 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
711 shortOutIndirections :: [CoreBind] -> [CoreBind]
712 shortOutIndirections binds
713 | isEmptyVarEnv ind_env = binds
714 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
715 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
717 ind_env = makeIndEnv binds
718 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
719 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
720 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
721 binds' = concatMap zap binds
723 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
724 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
727 | bndr `elemVarSet` exp_id_set = []
728 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
730 | otherwise = [(bndr,rhs)]
732 makeIndEnv :: [CoreBind] -> IndEnv
734 = foldr add_bind emptyVarEnv binds
736 add_bind :: CoreBind -> IndEnv -> IndEnv
737 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
738 add_bind (Rec pairs) env = foldr add_pair env pairs
740 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
741 add_pair (exported_id, Var local_id) env
742 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
743 add_pair (exported_id, rhs) env
747 shortMeOut ind_env exported_id local_id
748 -- The if-then-else stuff is just so I can get a pprTrace to see
749 -- how often I don't get shorting out becuase of IdInfo stuff
750 = if isExportedId exported_id && -- Only if this is exported
752 isLocalId local_id && -- Only if this one is defined in this
753 -- module, so that we *can* change its
754 -- binding to be the exported thing!
756 not (isExportedId local_id) && -- Only if this one is not itself exported,
757 -- since the transformation will nuke it
759 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
761 if hasShortableIdInfo exported_id
762 then True -- See Note [Messing up the exported Id's IdInfo]
763 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
769 hasShortableIdInfo :: Id -> Bool
770 -- True if there is no user-attached IdInfo on exported_id,
771 -- so we can safely discard it
772 -- See Note [Messing up the exported Id's IdInfo]
773 hasShortableIdInfo id
774 = isEmptySpecInfo (specInfo info)
775 && isDefaultInlinePragma (inlinePragInfo info)
780 transferIdInfo :: Id -> Id -> Id
781 -- See Note [Transferring IdInfo]
783 -- lcl_id = e; exp_id = lcl_id
784 -- and lcl_id has useful IdInfo, we don't want to discard it by going
785 -- gbl_id = e; lcl_id = gbl_id
786 -- Instead, transfer IdInfo from lcl_id to exp_id
787 -- Overwriting, rather than merging, seems to work ok.
788 transferIdInfo exported_id local_id
789 = modifyIdInfo transfer exported_id
791 local_info = idInfo local_id
792 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
793 `setUnfoldingInfo` unfoldingInfo local_info
794 `setInlinePragInfo` inlinePragInfo local_info
795 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
796 new_info = setSpecInfoHead (idName exported_id)
797 (specInfo local_info)
798 -- Remember to set the function-name field of the
799 -- rules as we transfer them from one function to another