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 ANNOTATIONS TO USE
88 ann_env <- prepareAnnotations hsc_env (Just guts)
90 -- COMPUTE THE RULE BASE TO USE
91 (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
93 -- Get the module out of the current HscEnv so we can retrieve it from the monad.
94 -- This is very convienent for the users of the monad (e.g. plugins do not have to
95 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
96 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
97 -- would mean our cached value would go out of date.
98 let mod = mg_module guts
99 (guts2, stats) <- runCoreM hsc_env ann_env hpt_rule_base cp_us mod $ do
100 -- FIND BUILT-IN PASSES
101 let builtin_core_todos = getCoreToDo dflags
104 doCorePasses builtin_core_todos guts1
106 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
107 "Grand total simplifier statistics"
108 (pprSimplCount stats)
113 type CorePass = CoreToDo
115 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
118 -- simplifyExpr is called by the driver to simplify an
119 -- expression typed in at the interactive prompt
121 -- Also used by Template Haskell
122 simplifyExpr dflags expr
124 ; Err.showPass dflags "Simplify"
126 ; us <- mkSplitUniqSupply 's'
128 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
129 simplExprGently simplEnvForGHCi expr
131 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
137 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
138 doCorePasses passes guts = foldM (flip doCorePass) guts passes
140 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
141 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
144 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
145 describePass "Common sub-expression" Opt_D_dump_cse $
148 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
149 describePass "Liberate case" Opt_D_verbose_core2core $
152 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
153 describePass "Float inwards" Opt_D_verbose_core2core $
156 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
157 describePassD (text "Float out" <+> parens (ppr f))
158 Opt_D_verbose_core2core $
159 doPassDUM (floatOutwards f)
161 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
162 describePass "Static argument" Opt_D_verbose_core2core $
165 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
166 describePass "Demand analysis" Opt_D_dump_stranal $
169 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
170 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
173 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
174 describePassR "Specialise" Opt_D_dump_spec $
177 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
178 describePassR "SpecConstr" Opt_D_dump_spec $
181 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
182 describePass "Vectorisation" Opt_D_dump_vect $
185 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
186 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
187 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
189 doCorePass CoreDoNothing = return
190 doCorePass (CoreDoPasses passes) = doCorePasses passes
193 %************************************************************************
195 \subsection{Core pass combinators}
197 %************************************************************************
201 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
202 dontDescribePass = ($)
204 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
205 describePass name dflag pass guts = do
206 dflags <- getDynFlags
208 liftIO $ Err.showPass dflags name
210 liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
214 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
215 describePassD doc = describePass (showSDoc doc)
217 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
218 describePassR name dflag pass guts = do
219 guts' <- describePass name dflag pass guts
220 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
221 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
224 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
226 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
227 ruleCheck current_phase pat guts = do
229 dflags <- getDynFlags
230 liftIO $ Err.showPass dflags "RuleCheck"
231 liftIO $ printDump (ruleCheckProgram current_phase pat rb (mg_binds guts))
235 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
236 doPassDMS do_pass = doPassM $ \binds -> do
237 dflags <- getDynFlags
238 liftIOWithCount $ do_pass dflags binds
240 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
241 doPassDUM do_pass = doPassM $ \binds -> do
242 dflags <- getDynFlags
243 us <- getUniqueSupplyM
244 liftIO $ do_pass dflags us binds
246 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
247 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
249 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
250 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
252 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
253 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
255 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
256 doPassU do_pass = doPassDU (const do_pass)
258 -- Most passes return no stats and don't change rules: these combinators
259 -- let us lift them to the full blown ModGuts+CoreM world
260 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
261 doPassM bind_f guts = do
262 binds' <- bind_f (mg_binds guts)
263 return (guts { mg_binds = binds' })
265 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
266 doPassMG bind_f guts = do
267 binds' <- bind_f guts
268 return (guts { mg_binds = binds' })
270 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
271 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
273 -- Observer passes just peek; don't modify the bindings at all
274 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
275 observe do_pass = doPassM $ \binds -> do
276 dflags <- getDynFlags
277 liftIO $ do_pass dflags binds
282 %************************************************************************
286 %************************************************************************
288 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
289 -- It attaches those rules that are for local Ids to their binders, and
290 -- returns the remainder attached to Ids in an IdSet.
293 prepareRules :: HscEnv
296 -> IO (RuleBase, -- Rule base for imported things, incl
297 -- (a) rules defined in this module (orphans)
298 -- (b) rules from other modules in home package
299 -- but not things from other packages
301 ModGuts) -- Modified fields are
302 -- (a) Bindings have rules attached,
303 -- and INLINE rules simplified
304 -- (b) Rules are now just orphan rules
306 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
307 guts@(ModGuts { mg_binds = binds, mg_deps = deps
308 , mg_rules = local_rules, mg_rdr_env = rdr_env })
310 = do { us <- mkSplitUniqSupply 'w'
312 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
313 -- from the local binders, to avoid warnings from Simplify.simplVar
314 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
315 env = setInScopeSet simplEnvForRules local_ids
316 (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
317 mapM (simplRule env) local_rules
319 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
321 home_pkg_rules = hptRules hsc_env (dep_mods deps)
322 hpt_rule_base = mkRuleBase home_pkg_rules
323 binds_w_rules = updateBinders rules_for_locals binds
326 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
327 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
328 vcat [text "Local rules", pprRules simpl_rules,
330 text "Imported rules", pprRuleBase hpt_rule_base])
332 ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
333 mg_rules = rules_for_imps })
336 -- Note [Attach rules to local ids]
337 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
338 -- Find the rules for locally-defined Ids; then we can attach them
339 -- to the binders in the top-level bindings
342 -- - It makes the rules easier to look up
343 -- - It means that transformation rules and specialisations for
344 -- locally defined Ids are handled uniformly
345 -- - It keeps alive things that are referred to only from a rule
346 -- (the occurrence analyser knows about rules attached to Ids)
347 -- - It makes sure that, when we apply a rule, the free vars
348 -- of the RHS are more likely to be in scope
349 -- - The imported rules are carried in the in-scope set
350 -- which is extended on each iteration by the new wave of
351 -- local binders; any rules which aren't on the binding will
352 -- thereby get dropped
354 updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
355 updateBinders rules_for_locals binds
356 = map update_bind binds
358 local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
360 update_bind (NonRec b r) = NonRec (add_rules b) r
361 update_bind (Rec prs) = Rec (mapFst add_rules prs)
363 -- See Note [Attach rules to local ids]
364 -- NB: the binder might have some existing rules,
365 -- arising from specialisation pragmas
367 | Just rules <- lookupNameEnv local_rules (idName bndr)
368 = bndr `addIdSpecialisations` rules
373 Note [Simplifying the left-hand side of a RULE]
374 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
375 We must do some gentle simplification on the lhs (template) of each
376 rule. The case that forced me to add this was the fold/build rule,
377 which without simplification looked like:
378 fold k z (build (/\a. g a)) ==> ...
379 This doesn't match unless you do eta reduction on the build argument.
380 Similarly for a LHS like
382 we do not want to get
383 augment (\a. g a) (build h)
384 otherwise we don't match when given an argument like
385 augment (\a. h a a) (build h)
387 The simplifier does indeed do eta reduction (it's in
388 Simplify.completeLam) but only if -O is on.
391 simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
392 simplRule env rule@(BuiltinRule {})
394 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
395 = do (env, bndrs') <- simplBinders env bndrs
396 args' <- mapM (simplExprGently env) args
397 rhs' <- simplExprGently env rhs
398 return (rule { ru_bndrs = bndrs', ru_args = args'
399 , ru_rhs = occurAnalyseExpr rhs' })
403 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
404 -- Simplifies an expression
405 -- does occurrence analysis, then simplification
406 -- and repeats (twice currently) because one pass
407 -- alone leaves tons of crud.
408 -- Used (a) for user expressions typed in at the interactive prompt
409 -- (b) the LHS and RHS of a RULE
410 -- (c) Template Haskell splices
412 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
413 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
414 -- enforce that; it just simplifies the expression twice
416 -- It's important that simplExprGently does eta reduction; see
417 -- Note [Simplifying the left-hand side of a RULE] above. The
418 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
419 -- but only if -O is on.
421 simplExprGently env expr = do
422 expr1 <- simplExpr env (occurAnalyseExpr expr)
423 simplExpr env (occurAnalyseExpr expr1)
427 %************************************************************************
429 \subsection{Glomming}
431 %************************************************************************
434 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
435 -- Glom all binds together in one Rec, in case any
436 -- transformations have introduced any new dependencies
438 -- NB: the global invariant is this:
439 -- *** the top level bindings are never cloned, and are always unique ***
441 -- We sort them into dependency order, but applying transformation rules may
442 -- make something at the top refer to something at the bottom:
446 -- RULE: p (q x) = h x
448 -- Applying this rule makes f refer to h,
449 -- although it doesn't appear to in the source program.
450 -- This pass lets us control where it happens.
452 -- NOTICE that this cannot happen for rules whose head is a locally-defined
453 -- function. It only happens for rules whose head is an imported function
454 -- (p in the example above). So, for example, the rule had been
455 -- RULE: f (p x) = h x
456 -- then the rule for f would be attached to f itself (in its IdInfo)
457 -- by prepareLocalRuleBase and h would be regarded by the occurrency
458 -- analyser as free in f.
460 glomBinds dflags binds
461 = do { Err.showPass dflags "GlomBinds" ;
462 let { recd_binds = [Rec (flattenBinds binds)] } ;
464 -- Not much point in printing the result...
465 -- just consumes output bandwidth
469 %************************************************************************
471 \subsection{The driver for the simplifier}
473 %************************************************************************
476 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
477 simplifyPgm mode switches
478 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
479 do { hsc_env <- getHscEnv
480 ; us <- getUniqueSupplyM
483 simplifyPgmIO mode switches hsc_env us rb guts }
485 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
487 simplifyPgmIO :: SimplifierMode
488 -> [SimplifierSwitch]
493 -> IO (SimplCount, ModGuts) -- New bindings
495 simplifyPgmIO mode switches hsc_env us hpt_rule_base
496 guts@(ModGuts { mg_binds = binds, mg_rules = rules
497 , mg_fam_inst_env = fam_inst_env })
499 (termination_msg, it_count, counts_out, guts')
500 <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
502 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
503 "Simplifier statistics for following pass"
504 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
506 pprSimplCount counts_out]);
508 return (counts_out, guts')
511 dflags = hsc_dflags hsc_env
512 dump_phase = shouldDumpSimplPhase dflags mode
514 sw_chkr = isAmongSimpl switches
515 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
517 do_iteration :: UniqSupply
518 -> Int -- Counts iterations
519 -> SimplCount -- Logs optimisations performed
520 -> [CoreBind] -- Bindings in
521 -> [CoreRule] -- and orphan rules
522 -> IO (String, Int, SimplCount, ModGuts)
524 do_iteration us iteration_no counts binds rules
525 -- iteration_no is the number of the iteration we are
526 -- about to begin, with '1' for the first
527 | iteration_no > max_iterations -- Stop if we've run out of iterations
528 = WARN(debugIsOn && (max_iterations > 2),
529 text ("Simplifier still going after " ++
530 show max_iterations ++
531 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
532 -- Subtract 1 from iteration_no to get the
533 -- number of iterations we actually completed
534 return ("Simplifier bailed out", iteration_no - 1, counts,
535 guts { mg_binds = binds, mg_rules = rules })
537 -- Try and force thunks off the binds; significantly reduces
538 -- space usage, especially with -O. JRS, 000620.
539 | let sz = coreBindsSize binds in sz == sz
541 -- Occurrence analysis
542 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
543 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
544 (pprCoreBindings tagged_binds);
546 -- Get any new rules, and extend the rule base
547 -- We need to do this regularly, because simplification can
548 -- poke on IdInfo thunks, which in turn brings in new rules
549 -- behind the scenes. Otherwise there's a danger we'll simply
550 -- miss the rules for Ids hidden inside imported inlinings
551 eps <- hscEPS hsc_env ;
552 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
553 ; rule_base2 = extendRuleBaseList rule_base1 rules
554 ; simpl_env = mkSimplEnv sw_chkr mode
555 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
556 simplTopBinds simpl_env tagged_binds
557 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
559 -- Simplify the program
560 -- We do this with a *case* not a *let* because lazy pattern
561 -- matching bit us with bad space leak!
562 -- With a let, we ended up with
567 -- case t of {(_,counts') -> if counts'=0 then ... }
568 -- So the conditional didn't force counts', because the
569 -- selection got duplicated. Sigh!
570 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
571 (env1, counts1) -> do {
573 let { all_counts = counts `plusSimplCount` counts1
574 ; binds1 = getFloats env1
575 ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
578 -- Stop if nothing happened; don't dump output
579 if isZeroSimplCount counts1 then
580 return ("Simplifier reached fixed point", iteration_no, all_counts,
581 guts { mg_binds = binds1, mg_rules = rules1 })
583 -- Short out indirections
584 -- We do this *after* at least one run of the simplifier
585 -- because indirection-shorting uses the export flag on *occurrences*
586 -- and that isn't guaranteed to be ok until after the first run propagates
587 -- stuff from the binding site to its occurrences
589 -- ToDo: alas, this means that indirection-shorting does not happen at all
590 -- if the simplifier does nothing (not common, I know, but unsavoury)
591 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
593 -- Dump the result of this iteration
594 end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
597 do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
600 (us1, us2) = splitUniqSupply us
603 end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
604 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
605 -- Same as endIteration but with simplifier counts
606 end_iteration dflags mode iteration_no max_iterations counts binds rules
607 = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
608 (pprSimplCount counts) ;
610 ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
612 pass_name = "Simplifier mode " ++ showPpr mode ++
613 ", iteration " ++ show iteration_no ++
614 " out of " ++ show max_iterations
618 %************************************************************************
620 Shorting out indirections
622 %************************************************************************
626 x_local = <expression>
630 where x_exported is exported, and x_local is not, then we replace it with this:
632 x_exported = <expression>
636 Without this we never get rid of the x_exported = x_local thing. This
637 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
638 makes strictness information propagate better. This used to happen in
639 the final phase, but it's tidier to do it here.
641 Note [Transferring IdInfo]
642 ~~~~~~~~~~~~~~~~~~~~~~~~~~
643 We want to propagage any useful IdInfo on x_local to x_exported.
645 STRICTNESS: if we have done strictness analysis, we want the strictness info on
646 x_local to transfer to x_exported. Hence the copyIdInfo call.
648 RULES: we want to *add* any RULES for x_local to x_exported.
651 Note [Messing up the exported Id's RULES]
652 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
653 We must be careful about discarding (obviously) or even merging the
654 RULES on the exported Id. The example that went bad on me at one stage
657 iterate :: (a -> a) -> a -> [a]
659 iterate = iterateList
661 iterateFB c f x = x `c` iterateFB c f (f x)
662 iterateList f x = x : iterateList f (f x)
666 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
667 "iterateFB" iterateFB (:) = iterateList
670 This got shorted out to:
672 iterateList :: (a -> a) -> a -> [a]
673 iterateList = iterate
675 iterateFB c f x = x `c` iterateFB c f (f x)
676 iterate f x = x : iterate f (f x)
679 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
680 "iterateFB" iterateFB (:) = iterate
683 And now we get an infinite loop in the rule system
684 iterate f x -> build (\cn -> iterateFB c f x)
689 use rule switching-off pragmas to get rid
690 of iterateList in the first place
692 But in principle the user *might* want rules that only apply to the Id
693 he says. And inline pragmas are similar
697 Then we do not want to get rid of the NOINLINE.
699 Hence hasShortableIdinfo.
702 Note [Rules and indirection-zapping]
703 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
704 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
705 Then the things mentioned can be out of scope! Solution
706 a) Make sure that in this pass the usage-info from x_exported is
707 available for ...bindings...
708 b) If there are any such RULES, rec-ify the entire top-level.
709 It'll get sorted out next time round
713 If more than one exported thing is equal to a local thing (i.e., the
714 local thing really is shared), then we do one only:
717 x_exported1 = x_local
718 x_exported2 = x_local
722 x_exported2 = x_exported1
725 We rely on prior eta reduction to simplify things like
727 x_exported = /\ tyvars -> x_local tyvars
731 Hence,there's a possibility of leaving unchanged something like this:
734 x_exported1 = x_local Int
736 By the time we've thrown away the types in STG land this
737 could be eliminated. But I don't think it's very common
738 and it's dangerous to do this fiddling in STG land
739 because we might elminate a binding that's mentioned in the
740 unfolding for something.
743 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
745 shortOutIndirections :: [CoreBind] -> [CoreBind]
746 shortOutIndirections binds
747 | isEmptyVarEnv ind_env = binds
748 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
749 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
751 ind_env = makeIndEnv binds
752 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
753 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
754 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
755 binds' = concatMap zap binds
757 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
758 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
761 | bndr `elemVarSet` exp_id_set = []
762 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
764 | otherwise = [(bndr,rhs)]
766 makeIndEnv :: [CoreBind] -> IndEnv
768 = foldr add_bind emptyVarEnv binds
770 add_bind :: CoreBind -> IndEnv -> IndEnv
771 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
772 add_bind (Rec pairs) env = foldr add_pair env pairs
774 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
775 add_pair (exported_id, Var local_id) env
776 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
777 add_pair (exported_id, rhs) env
781 shortMeOut ind_env exported_id local_id
782 -- The if-then-else stuff is just so I can get a pprTrace to see
783 -- how often I don't get shorting out becuase of IdInfo stuff
784 = if isExportedId exported_id && -- Only if this is exported
786 isLocalId local_id && -- Only if this one is defined in this
787 -- module, so that we *can* change its
788 -- binding to be the exported thing!
790 not (isExportedId local_id) && -- Only if this one is not itself exported,
791 -- since the transformation will nuke it
793 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
795 if hasShortableIdInfo exported_id
796 then True -- See Note [Messing up the exported Id's IdInfo]
797 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
803 hasShortableIdInfo :: Id -> Bool
804 -- True if there is no user-attached IdInfo on exported_id,
805 -- so we can safely discard it
806 -- See Note [Messing up the exported Id's IdInfo]
807 hasShortableIdInfo id
808 = isEmptySpecInfo (specInfo info)
809 && isDefaultInlinePragma (inlinePragInfo info)
814 transferIdInfo :: Id -> Id -> Id
815 -- See Note [Transferring IdInfo]
817 -- lcl_id = e; exp_id = lcl_id
818 -- and lcl_id has useful IdInfo, we don't want to discard it by going
819 -- gbl_id = e; lcl_id = gbl_id
820 -- Instead, transfer IdInfo from lcl_id to exp_id
821 -- Overwriting, rather than merging, seems to work ok.
822 transferIdInfo exported_id local_id
823 = modifyIdInfo transfer exported_id
825 local_info = idInfo local_id
826 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
827 `setUnfoldingInfo` unfoldingInfo local_info
828 `setInlinePragInfo` inlinePragInfo local_info
829 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
830 new_info = setSpecInfoHead (idName exported_id)
831 (specInfo local_info)
832 -- Remember to set the function-name field of the
833 -- rules as we transfer them from one function to another