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 )
24 import CSE ( cseProgram )
25 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
26 extendRuleBaseList, pprRuleBase, pprRulesForUser,
27 ruleCheckProgram, rulesOfBinds,
28 addSpecInfo, addIdSpecialisations )
29 import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
30 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
32 import CoreUtils ( coreBindsSize )
33 import Simplify ( simplTopBinds, simplExpr )
34 import SimplUtils ( simplEnvForGHCi, simplEnvForRules )
38 import qualified ErrUtils as Err
40 import CoreMonad ( endPass )
41 import FloatIn ( floatInwards )
42 import FloatOut ( floatOutwards )
46 import TyCon ( tyConDataCons )
47 import Class ( classSelIds )
48 import BasicTypes ( CompilerPhase, isActive, isDefaultInlinePragma )
51 import NameEnv ( lookupNameEnv )
52 import LiberateCase ( liberateCase )
53 import SAT ( doStaticArgs )
54 import Specialise ( specProgram)
55 import SpecConstr ( specConstrProgram)
56 import DmdAnal ( dmdAnalPgm )
57 import WorkWrap ( wwTopBinds )
58 import Vectorise ( vectorise )
62 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
70 %************************************************************************
72 \subsection{The driver for the simplifier}
74 %************************************************************************
81 core2core hsc_env guts = do
82 let dflags = hsc_dflags hsc_env
84 us <- mkSplitUniqSupply 's'
85 let (cp_us, ru_us) = splitUniqSupply us
87 -- COMPUTE THE RULE BASE TO USE
88 -- See Note [Overall plumbing for rules] in Rules.lhs
89 (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
91 -- Get the module out of the current HscEnv so we can retrieve it from the monad.
92 -- This is very convienent for the users of the monad (e.g. plugins do not have to
93 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
94 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
95 -- would mean our cached value would go out of date.
96 let mod = mg_module guts
97 (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do
98 -- FIND BUILT-IN PASSES
99 let builtin_core_todos = getCoreToDo dflags
102 doCorePasses builtin_core_todos guts1
104 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
105 "Grand total simplifier statistics"
106 (pprSimplCount stats)
111 type CorePass = CoreToDo
113 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
116 -- simplifyExpr is called by the driver to simplify an
117 -- expression typed in at the interactive prompt
119 -- Also used by Template Haskell
120 simplifyExpr dflags expr
122 ; Err.showPass dflags "Simplify"
124 ; us <- mkSplitUniqSupply 's'
126 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
127 simplExprGently simplEnvForGHCi expr
129 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
135 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
136 doCorePasses passes guts = foldM (flip doCorePass) guts passes
138 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
139 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
142 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
143 describePass "Common sub-expression" Opt_D_dump_cse $
146 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
147 describePass "Liberate case" Opt_D_verbose_core2core $
150 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
151 describePass "Float inwards" Opt_D_verbose_core2core $
154 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
155 describePassD (text "Float out" <+> parens (ppr f))
156 Opt_D_verbose_core2core $
157 doPassDUM (floatOutwards f)
159 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
160 describePass "Static argument" Opt_D_verbose_core2core $
163 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
164 describePass "Demand analysis" Opt_D_dump_stranal $
167 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
168 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
171 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
172 describePassR "Specialise" Opt_D_dump_spec $
175 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
176 describePassR "SpecConstr" Opt_D_dump_spec $
179 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
180 describePass "Vectorisation" Opt_D_dump_vect $
183 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
184 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
185 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
187 doCorePass CoreDoNothing = return
188 doCorePass (CoreDoPasses passes) = doCorePasses passes
191 %************************************************************************
193 \subsection{Core pass combinators}
195 %************************************************************************
199 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
200 dontDescribePass = ($)
202 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
203 describePass name dflag pass guts = do
204 dflags <- getDynFlags
206 liftIO $ Err.showPass dflags name
208 liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
212 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
213 describePassD doc = describePass (showSDoc doc)
215 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
216 describePassR name dflag pass guts = do
217 guts' <- describePass name dflag pass guts
218 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
219 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
222 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
224 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
225 ruleCheck current_phase pat guts = do
227 dflags <- getDynFlags
228 liftIO $ Err.showPass dflags "RuleCheck"
229 liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
233 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
234 doPassDMS do_pass = doPassM $ \binds -> do
235 dflags <- getDynFlags
236 liftIOWithCount $ do_pass dflags binds
238 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
239 doPassDUM do_pass = doPassM $ \binds -> do
240 dflags <- getDynFlags
241 us <- getUniqueSupplyM
242 liftIO $ do_pass dflags us binds
244 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
245 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
247 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
248 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
250 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
251 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
253 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
254 doPassU do_pass = doPassDU (const do_pass)
256 -- Most passes return no stats and don't change rules: these combinators
257 -- let us lift them to the full blown ModGuts+CoreM world
258 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
259 doPassM bind_f guts = do
260 binds' <- bind_f (mg_binds guts)
261 return (guts { mg_binds = binds' })
263 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
264 doPassMG bind_f guts = do
265 binds' <- bind_f guts
266 return (guts { mg_binds = binds' })
268 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
269 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
271 -- Observer passes just peek; don't modify the bindings at all
272 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
273 observe do_pass = doPassM $ \binds -> do
274 dflags <- getDynFlags
275 liftIO $ do_pass dflags binds
280 %************************************************************************
284 %************************************************************************
286 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
287 -- It attaches those rules that are for local Ids to their binders, and
288 -- returns the remainder attached to Ids in an IdSet.
291 prepareRules :: HscEnv
294 -> IO (RuleBase, -- Rule base for imported things, incl
295 -- (a) rules defined in this module (orphans)
296 -- (b) rules from other modules in home package
297 -- but not things from other packages
299 ModGuts) -- Modified fields are
300 -- (a) Bindings have rules attached,
301 -- and INLINE rules simplified
302 -- (b) Rules are now just orphan rules
304 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
305 guts@(ModGuts { mg_binds = binds, mg_deps = deps
306 , mg_rules = local_rules, mg_rdr_env = rdr_env })
308 = do { us <- mkSplitUniqSupply 'w'
310 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
311 -- from the local binders, to avoid warnings from Simplify.simplVar
312 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
313 env = setInScopeSet simplEnvForRules local_ids
314 (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
315 mapM (simplRule env) local_rules
317 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
319 home_pkg_rules = hptRules hsc_env (dep_mods deps)
320 hpt_rule_base = mkRuleBase home_pkg_rules
321 binds_w_rules = updateBinders rules_for_locals binds
324 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
325 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
326 vcat [text "Local rules", pprRules simpl_rules,
328 text "Imported rules", pprRuleBase hpt_rule_base])
330 ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
331 mg_rules = rules_for_imps })
334 -- Note [Attach rules to local ids]
335 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
336 -- Find the rules for locally-defined Ids; then we can attach them
337 -- to the binders in the top-level bindings
340 -- - It makes the rules easier to look up
341 -- - It means that transformation rules and specialisations for
342 -- locally defined Ids are handled uniformly
343 -- - It keeps alive things that are referred to only from a rule
344 -- (the occurrence analyser knows about rules attached to Ids)
345 -- - It makes sure that, when we apply a rule, the free vars
346 -- of the RHS are more likely to be in scope
347 -- - The imported rules are carried in the in-scope set
348 -- which is extended on each iteration by the new wave of
349 -- local binders; any rules which aren't on the binding will
350 -- thereby get dropped
352 updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
353 updateBinders rules_for_locals binds
354 = map update_bind binds
356 local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
358 update_bind (NonRec b r) = NonRec (add_rules b) r
359 update_bind (Rec prs) = Rec (mapFst add_rules prs)
361 -- See Note [Attach rules to local ids]
362 -- NB: the binder might have some existing rules,
363 -- arising from specialisation pragmas
365 | Just rules <- lookupNameEnv local_rules (idName bndr)
366 = bndr `addIdSpecialisations` rules
371 Note [Simplifying the left-hand side of a RULE]
372 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
373 We must do some gentle simplification on the lhs (template) of each
374 rule. The case that forced me to add this was the fold/build rule,
375 which without simplification looked like:
376 fold k z (build (/\a. g a)) ==> ...
377 This doesn't match unless you do eta reduction on the build argument.
378 Similarly for a LHS like
380 we do not want to get
381 augment (\a. g a) (build h)
382 otherwise we don't match when given an argument like
383 augment (\a. h a a) (build h)
385 The simplifier does indeed do eta reduction (it's in
386 Simplify.completeLam) but only if -O is on.
389 simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
390 simplRule env rule@(BuiltinRule {})
392 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
393 = do (env, bndrs') <- simplBinders env bndrs
394 args' <- mapM (simplExprGently env) args
395 rhs' <- simplExprGently env rhs
396 return (rule { ru_bndrs = bndrs', ru_args = args'
397 , ru_rhs = occurAnalyseExpr rhs' })
401 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
402 -- Simplifies an expression
403 -- does occurrence analysis, then simplification
404 -- and repeats (twice currently) because one pass
405 -- alone leaves tons of crud.
406 -- Used (a) for user expressions typed in at the interactive prompt
407 -- (b) the LHS and RHS of a RULE
408 -- (c) Template Haskell splices
410 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
411 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
412 -- enforce that; it just simplifies the expression twice
414 -- It's important that simplExprGently does eta reduction; see
415 -- Note [Simplifying the left-hand side of a RULE] above. The
416 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
417 -- but only if -O is on.
419 simplExprGently env expr = do
420 expr1 <- simplExpr env (occurAnalyseExpr expr)
421 simplExpr env (occurAnalyseExpr expr1)
425 %************************************************************************
427 \subsection{Glomming}
429 %************************************************************************
432 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
433 -- Glom all binds together in one Rec, in case any
434 -- transformations have introduced any new dependencies
436 -- NB: the global invariant is this:
437 -- *** the top level bindings are never cloned, and are always unique ***
439 -- We sort them into dependency order, but applying transformation rules may
440 -- make something at the top refer to something at the bottom:
444 -- RULE: p (q x) = h x
446 -- Applying this rule makes f refer to h,
447 -- although it doesn't appear to in the source program.
448 -- This pass lets us control where it happens.
450 -- NOTICE that this cannot happen for rules whose head is a locally-defined
451 -- function. It only happens for rules whose head is an imported function
452 -- (p in the example above). So, for example, the rule had been
453 -- RULE: f (p x) = h x
454 -- then the rule for f would be attached to f itself (in its IdInfo)
455 -- by prepareLocalRuleBase and h would be regarded by the occurrency
456 -- analyser as free in f.
458 glomBinds dflags binds
459 = do { Err.showPass dflags "GlomBinds" ;
460 let { recd_binds = [Rec (flattenBinds binds)] } ;
462 -- Not much point in printing the result...
463 -- just consumes output bandwidth
467 %************************************************************************
469 \subsection{The driver for the simplifier}
471 %************************************************************************
474 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
475 simplifyPgm mode switches
476 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
477 do { hsc_env <- getHscEnv
478 ; us <- getUniqueSupplyM
481 simplifyPgmIO mode switches hsc_env us rb guts }
483 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
485 simplifyPgmIO :: SimplifierMode
486 -> [SimplifierSwitch]
491 -> IO (SimplCount, ModGuts) -- New bindings
493 simplifyPgmIO mode switches hsc_env us hpt_rule_base
494 guts@(ModGuts { mg_binds = binds, mg_rules = rules
495 , mg_fam_inst_env = fam_inst_env })
497 (termination_msg, it_count, counts_out, guts')
498 <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
500 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
501 "Simplifier statistics for following pass"
502 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
504 pprSimplCount counts_out]);
506 return (counts_out, guts')
509 dflags = hsc_dflags hsc_env
510 dump_phase = shouldDumpSimplPhase dflags mode
512 sw_chkr = isAmongSimpl switches
513 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
515 do_iteration :: UniqSupply
516 -> Int -- Counts iterations
517 -> SimplCount -- Logs optimisations performed
518 -> [CoreBind] -- Bindings in
519 -> [CoreRule] -- and orphan rules
520 -> IO (String, Int, SimplCount, ModGuts)
522 do_iteration us iteration_no counts binds rules
523 -- iteration_no is the number of the iteration we are
524 -- about to begin, with '1' for the first
525 | iteration_no > max_iterations -- Stop if we've run out of iterations
526 = WARN(debugIsOn && (max_iterations > 2),
527 text ("Simplifier still going after " ++
528 show max_iterations ++
529 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
530 -- Subtract 1 from iteration_no to get the
531 -- number of iterations we actually completed
532 return ("Simplifier bailed out", iteration_no - 1, counts,
533 guts { mg_binds = binds, mg_rules = rules })
535 -- Try and force thunks off the binds; significantly reduces
536 -- space usage, especially with -O. JRS, 000620.
537 | let sz = coreBindsSize binds in sz == sz
539 -- Occurrence analysis
540 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
541 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
542 (pprCoreBindings tagged_binds);
544 -- Get any new rules, and extend the rule base
545 -- See Note [Overall plumbing for rules] in Rules.lhs
546 -- We need to do this regularly, because simplification can
547 -- poke on IdInfo thunks, which in turn brings in new rules
548 -- behind the scenes. Otherwise there's a danger we'll simply
549 -- miss the rules for Ids hidden inside imported inlinings
550 eps <- hscEPS hsc_env ;
551 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
552 ; rule_base2 = extendRuleBaseList rule_base1 rules
553 ; simpl_env = mkSimplEnv sw_chkr mode
554 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
555 simplTopBinds simpl_env tagged_binds
556 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
558 -- Simplify the program
559 -- We do this with a *case* not a *let* because lazy pattern
560 -- matching bit us with bad space leak!
561 -- With a let, we ended up with
566 -- case t of {(_,counts') -> if counts'=0 then ... }
567 -- So the conditional didn't force counts', because the
568 -- selection got duplicated. Sigh!
569 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
570 (env1, counts1) -> do {
572 let { all_counts = counts `plusSimplCount` counts1
573 ; binds1 = getFloats env1
574 ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
577 -- Stop if nothing happened; don't dump output
578 if isZeroSimplCount counts1 then
579 return ("Simplifier reached fixed point", iteration_no, all_counts,
580 guts { mg_binds = binds1, mg_rules = rules1 })
582 -- Short out indirections
583 -- We do this *after* at least one run of the simplifier
584 -- because indirection-shorting uses the export flag on *occurrences*
585 -- and that isn't guaranteed to be ok until after the first run propagates
586 -- stuff from the binding site to its occurrences
588 -- ToDo: alas, this means that indirection-shorting does not happen at all
589 -- if the simplifier does nothing (not common, I know, but unsavoury)
590 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
592 -- Dump the result of this iteration
593 end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
596 do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
599 (us1, us2) = splitUniqSupply us
602 end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
603 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
604 -- Same as endIteration but with simplifier counts
605 end_iteration dflags mode iteration_no max_iterations counts binds rules
606 = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
607 (pprSimplCount counts) ;
609 ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
611 pass_name = "Simplifier mode " ++ showPpr mode ++
612 ", iteration " ++ show iteration_no ++
613 " out of " ++ show max_iterations
617 %************************************************************************
619 Shorting out indirections
621 %************************************************************************
625 x_local = <expression>
629 where x_exported is exported, and x_local is not, then we replace it with this:
631 x_exported = <expression>
635 Without this we never get rid of the x_exported = x_local thing. This
636 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
637 makes strictness information propagate better. This used to happen in
638 the final phase, but it's tidier to do it here.
640 Note [Transferring IdInfo]
641 ~~~~~~~~~~~~~~~~~~~~~~~~~~
642 We want to propagage any useful IdInfo on x_local to x_exported.
644 STRICTNESS: if we have done strictness analysis, we want the strictness info on
645 x_local to transfer to x_exported. Hence the copyIdInfo call.
647 RULES: we want to *add* any RULES for x_local to x_exported.
650 Note [Messing up the exported Id's RULES]
651 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
652 We must be careful about discarding (obviously) or even merging the
653 RULES on the exported Id. The example that went bad on me at one stage
656 iterate :: (a -> a) -> a -> [a]
658 iterate = iterateList
660 iterateFB c f x = x `c` iterateFB c f (f x)
661 iterateList f x = x : iterateList f (f x)
665 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
666 "iterateFB" iterateFB (:) = iterateList
669 This got shorted out to:
671 iterateList :: (a -> a) -> a -> [a]
672 iterateList = iterate
674 iterateFB c f x = x `c` iterateFB c f (f x)
675 iterate f x = x : iterate f (f x)
678 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
679 "iterateFB" iterateFB (:) = iterate
682 And now we get an infinite loop in the rule system
683 iterate f x -> build (\cn -> iterateFB c f x)
688 use rule switching-off pragmas to get rid
689 of iterateList in the first place
691 But in principle the user *might* want rules that only apply to the Id
692 he says. And inline pragmas are similar
696 Then we do not want to get rid of the NOINLINE.
698 Hence hasShortableIdinfo.
701 Note [Rules and indirection-zapping]
702 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
703 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
704 Then the things mentioned can be out of scope! Solution
705 a) Make sure that in this pass the usage-info from x_exported is
706 available for ...bindings...
707 b) If there are any such RULES, rec-ify the entire top-level.
708 It'll get sorted out next time round
712 If more than one exported thing is equal to a local thing (i.e., the
713 local thing really is shared), then we do one only:
716 x_exported1 = x_local
717 x_exported2 = x_local
721 x_exported2 = x_exported1
724 We rely on prior eta reduction to simplify things like
726 x_exported = /\ tyvars -> x_local tyvars
730 Hence,there's a possibility of leaving unchanged something like this:
733 x_exported1 = x_local Int
735 By the time we've thrown away the types in STG land this
736 could be eliminated. But I don't think it's very common
737 and it's dangerous to do this fiddling in STG land
738 because we might elminate a binding that's mentioned in the
739 unfolding for something.
742 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
744 shortOutIndirections :: [CoreBind] -> [CoreBind]
745 shortOutIndirections binds
746 | isEmptyVarEnv ind_env = binds
747 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
748 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
750 ind_env = makeIndEnv binds
751 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
752 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
753 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
754 binds' = concatMap zap binds
756 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
757 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
760 | bndr `elemVarSet` exp_id_set = []
761 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
763 | otherwise = [(bndr,rhs)]
765 makeIndEnv :: [CoreBind] -> IndEnv
767 = foldr add_bind emptyVarEnv binds
769 add_bind :: CoreBind -> IndEnv -> IndEnv
770 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
771 add_bind (Rec pairs) env = foldr add_pair env pairs
773 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
774 add_pair (exported_id, Var local_id) env
775 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
776 add_pair (exported_id, rhs) env
780 shortMeOut ind_env exported_id local_id
781 -- The if-then-else stuff is just so I can get a pprTrace to see
782 -- how often I don't get shorting out becuase of IdInfo stuff
783 = if isExportedId exported_id && -- Only if this is exported
785 isLocalId local_id && -- Only if this one is defined in this
786 -- module, so that we *can* change its
787 -- binding to be the exported thing!
789 not (isExportedId local_id) && -- Only if this one is not itself exported,
790 -- since the transformation will nuke it
792 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
794 if hasShortableIdInfo exported_id
795 then True -- See Note [Messing up the exported Id's IdInfo]
796 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
802 hasShortableIdInfo :: Id -> Bool
803 -- True if there is no user-attached IdInfo on exported_id,
804 -- so we can safely discard it
805 -- See Note [Messing up the exported Id's IdInfo]
806 hasShortableIdInfo id
807 = isEmptySpecInfo (specInfo info)
808 && isDefaultInlinePragma (inlinePragInfo info)
813 transferIdInfo :: Id -> Id -> Id
814 -- See Note [Transferring IdInfo]
816 -- lcl_id = e; exp_id = lcl_id
817 -- and lcl_id has useful IdInfo, we don't want to discard it by going
818 -- gbl_id = e; lcl_id = gbl_id
819 -- Instead, transfer IdInfo from lcl_id to exp_id
820 -- Overwriting, rather than merging, seems to work ok.
821 transferIdInfo exported_id local_id
822 = modifyIdInfo transfer exported_id
824 local_info = idInfo local_id
825 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
826 `setUnfoldingInfo` unfoldingInfo local_info
827 `setInlinePragInfo` inlinePragInfo local_info
828 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
829 new_info = setSpecInfoHead (idName exported_id)
830 (specInfo local_info)
831 -- Remember to set the function-name field of the
832 -- rules as we transfer them from one function to another