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 )
30 import IdInfo ( setNewStrictnessInfo, newStrictnessInfo,
31 setWorkerInfo, workerInfo, setSpecInfoHead,
32 setInlinePragInfo, inlinePragInfo,
33 setSpecInfo, specInfo, specInfoRules )
34 import CoreUtils ( coreBindsSize )
35 import Simplify ( simplTopBinds, simplExpr )
36 import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
39 import qualified ErrUtils as Err ( dumpIfSet_dyn, dumpIfSet, showPass )
40 import CoreLint ( showPass, endPass, endPassIf, endIteration )
41 import FloatIn ( floatInwards )
42 import FloatOut ( floatOutwards )
46 import TyCon ( tyConDataCons )
47 import Class ( classSelIds )
48 import BasicTypes ( CompilerPhase, isActive )
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 )
67 import IO ( hPutStr, stderr )
70 import List ( partition, intersperse )
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 (imp_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 imp_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
124 simplifyExpr dflags expr
126 ; Err.showPass dflags "Simplify"
128 ; us <- mkSplitUniqSupply 's'
130 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
131 simplExprGently gentleSimplEnv expr
133 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
139 gentleSimplEnv :: SimplEnv
140 gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
142 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
143 doCorePasses passes guts = foldM (flip doCorePass) guts passes
145 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
146 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
149 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
150 describePass "Common sub-expression" Opt_D_dump_cse $
153 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
154 describePass "Liberate case" Opt_D_verbose_core2core $
157 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
158 describePass "Float inwards" Opt_D_verbose_core2core $
161 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
162 describePassD (text "Float out" <+> parens (ppr f))
163 Opt_D_verbose_core2core $
164 doPassDUM (floatOutwards f)
166 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
167 describePass "Static argument" Opt_D_verbose_core2core $
170 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
171 describePass "Demand analysis" Opt_D_dump_stranal $
174 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
175 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
178 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
179 describePassR "Specialise" Opt_D_dump_spec $
182 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
183 describePassR "SpecConstr" Opt_D_dump_spec $
184 doPassDU specConstrProgram
186 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
187 describePass "Vectorisation" Opt_D_dump_vect $
190 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
191 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
192 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
194 #ifdef OLD_STRICTNESS
195 doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness
198 doCorePass CoreDoNothing = return
199 doCorePass (CoreDoPasses passes) = doCorePasses passes
201 #ifdef OLD_STRICTNESS
202 doOldStrictness :: ModGuts -> CoreM ModGuts
204 = do dfs <- getDynFlags
205 guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $
206 doPassM (saBinds dfs) guts
207 guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $
208 doPass cprAnalyse guts'
214 %************************************************************************
216 \subsection{Core pass combinators}
218 %************************************************************************
222 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
223 dontDescribePass = ($)
225 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
226 describePass name dflag pass guts = do
227 dflags <- getDynFlags
229 liftIO $ showPass dflags name
231 liftIO $ endPass dflags name dflag (mg_binds guts')
235 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
236 describePassD doc = describePass (showSDoc doc)
238 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
239 describePassR name dflag pass guts = do
240 guts' <- describePass name dflag pass guts
241 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
242 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
245 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
247 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
248 ruleCheck current_phase pat guts = do
249 let is_active = isActive current_phase
251 dflags <- getDynFlags
252 liftIO $ Err.showPass dflags "RuleCheck"
253 liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
257 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
258 doPassDMS do_pass = doPassM $ \binds -> do
259 dflags <- getDynFlags
260 liftIOWithCount $ do_pass dflags binds
262 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
263 doPassDUM do_pass = doPassM $ \binds -> do
264 dflags <- getDynFlags
265 us <- getUniqueSupplyM
266 liftIO $ do_pass dflags us binds
268 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
269 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
271 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
272 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
274 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
275 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
277 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
278 doPassU do_pass = doPassDU (const do_pass)
280 -- Most passes return no stats and don't change rules: these combinators
281 -- let us lift them to the full blown ModGuts+CoreM world
282 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
283 doPassM bind_f guts = do
284 binds' <- bind_f (mg_binds guts)
285 return (guts { mg_binds = binds' })
287 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
288 doPassMG bind_f guts = do
289 binds' <- bind_f guts
290 return (guts { mg_binds = binds' })
292 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
293 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
295 -- Observer passes just peek; don't modify the bindings at all
296 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
297 observe do_pass = doPassM $ \binds -> do
298 dflags <- getDynFlags
299 liftIO $ do_pass dflags binds
304 %************************************************************************
308 %************************************************************************
310 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
311 -- It attaches those rules that are for local Ids to their binders, and
312 -- returns the remainder attached to Ids in an IdSet.
315 prepareRules :: HscEnv
318 -> IO (RuleBase, -- Rule base for imported things, incl
319 -- (a) rules defined in this module (orphans)
320 -- (b) rules from other modules in home package
321 -- but not things from other packages
323 ModGuts) -- Modified fields are
324 -- (a) Bindings have rules attached,
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 { let -- Simplify the local rules; boringly, we need to make an in-scope set
332 -- from the local binders, to avoid warnings from Simplify.simplVar
333 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
334 env = setInScopeSet gentleSimplEnv local_ids
335 (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
336 (mapM (simplRule env) local_rules)
337 home_pkg_rules = hptRules hsc_env (dep_mods deps)
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
354 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
355 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
356 binds_w_rules = updateBinders local_rule_base binds
358 hpt_rule_base = mkRuleBase home_pkg_rules
359 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
361 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
362 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
363 vcat [text "Local rules", pprRules better_rules,
365 text "Imported rules", pprRuleBase imp_rule_base])
367 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
368 mg_rules = rules_for_imps })
371 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
372 updateBinders local_rules binds
373 = map update_bndrs binds
375 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
376 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
378 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
380 Just rules -> bndr `addIdSpecialisations` rules
381 -- The binder might have some existing rules,
382 -- arising from specialisation pragmas
385 Note [Simplifying the left-hand side of a RULE]
386 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
387 We must do some gentle simplification on the lhs (template) of each
388 rule. The case that forced me to add this was the fold/build rule,
389 which without simplification looked like:
390 fold k z (build (/\a. g a)) ==> ...
391 This doesn't match unless you do eta reduction on the build argument.
392 Similarly for a LHS like
394 we do not want to get
395 augment (\a. g a) (build h)
396 otherwise we don't match when given an argument like
397 augment (\a. h a a) (build h)
400 simplRule env rule@(BuiltinRule {})
402 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
403 = do (env, bndrs') <- simplBinders env bndrs
404 args' <- mapM (simplExprGently env) args
405 rhs' <- simplExprGently env rhs
406 return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
408 -- It's important that simplExprGently does eta reduction.
409 -- For example, in a rule like:
410 -- augment g (build h)
411 -- we do not want to get
412 -- augment (\a. g a) (build h)
413 -- otherwise we don't match when given an argument like
416 -- The simplifier does indeed do eta reduction (it's in
417 -- Simplify.completeLam) but only if -O is on.
421 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
422 -- Simplifies an expression
423 -- does occurrence analysis, then simplification
424 -- and repeats (twice currently) because one pass
425 -- alone leaves tons of crud.
426 -- Used (a) for user expressions typed in at the interactive prompt
427 -- (b) the LHS and RHS of a RULE
428 -- (c) Template Haskell splices
430 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
431 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
432 -- enforce that; it just simplifies the expression twice
434 -- It's important that simplExprGently does eta reduction; see
435 -- Note [Simplifying the left-hand side of a RULE] above. The
436 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
437 -- but only if -O is on.
439 simplExprGently env expr = do
440 expr1 <- simplExpr env (occurAnalyseExpr expr)
441 simplExpr env (occurAnalyseExpr expr1)
445 %************************************************************************
447 \subsection{Glomming}
449 %************************************************************************
452 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
453 -- Glom all binds together in one Rec, in case any
454 -- transformations have introduced any new dependencies
456 -- NB: the global invariant is this:
457 -- *** the top level bindings are never cloned, and are always unique ***
459 -- We sort them into dependency order, but applying transformation rules may
460 -- make something at the top refer to something at the bottom:
464 -- RULE: p (q x) = h x
466 -- Applying this rule makes f refer to h,
467 -- although it doesn't appear to in the source program.
468 -- This pass lets us control where it happens.
470 -- NOTICE that this cannot happen for rules whose head is a locally-defined
471 -- function. It only happens for rules whose head is an imported function
472 -- (p in the example above). So, for example, the rule had been
473 -- RULE: f (p x) = h x
474 -- then the rule for f would be attached to f itself (in its IdInfo)
475 -- by prepareLocalRuleBase and h would be regarded by the occurrency
476 -- analyser as free in f.
478 glomBinds dflags binds
479 = do { Err.showPass dflags "GlomBinds" ;
480 let { recd_binds = [Rec (flattenBinds binds)] } ;
482 -- Not much point in printing the result...
483 -- just consumes output bandwidth
487 %************************************************************************
489 \subsection{The driver for the simplifier}
491 %************************************************************************
494 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
495 simplifyPgm mode switches
496 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
497 do { hsc_env <- getHscEnv
498 ; us <- getUniqueSupplyM
500 ; let fam_inst_env = mg_fam_inst_env guts
501 dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
502 simplify_pgm = simplifyPgmIO dump_phase mode switches
503 hsc_env us rb fam_inst_env
505 ; doPassM (liftIOWithCount . simplify_pgm) guts }
507 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
509 simplifyPgmIO :: Bool
511 -> [SimplifierSwitch]
517 -> IO (SimplCount, [CoreBind]) -- New bindings
519 simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
521 (termination_msg, it_count, counts_out, binds')
522 <- do_iteration us 1 (zeroSimplCount dflags) binds ;
524 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
525 "Simplifier statistics for following pass"
526 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
528 pprSimplCount counts_out]);
530 return (counts_out, binds')
533 dflags = hsc_dflags hsc_env
535 sw_chkr = isAmongSimpl switches
536 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
538 do_iteration us iteration_no counts binds
539 -- iteration_no is the number of the iteration we are
540 -- about to begin, with '1' for the first
541 | iteration_no > max_iterations -- Stop if we've run out of iterations
542 = WARN(debugIsOn && (max_iterations > 2),
543 text ("Simplifier still going after " ++
544 show max_iterations ++
545 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
546 -- Subtract 1 from iteration_no to get the
547 -- number of iterations we actually completed
548 return ("Simplifier bailed out", iteration_no - 1, counts, binds)
550 -- Try and force thunks off the binds; significantly reduces
551 -- space usage, especially with -O. JRS, 000620.
552 | let sz = coreBindsSize binds in sz == sz
554 -- Occurrence analysis
555 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
556 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
557 (pprCoreBindings tagged_binds);
559 -- Get any new rules, and extend the rule base
560 -- We need to do this regularly, because simplification can
561 -- poke on IdInfo thunks, which in turn brings in new rules
562 -- behind the scenes. Otherwise there's a danger we'll simply
563 -- miss the rules for Ids hidden inside imported inlinings
564 eps <- hscEPS hsc_env ;
565 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
566 ; simpl_env = mkSimplEnv mode sw_chkr
567 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
568 simplTopBinds simpl_env tagged_binds
569 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
571 -- Simplify the program
572 -- We do this with a *case* not a *let* because lazy pattern
573 -- matching bit us with bad space leak!
574 -- With a let, we ended up with
579 -- case t of {(_,counts') -> if counts'=0 then ... }
580 -- So the conditional didn't force counts', because the
581 -- selection got duplicated. Sigh!
582 case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
583 (binds', counts') -> do {
585 let { all_counts = counts `plusSimplCount` counts'
586 ; herald = "Simplifier mode " ++ showPpr mode ++
587 ", iteration " ++ show iteration_no ++
588 " out of " ++ show max_iterations
591 -- Stop if nothing happened; don't dump output
592 if isZeroSimplCount counts' then
593 return ("Simplifier reached fixed point", iteration_no,
596 -- Short out indirections
597 -- We do this *after* at least one run of the simplifier
598 -- because indirection-shorting uses the export flag on *occurrences*
599 -- and that isn't guaranteed to be ok until after the first run propagates
600 -- stuff from the binding site to its occurrences
602 -- ToDo: alas, this means that indirection-shorting does not happen at all
603 -- if the simplifier does nothing (not common, I know, but unsavoury)
604 let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
606 -- Dump the result of this iteration
607 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
608 (pprSimplCount counts') ;
609 endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
612 do_iteration us2 (iteration_no + 1) all_counts binds''
615 (us1, us2) = splitUniqSupply us
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 STRICTNESS: if we have done strictness analysis, we want the strictness info on
643 x_local to transfer to x_exported. Hence the copyIdInfo call.
645 RULES: we want to *add* any RULES for x_local to x_exported.
647 Note [Rules and indirection-zapping]
648 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
649 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
650 Then the things mentioned can be out of scope! Solution
651 a) Make sure that in this pass the usage-info from x_exported is
652 available for ...bindings...
653 b) If there are any such RULES, rec-ify the entire top-level.
654 It'll get sorted out next time round
658 The example that went bad on me at one stage was this one:
660 iterate :: (a -> a) -> a -> [a]
662 iterate = iterateList
664 iterateFB c f x = x `c` iterateFB c f (f x)
665 iterateList f x = x : iterateList f (f x)
669 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
670 "iterateFB" iterateFB (:) = iterateList
673 This got shorted out to:
675 iterateList :: (a -> a) -> a -> [a]
676 iterateList = iterate
678 iterateFB c f x = x `c` iterateFB c f (f x)
679 iterate f x = x : iterate f (f x)
682 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
683 "iterateFB" iterateFB (:) = iterate
686 And now we get an infinite loop in the rule system
687 iterate f x -> build (\cn -> iterateFB c f x)
691 Tiresome old solution:
692 don't do shorting out if f has rewrite rules (see shortableIdInfo)
694 New solution (I think):
695 use rule switching-off pragmas to get rid
696 of iterateList in the first place
701 If more than one exported thing is equal to a local thing (i.e., the
702 local thing really is shared), then we do one only:
705 x_exported1 = x_local
706 x_exported2 = x_local
710 x_exported2 = x_exported1
713 We rely on prior eta reduction to simplify things like
715 x_exported = /\ tyvars -> x_local tyvars
719 Hence,there's a possibility of leaving unchanged something like this:
722 x_exported1 = x_local Int
724 By the time we've thrown away the types in STG land this
725 could be eliminated. But I don't think it's very common
726 and it's dangerous to do this fiddling in STG land
727 because we might elminate a binding that's mentioned in the
728 unfolding for something.
731 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
733 shortOutIndirections :: [CoreBind] -> [CoreBind]
734 shortOutIndirections binds
735 | isEmptyVarEnv ind_env = binds
736 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
737 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
739 ind_env = makeIndEnv binds
740 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
741 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
742 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
743 binds' = concatMap zap binds
745 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
746 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
749 | bndr `elemVarSet` exp_id_set = []
750 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
752 | otherwise = [(bndr,rhs)]
754 makeIndEnv :: [CoreBind] -> IndEnv
756 = foldr add_bind emptyVarEnv binds
758 add_bind :: CoreBind -> IndEnv -> IndEnv
759 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
760 add_bind (Rec pairs) env = foldr add_pair env pairs
762 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
763 add_pair (exported_id, Var local_id) env
764 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
765 add_pair (exported_id, rhs) env
768 shortMeOut ind_env exported_id local_id
769 -- The if-then-else stuff is just so I can get a pprTrace to see
770 -- how often I don't get shorting out becuase of IdInfo stuff
771 = if isExportedId exported_id && -- Only if this is exported
773 isLocalId local_id && -- Only if this one is defined in this
774 -- module, so that we *can* change its
775 -- binding to be the exported thing!
777 not (isExportedId local_id) && -- Only if this one is not itself exported,
778 -- since the transformation will nuke it
780 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
785 if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
786 then True -- See note on "Messing up rules"
789 pprTrace "shortMeOut:" (ppr exported_id)
798 transferIdInfo :: Id -> Id -> Id
800 -- lcl_id = e; exp_id = lcl_id
801 -- and lcl_id has useful IdInfo, we don't want to discard it by going
802 -- gbl_id = e; lcl_id = gbl_id
803 -- Instead, transfer IdInfo from lcl_id to exp_id
804 -- Overwriting, rather than merging, seems to work ok.
805 transferIdInfo exported_id local_id
806 = modifyIdInfo transfer exported_id
808 local_info = idInfo local_id
809 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
810 `setWorkerInfo` workerInfo local_info
811 `setInlinePragInfo` inlinePragInfo local_info
812 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
813 new_info = setSpecInfoHead (idName exported_id)
814 (specInfo local_info)
815 -- Remember to set the function-name field of the
816 -- rules as we transfer them from one function to another