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 = foldM (flip doCorePass) guts passes
135 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
136 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
139 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
140 describePass "Common sub-expression" Opt_D_dump_cse $
143 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
144 describePass "Liberate case" Opt_D_verbose_core2core $
147 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
148 describePass "Float inwards" Opt_D_verbose_core2core $
151 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
152 describePassD (text "Float out" <+> parens (ppr f))
153 Opt_D_verbose_core2core $
154 doPassDUM (floatOutwards f)
156 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
157 describePass "Static argument" Opt_D_verbose_core2core $
160 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
161 describePass "Demand analysis" Opt_D_dump_stranal $
164 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
165 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
168 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
169 describePassR "Specialise" Opt_D_dump_spec $
172 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
173 describePassR "SpecConstr" Opt_D_dump_spec $
176 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
177 describePass "Vectorisation" Opt_D_dump_vect $
180 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
181 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
182 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
184 doCorePass CoreDoNothing = return
185 doCorePass (CoreDoPasses passes) = doCorePasses passes
188 %************************************************************************
190 \subsection{Core pass combinators}
192 %************************************************************************
196 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
197 dontDescribePass = ($)
199 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
200 describePass name dflag pass guts = do
201 dflags <- getDynFlags
203 liftIO $ Err.showPass dflags name
205 liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
209 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
210 describePassD doc = describePass (showSDoc doc)
212 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
213 describePassR name dflag pass guts = do
214 guts' <- describePass name dflag pass guts
215 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
216 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
219 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
221 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
222 ruleCheck current_phase pat guts = do
224 dflags <- getDynFlags
225 liftIO $ Err.showPass dflags "RuleCheck"
226 liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
230 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
231 doPassDMS do_pass = doPassM $ \binds -> do
232 dflags <- getDynFlags
233 liftIOWithCount $ do_pass dflags binds
235 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
236 doPassDUM do_pass = doPassM $ \binds -> do
237 dflags <- getDynFlags
238 us <- getUniqueSupplyM
239 liftIO $ do_pass dflags us binds
241 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
242 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
244 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
245 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
247 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
248 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
250 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
251 doPassU do_pass = doPassDU (const do_pass)
253 -- Most passes return no stats and don't change rules: these combinators
254 -- let us lift them to the full blown ModGuts+CoreM world
255 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
256 doPassM bind_f guts = do
257 binds' <- bind_f (mg_binds guts)
258 return (guts { mg_binds = binds' })
260 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
261 doPassMG bind_f guts = do
262 binds' <- bind_f guts
263 return (guts { mg_binds = binds' })
265 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
266 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
268 -- Observer passes just peek; don't modify the bindings at all
269 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
270 observe do_pass = doPassM $ \binds -> do
271 dflags <- getDynFlags
272 liftIO $ do_pass dflags binds
277 %************************************************************************
281 %************************************************************************
283 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
284 -- It attaches those rules that are for local Ids to their binders, and
285 -- returns the remainder attached to Ids in an IdSet.
288 prepareRules :: HscEnv
291 -> IO (RuleBase, -- Rule base for imported things, incl
292 -- (a) rules defined in this module (orphans)
293 -- (b) rules from other modules in home package
294 -- but not things from other packages
296 ModGuts) -- Modified fields are
297 -- (a) Bindings have rules attached,
298 -- and INLINE rules simplified
299 -- (b) Rules are now just orphan rules
301 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
302 guts@(ModGuts { mg_binds = binds, mg_deps = deps
303 , mg_rules = local_rules, mg_rdr_env = rdr_env })
305 = do { us <- mkSplitUniqSupply 'w'
307 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
308 -- from the local binders, to avoid warnings from Simplify.simplVar
309 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
310 env = setInScopeSet simplEnvForRules local_ids
311 (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
312 mapM (simplRule env) local_rules
314 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
316 home_pkg_rules = hptRules hsc_env (dep_mods deps)
317 hpt_rule_base = mkRuleBase home_pkg_rules
318 binds_w_rules = updateBinders rules_for_locals binds
321 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
322 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
323 vcat [text "Local rules for local Ids", pprRules simpl_rules,
325 text "Local rules for imported Ids", pprRuleBase hpt_rule_base])
327 ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
328 mg_rules = rules_for_imps })
331 -- Note [Attach rules to local ids]
332 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
333 -- Find the rules for locally-defined Ids; then we can attach them
334 -- to the binders in the top-level bindings
337 -- - It makes the rules easier to look up
338 -- - It means that transformation rules and specialisations for
339 -- locally defined Ids are handled uniformly
340 -- - It keeps alive things that are referred to only from a rule
341 -- (the occurrence analyser knows about rules attached to Ids)
342 -- - It makes sure that, when we apply a rule, the free vars
343 -- of the RHS are more likely to be in scope
344 -- - The imported rules are carried in the in-scope set
345 -- which is extended on each iteration by the new wave of
346 -- local binders; any rules which aren't on the binding will
347 -- thereby get dropped
349 updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
350 updateBinders rules_for_locals binds
351 = map update_bind binds
353 local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
355 update_bind (NonRec b r) = NonRec (add_rules b) r
356 update_bind (Rec prs) = Rec (mapFst add_rules prs)
358 -- See Note [Attach rules to local ids]
359 -- NB: the binder might have some existing rules,
360 -- arising from specialisation pragmas
362 | Just rules <- lookupNameEnv local_rules (idName bndr)
363 = bndr `addIdSpecialisations` rules
368 Note [Simplifying the left-hand side of a RULE]
369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
370 We must do some gentle simplification on the lhs (template) of each
371 rule. The case that forced me to add this was the fold/build rule,
372 which without simplification looked like:
373 fold k z (build (/\a. g a)) ==> ...
374 This doesn't match unless you do eta reduction on the build argument.
375 Similarly for a LHS like
377 we do not want to get
378 augment (\a. g a) (build h)
379 otherwise we don't match when given an argument like
380 augment (\a. h a a) (build h)
382 The simplifier does indeed do eta reduction (it's in
383 Simplify.completeLam) but only if -O is on.
386 simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
387 simplRule env rule@(BuiltinRule {})
389 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
390 = do (env, bndrs') <- simplBinders env bndrs
391 args' <- mapM (simplExprGently env) args
392 rhs' <- simplExprGently env rhs
393 return (rule { ru_bndrs = bndrs', ru_args = args'
394 , ru_rhs = occurAnalyseExpr rhs' })
398 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
399 -- Simplifies an expression
400 -- does occurrence analysis, then simplification
401 -- and repeats (twice currently) because one pass
402 -- alone leaves tons of crud.
403 -- Used (a) for user expressions typed in at the interactive prompt
404 -- (b) the LHS and RHS of a RULE
405 -- (c) Template Haskell splices
407 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
408 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
409 -- enforce that; it just simplifies the expression twice
411 -- It's important that simplExprGently does eta reduction; see
412 -- Note [Simplifying the left-hand side of a RULE] above. The
413 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
414 -- but only if -O is on.
416 simplExprGently env expr = do
417 expr1 <- simplExpr env (occurAnalyseExpr expr)
418 simplExpr env (occurAnalyseExpr expr1)
422 %************************************************************************
424 \subsection{Glomming}
426 %************************************************************************
429 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
430 -- Glom all binds together in one Rec, in case any
431 -- transformations have introduced any new dependencies
433 -- NB: the global invariant is this:
434 -- *** the top level bindings are never cloned, and are always unique ***
436 -- We sort them into dependency order, but applying transformation rules may
437 -- make something at the top refer to something at the bottom:
441 -- RULE: p (q x) = h x
443 -- Applying this rule makes f refer to h,
444 -- although it doesn't appear to in the source program.
445 -- This pass lets us control where it happens.
447 -- NOTICE that this cannot happen for rules whose head is a locally-defined
448 -- function. It only happens for rules whose head is an imported function
449 -- (p in the example above). So, for example, the rule had been
450 -- RULE: f (p x) = h x
451 -- then the rule for f would be attached to f itself (in its IdInfo)
452 -- by prepareLocalRuleBase and h would be regarded by the occurrency
453 -- analyser as free in f.
455 glomBinds dflags binds
456 = do { Err.showPass dflags "GlomBinds" ;
457 let { recd_binds = [Rec (flattenBinds binds)] } ;
459 -- Not much point in printing the result...
460 -- just consumes output bandwidth
464 %************************************************************************
466 \subsection{The driver for the simplifier}
468 %************************************************************************
471 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
472 simplifyPgm mode switches
473 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
474 do { hsc_env <- getHscEnv
475 ; us <- getUniqueSupplyM
478 simplifyPgmIO mode switches hsc_env us rb guts }
480 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
482 simplifyPgmIO :: SimplifierMode
483 -> [SimplifierSwitch]
488 -> IO (SimplCount, ModGuts) -- New bindings
490 simplifyPgmIO mode switches hsc_env us hpt_rule_base
491 guts@(ModGuts { mg_binds = binds, mg_rules = rules
492 , mg_fam_inst_env = fam_inst_env })
494 (termination_msg, it_count, counts_out, guts')
495 <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
497 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
498 "Simplifier statistics for following pass"
499 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
501 pprSimplCount counts_out]);
503 return (counts_out, guts')
506 dflags = hsc_dflags hsc_env
507 dump_phase = dumpSimplPhase dflags mode
509 sw_chkr = isAmongSimpl switches
510 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
512 do_iteration :: UniqSupply
513 -> Int -- Counts iterations
514 -> SimplCount -- Logs optimisations performed
515 -> [CoreBind] -- Bindings in
516 -> [CoreRule] -- and orphan rules
517 -> IO (String, Int, SimplCount, ModGuts)
519 do_iteration us iteration_no counts binds rules
520 -- iteration_no is the number of the iteration we are
521 -- about to begin, with '1' for the first
522 | iteration_no > max_iterations -- Stop if we've run out of iterations
523 = WARN(debugIsOn && (max_iterations > 2),
524 text ("Simplifier still going after " ++
525 show max_iterations ++
526 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
527 -- Subtract 1 from iteration_no to get the
528 -- number of iterations we actually completed
529 return ("Simplifier bailed out", iteration_no - 1, counts,
530 guts { mg_binds = binds, mg_rules = rules })
532 -- Try and force thunks off the binds; significantly reduces
533 -- space usage, especially with -O. JRS, 000620.
534 | let sz = coreBindsSize binds in sz == sz
536 -- Occurrence analysis
537 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
538 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
539 (pprCoreBindings tagged_binds);
541 -- Get any new rules, and extend the rule base
542 -- See Note [Overall plumbing for rules] in Rules.lhs
543 -- We need to do this regularly, because simplification can
544 -- poke on IdInfo thunks, which in turn brings in new rules
545 -- behind the scenes. Otherwise there's a danger we'll simply
546 -- miss the rules for Ids hidden inside imported inlinings
547 eps <- hscEPS hsc_env ;
548 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
549 ; rule_base2 = extendRuleBaseList rule_base1 rules
550 ; simpl_env = mkSimplEnv sw_chkr mode
551 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
552 simplTopBinds simpl_env tagged_binds
553 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
555 -- Simplify the program
556 -- We do this with a *case* not a *let* because lazy pattern
557 -- matching bit us with bad space leak!
558 -- With a let, we ended up with
563 -- case t of {(_,counts') -> if counts'=0 then ... }
564 -- So the conditional didn't force counts', because the
565 -- selection got duplicated. Sigh!
566 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
567 (env1, counts1) -> do {
569 let { all_counts = counts `plusSimplCount` counts1
570 ; binds1 = getFloats env1
571 ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
574 -- Stop if nothing happened; don't dump output
575 if isZeroSimplCount counts1 then
576 return ("Simplifier reached fixed point", iteration_no, all_counts,
577 guts { mg_binds = binds1, mg_rules = rules1 })
579 -- Short out indirections
580 -- We do this *after* at least one run of the simplifier
581 -- because indirection-shorting uses the export flag on *occurrences*
582 -- and that isn't guaranteed to be ok until after the first run propagates
583 -- stuff from the binding site to its occurrences
585 -- ToDo: alas, this means that indirection-shorting does not happen at all
586 -- if the simplifier does nothing (not common, I know, but unsavoury)
587 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
589 -- Dump the result of this iteration
590 end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
593 do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
596 (us1, us2) = splitUniqSupply us
599 end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
600 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
601 -- Same as endIteration but with simplifier counts
602 end_iteration dflags mode iteration_no max_iterations counts binds rules
603 = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
604 (pprSimplCount counts) ;
606 ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
608 pass_name = "Simplifier mode " ++ showPpr mode ++
609 ", iteration " ++ show iteration_no ++
610 " out of " ++ show max_iterations
614 %************************************************************************
616 Shorting out indirections
618 %************************************************************************
622 x_local = <expression>
626 where x_exported is exported, and x_local is not, then we replace it with this:
628 x_exported = <expression>
632 Without this we never get rid of the x_exported = x_local thing. This
633 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
634 makes strictness information propagate better. This used to happen in
635 the final phase, but it's tidier to do it here.
637 Note [Transferring IdInfo]
638 ~~~~~~~~~~~~~~~~~~~~~~~~~~
639 We want to propagage any useful IdInfo on x_local to x_exported.
641 STRICTNESS: if we have done strictness analysis, we want the strictness info on
642 x_local to transfer to x_exported. Hence the copyIdInfo call.
644 RULES: we want to *add* any RULES for x_local to x_exported.
647 Note [Messing up the exported Id's RULES]
648 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
649 We must be careful about discarding (obviously) or even merging the
650 RULES on the exported Id. The example that went bad on me at one stage
653 iterate :: (a -> a) -> a -> [a]
655 iterate = iterateList
657 iterateFB c f x = x `c` iterateFB c f (f x)
658 iterateList f x = x : iterateList f (f x)
662 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
663 "iterateFB" iterateFB (:) = iterateList
666 This got shorted out to:
668 iterateList :: (a -> a) -> a -> [a]
669 iterateList = iterate
671 iterateFB c f x = x `c` iterateFB c f (f x)
672 iterate f x = x : iterate f (f x)
675 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
676 "iterateFB" iterateFB (:) = iterate
679 And now we get an infinite loop in the rule system
680 iterate f x -> build (\cn -> iterateFB c f x)
685 use rule switching-off pragmas to get rid
686 of iterateList in the first place
688 But in principle the user *might* want rules that only apply to the Id
689 he says. And inline pragmas are similar
693 Then we do not want to get rid of the NOINLINE.
695 Hence hasShortableIdinfo.
698 Note [Rules and indirection-zapping]
699 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
700 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
701 Then the things mentioned can be out of scope! Solution
702 a) Make sure that in this pass the usage-info from x_exported is
703 available for ...bindings...
704 b) If there are any such RULES, rec-ify the entire top-level.
705 It'll get sorted out next time round
709 If more than one exported thing is equal to a local thing (i.e., the
710 local thing really is shared), then we do one only:
713 x_exported1 = x_local
714 x_exported2 = x_local
718 x_exported2 = x_exported1
721 We rely on prior eta reduction to simplify things like
723 x_exported = /\ tyvars -> x_local tyvars
727 Hence,there's a possibility of leaving unchanged something like this:
730 x_exported1 = x_local Int
732 By the time we've thrown away the types in STG land this
733 could be eliminated. But I don't think it's very common
734 and it's dangerous to do this fiddling in STG land
735 because we might elminate a binding that's mentioned in the
736 unfolding for something.
739 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
741 shortOutIndirections :: [CoreBind] -> [CoreBind]
742 shortOutIndirections binds
743 | isEmptyVarEnv ind_env = binds
744 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
745 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
747 ind_env = makeIndEnv binds
748 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
749 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
750 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
751 binds' = concatMap zap binds
753 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
754 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
757 | bndr `elemVarSet` exp_id_set = []
758 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
760 | otherwise = [(bndr,rhs)]
762 makeIndEnv :: [CoreBind] -> IndEnv
764 = foldr add_bind emptyVarEnv binds
766 add_bind :: CoreBind -> IndEnv -> IndEnv
767 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
768 add_bind (Rec pairs) env = foldr add_pair env pairs
770 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
771 add_pair (exported_id, Var local_id) env
772 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
773 add_pair (exported_id, rhs) env
777 shortMeOut ind_env exported_id local_id
778 -- The if-then-else stuff is just so I can get a pprTrace to see
779 -- how often I don't get shorting out becuase of IdInfo stuff
780 = if isExportedId exported_id && -- Only if this is exported
782 isLocalId local_id && -- Only if this one is defined in this
783 -- module, so that we *can* change its
784 -- binding to be the exported thing!
786 not (isExportedId local_id) && -- Only if this one is not itself exported,
787 -- since the transformation will nuke it
789 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
791 if hasShortableIdInfo exported_id
792 then True -- See Note [Messing up the exported Id's IdInfo]
793 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
799 hasShortableIdInfo :: Id -> Bool
800 -- True if there is no user-attached IdInfo on exported_id,
801 -- so we can safely discard it
802 -- See Note [Messing up the exported Id's IdInfo]
803 hasShortableIdInfo id
804 = isEmptySpecInfo (specInfo info)
805 && isDefaultInlinePragma (inlinePragInfo info)
810 transferIdInfo :: Id -> Id -> Id
811 -- See Note [Transferring IdInfo]
813 -- lcl_id = e; exp_id = lcl_id
814 -- and lcl_id has useful IdInfo, we don't want to discard it by going
815 -- gbl_id = e; lcl_id = gbl_id
816 -- Instead, transfer IdInfo from lcl_id to exp_id
817 -- Overwriting, rather than merging, seems to work ok.
818 transferIdInfo exported_id local_id
819 = modifyIdInfo transfer exported_id
821 local_info = idInfo local_id
822 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
823 `setUnfoldingInfo` unfoldingInfo local_info
824 `setInlinePragInfo` inlinePragInfo local_info
825 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
826 new_info = setSpecInfoHead (idName exported_id)
827 (specInfo local_info)
828 -- Remember to set the function-name field of the
829 -- rules as we transfer them from one function to another