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 )
23 import CSE ( cseProgram )
24 import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
25 extendRuleBaseList, pprRuleBase, pprRulesForUser,
26 ruleCheckProgram, rulesOfBinds,
27 addSpecInfo, addIdSpecialisations )
28 import PprCore ( pprCoreBindings, pprCoreExpr, pprRules )
29 import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
31 import CoreUtils ( coreBindsSize )
32 import Simplify ( simplTopBinds, simplExpr )
33 import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
36 import qualified ErrUtils as Err ( dumpIfSet_dyn, dumpIfSet, showPass )
37 import CoreLint ( showPass, endPass, endPassIf, endIteration )
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 )
56 import StrictAnal ( saBinds )
57 import CprAnalyse ( cprAnalyse )
59 import Vectorise ( vectorise )
63 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
64 import IO ( hPutStr, stderr )
67 import List ( partition, intersperse )
71 %************************************************************************
73 \subsection{The driver for the simplifier}
75 %************************************************************************
82 core2core hsc_env guts = do
83 let dflags = hsc_dflags hsc_env
85 us <- mkSplitUniqSupply 's'
86 let (cp_us, ru_us) = splitUniqSupply us
88 -- COMPUTE THE ANNOTATIONS TO USE
89 ann_env <- prepareAnnotations hsc_env (Just guts)
91 -- COMPUTE THE RULE BASE TO USE
92 (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us
94 -- Get the module out of the current HscEnv so we can retrieve it from the monad.
95 -- This is very convienent for the users of the monad (e.g. plugins do not have to
96 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
97 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
98 -- would mean our cached value would go out of date.
99 let mod = mg_module guts
100 (guts2, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
101 -- FIND BUILT-IN PASSES
102 let builtin_core_todos = getCoreToDo dflags
105 doCorePasses builtin_core_todos guts1
107 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
108 "Grand total simplifier statistics"
109 (pprSimplCount stats)
114 type CorePass = CoreToDo
116 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
119 -- simplifyExpr is called by the driver to simplify an
120 -- expression typed in at the interactive prompt
121 simplifyExpr dflags expr
123 ; Err.showPass dflags "Simplify"
125 ; us <- mkSplitUniqSupply 's'
127 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
128 simplExprGently gentleSimplEnv expr
130 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
136 gentleSimplEnv :: SimplEnv
137 gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
139 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
140 doCorePasses passes guts = foldM (flip doCorePass) guts passes
142 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
143 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
146 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
147 describePass "Common sub-expression" Opt_D_dump_cse $
150 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
151 describePass "Liberate case" Opt_D_verbose_core2core $
154 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
155 describePass "Float inwards" Opt_D_verbose_core2core $
158 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
159 describePassD (text "Float out" <+> parens (ppr f))
160 Opt_D_verbose_core2core $
161 doPassDUM (floatOutwards f)
163 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
164 describePass "Static argument" Opt_D_verbose_core2core $
167 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
168 describePass "Demand analysis" Opt_D_dump_stranal $
171 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
172 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
175 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
176 describePassR "Specialise" Opt_D_dump_spec $
179 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
180 describePassR "SpecConstr" Opt_D_dump_spec $
181 doPassDU specConstrProgram
183 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
184 describePass "Vectorisation" Opt_D_dump_vect $
187 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
188 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
189 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
191 #ifdef OLD_STRICTNESS
192 doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness
195 doCorePass CoreDoNothing = return
196 doCorePass (CoreDoPasses passes) = doCorePasses passes
198 #ifdef OLD_STRICTNESS
199 doOldStrictness :: ModGuts -> CoreM ModGuts
201 = do dfs <- getDynFlags
202 guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $
203 doPassM (saBinds dfs) guts
204 guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $
205 doPass cprAnalyse guts'
211 %************************************************************************
213 \subsection{Core pass combinators}
215 %************************************************************************
219 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
220 dontDescribePass = ($)
222 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
223 describePass name dflag pass guts = do
224 dflags <- getDynFlags
226 liftIO $ showPass dflags name
228 liftIO $ endPass dflags name dflag (mg_binds guts')
232 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
233 describePassD doc = describePass (showSDoc doc)
235 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
236 describePassR name dflag pass guts = do
237 guts' <- describePass name dflag pass guts
238 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
239 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
242 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
244 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
245 ruleCheck current_phase pat guts = do
246 let is_active = isActive current_phase
248 dflags <- getDynFlags
249 liftIO $ Err.showPass dflags "RuleCheck"
250 liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
254 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
255 doPassDMS do_pass = doPassM $ \binds -> do
256 dflags <- getDynFlags
257 liftIOWithCount $ do_pass dflags binds
259 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
260 doPassDUM do_pass = doPassM $ \binds -> do
261 dflags <- getDynFlags
262 us <- getUniqueSupplyM
263 liftIO $ do_pass dflags us binds
265 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
266 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
268 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
269 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
271 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
272 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
274 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
275 doPassU do_pass = doPassDU (const do_pass)
277 -- Most passes return no stats and don't change rules: these combinators
278 -- let us lift them to the full blown ModGuts+CoreM world
279 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
280 doPassM bind_f guts = do
281 binds' <- bind_f (mg_binds guts)
282 return (guts { mg_binds = binds' })
284 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
285 doPassMG bind_f guts = do
286 binds' <- bind_f guts
287 return (guts { mg_binds = binds' })
289 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
290 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
292 -- Observer passes just peek; don't modify the bindings at all
293 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
294 observe do_pass = doPassM $ \binds -> do
295 dflags <- getDynFlags
296 liftIO $ do_pass dflags binds
301 %************************************************************************
305 %************************************************************************
307 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
308 -- It attaches those rules that are for local Ids to their binders, and
309 -- returns the remainder attached to Ids in an IdSet.
312 prepareRules :: HscEnv
315 -> IO (RuleBase, -- Rule base for imported things, incl
316 -- (a) rules defined in this module (orphans)
317 -- (b) rules from other modules in home package
318 -- but not things from other packages
320 ModGuts) -- Modified fields are
321 -- (a) Bindings have rules attached,
322 -- (b) Rules are now just orphan rules
324 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
325 guts@(ModGuts { mg_binds = binds, mg_deps = deps
326 , mg_rules = local_rules, mg_rdr_env = rdr_env })
328 = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
329 -- from the local binders, to avoid warnings from Simplify.simplVar
330 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
331 env = setInScopeSet gentleSimplEnv local_ids
332 (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
333 (mapM (simplRule env) local_rules)
334 home_pkg_rules = hptRules hsc_env (dep_mods deps)
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
351 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
352 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
353 binds_w_rules = updateBinders local_rule_base binds
355 hpt_rule_base = mkRuleBase home_pkg_rules
356 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
358 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
359 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
360 vcat [text "Local rules", pprRules better_rules,
362 text "Imported rules", pprRuleBase imp_rule_base])
364 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
365 mg_rules = rules_for_imps })
368 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
369 updateBinders local_rules binds
370 = map update_bndrs binds
372 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
373 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
375 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
377 Just rules -> bndr `addIdSpecialisations` rules
378 -- The binder might have some existing rules,
379 -- arising from specialisation pragmas
382 Note [Simplifying the left-hand side of a RULE]
383 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
384 We must do some gentle simplification on the lhs (template) of each
385 rule. The case that forced me to add this was the fold/build rule,
386 which without simplification looked like:
387 fold k z (build (/\a. g a)) ==> ...
388 This doesn't match unless you do eta reduction on the build argument.
389 Similarly for a LHS like
391 we do not want to get
392 augment (\a. g a) (build h)
393 otherwise we don't match when given an argument like
394 augment (\a. h a a) (build h)
397 simplRule env rule@(BuiltinRule {})
399 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
400 = do (env, bndrs') <- simplBinders env bndrs
401 args' <- mapM (simplExprGently env) args
402 rhs' <- simplExprGently env rhs
403 return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
405 -- It's important that simplExprGently does eta reduction.
406 -- For example, in a rule like:
407 -- augment g (build h)
408 -- we do not want to get
409 -- augment (\a. g a) (build h)
410 -- otherwise we don't match when given an argument like
413 -- The simplifier does indeed do eta reduction (it's in
414 -- Simplify.completeLam) but only if -O is on.
418 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
419 -- Simplifies an expression
420 -- does occurrence analysis, then simplification
421 -- and repeats (twice currently) because one pass
422 -- alone leaves tons of crud.
423 -- Used (a) for user expressions typed in at the interactive prompt
424 -- (b) the LHS and RHS of a RULE
425 -- (c) Template Haskell splices
427 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
428 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
429 -- enforce that; it just simplifies the expression twice
431 -- It's important that simplExprGently does eta reduction; see
432 -- Note [Simplifying the left-hand side of a RULE] above. The
433 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
434 -- but only if -O is on.
436 simplExprGently env expr = do
437 expr1 <- simplExpr env (occurAnalyseExpr expr)
438 simplExpr env (occurAnalyseExpr expr1)
442 %************************************************************************
444 \subsection{Glomming}
446 %************************************************************************
449 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
450 -- Glom all binds together in one Rec, in case any
451 -- transformations have introduced any new dependencies
453 -- NB: the global invariant is this:
454 -- *** the top level bindings are never cloned, and are always unique ***
456 -- We sort them into dependency order, but applying transformation rules may
457 -- make something at the top refer to something at the bottom:
461 -- RULE: p (q x) = h x
463 -- Applying this rule makes f refer to h,
464 -- although it doesn't appear to in the source program.
465 -- This pass lets us control where it happens.
467 -- NOTICE that this cannot happen for rules whose head is a locally-defined
468 -- function. It only happens for rules whose head is an imported function
469 -- (p in the example above). So, for example, the rule had been
470 -- RULE: f (p x) = h x
471 -- then the rule for f would be attached to f itself (in its IdInfo)
472 -- by prepareLocalRuleBase and h would be regarded by the occurrency
473 -- analyser as free in f.
475 glomBinds dflags binds
476 = do { Err.showPass dflags "GlomBinds" ;
477 let { recd_binds = [Rec (flattenBinds binds)] } ;
479 -- Not much point in printing the result...
480 -- just consumes output bandwidth
484 %************************************************************************
486 \subsection{The driver for the simplifier}
488 %************************************************************************
491 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
492 simplifyPgm mode switches
493 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
494 do { hsc_env <- getHscEnv
495 ; us <- getUniqueSupplyM
497 ; let fam_inst_env = mg_fam_inst_env guts
498 dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
499 simplify_pgm = simplifyPgmIO dump_phase mode switches
500 hsc_env us rb fam_inst_env
502 ; doPassM (liftIOWithCount . simplify_pgm) guts }
504 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
506 simplifyPgmIO :: Bool
508 -> [SimplifierSwitch]
514 -> IO (SimplCount, [CoreBind]) -- New bindings
516 simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
518 (termination_msg, it_count, counts_out, binds')
519 <- do_iteration us 1 (zeroSimplCount dflags) binds ;
521 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
522 "Simplifier statistics for following pass"
523 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
525 pprSimplCount counts_out]);
527 return (counts_out, binds')
530 dflags = hsc_dflags hsc_env
532 sw_chkr = isAmongSimpl switches
533 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
535 do_iteration us iteration_no counts binds
536 -- iteration_no is the number of the iteration we are
537 -- about to begin, with '1' for the first
538 | iteration_no > max_iterations -- Stop if we've run out of iterations
539 = WARN(debugIsOn && (max_iterations > 2),
540 text ("Simplifier still going after " ++
541 show max_iterations ++
542 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
543 -- Subtract 1 from iteration_no to get the
544 -- number of iterations we actually completed
545 return ("Simplifier bailed out", iteration_no - 1, counts, binds)
547 -- Try and force thunks off the binds; significantly reduces
548 -- space usage, especially with -O. JRS, 000620.
549 | let sz = coreBindsSize binds in sz == sz
551 -- Occurrence analysis
552 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
553 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
554 (pprCoreBindings tagged_binds);
556 -- Get any new rules, and extend the rule base
557 -- We need to do this regularly, because simplification can
558 -- poke on IdInfo thunks, which in turn brings in new rules
559 -- behind the scenes. Otherwise there's a danger we'll simply
560 -- miss the rules for Ids hidden inside imported inlinings
561 eps <- hscEPS hsc_env ;
562 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
563 ; simpl_env = mkSimplEnv mode sw_chkr
564 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
565 simplTopBinds simpl_env tagged_binds
566 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
568 -- Simplify the program
569 -- We do this with a *case* not a *let* because lazy pattern
570 -- matching bit us with bad space leak!
571 -- With a let, we ended up with
576 -- case t of {(_,counts') -> if counts'=0 then ... }
577 -- So the conditional didn't force counts', because the
578 -- selection got duplicated. Sigh!
579 case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
580 (binds', counts') -> do {
582 let { all_counts = counts `plusSimplCount` counts'
583 ; herald = "Simplifier mode " ++ showPpr mode ++
584 ", iteration " ++ show iteration_no ++
585 " out of " ++ show max_iterations
588 -- Stop if nothing happened; don't dump output
589 if isZeroSimplCount counts' then
590 return ("Simplifier reached fixed point", iteration_no,
593 -- Short out indirections
594 -- We do this *after* at least one run of the simplifier
595 -- because indirection-shorting uses the export flag on *occurrences*
596 -- and that isn't guaranteed to be ok until after the first run propagates
597 -- stuff from the binding site to its occurrences
599 -- ToDo: alas, this means that indirection-shorting does not happen at all
600 -- if the simplifier does nothing (not common, I know, but unsavoury)
601 let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
603 -- Dump the result of this iteration
604 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
605 (pprSimplCount counts') ;
606 endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
609 do_iteration us2 (iteration_no + 1) all_counts binds''
612 (us1, us2) = splitUniqSupply us
616 %************************************************************************
618 Shorting out indirections
620 %************************************************************************
624 x_local = <expression>
628 where x_exported is exported, and x_local is not, then we replace it with this:
630 x_exported = <expression>
634 Without this we never get rid of the x_exported = x_local thing. This
635 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
636 makes strictness information propagate better. This used to happen in
637 the final phase, but it's tidier to do it here.
639 Note [Transferring IdInfo]
640 ~~~~~~~~~~~~~~~~~~~~~~~~~~
641 We want to propagage any useful IdInfo on x_local to x_exported.
643 STRICTNESS: if we have done strictness analysis, we want the strictness info on
644 x_local to transfer to x_exported. Hence the copyIdInfo call.
646 RULES: we want to *add* any RULES for x_local to x_exported.
649 Note [Messing up the exported Id's IdInfo]
650 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
651 We must be careful about discarding the IdInfo on the old Id
653 The example that went bad on me at one stage was this one:
655 iterate :: (a -> a) -> a -> [a]
657 iterate = iterateList
659 iterateFB c f x = x `c` iterateFB c f (f x)
660 iterateList f x = x : iterateList f (f x)
664 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
665 "iterateFB" iterateFB (:) = iterateList
668 This got shorted out to:
670 iterateList :: (a -> a) -> a -> [a]
671 iterateList = iterate
673 iterateFB c f x = x `c` iterateFB c f (f x)
674 iterate f x = x : iterate f (f x)
677 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
678 "iterateFB" iterateFB (:) = iterate
681 And now we get an infinite loop in the rule system
682 iterate f x -> build (\cn -> iterateFB c f x)
687 use rule switching-off pragmas to get rid
688 of iterateList in the first place
690 But in principle the user *might* want rules that only apply to the Id
691 he says. And inline pragmas are similar
695 Then we do not want to get rid of the NOINLINE.
697 Hence hasShortableIdinfo.
700 Note [Rules and indirection-zapping]
701 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
702 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
703 Then the things mentioned can be out of scope! Solution
704 a) Make sure that in this pass the usage-info from x_exported is
705 available for ...bindings...
706 b) If there are any such RULES, rec-ify the entire top-level.
707 It'll get sorted out next time round
711 If more than one exported thing is equal to a local thing (i.e., the
712 local thing really is shared), then we do one only:
715 x_exported1 = x_local
716 x_exported2 = x_local
720 x_exported2 = x_exported1
723 We rely on prior eta reduction to simplify things like
725 x_exported = /\ tyvars -> x_local tyvars
729 Hence,there's a possibility of leaving unchanged something like this:
732 x_exported1 = x_local Int
734 By the time we've thrown away the types in STG land this
735 could be eliminated. But I don't think it's very common
736 and it's dangerous to do this fiddling in STG land
737 because we might elminate a binding that's mentioned in the
738 unfolding for something.
741 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
743 shortOutIndirections :: [CoreBind] -> [CoreBind]
744 shortOutIndirections binds
745 | isEmptyVarEnv ind_env = binds
746 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
747 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
749 ind_env = makeIndEnv binds
750 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
751 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
752 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
753 binds' = concatMap zap binds
755 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
756 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
759 | bndr `elemVarSet` exp_id_set = []
760 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
762 | otherwise = [(bndr,rhs)]
764 makeIndEnv :: [CoreBind] -> IndEnv
766 = foldr add_bind emptyVarEnv binds
768 add_bind :: CoreBind -> IndEnv -> IndEnv
769 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
770 add_bind (Rec pairs) env = foldr add_pair env pairs
772 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
773 add_pair (exported_id, Var local_id) env
774 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
775 add_pair (exported_id, rhs) env
779 shortMeOut ind_env exported_id local_id
780 -- The if-then-else stuff is just so I can get a pprTrace to see
781 -- how often I don't get shorting out becuase of IdInfo stuff
782 = if isExportedId exported_id && -- Only if this is exported
784 isLocalId local_id && -- Only if this one is defined in this
785 -- module, so that we *can* change its
786 -- binding to be the exported thing!
788 not (isExportedId local_id) && -- Only if this one is not itself exported,
789 -- since the transformation will nuke it
791 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
793 if hasShortableIdInfo exported_id
794 then True -- See Note [Messing up the exported Id's IdInfo]
795 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
801 hasShortableIdInfo :: Id -> Bool
802 -- True if there is no user-attached IdInfo on exported_id,
803 -- so we can safely discard it
804 -- See Note [Messing up the exported Id's IdInfo]
805 hasShortableIdInfo id
806 = isEmptySpecInfo (specInfo info)
807 && isDefaultInlinePragma (inlinePragInfo info)
812 transferIdInfo :: Id -> Id -> Id
813 -- See Note [Transferring IdInfo]
815 -- lcl_id = e; exp_id = lcl_id
816 -- and lcl_id has useful IdInfo, we don't want to discard it by going
817 -- gbl_id = e; lcl_id = gbl_id
818 -- Instead, transfer IdInfo from lcl_id to exp_id
819 -- Overwriting, rather than merging, seems to work ok.
820 transferIdInfo exported_id local_id
821 = modifyIdInfo transfer exported_id
823 local_info = idInfo local_id
824 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
825 `setWorkerInfo` workerInfo local_info
826 `setInlinePragInfo` inlinePragInfo local_info
827 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
828 new_info = setSpecInfoHead (idName exported_id)
829 (specInfo local_info)
830 -- Remember to set the function-name field of the
831 -- rules as we transfer them from one function to another