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 (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
90 -- Get the module out of the current HscEnv so we can retrieve it from the monad.
91 -- This is very convienent for the users of the monad (e.g. plugins do not have to
92 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
93 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
94 -- would mean our cached value would go out of date.
95 let mod = mg_module guts
96 (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do
97 -- FIND BUILT-IN PASSES
98 let builtin_core_todos = getCoreToDo dflags
101 doCorePasses builtin_core_todos guts1
103 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
104 "Grand total simplifier statistics"
105 (pprSimplCount stats)
110 type CorePass = CoreToDo
112 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
115 -- simplifyExpr is called by the driver to simplify an
116 -- expression typed in at the interactive prompt
118 -- Also used by Template Haskell
119 simplifyExpr dflags expr
121 ; Err.showPass dflags "Simplify"
123 ; us <- mkSplitUniqSupply 's'
125 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
126 simplExprGently simplEnvForGHCi expr
128 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
134 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
135 doCorePasses passes guts = foldM (flip doCorePass) guts passes
137 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
138 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
141 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
142 describePass "Common sub-expression" Opt_D_dump_cse $
145 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
146 describePass "Liberate case" Opt_D_verbose_core2core $
149 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
150 describePass "Float inwards" Opt_D_verbose_core2core $
153 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
154 describePassD (text "Float out" <+> parens (ppr f))
155 Opt_D_verbose_core2core $
156 doPassDUM (floatOutwards f)
158 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
159 describePass "Static argument" Opt_D_verbose_core2core $
162 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
163 describePass "Demand analysis" Opt_D_dump_stranal $
166 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
167 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
170 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
171 describePassR "Specialise" Opt_D_dump_spec $
174 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
175 describePassR "SpecConstr" Opt_D_dump_spec $
178 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
179 describePass "Vectorisation" Opt_D_dump_vect $
182 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
183 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
184 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
186 doCorePass CoreDoNothing = return
187 doCorePass (CoreDoPasses passes) = doCorePasses passes
190 %************************************************************************
192 \subsection{Core pass combinators}
194 %************************************************************************
198 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
199 dontDescribePass = ($)
201 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
202 describePass name dflag pass guts = do
203 dflags <- getDynFlags
205 liftIO $ Err.showPass dflags name
207 liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
211 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
212 describePassD doc = describePass (showSDoc doc)
214 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
215 describePassR name dflag pass guts = do
216 guts' <- describePass name dflag pass guts
217 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
218 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
221 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
223 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
224 ruleCheck current_phase pat guts = do
226 dflags <- getDynFlags
227 liftIO $ Err.showPass dflags "RuleCheck"
228 liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
232 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
233 doPassDMS do_pass = doPassM $ \binds -> do
234 dflags <- getDynFlags
235 liftIOWithCount $ do_pass dflags binds
237 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
238 doPassDUM do_pass = doPassM $ \binds -> do
239 dflags <- getDynFlags
240 us <- getUniqueSupplyM
241 liftIO $ do_pass dflags us binds
243 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
244 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
246 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
247 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
249 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
250 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
252 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
253 doPassU do_pass = doPassDU (const do_pass)
255 -- Most passes return no stats and don't change rules: these combinators
256 -- let us lift them to the full blown ModGuts+CoreM world
257 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
258 doPassM bind_f guts = do
259 binds' <- bind_f (mg_binds guts)
260 return (guts { mg_binds = binds' })
262 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
263 doPassMG bind_f guts = do
264 binds' <- bind_f guts
265 return (guts { mg_binds = binds' })
267 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
268 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
270 -- Observer passes just peek; don't modify the bindings at all
271 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
272 observe do_pass = doPassM $ \binds -> do
273 dflags <- getDynFlags
274 liftIO $ do_pass dflags binds
279 %************************************************************************
283 %************************************************************************
285 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
286 -- It attaches those rules that are for local Ids to their binders, and
287 -- returns the remainder attached to Ids in an IdSet.
290 prepareRules :: HscEnv
293 -> IO (RuleBase, -- Rule base for imported things, incl
294 -- (a) rules defined in this module (orphans)
295 -- (b) rules from other modules in home package
296 -- but not things from other packages
298 ModGuts) -- Modified fields are
299 -- (a) Bindings have rules attached,
300 -- and INLINE rules simplified
301 -- (b) Rules are now just orphan rules
303 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
304 guts@(ModGuts { mg_binds = binds, mg_deps = deps
305 , mg_rules = local_rules, mg_rdr_env = rdr_env })
307 = do { us <- mkSplitUniqSupply 'w'
309 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
310 -- from the local binders, to avoid warnings from Simplify.simplVar
311 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
312 env = setInScopeSet simplEnvForRules local_ids
313 (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
314 mapM (simplRule env) local_rules
316 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
318 home_pkg_rules = hptRules hsc_env (dep_mods deps)
319 hpt_rule_base = mkRuleBase home_pkg_rules
320 binds_w_rules = updateBinders rules_for_locals binds
323 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
324 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
325 vcat [text "Local rules", pprRules simpl_rules,
327 text "Imported rules", pprRuleBase hpt_rule_base])
329 ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
330 mg_rules = rules_for_imps })
333 -- Note [Attach rules to local ids]
334 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
335 -- Find the rules for locally-defined Ids; then we can attach them
336 -- to the binders in the top-level bindings
339 -- - It makes the rules easier to look up
340 -- - It means that transformation rules and specialisations for
341 -- locally defined Ids are handled uniformly
342 -- - It keeps alive things that are referred to only from a rule
343 -- (the occurrence analyser knows about rules attached to Ids)
344 -- - It makes sure that, when we apply a rule, the free vars
345 -- of the RHS are more likely to be in scope
346 -- - The imported rules are carried in the in-scope set
347 -- which is extended on each iteration by the new wave of
348 -- local binders; any rules which aren't on the binding will
349 -- thereby get dropped
351 updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
352 updateBinders rules_for_locals binds
353 = map update_bind binds
355 local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
357 update_bind (NonRec b r) = NonRec (add_rules b) r
358 update_bind (Rec prs) = Rec (mapFst add_rules prs)
360 -- See Note [Attach rules to local ids]
361 -- NB: the binder might have some existing rules,
362 -- arising from specialisation pragmas
364 | Just rules <- lookupNameEnv local_rules (idName bndr)
365 = bndr `addIdSpecialisations` rules
370 Note [Simplifying the left-hand side of a RULE]
371 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
372 We must do some gentle simplification on the lhs (template) of each
373 rule. The case that forced me to add this was the fold/build rule,
374 which without simplification looked like:
375 fold k z (build (/\a. g a)) ==> ...
376 This doesn't match unless you do eta reduction on the build argument.
377 Similarly for a LHS like
379 we do not want to get
380 augment (\a. g a) (build h)
381 otherwise we don't match when given an argument like
382 augment (\a. h a a) (build h)
384 The simplifier does indeed do eta reduction (it's in
385 Simplify.completeLam) but only if -O is on.
388 simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
389 simplRule env rule@(BuiltinRule {})
391 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
392 = do (env, bndrs') <- simplBinders env bndrs
393 args' <- mapM (simplExprGently env) args
394 rhs' <- simplExprGently env rhs
395 return (rule { ru_bndrs = bndrs', ru_args = args'
396 , ru_rhs = occurAnalyseExpr rhs' })
400 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
401 -- Simplifies an expression
402 -- does occurrence analysis, then simplification
403 -- and repeats (twice currently) because one pass
404 -- alone leaves tons of crud.
405 -- Used (a) for user expressions typed in at the interactive prompt
406 -- (b) the LHS and RHS of a RULE
407 -- (c) Template Haskell splices
409 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
410 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
411 -- enforce that; it just simplifies the expression twice
413 -- It's important that simplExprGently does eta reduction; see
414 -- Note [Simplifying the left-hand side of a RULE] above. The
415 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
416 -- but only if -O is on.
418 simplExprGently env expr = do
419 expr1 <- simplExpr env (occurAnalyseExpr expr)
420 simplExpr env (occurAnalyseExpr expr1)
424 %************************************************************************
426 \subsection{Glomming}
428 %************************************************************************
431 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
432 -- Glom all binds together in one Rec, in case any
433 -- transformations have introduced any new dependencies
435 -- NB: the global invariant is this:
436 -- *** the top level bindings are never cloned, and are always unique ***
438 -- We sort them into dependency order, but applying transformation rules may
439 -- make something at the top refer to something at the bottom:
443 -- RULE: p (q x) = h x
445 -- Applying this rule makes f refer to h,
446 -- although it doesn't appear to in the source program.
447 -- This pass lets us control where it happens.
449 -- NOTICE that this cannot happen for rules whose head is a locally-defined
450 -- function. It only happens for rules whose head is an imported function
451 -- (p in the example above). So, for example, the rule had been
452 -- RULE: f (p x) = h x
453 -- then the rule for f would be attached to f itself (in its IdInfo)
454 -- by prepareLocalRuleBase and h would be regarded by the occurrency
455 -- analyser as free in f.
457 glomBinds dflags binds
458 = do { Err.showPass dflags "GlomBinds" ;
459 let { recd_binds = [Rec (flattenBinds binds)] } ;
461 -- Not much point in printing the result...
462 -- just consumes output bandwidth
466 %************************************************************************
468 \subsection{The driver for the simplifier}
470 %************************************************************************
473 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
474 simplifyPgm mode switches
475 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
476 do { hsc_env <- getHscEnv
477 ; us <- getUniqueSupplyM
480 simplifyPgmIO mode switches hsc_env us rb guts }
482 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
484 simplifyPgmIO :: SimplifierMode
485 -> [SimplifierSwitch]
490 -> IO (SimplCount, ModGuts) -- New bindings
492 simplifyPgmIO mode switches hsc_env us hpt_rule_base
493 guts@(ModGuts { mg_binds = binds, mg_rules = rules
494 , mg_fam_inst_env = fam_inst_env })
496 (termination_msg, it_count, counts_out, guts')
497 <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
499 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
500 "Simplifier statistics for following pass"
501 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
503 pprSimplCount counts_out]);
505 return (counts_out, guts')
508 dflags = hsc_dflags hsc_env
509 dump_phase = shouldDumpSimplPhase dflags mode
511 sw_chkr = isAmongSimpl switches
512 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
514 do_iteration :: UniqSupply
515 -> Int -- Counts iterations
516 -> SimplCount -- Logs optimisations performed
517 -> [CoreBind] -- Bindings in
518 -> [CoreRule] -- and orphan rules
519 -> IO (String, Int, SimplCount, ModGuts)
521 do_iteration us iteration_no counts binds rules
522 -- iteration_no is the number of the iteration we are
523 -- about to begin, with '1' for the first
524 | iteration_no > max_iterations -- Stop if we've run out of iterations
525 = WARN(debugIsOn && (max_iterations > 2),
526 text ("Simplifier still going after " ++
527 show max_iterations ++
528 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
529 -- Subtract 1 from iteration_no to get the
530 -- number of iterations we actually completed
531 return ("Simplifier bailed out", iteration_no - 1, counts,
532 guts { mg_binds = binds, mg_rules = rules })
534 -- Try and force thunks off the binds; significantly reduces
535 -- space usage, especially with -O. JRS, 000620.
536 | let sz = coreBindsSize binds in sz == sz
538 -- Occurrence analysis
539 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
540 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
541 (pprCoreBindings tagged_binds);
543 -- Get any new rules, and extend the rule base
544 -- We need to do this regularly, because simplification can
545 -- poke on IdInfo thunks, which in turn brings in new rules
546 -- behind the scenes. Otherwise there's a danger we'll simply
547 -- miss the rules for Ids hidden inside imported inlinings
548 eps <- hscEPS hsc_env ;
549 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
550 ; rule_base2 = extendRuleBaseList rule_base1 rules
551 ; simpl_env = mkSimplEnv sw_chkr mode
552 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
553 simplTopBinds simpl_env tagged_binds
554 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
556 -- Simplify the program
557 -- We do this with a *case* not a *let* because lazy pattern
558 -- matching bit us with bad space leak!
559 -- With a let, we ended up with
564 -- case t of {(_,counts') -> if counts'=0 then ... }
565 -- So the conditional didn't force counts', because the
566 -- selection got duplicated. Sigh!
567 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
568 (env1, counts1) -> do {
570 let { all_counts = counts `plusSimplCount` counts1
571 ; binds1 = getFloats env1
572 ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
575 -- Stop if nothing happened; don't dump output
576 if isZeroSimplCount counts1 then
577 return ("Simplifier reached fixed point", iteration_no, all_counts,
578 guts { mg_binds = binds1, mg_rules = rules1 })
580 -- Short out indirections
581 -- We do this *after* at least one run of the simplifier
582 -- because indirection-shorting uses the export flag on *occurrences*
583 -- and that isn't guaranteed to be ok until after the first run propagates
584 -- stuff from the binding site to its occurrences
586 -- ToDo: alas, this means that indirection-shorting does not happen at all
587 -- if the simplifier does nothing (not common, I know, but unsavoury)
588 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
590 -- Dump the result of this iteration
591 end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
594 do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
597 (us1, us2) = splitUniqSupply us
600 end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
601 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
602 -- Same as endIteration but with simplifier counts
603 end_iteration dflags mode iteration_no max_iterations counts binds rules
604 = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
605 (pprSimplCount counts) ;
607 ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
609 pass_name = "Simplifier mode " ++ showPpr mode ++
610 ", iteration " ++ show iteration_no ++
611 " out of " ++ show max_iterations
615 %************************************************************************
617 Shorting out indirections
619 %************************************************************************
623 x_local = <expression>
627 where x_exported is exported, and x_local is not, then we replace it with this:
629 x_exported = <expression>
633 Without this we never get rid of the x_exported = x_local thing. This
634 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
635 makes strictness information propagate better. This used to happen in
636 the final phase, but it's tidier to do it here.
638 Note [Transferring IdInfo]
639 ~~~~~~~~~~~~~~~~~~~~~~~~~~
640 We want to propagage any useful IdInfo on x_local to x_exported.
642 STRICTNESS: if we have done strictness analysis, we want the strictness info on
643 x_local to transfer to x_exported. Hence the copyIdInfo call.
645 RULES: we want to *add* any RULES for x_local to x_exported.
648 Note [Messing up the exported Id's RULES]
649 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
650 We must be careful about discarding (obviously) or even merging the
651 RULES on the exported Id. The example that went bad on me at one stage
654 iterate :: (a -> a) -> a -> [a]
656 iterate = iterateList
658 iterateFB c f x = x `c` iterateFB c f (f x)
659 iterateList f x = x : iterateList f (f x)
663 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
664 "iterateFB" iterateFB (:) = iterateList
667 This got shorted out to:
669 iterateList :: (a -> a) -> a -> [a]
670 iterateList = iterate
672 iterateFB c f x = x `c` iterateFB c f (f x)
673 iterate f x = x : iterate f (f x)
676 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
677 "iterateFB" iterateFB (:) = iterate
680 And now we get an infinite loop in the rule system
681 iterate f x -> build (\cn -> iterateFB c f x)
686 use rule switching-off pragmas to get rid
687 of iterateList in the first place
689 But in principle the user *might* want rules that only apply to the Id
690 he says. And inline pragmas are similar
694 Then we do not want to get rid of the NOINLINE.
696 Hence hasShortableIdinfo.
699 Note [Rules and indirection-zapping]
700 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
701 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
702 Then the things mentioned can be out of scope! Solution
703 a) Make sure that in this pass the usage-info from x_exported is
704 available for ...bindings...
705 b) If there are any such RULES, rec-ify the entire top-level.
706 It'll get sorted out next time round
710 If more than one exported thing is equal to a local thing (i.e., the
711 local thing really is shared), then we do one only:
714 x_exported1 = x_local
715 x_exported2 = x_local
719 x_exported2 = x_exported1
722 We rely on prior eta reduction to simplify things like
724 x_exported = /\ tyvars -> x_local tyvars
728 Hence,there's a possibility of leaving unchanged something like this:
731 x_exported1 = x_local Int
733 By the time we've thrown away the types in STG land this
734 could be eliminated. But I don't think it's very common
735 and it's dangerous to do this fiddling in STG land
736 because we might elminate a binding that's mentioned in the
737 unfolding for something.
740 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
742 shortOutIndirections :: [CoreBind] -> [CoreBind]
743 shortOutIndirections binds
744 | isEmptyVarEnv ind_env = binds
745 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
746 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
748 ind_env = makeIndEnv binds
749 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
750 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
751 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
752 binds' = concatMap zap binds
754 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
755 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
758 | bndr `elemVarSet` exp_id_set = []
759 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
761 | otherwise = [(bndr,rhs)]
763 makeIndEnv :: [CoreBind] -> IndEnv
765 = foldr add_bind emptyVarEnv binds
767 add_bind :: CoreBind -> IndEnv -> IndEnv
768 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
769 add_bind (Rec pairs) env = foldr add_pair env pairs
771 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
772 add_pair (exported_id, Var local_id) env
773 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
774 add_pair (exported_id, rhs) env
778 shortMeOut ind_env exported_id local_id
779 -- The if-then-else stuff is just so I can get a pprTrace to see
780 -- how often I don't get shorting out becuase of IdInfo stuff
781 = if isExportedId exported_id && -- Only if this is exported
783 isLocalId local_id && -- Only if this one is defined in this
784 -- module, so that we *can* change its
785 -- binding to be the exported thing!
787 not (isExportedId local_id) && -- Only if this one is not itself exported,
788 -- since the transformation will nuke it
790 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
792 if hasShortableIdInfo exported_id
793 then True -- See Note [Messing up the exported Id's IdInfo]
794 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
800 hasShortableIdInfo :: Id -> Bool
801 -- True if there is no user-attached IdInfo on exported_id,
802 -- so we can safely discard it
803 -- See Note [Messing up the exported Id's IdInfo]
804 hasShortableIdInfo id
805 = isEmptySpecInfo (specInfo info)
806 && isDefaultInlinePragma (inlinePragInfo info)
811 transferIdInfo :: Id -> Id -> Id
812 -- See Note [Transferring IdInfo]
814 -- lcl_id = e; exp_id = lcl_id
815 -- and lcl_id has useful IdInfo, we don't want to discard it by going
816 -- gbl_id = e; lcl_id = gbl_id
817 -- Instead, transfer IdInfo from lcl_id to exp_id
818 -- Overwriting, rather than merging, seems to work ok.
819 transferIdInfo exported_id local_id
820 = modifyIdInfo transfer exported_id
822 local_info = idInfo local_id
823 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
824 `setUnfoldingInfo` unfoldingInfo local_info
825 `setInlinePragInfo` inlinePragInfo local_info
826 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
827 new_info = setSpecInfoHead (idName exported_id)
828 (specInfo local_info)
829 -- Remember to set the function-name field of the
830 -- rules as we transfer them from one function to another