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
228 let is_active = isActive current_phase
230 dflags <- getDynFlags
231 liftIO $ Err.showPass dflags "RuleCheck"
232 liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
236 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
237 doPassDMS do_pass = doPassM $ \binds -> do
238 dflags <- getDynFlags
239 liftIOWithCount $ do_pass dflags binds
241 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
242 doPassDUM do_pass = doPassM $ \binds -> do
243 dflags <- getDynFlags
244 us <- getUniqueSupplyM
245 liftIO $ do_pass dflags us binds
247 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
248 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
250 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
251 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
253 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
254 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
256 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
257 doPassU do_pass = doPassDU (const do_pass)
259 -- Most passes return no stats and don't change rules: these combinators
260 -- let us lift them to the full blown ModGuts+CoreM world
261 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
262 doPassM bind_f guts = do
263 binds' <- bind_f (mg_binds guts)
264 return (guts { mg_binds = binds' })
266 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
267 doPassMG bind_f guts = do
268 binds' <- bind_f guts
269 return (guts { mg_binds = binds' })
271 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
272 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
274 -- Observer passes just peek; don't modify the bindings at all
275 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
276 observe do_pass = doPassM $ \binds -> do
277 dflags <- getDynFlags
278 liftIO $ do_pass dflags binds
283 %************************************************************************
287 %************************************************************************
289 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
290 -- It attaches those rules that are for local Ids to their binders, and
291 -- returns the remainder attached to Ids in an IdSet.
294 prepareRules :: HscEnv
297 -> IO (RuleBase, -- Rule base for imported things, incl
298 -- (a) rules defined in this module (orphans)
299 -- (b) rules from other modules in home package
300 -- but not things from other packages
302 ModGuts) -- Modified fields are
303 -- (a) Bindings have rules attached,
304 -- and INLINE rules simplified
305 -- (b) Rules are now just orphan rules
307 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
308 guts@(ModGuts { mg_binds = binds, mg_deps = deps
309 , mg_rules = local_rules, mg_rdr_env = rdr_env })
311 = do { us <- mkSplitUniqSupply 'w'
313 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
314 -- from the local binders, to avoid warnings from Simplify.simplVar
315 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
316 env = setInScopeSet simplEnvForRules local_ids
317 (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
318 mapM (simplRule env) local_rules
320 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
322 home_pkg_rules = hptRules hsc_env (dep_mods deps)
323 hpt_rule_base = mkRuleBase home_pkg_rules
324 binds_w_rules = updateBinders rules_for_locals binds
327 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
328 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
329 vcat [text "Local rules", pprRules simpl_rules,
331 text "Imported rules", pprRuleBase hpt_rule_base])
333 ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
334 mg_rules = rules_for_imps })
337 -- Note [Attach rules to local ids]
338 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
339 -- Find the rules for locally-defined Ids; then we can attach them
340 -- to the binders in the top-level bindings
343 -- - It makes the rules easier to look up
344 -- - It means that transformation rules and specialisations for
345 -- locally defined Ids are handled uniformly
346 -- - It keeps alive things that are referred to only from a rule
347 -- (the occurrence analyser knows about rules attached to Ids)
348 -- - It makes sure that, when we apply a rule, the free vars
349 -- of the RHS are more likely to be in scope
350 -- - The imported rules are carried in the in-scope set
351 -- which is extended on each iteration by the new wave of
352 -- local binders; any rules which aren't on the binding will
353 -- thereby get dropped
355 updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
356 updateBinders rules_for_locals binds
357 = map update_bind binds
359 local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
361 update_bind (NonRec b r) = NonRec (add_rules b) r
362 update_bind (Rec prs) = Rec (mapFst add_rules prs)
364 -- See Note [Attach rules to local ids]
365 -- NB: the binder might have some existing rules,
366 -- arising from specialisation pragmas
368 | Just rules <- lookupNameEnv local_rules (idName bndr)
369 = bndr `addIdSpecialisations` rules
374 Note [Simplifying the left-hand side of a RULE]
375 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
376 We must do some gentle simplification on the lhs (template) of each
377 rule. The case that forced me to add this was the fold/build rule,
378 which without simplification looked like:
379 fold k z (build (/\a. g a)) ==> ...
380 This doesn't match unless you do eta reduction on the build argument.
381 Similarly for a LHS like
383 we do not want to get
384 augment (\a. g a) (build h)
385 otherwise we don't match when given an argument like
386 augment (\a. h a a) (build h)
388 The simplifier does indeed do eta reduction (it's in
389 Simplify.completeLam) but only if -O is on.
392 simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
393 simplRule env rule@(BuiltinRule {})
395 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
396 = do (env, bndrs') <- simplBinders env bndrs
397 args' <- mapM (simplExprGently env) args
398 rhs' <- simplExprGently env rhs
399 return (rule { ru_bndrs = bndrs', ru_args = args'
400 , ru_rhs = occurAnalyseExpr rhs' })
404 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
405 -- Simplifies an expression
406 -- does occurrence analysis, then simplification
407 -- and repeats (twice currently) because one pass
408 -- alone leaves tons of crud.
409 -- Used (a) for user expressions typed in at the interactive prompt
410 -- (b) the LHS and RHS of a RULE
411 -- (c) Template Haskell splices
413 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
414 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
415 -- enforce that; it just simplifies the expression twice
417 -- It's important that simplExprGently does eta reduction; see
418 -- Note [Simplifying the left-hand side of a RULE] above. The
419 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
420 -- but only if -O is on.
422 simplExprGently env expr = do
423 expr1 <- simplExpr env (occurAnalyseExpr expr)
424 simplExpr env (occurAnalyseExpr expr1)
428 %************************************************************************
430 \subsection{Glomming}
432 %************************************************************************
435 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
436 -- Glom all binds together in one Rec, in case any
437 -- transformations have introduced any new dependencies
439 -- NB: the global invariant is this:
440 -- *** the top level bindings are never cloned, and are always unique ***
442 -- We sort them into dependency order, but applying transformation rules may
443 -- make something at the top refer to something at the bottom:
447 -- RULE: p (q x) = h x
449 -- Applying this rule makes f refer to h,
450 -- although it doesn't appear to in the source program.
451 -- This pass lets us control where it happens.
453 -- NOTICE that this cannot happen for rules whose head is a locally-defined
454 -- function. It only happens for rules whose head is an imported function
455 -- (p in the example above). So, for example, the rule had been
456 -- RULE: f (p x) = h x
457 -- then the rule for f would be attached to f itself (in its IdInfo)
458 -- by prepareLocalRuleBase and h would be regarded by the occurrency
459 -- analyser as free in f.
461 glomBinds dflags binds
462 = do { Err.showPass dflags "GlomBinds" ;
463 let { recd_binds = [Rec (flattenBinds binds)] } ;
465 -- Not much point in printing the result...
466 -- just consumes output bandwidth
470 %************************************************************************
472 \subsection{The driver for the simplifier}
474 %************************************************************************
477 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
478 simplifyPgm mode switches
479 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
480 do { hsc_env <- getHscEnv
481 ; us <- getUniqueSupplyM
484 simplifyPgmIO mode switches hsc_env us rb guts }
486 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
488 simplifyPgmIO :: SimplifierMode
489 -> [SimplifierSwitch]
494 -> IO (SimplCount, ModGuts) -- New bindings
496 simplifyPgmIO mode switches hsc_env us hpt_rule_base
497 guts@(ModGuts { mg_binds = binds, mg_rules = rules
498 , mg_fam_inst_env = fam_inst_env })
500 (termination_msg, it_count, counts_out, guts')
501 <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
503 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
504 "Simplifier statistics for following pass"
505 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
507 pprSimplCount counts_out]);
509 return (counts_out, guts')
512 dflags = hsc_dflags hsc_env
513 dump_phase = shouldDumpSimplPhase dflags mode
515 sw_chkr = isAmongSimpl switches
516 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
518 do_iteration :: UniqSupply
519 -> Int -- Counts iterations
520 -> SimplCount -- Logs optimisations performed
521 -> [CoreBind] -- Bindings in
522 -> [CoreRule] -- and orphan rules
523 -> IO (String, Int, SimplCount, ModGuts)
525 do_iteration us iteration_no counts binds rules
526 -- iteration_no is the number of the iteration we are
527 -- about to begin, with '1' for the first
528 | iteration_no > max_iterations -- Stop if we've run out of iterations
529 = WARN(debugIsOn && (max_iterations > 2),
530 text ("Simplifier still going after " ++
531 show max_iterations ++
532 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
533 -- Subtract 1 from iteration_no to get the
534 -- number of iterations we actually completed
535 return ("Simplifier bailed out", iteration_no - 1, counts,
536 guts { mg_binds = binds, mg_rules = rules })
538 -- Try and force thunks off the binds; significantly reduces
539 -- space usage, especially with -O. JRS, 000620.
540 | let sz = coreBindsSize binds in sz == sz
542 -- Occurrence analysis
543 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
544 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
545 (pprCoreBindings tagged_binds);
547 -- Get any new rules, and extend the rule base
548 -- We need to do this regularly, because simplification can
549 -- poke on IdInfo thunks, which in turn brings in new rules
550 -- behind the scenes. Otherwise there's a danger we'll simply
551 -- miss the rules for Ids hidden inside imported inlinings
552 eps <- hscEPS hsc_env ;
553 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
554 ; rule_base2 = extendRuleBaseList rule_base1 rules
555 ; simpl_env = mkSimplEnv sw_chkr mode
556 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
557 simplTopBinds simpl_env tagged_binds
558 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
560 -- Simplify the program
561 -- We do this with a *case* not a *let* because lazy pattern
562 -- matching bit us with bad space leak!
563 -- With a let, we ended up with
568 -- case t of {(_,counts') -> if counts'=0 then ... }
569 -- So the conditional didn't force counts', because the
570 -- selection got duplicated. Sigh!
571 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
572 (env1, counts1) -> do {
574 let { all_counts = counts `plusSimplCount` counts1
575 ; binds1 = getFloats env1
576 ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
579 -- Stop if nothing happened; don't dump output
580 if isZeroSimplCount counts1 then
581 return ("Simplifier reached fixed point", iteration_no, all_counts,
582 guts { mg_binds = binds1, mg_rules = rules1 })
584 -- Short out indirections
585 -- We do this *after* at least one run of the simplifier
586 -- because indirection-shorting uses the export flag on *occurrences*
587 -- and that isn't guaranteed to be ok until after the first run propagates
588 -- stuff from the binding site to its occurrences
590 -- ToDo: alas, this means that indirection-shorting does not happen at all
591 -- if the simplifier does nothing (not common, I know, but unsavoury)
592 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
594 -- Dump the result of this iteration
595 end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
598 do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
601 (us1, us2) = splitUniqSupply us
604 end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
605 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
606 -- Same as endIteration but with simplifier counts
607 end_iteration dflags mode iteration_no max_iterations counts binds rules
608 = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
609 (pprSimplCount counts) ;
611 ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
613 pass_name = "Simplifier mode " ++ showPpr mode ++
614 ", iteration " ++ show iteration_no ++
615 " out of " ++ show max_iterations
619 %************************************************************************
621 Shorting out indirections
623 %************************************************************************
627 x_local = <expression>
631 where x_exported is exported, and x_local is not, then we replace it with this:
633 x_exported = <expression>
637 Without this we never get rid of the x_exported = x_local thing. This
638 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
639 makes strictness information propagate better. This used to happen in
640 the final phase, but it's tidier to do it here.
642 Note [Transferring IdInfo]
643 ~~~~~~~~~~~~~~~~~~~~~~~~~~
644 We want to propagage any useful IdInfo on x_local to x_exported.
646 STRICTNESS: if we have done strictness analysis, we want the strictness info on
647 x_local to transfer to x_exported. Hence the copyIdInfo call.
649 RULES: we want to *add* any RULES for x_local to x_exported.
652 Note [Messing up the exported Id's RULES]
653 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
654 We must be careful about discarding (obviously) or even merging the
655 RULES on the exported Id. The example that went bad on me at one stage
658 iterate :: (a -> a) -> a -> [a]
660 iterate = iterateList
662 iterateFB c f x = x `c` iterateFB c f (f x)
663 iterateList f x = x : iterateList f (f x)
667 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
668 "iterateFB" iterateFB (:) = iterateList
671 This got shorted out to:
673 iterateList :: (a -> a) -> a -> [a]
674 iterateList = iterate
676 iterateFB c f x = x `c` iterateFB c f (f x)
677 iterate f x = x : iterate f (f x)
680 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
681 "iterateFB" iterateFB (:) = iterate
684 And now we get an infinite loop in the rule system
685 iterate f x -> build (\cn -> iterateFB c f x)
690 use rule switching-off pragmas to get rid
691 of iterateList in the first place
693 But in principle the user *might* want rules that only apply to the Id
694 he says. And inline pragmas are similar
698 Then we do not want to get rid of the NOINLINE.
700 Hence hasShortableIdinfo.
703 Note [Rules and indirection-zapping]
704 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
705 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
706 Then the things mentioned can be out of scope! Solution
707 a) Make sure that in this pass the usage-info from x_exported is
708 available for ...bindings...
709 b) If there are any such RULES, rec-ify the entire top-level.
710 It'll get sorted out next time round
714 If more than one exported thing is equal to a local thing (i.e., the
715 local thing really is shared), then we do one only:
718 x_exported1 = x_local
719 x_exported2 = x_local
723 x_exported2 = x_exported1
726 We rely on prior eta reduction to simplify things like
728 x_exported = /\ tyvars -> x_local tyvars
732 Hence,there's a possibility of leaving unchanged something like this:
735 x_exported1 = x_local Int
737 By the time we've thrown away the types in STG land this
738 could be eliminated. But I don't think it's very common
739 and it's dangerous to do this fiddling in STG land
740 because we might elminate a binding that's mentioned in the
741 unfolding for something.
744 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
746 shortOutIndirections :: [CoreBind] -> [CoreBind]
747 shortOutIndirections binds
748 | isEmptyVarEnv ind_env = binds
749 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
750 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
752 ind_env = makeIndEnv binds
753 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
754 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
755 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
756 binds' = concatMap zap binds
758 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
759 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
762 | bndr `elemVarSet` exp_id_set = []
763 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
765 | otherwise = [(bndr,rhs)]
767 makeIndEnv :: [CoreBind] -> IndEnv
769 = foldr add_bind emptyVarEnv binds
771 add_bind :: CoreBind -> IndEnv -> IndEnv
772 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
773 add_bind (Rec pairs) env = foldr add_pair env pairs
775 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
776 add_pair (exported_id, Var local_id) env
777 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
778 add_pair (exported_id, rhs) env
782 shortMeOut ind_env exported_id local_id
783 -- The if-then-else stuff is just so I can get a pprTrace to see
784 -- how often I don't get shorting out becuase of IdInfo stuff
785 = if isExportedId exported_id && -- Only if this is exported
787 isLocalId local_id && -- Only if this one is defined in this
788 -- module, so that we *can* change its
789 -- binding to be the exported thing!
791 not (isExportedId local_id) && -- Only if this one is not itself exported,
792 -- since the transformation will nuke it
794 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
796 if hasShortableIdInfo exported_id
797 then True -- See Note [Messing up the exported Id's IdInfo]
798 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
804 hasShortableIdInfo :: Id -> Bool
805 -- True if there is no user-attached IdInfo on exported_id,
806 -- so we can safely discard it
807 -- See Note [Messing up the exported Id's IdInfo]
808 hasShortableIdInfo id
809 = isEmptySpecInfo (specInfo info)
810 && isDefaultInlinePragma (inlinePragInfo info)
815 transferIdInfo :: Id -> Id -> Id
816 -- See Note [Transferring IdInfo]
818 -- lcl_id = e; exp_id = lcl_id
819 -- and lcl_id has useful IdInfo, we don't want to discard it by going
820 -- gbl_id = e; lcl_id = gbl_id
821 -- Instead, transfer IdInfo from lcl_id to exp_id
822 -- Overwriting, rather than merging, seems to work ok.
823 transferIdInfo exported_id local_id
824 = modifyIdInfo transfer exported_id
826 local_info = idInfo local_id
827 transfer exp_info = exp_info `setStrictnessInfo` strictnessInfo local_info
828 `setUnfoldingInfo` unfoldingInfo local_info
829 `setInlinePragInfo` inlinePragInfo local_info
830 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
831 new_info = setSpecInfoHead (idName exported_id)
832 (specInfo local_info)
833 -- Remember to set the function-name field of the
834 -- rules as we transfer them from one function to another