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 )
59 import StrictAnal ( saBinds )
60 import CprAnalyse ( cprAnalyse )
62 import Vectorise ( vectorise )
66 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
74 %************************************************************************
76 \subsection{The driver for the simplifier}
78 %************************************************************************
85 core2core hsc_env guts = do
86 let dflags = hsc_dflags hsc_env
88 us <- mkSplitUniqSupply 's'
89 let (cp_us, ru_us) = splitUniqSupply us
91 -- COMPUTE THE ANNOTATIONS TO USE
92 ann_env <- prepareAnnotations hsc_env (Just guts)
94 -- COMPUTE THE RULE BASE TO USE
95 (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
97 -- Get the module out of the current HscEnv so we can retrieve it from the monad.
98 -- This is very convienent for the users of the monad (e.g. plugins do not have to
99 -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
100 -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
101 -- would mean our cached value would go out of date.
102 let mod = mg_module guts
103 (guts2, stats) <- runCoreM hsc_env ann_env hpt_rule_base cp_us mod $ do
104 -- FIND BUILT-IN PASSES
105 let builtin_core_todos = getCoreToDo dflags
108 doCorePasses builtin_core_todos guts1
110 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
111 "Grand total simplifier statistics"
112 (pprSimplCount stats)
117 type CorePass = CoreToDo
119 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
122 -- simplifyExpr is called by the driver to simplify an
123 -- expression typed in at the interactive prompt
125 -- Also used by Template Haskell
126 simplifyExpr dflags expr
128 ; Err.showPass dflags "Simplify"
130 ; us <- mkSplitUniqSupply 's'
132 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
133 simplExprGently simplEnvForGHCi expr
135 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
141 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
142 doCorePasses passes guts = foldM (flip doCorePass) guts passes
144 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
145 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
148 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
149 describePass "Common sub-expression" Opt_D_dump_cse $
152 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
153 describePass "Liberate case" Opt_D_verbose_core2core $
156 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
157 describePass "Float inwards" Opt_D_verbose_core2core $
160 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
161 describePassD (text "Float out" <+> parens (ppr f))
162 Opt_D_verbose_core2core $
163 doPassDUM (floatOutwards f)
165 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
166 describePass "Static argument" Opt_D_verbose_core2core $
169 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
170 describePass "Demand analysis" Opt_D_dump_stranal $
173 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
174 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
177 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
178 describePassR "Specialise" Opt_D_dump_spec $
181 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
182 describePassR "SpecConstr" Opt_D_dump_spec $
185 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
186 describePass "Vectorisation" Opt_D_dump_vect $
189 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
190 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
191 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
193 #ifdef OLD_STRICTNESS
194 doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness
197 doCorePass CoreDoNothing = return
198 doCorePass (CoreDoPasses passes) = doCorePasses passes
200 #ifdef OLD_STRICTNESS
201 doOldStrictness :: ModGuts -> CoreM ModGuts
203 = do dfs <- getDynFlags
204 guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $
205 doPassM (saBinds dfs) guts
206 guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $
207 doPass cprAnalyse guts'
213 %************************************************************************
215 \subsection{Core pass combinators}
217 %************************************************************************
221 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
222 dontDescribePass = ($)
224 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
225 describePass name dflag pass guts = do
226 dflags <- getDynFlags
228 liftIO $ Err.showPass dflags name
230 liftIO $ endPass dflags name dflag (mg_binds guts') (mg_rules guts')
234 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
235 describePassD doc = describePass (showSDoc doc)
237 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
238 describePassR name dflag pass guts = do
239 guts' <- describePass name dflag pass guts
240 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
241 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
244 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
246 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
247 ruleCheck current_phase pat guts = do
248 let is_active = isActive current_phase
250 dflags <- getDynFlags
251 liftIO $ Err.showPass dflags "RuleCheck"
252 liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
256 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
257 doPassDMS do_pass = doPassM $ \binds -> do
258 dflags <- getDynFlags
259 liftIOWithCount $ do_pass dflags binds
261 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
262 doPassDUM do_pass = doPassM $ \binds -> do
263 dflags <- getDynFlags
264 us <- getUniqueSupplyM
265 liftIO $ do_pass dflags us binds
267 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
268 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
270 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
271 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
273 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
274 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
276 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
277 doPassU do_pass = doPassDU (const do_pass)
279 -- Most passes return no stats and don't change rules: these combinators
280 -- let us lift them to the full blown ModGuts+CoreM world
281 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
282 doPassM bind_f guts = do
283 binds' <- bind_f (mg_binds guts)
284 return (guts { mg_binds = binds' })
286 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
287 doPassMG bind_f guts = do
288 binds' <- bind_f guts
289 return (guts { mg_binds = binds' })
291 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
292 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
294 -- Observer passes just peek; don't modify the bindings at all
295 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
296 observe do_pass = doPassM $ \binds -> do
297 dflags <- getDynFlags
298 liftIO $ do_pass dflags binds
303 %************************************************************************
307 %************************************************************************
309 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
310 -- It attaches those rules that are for local Ids to their binders, and
311 -- returns the remainder attached to Ids in an IdSet.
314 prepareRules :: HscEnv
317 -> IO (RuleBase, -- Rule base for imported things, incl
318 -- (a) rules defined in this module (orphans)
319 -- (b) rules from other modules in home package
320 -- but not things from other packages
322 ModGuts) -- Modified fields are
323 -- (a) Bindings have rules attached,
324 -- and INLINE rules simplified
325 -- (b) Rules are now just orphan rules
327 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
328 guts@(ModGuts { mg_binds = binds, mg_deps = deps
329 , mg_rules = local_rules, mg_rdr_env = rdr_env })
331 = do { us <- mkSplitUniqSupply 'w'
333 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
334 -- from the local binders, to avoid warnings from Simplify.simplVar
335 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
336 env = setInScopeSet simplEnvForRules local_ids
337 (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
338 mapM (simplRule env) local_rules
340 ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
342 home_pkg_rules = hptRules hsc_env (dep_mods deps)
343 hpt_rule_base = mkRuleBase home_pkg_rules
344 binds_w_rules = updateBinders rules_for_locals binds
347 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
348 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
349 vcat [text "Local rules", pprRules simpl_rules,
351 text "Imported rules", pprRuleBase hpt_rule_base])
353 ; return (hpt_rule_base, guts { mg_binds = binds_w_rules,
354 mg_rules = rules_for_imps })
357 -- Note [Attach rules to local ids]
358 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
359 -- Find the rules for locally-defined Ids; then we can attach them
360 -- to the binders in the top-level bindings
363 -- - It makes the rules easier to look up
364 -- - It means that transformation rules and specialisations for
365 -- locally defined Ids are handled uniformly
366 -- - It keeps alive things that are referred to only from a rule
367 -- (the occurrence analyser knows about rules attached to Ids)
368 -- - It makes sure that, when we apply a rule, the free vars
369 -- of the RHS are more likely to be in scope
370 -- - The imported rules are carried in the in-scope set
371 -- which is extended on each iteration by the new wave of
372 -- local binders; any rules which aren't on the binding will
373 -- thereby get dropped
375 updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
376 updateBinders rules_for_locals binds
377 = map update_bind binds
379 local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
381 update_bind (NonRec b r) = NonRec (add_rules b) r
382 update_bind (Rec prs) = Rec (mapFst add_rules prs)
384 -- See Note [Attach rules to local ids]
385 -- NB: the binder might have some existing rules,
386 -- arising from specialisation pragmas
388 | Just rules <- lookupNameEnv local_rules (idName bndr)
389 = bndr `addIdSpecialisations` rules
394 Note [Simplifying the left-hand side of a RULE]
395 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
396 We must do some gentle simplification on the lhs (template) of each
397 rule. The case that forced me to add this was the fold/build rule,
398 which without simplification looked like:
399 fold k z (build (/\a. g a)) ==> ...
400 This doesn't match unless you do eta reduction on the build argument.
401 Similarly for a LHS like
403 we do not want to get
404 augment (\a. g a) (build h)
405 otherwise we don't match when given an argument like
406 augment (\a. h a a) (build h)
408 The simplifier does indeed do eta reduction (it's in
409 Simplify.completeLam) but only if -O is on.
412 simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
413 simplRule env rule@(BuiltinRule {})
415 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
416 = do (env, bndrs') <- simplBinders env bndrs
417 args' <- mapM (simplExprGently env) args
418 rhs' <- simplExprGently env rhs
419 return (rule { ru_bndrs = bndrs', ru_args = args'
420 , ru_rhs = occurAnalyseExpr rhs' })
424 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
425 -- Simplifies an expression
426 -- does occurrence analysis, then simplification
427 -- and repeats (twice currently) because one pass
428 -- alone leaves tons of crud.
429 -- Used (a) for user expressions typed in at the interactive prompt
430 -- (b) the LHS and RHS of a RULE
431 -- (c) Template Haskell splices
433 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
434 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
435 -- enforce that; it just simplifies the expression twice
437 -- It's important that simplExprGently does eta reduction; see
438 -- Note [Simplifying the left-hand side of a RULE] above. The
439 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
440 -- but only if -O is on.
442 simplExprGently env expr = do
443 expr1 <- simplExpr env (occurAnalyseExpr expr)
444 simplExpr env (occurAnalyseExpr expr1)
448 %************************************************************************
450 \subsection{Glomming}
452 %************************************************************************
455 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
456 -- Glom all binds together in one Rec, in case any
457 -- transformations have introduced any new dependencies
459 -- NB: the global invariant is this:
460 -- *** the top level bindings are never cloned, and are always unique ***
462 -- We sort them into dependency order, but applying transformation rules may
463 -- make something at the top refer to something at the bottom:
467 -- RULE: p (q x) = h x
469 -- Applying this rule makes f refer to h,
470 -- although it doesn't appear to in the source program.
471 -- This pass lets us control where it happens.
473 -- NOTICE that this cannot happen for rules whose head is a locally-defined
474 -- function. It only happens for rules whose head is an imported function
475 -- (p in the example above). So, for example, the rule had been
476 -- RULE: f (p x) = h x
477 -- then the rule for f would be attached to f itself (in its IdInfo)
478 -- by prepareLocalRuleBase and h would be regarded by the occurrency
479 -- analyser as free in f.
481 glomBinds dflags binds
482 = do { Err.showPass dflags "GlomBinds" ;
483 let { recd_binds = [Rec (flattenBinds binds)] } ;
485 -- Not much point in printing the result...
486 -- just consumes output bandwidth
490 %************************************************************************
492 \subsection{The driver for the simplifier}
494 %************************************************************************
497 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
498 simplifyPgm mode switches
499 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
500 do { hsc_env <- getHscEnv
501 ; us <- getUniqueSupplyM
504 simplifyPgmIO mode switches hsc_env us rb guts }
506 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
508 simplifyPgmIO :: SimplifierMode
509 -> [SimplifierSwitch]
514 -> IO (SimplCount, ModGuts) -- New bindings
516 simplifyPgmIO mode switches hsc_env us hpt_rule_base
517 guts@(ModGuts { mg_binds = binds, mg_rules = rules
518 , mg_fam_inst_env = fam_inst_env })
520 (termination_msg, it_count, counts_out, guts')
521 <- do_iteration us 1 (zeroSimplCount dflags) binds rules ;
523 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
524 "Simplifier statistics for following pass"
525 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
527 pprSimplCount counts_out]);
529 return (counts_out, guts')
532 dflags = hsc_dflags hsc_env
533 dump_phase = shouldDumpSimplPhase dflags mode
535 sw_chkr = isAmongSimpl switches
536 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
538 do_iteration :: UniqSupply
539 -> Int -- Counts iterations
540 -> SimplCount -- Logs optimisations performed
541 -> [CoreBind] -- Bindings in
542 -> [CoreRule] -- and orphan rules
543 -> IO (String, Int, SimplCount, ModGuts)
545 do_iteration us iteration_no counts binds rules
546 -- iteration_no is the number of the iteration we are
547 -- about to begin, with '1' for the first
548 | iteration_no > max_iterations -- Stop if we've run out of iterations
549 = WARN(debugIsOn && (max_iterations > 2),
550 text ("Simplifier still going after " ++
551 show max_iterations ++
552 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
553 -- Subtract 1 from iteration_no to get the
554 -- number of iterations we actually completed
555 return ("Simplifier bailed out", iteration_no - 1, counts,
556 guts { mg_binds = binds, mg_rules = rules })
558 -- Try and force thunks off the binds; significantly reduces
559 -- space usage, especially with -O. JRS, 000620.
560 | let sz = coreBindsSize binds in sz == sz
562 -- Occurrence analysis
563 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds rules } ;
564 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
565 (pprCoreBindings tagged_binds);
567 -- Get any new rules, and extend the rule base
568 -- We need to do this regularly, because simplification can
569 -- poke on IdInfo thunks, which in turn brings in new rules
570 -- behind the scenes. Otherwise there's a danger we'll simply
571 -- miss the rules for Ids hidden inside imported inlinings
572 eps <- hscEPS hsc_env ;
573 let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
574 ; rule_base2 = extendRuleBaseList rule_base1 rules
575 ; simpl_env = mkSimplEnv sw_chkr mode
576 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
577 simplTopBinds simpl_env tagged_binds
578 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
580 -- Simplify the program
581 -- We do this with a *case* not a *let* because lazy pattern
582 -- matching bit us with bad space leak!
583 -- With a let, we ended up with
588 -- case t of {(_,counts') -> if counts'=0 then ... }
589 -- So the conditional didn't force counts', because the
590 -- selection got duplicated. Sigh!
591 case initSmpl dflags rule_base2 fam_envs us1 simpl_binds of {
592 (env1, counts1) -> do {
594 let { all_counts = counts `plusSimplCount` counts1
595 ; binds1 = getFloats env1
596 ; rules1 = substRulesForImportedIds (mkCoreSubst env1) rules
599 -- Stop if nothing happened; don't dump output
600 if isZeroSimplCount counts1 then
601 return ("Simplifier reached fixed point", iteration_no, all_counts,
602 guts { mg_binds = binds1, mg_rules = rules1 })
604 -- Short out indirections
605 -- We do this *after* at least one run of the simplifier
606 -- because indirection-shorting uses the export flag on *occurrences*
607 -- and that isn't guaranteed to be ok until after the first run propagates
608 -- stuff from the binding site to its occurrences
610 -- ToDo: alas, this means that indirection-shorting does not happen at all
611 -- if the simplifier does nothing (not common, I know, but unsavoury)
612 let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;
614 -- Dump the result of this iteration
615 end_iteration dflags mode iteration_no max_iterations counts1 binds2 rules1 ;
618 do_iteration us2 (iteration_no + 1) all_counts binds2 rules1
621 (us1, us2) = splitUniqSupply us
624 end_iteration :: DynFlags -> SimplifierMode -> Int -> Int
625 -> SimplCount -> [CoreBind] -> [CoreRule] -> IO ()
626 -- Same as endIteration but with simplifier counts
627 end_iteration dflags mode iteration_no max_iterations counts binds rules
628 = do { Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations pass_name
629 (pprSimplCount counts) ;
631 ; endIteration dflags pass_name Opt_D_dump_simpl_iterations binds rules }
633 pass_name = "Simplifier mode " ++ showPpr mode ++
634 ", iteration " ++ show iteration_no ++
635 " out of " ++ show max_iterations
639 %************************************************************************
641 Shorting out indirections
643 %************************************************************************
647 x_local = <expression>
651 where x_exported is exported, and x_local is not, then we replace it with this:
653 x_exported = <expression>
657 Without this we never get rid of the x_exported = x_local thing. This
658 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
659 makes strictness information propagate better. This used to happen in
660 the final phase, but it's tidier to do it here.
662 Note [Transferring IdInfo]
663 ~~~~~~~~~~~~~~~~~~~~~~~~~~
664 We want to propagage any useful IdInfo on x_local to x_exported.
666 STRICTNESS: if we have done strictness analysis, we want the strictness info on
667 x_local to transfer to x_exported. Hence the copyIdInfo call.
669 RULES: we want to *add* any RULES for x_local to x_exported.
672 Note [Messing up the exported Id's RULES]
673 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
674 We must be careful about discarding (obviously) or even merging the
675 RULES on the exported Id. The example that went bad on me at one stage
678 iterate :: (a -> a) -> a -> [a]
680 iterate = iterateList
682 iterateFB c f x = x `c` iterateFB c f (f x)
683 iterateList f x = x : iterateList f (f x)
687 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
688 "iterateFB" iterateFB (:) = iterateList
691 This got shorted out to:
693 iterateList :: (a -> a) -> a -> [a]
694 iterateList = iterate
696 iterateFB c f x = x `c` iterateFB c f (f x)
697 iterate f x = x : iterate f (f x)
700 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
701 "iterateFB" iterateFB (:) = iterate
704 And now we get an infinite loop in the rule system
705 iterate f x -> build (\cn -> iterateFB c f x)
710 use rule switching-off pragmas to get rid
711 of iterateList in the first place
713 But in principle the user *might* want rules that only apply to the Id
714 he says. And inline pragmas are similar
718 Then we do not want to get rid of the NOINLINE.
720 Hence hasShortableIdinfo.
723 Note [Rules and indirection-zapping]
724 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
725 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
726 Then the things mentioned can be out of scope! Solution
727 a) Make sure that in this pass the usage-info from x_exported is
728 available for ...bindings...
729 b) If there are any such RULES, rec-ify the entire top-level.
730 It'll get sorted out next time round
734 If more than one exported thing is equal to a local thing (i.e., the
735 local thing really is shared), then we do one only:
738 x_exported1 = x_local
739 x_exported2 = x_local
743 x_exported2 = x_exported1
746 We rely on prior eta reduction to simplify things like
748 x_exported = /\ tyvars -> x_local tyvars
752 Hence,there's a possibility of leaving unchanged something like this:
755 x_exported1 = x_local Int
757 By the time we've thrown away the types in STG land this
758 could be eliminated. But I don't think it's very common
759 and it's dangerous to do this fiddling in STG land
760 because we might elminate a binding that's mentioned in the
761 unfolding for something.
764 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
766 shortOutIndirections :: [CoreBind] -> [CoreBind]
767 shortOutIndirections binds
768 | isEmptyVarEnv ind_env = binds
769 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
770 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
772 ind_env = makeIndEnv binds
773 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
774 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
775 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
776 binds' = concatMap zap binds
778 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
779 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
782 | bndr `elemVarSet` exp_id_set = []
783 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
785 | otherwise = [(bndr,rhs)]
787 makeIndEnv :: [CoreBind] -> IndEnv
789 = foldr add_bind emptyVarEnv binds
791 add_bind :: CoreBind -> IndEnv -> IndEnv
792 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
793 add_bind (Rec pairs) env = foldr add_pair env pairs
795 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
796 add_pair (exported_id, Var local_id) env
797 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
798 add_pair (exported_id, rhs) env
802 shortMeOut ind_env exported_id local_id
803 -- The if-then-else stuff is just so I can get a pprTrace to see
804 -- how often I don't get shorting out becuase of IdInfo stuff
805 = if isExportedId exported_id && -- Only if this is exported
807 isLocalId local_id && -- Only if this one is defined in this
808 -- module, so that we *can* change its
809 -- binding to be the exported thing!
811 not (isExportedId local_id) && -- Only if this one is not itself exported,
812 -- since the transformation will nuke it
814 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
816 if hasShortableIdInfo exported_id
817 then True -- See Note [Messing up the exported Id's IdInfo]
818 else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
824 hasShortableIdInfo :: Id -> Bool
825 -- True if there is no user-attached IdInfo on exported_id,
826 -- so we can safely discard it
827 -- See Note [Messing up the exported Id's IdInfo]
828 hasShortableIdInfo id
829 = isEmptySpecInfo (specInfo info)
830 && isDefaultInlinePragma (inlinePragInfo info)
835 transferIdInfo :: Id -> Id -> Id
836 -- See Note [Transferring IdInfo]
838 -- lcl_id = e; exp_id = lcl_id
839 -- and lcl_id has useful IdInfo, we don't want to discard it by going
840 -- gbl_id = e; lcl_id = gbl_id
841 -- Instead, transfer IdInfo from lcl_id to exp_id
842 -- Overwriting, rather than merging, seems to work ok.
843 transferIdInfo exported_id local_id
844 = modifyIdInfo transfer exported_id
846 local_info = idInfo local_id
847 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
848 `setUnfoldingInfo` unfoldingInfo local_info
849 `setInlinePragInfo` inlinePragInfo local_info
850 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
851 new_info = setSpecInfoHead (idName exported_id)
852 (specInfo local_info)
853 -- Remember to set the function-name field of the
854 -- rules as we transfer them from one function to another