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 ( tyConSelIds, 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 (guts, 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
107 -- Note [Injecting implicit bindings]
108 let implicit_binds = getImplicitBinds (mg_types guts1)
109 guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
112 doCorePasses builtin_core_todos guts2
114 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
115 "Grand total simplifier statistics"
116 (pprSimplCount stats)
121 type CorePass = CoreToDo
123 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
126 -- simplifyExpr is called by the driver to simplify an
127 -- expression typed in at the interactive prompt
128 simplifyExpr dflags expr
130 ; Err.showPass dflags "Simplify"
132 ; us <- mkSplitUniqSupply 's'
134 ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
135 simplExprGently gentleSimplEnv expr
137 ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
143 gentleSimplEnv :: SimplEnv
144 gentleSimplEnv = mkSimplEnv SimplGently (isAmongSimpl [])
146 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
147 doCorePasses passes guts = foldM (flip doCorePass) guts passes
149 doCorePass :: CorePass -> ModGuts -> CoreM ModGuts
150 doCorePass (CoreDoSimplify mode sws) = {-# SCC "Simplify" #-}
153 doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-}
154 describePass "Common sub-expression" Opt_D_dump_cse $
157 doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-}
158 describePass "Liberate case" Opt_D_verbose_core2core $
161 doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-}
162 describePass "Float inwards" Opt_D_verbose_core2core $
165 doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-}
166 describePassD (text "Float out" <+> parens (ppr f))
167 Opt_D_verbose_core2core $
168 doPassDUM (floatOutwards f)
170 doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-}
171 describePass "Static argument" Opt_D_verbose_core2core $
174 doCorePass CoreDoStrictness = {-# SCC "Stranal" #-}
175 describePass "Demand analysis" Opt_D_dump_stranal $
178 doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-}
179 describePass "Worker Wrapper binds" Opt_D_dump_worker_wrapper $
182 doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-}
183 describePassR "Specialise" Opt_D_dump_spec $
186 doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-}
187 describePassR "SpecConstr" Opt_D_dump_spec $
188 doPassDU specConstrProgram
190 doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-}
191 describePass "Vectorisation" Opt_D_dump_vect $
194 doCorePass CoreDoGlomBinds = dontDescribePass $ doPassDM glomBinds
195 doCorePass CoreDoPrintCore = dontDescribePass $ observe printCore
196 doCorePass (CoreDoRuleCheck phase pat) = dontDescribePass $ ruleCheck phase pat
198 #ifdef OLD_STRICTNESS
199 doCorePass CoreDoOldStrictness = {-# SCC "OldStrictness" #-} doOldStrictness
202 doCorePass CoreDoNothing = return
203 doCorePass (CoreDoPasses passes) = doCorePasses passes
205 #ifdef OLD_STRICTNESS
206 doOldStrictness :: ModGuts -> CoreM ModGuts
208 = do dfs <- getDynFlags
209 guts' <- describePass "Strictness analysis" Opt_D_dump_stranal $
210 doPassM (saBinds dfs) guts
211 guts'' <- describePass "Constructed Product analysis" Opt_D_dump_cpranal $
212 doPass cprAnalyse guts'
218 %************************************************************************
220 \subsection{Core pass combinators}
222 %************************************************************************
226 dontDescribePass :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
227 dontDescribePass = ($)
229 describePass :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
230 describePass name dflag pass guts = do
231 dflags <- getDynFlags
233 liftIO $ showPass dflags name
235 liftIO $ endPass dflags name dflag (mg_binds guts')
239 describePassD :: SDoc -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
240 describePassD doc = describePass (showSDoc doc)
242 describePassR :: String -> DynFlag -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts
243 describePassR name dflag pass guts = do
244 guts' <- describePass name dflag pass guts
245 dumpIfSet_dyn Opt_D_dump_rules "Top-level specialisations"
246 (pprRulesForUser (rulesOfBinds (mg_binds guts')))
249 printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds)
251 ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
252 ruleCheck current_phase pat guts = do
253 let is_active = isActive current_phase
255 dflags <- getDynFlags
256 liftIO $ Err.showPass dflags "RuleCheck"
257 liftIO $ printDump (ruleCheckProgram is_active pat rb (mg_binds guts))
261 doPassDMS :: (DynFlags -> [CoreBind] -> IO (SimplCount, [CoreBind])) -> ModGuts -> CoreM ModGuts
262 doPassDMS do_pass = doPassM $ \binds -> do
263 dflags <- getDynFlags
264 liftIOWithCount $ do_pass dflags binds
266 doPassDUM :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
267 doPassDUM do_pass = doPassM $ \binds -> do
268 dflags <- getDynFlags
269 us <- getUniqueSupplyM
270 liftIO $ do_pass dflags us binds
272 doPassDM :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> ModGuts -> CoreM ModGuts
273 doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))
275 doPassD :: (DynFlags -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
276 doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)
278 doPassDU :: (DynFlags -> UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
279 doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)
281 doPassU :: (UniqSupply -> [CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
282 doPassU do_pass = doPassDU (const do_pass)
284 -- Most passes return no stats and don't change rules: these combinators
285 -- let us lift them to the full blown ModGuts+CoreM world
286 doPassM :: Monad m => ([CoreBind] -> m [CoreBind]) -> ModGuts -> m ModGuts
287 doPassM bind_f guts = do
288 binds' <- bind_f (mg_binds guts)
289 return (guts { mg_binds = binds' })
291 doPassMG :: Monad m => (ModGuts -> m [CoreBind]) -> ModGuts -> m ModGuts
292 doPassMG bind_f guts = do
293 binds' <- bind_f guts
294 return (guts { mg_binds = binds' })
296 doPass :: ([CoreBind] -> [CoreBind]) -> ModGuts -> CoreM ModGuts
297 doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }
299 -- Observer passes just peek; don't modify the bindings at all
300 observe :: (DynFlags -> [CoreBind] -> IO a) -> ModGuts -> CoreM ModGuts
301 observe do_pass = doPassM $ \binds -> do
302 dflags <- getDynFlags
303 liftIO $ do_pass dflags binds
308 %************************************************************************
312 %************************************************************************
314 Note [Injecting implicit bindings]
315 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
316 We used to inject the implict bindings right at the end, in CoreTidy.
317 But some of these bindings, notably record selectors, are not
318 constructed in an optimised form. E.g. record selector for
319 data T = MkT { x :: {-# UNPACK #-} !Int }
320 Then the unfolding looks like
321 x = \t. case t of MkT x1 -> let x = I# x1 in x
322 This generates bad code unless it's first simplified a bit.
323 (Only matters when the selector is used curried; eg map x ys.)
327 getImplicitBinds :: TypeEnv -> [CoreBind]
328 getImplicitBinds type_env
329 = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
330 ++ concatMap other_implicit_ids (typeEnvElts type_env))
331 -- Put the constructor wrappers first, because
332 -- other implicit bindings (notably the fromT functions arising
333 -- from generics) use the constructor wrappers. At least that's
334 -- what External Core likes
336 implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
338 other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
339 -- The "naughty" ones are not real functions at all
340 -- They are there just so we can get decent error messages
341 -- See Note [Naughty record selectors] in MkId.lhs
342 other_implicit_ids (AClass cl) = classSelIds cl
343 other_implicit_ids _other = []
345 get_defn :: Id -> CoreBind
346 get_defn id = NonRec id (unfoldingTemplate (idUnfolding id))
350 %************************************************************************
354 %************************************************************************
356 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
357 -- It attaches those rules that are for local Ids to their binders, and
358 -- returns the remainder attached to Ids in an IdSet.
361 prepareRules :: HscEnv
364 -> IO (RuleBase, -- Rule base for imported things, incl
365 -- (a) rules defined in this module (orphans)
366 -- (b) rules from other modules in home package
367 -- but not things from other packages
369 ModGuts) -- Modified fields are
370 -- (a) Bindings have rules attached,
371 -- (b) Rules are now just orphan rules
373 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
374 guts@(ModGuts { mg_binds = binds, mg_deps = deps
375 , mg_rules = local_rules, mg_rdr_env = rdr_env })
377 = do { let -- Simplify the local rules; boringly, we need to make an in-scope set
378 -- from the local binders, to avoid warnings from Simplify.simplVar
379 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
380 env = setInScopeSet gentleSimplEnv local_ids
381 (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
382 (mapM (simplRule env) local_rules)
383 home_pkg_rules = hptRules hsc_env (dep_mods deps)
385 -- Find the rules for locally-defined Ids; then we can attach them
386 -- to the binders in the top-level bindings
389 -- - It makes the rules easier to look up
390 -- - It means that transformation rules and specialisations for
391 -- locally defined Ids are handled uniformly
392 -- - It keeps alive things that are referred to only from a rule
393 -- (the occurrence analyser knows about rules attached to Ids)
394 -- - It makes sure that, when we apply a rule, the free vars
395 -- of the RHS are more likely to be in scope
396 -- - The imported rules are carried in the in-scope set
397 -- which is extended on each iteration by the new wave of
398 -- local binders; any rules which aren't on the binding will
399 -- thereby get dropped
400 (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
401 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
402 binds_w_rules = updateBinders local_rule_base binds
404 hpt_rule_base = mkRuleBase home_pkg_rules
405 imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps
407 ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
408 (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
409 vcat [text "Local rules", pprRules better_rules,
411 text "Imported rules", pprRuleBase imp_rule_base])
413 ; return (imp_rule_base, guts { mg_binds = binds_w_rules,
414 mg_rules = rules_for_imps })
417 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
418 updateBinders local_rules binds
419 = map update_bndrs binds
421 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
422 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
424 update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
426 Just rules -> bndr `addIdSpecialisations` rules
427 -- The binder might have some existing rules,
428 -- arising from specialisation pragmas
431 Note [Simplifying the left-hand side of a RULE]
432 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
433 We must do some gentle simplification on the lhs (template) of each
434 rule. The case that forced me to add this was the fold/build rule,
435 which without simplification looked like:
436 fold k z (build (/\a. g a)) ==> ...
437 This doesn't match unless you do eta reduction on the build argument.
438 Similarly for a LHS like
440 we do not want to get
441 augment (\a. g a) (build h)
442 otherwise we don't match when given an argument like
443 augment (\a. h a a) (build h)
446 simplRule env rule@(BuiltinRule {})
448 simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
449 = do (env, bndrs') <- simplBinders env bndrs
450 args' <- mapM (simplExprGently env) args
451 rhs' <- simplExprGently env rhs
452 return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
454 -- It's important that simplExprGently does eta reduction.
455 -- For example, in a rule like:
456 -- augment g (build h)
457 -- we do not want to get
458 -- augment (\a. g a) (build h)
459 -- otherwise we don't match when given an argument like
462 -- The simplifier does indeed do eta reduction (it's in
463 -- Simplify.completeLam) but only if -O is on.
467 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
468 -- Simplifies an expression
469 -- does occurrence analysis, then simplification
470 -- and repeats (twice currently) because one pass
471 -- alone leaves tons of crud.
472 -- Used (a) for user expressions typed in at the interactive prompt
473 -- (b) the LHS and RHS of a RULE
474 -- (c) Template Haskell splices
476 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
477 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
478 -- enforce that; it just simplifies the expression twice
480 -- It's important that simplExprGently does eta reduction; see
481 -- Note [Simplifying the left-hand side of a RULE] above. The
482 -- simplifier does indeed do eta reduction (it's in Simplify.completeLam)
483 -- but only if -O is on.
485 simplExprGently env expr = do
486 expr1 <- simplExpr env (occurAnalyseExpr expr)
487 simplExpr env (occurAnalyseExpr expr1)
491 %************************************************************************
493 \subsection{Glomming}
495 %************************************************************************
498 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
499 -- Glom all binds together in one Rec, in case any
500 -- transformations have introduced any new dependencies
502 -- NB: the global invariant is this:
503 -- *** the top level bindings are never cloned, and are always unique ***
505 -- We sort them into dependency order, but applying transformation rules may
506 -- make something at the top refer to something at the bottom:
510 -- RULE: p (q x) = h x
512 -- Applying this rule makes f refer to h,
513 -- although it doesn't appear to in the source program.
514 -- This pass lets us control where it happens.
516 -- NOTICE that this cannot happen for rules whose head is a locally-defined
517 -- function. It only happens for rules whose head is an imported function
518 -- (p in the example above). So, for example, the rule had been
519 -- RULE: f (p x) = h x
520 -- then the rule for f would be attached to f itself (in its IdInfo)
521 -- by prepareLocalRuleBase and h would be regarded by the occurrency
522 -- analyser as free in f.
524 glomBinds dflags binds
525 = do { Err.showPass dflags "GlomBinds" ;
526 let { recd_binds = [Rec (flattenBinds binds)] } ;
528 -- Not much point in printing the result...
529 -- just consumes output bandwidth
533 %************************************************************************
535 \subsection{The driver for the simplifier}
537 %************************************************************************
540 simplifyPgm :: SimplifierMode -> [SimplifierSwitch] -> ModGuts -> CoreM ModGuts
541 simplifyPgm mode switches
542 = describePassD doc Opt_D_dump_simpl_phases $ \guts ->
543 do { hsc_env <- getHscEnv
544 ; us <- getUniqueSupplyM
546 ; let fam_inst_env = mg_fam_inst_env guts
547 dump_phase = shouldDumpSimplPhase (hsc_dflags hsc_env) mode
548 simplify_pgm = simplifyPgmIO dump_phase mode switches
549 hsc_env us rb fam_inst_env
551 ; doPassM (liftIOWithCount . simplify_pgm) guts }
553 doc = ptext (sLit "Simplifier Phase") <+> text (showPpr mode)
555 simplifyPgmIO :: Bool
557 -> [SimplifierSwitch]
563 -> IO (SimplCount, [CoreBind]) -- New bindings
565 simplifyPgmIO dump_phase mode switches hsc_env us imp_rule_base fam_inst_env binds
567 (termination_msg, it_count, counts_out, binds')
568 <- do_iteration us 1 (zeroSimplCount dflags) binds ;
570 Err.dumpIfSet (dump_phase && dopt Opt_D_dump_simpl_stats dflags)
571 "Simplifier statistics for following pass"
572 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
574 pprSimplCount counts_out]);
576 return (counts_out, binds')
579 dflags = hsc_dflags hsc_env
581 sw_chkr = isAmongSimpl switches
582 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
584 do_iteration us iteration_no counts binds
585 -- iteration_no is the number of the iteration we are
586 -- about to begin, with '1' for the first
587 | iteration_no > max_iterations -- Stop if we've run out of iterations
588 = WARN(debugIsOn && (max_iterations > 2),
589 text ("Simplifier still going after " ++
590 show max_iterations ++
591 " iterations; bailing out. Size = " ++ show (coreBindsSize binds) ++ "\n" ))
592 -- Subtract 1 from iteration_no to get the
593 -- number of iterations we actually completed
594 return ("Simplifier bailed out", iteration_no - 1, counts, binds)
596 -- Try and force thunks off the binds; significantly reduces
597 -- space usage, especially with -O. JRS, 000620.
598 | let sz = coreBindsSize binds in sz == sz
600 -- Occurrence analysis
601 let { tagged_binds = {-# SCC "OccAnal" #-} occurAnalysePgm binds } ;
602 Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
603 (pprCoreBindings tagged_binds);
605 -- Get any new rules, and extend the rule base
606 -- We need to do this regularly, because simplification can
607 -- poke on IdInfo thunks, which in turn brings in new rules
608 -- behind the scenes. Otherwise there's a danger we'll simply
609 -- miss the rules for Ids hidden inside imported inlinings
610 eps <- hscEPS hsc_env ;
611 let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps)
612 ; simpl_env = mkSimplEnv mode sw_chkr
613 ; simpl_binds = {-# SCC "SimplTopBinds" #-}
614 simplTopBinds simpl_env tagged_binds
615 ; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
617 -- Simplify the program
618 -- We do this with a *case* not a *let* because lazy pattern
619 -- matching bit us with bad space leak!
620 -- With a let, we ended up with
625 -- case t of {(_,counts') -> if counts'=0 then ... }
626 -- So the conditional didn't force counts', because the
627 -- selection got duplicated. Sigh!
628 case initSmpl dflags rule_base' fam_envs us1 simpl_binds of {
629 (binds', counts') -> do {
631 let { all_counts = counts `plusSimplCount` counts'
632 ; herald = "Simplifier mode " ++ showPpr mode ++
633 ", iteration " ++ show iteration_no ++
634 " out of " ++ show max_iterations
637 -- Stop if nothing happened; don't dump output
638 if isZeroSimplCount counts' then
639 return ("Simplifier reached fixed point", iteration_no,
642 -- Short out indirections
643 -- We do this *after* at least one run of the simplifier
644 -- because indirection-shorting uses the export flag on *occurrences*
645 -- and that isn't guaranteed to be ok until after the first run propagates
646 -- stuff from the binding site to its occurrences
648 -- ToDo: alas, this means that indirection-shorting does not happen at all
649 -- if the simplifier does nothing (not common, I know, but unsavoury)
650 let { binds'' = {-# SCC "ZapInd" #-} shortOutIndirections binds' } ;
652 -- Dump the result of this iteration
653 Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
654 (pprSimplCount counts') ;
655 endIteration dflags herald Opt_D_dump_simpl_iterations binds'' ;
658 do_iteration us2 (iteration_no + 1) all_counts binds''
661 (us1, us2) = splitUniqSupply us
665 %************************************************************************
667 Shorting out indirections
669 %************************************************************************
673 x_local = <expression>
677 where x_exported is exported, and x_local is not, then we replace it with this:
679 x_exported = <expression>
683 Without this we never get rid of the x_exported = x_local thing. This
684 save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
685 makes strictness information propagate better. This used to happen in
686 the final phase, but it's tidier to do it here.
688 STRICTNESS: if we have done strictness analysis, we want the strictness info on
689 x_local to transfer to x_exported. Hence the copyIdInfo call.
691 RULES: we want to *add* any RULES for x_local to x_exported.
693 Note [Rules and indirection-zapping]
694 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
695 Problem: what if x_exported has a RULE that mentions something in ...bindings...?
696 Then the things mentioned can be out of scope! Solution
697 a) Make sure that in this pass the usage-info from x_exported is
698 available for ...bindings...
699 b) If there are any such RULES, rec-ify the entire top-level.
700 It'll get sorted out next time round
704 The example that went bad on me at one stage was this one:
706 iterate :: (a -> a) -> a -> [a]
708 iterate = iterateList
710 iterateFB c f x = x `c` iterateFB c f (f x)
711 iterateList f x = x : iterateList f (f x)
715 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
716 "iterateFB" iterateFB (:) = iterateList
719 This got shorted out to:
721 iterateList :: (a -> a) -> a -> [a]
722 iterateList = iterate
724 iterateFB c f x = x `c` iterateFB c f (f x)
725 iterate f x = x : iterate f (f x)
728 "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)
729 "iterateFB" iterateFB (:) = iterate
732 And now we get an infinite loop in the rule system
733 iterate f x -> build (\cn -> iterateFB c f x)
737 Tiresome old solution:
738 don't do shorting out if f has rewrite rules (see shortableIdInfo)
740 New solution (I think):
741 use rule switching-off pragmas to get rid
742 of iterateList in the first place
747 If more than one exported thing is equal to a local thing (i.e., the
748 local thing really is shared), then we do one only:
751 x_exported1 = x_local
752 x_exported2 = x_local
756 x_exported2 = x_exported1
759 We rely on prior eta reduction to simplify things like
761 x_exported = /\ tyvars -> x_local tyvars
765 Hence,there's a possibility of leaving unchanged something like this:
768 x_exported1 = x_local Int
770 By the time we've thrown away the types in STG land this
771 could be eliminated. But I don't think it's very common
772 and it's dangerous to do this fiddling in STG land
773 because we might elminate a binding that's mentioned in the
774 unfolding for something.
777 type IndEnv = IdEnv Id -- Maps local_id -> exported_id
779 shortOutIndirections :: [CoreBind] -> [CoreBind]
780 shortOutIndirections binds
781 | isEmptyVarEnv ind_env = binds
782 | no_need_to_flatten = binds' -- See Note [Rules and indirect-zapping]
783 | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff
785 ind_env = makeIndEnv binds
786 exp_ids = varSetElems ind_env -- These exported Ids are the subjects
787 exp_id_set = mkVarSet exp_ids -- of the indirection-elimination
788 no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids
789 binds' = concatMap zap binds
791 zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]
792 zap (Rec pairs) = [Rec (concatMap zapPair pairs)]
795 | bndr `elemVarSet` exp_id_set = []
796 | Just exp_id <- lookupVarEnv ind_env bndr = [(transferIdInfo exp_id bndr, rhs),
798 | otherwise = [(bndr,rhs)]
800 makeIndEnv :: [CoreBind] -> IndEnv
802 = foldr add_bind emptyVarEnv binds
804 add_bind :: CoreBind -> IndEnv -> IndEnv
805 add_bind (NonRec exported_id rhs) env = add_pair (exported_id, rhs) env
806 add_bind (Rec pairs) env = foldr add_pair env pairs
808 add_pair :: (Id,CoreExpr) -> IndEnv -> IndEnv
809 add_pair (exported_id, Var local_id) env
810 | shortMeOut env exported_id local_id = extendVarEnv env local_id exported_id
811 add_pair (exported_id, rhs) env
814 shortMeOut ind_env exported_id local_id
815 -- The if-then-else stuff is just so I can get a pprTrace to see
816 -- how often I don't get shorting out becuase of IdInfo stuff
817 = if isExportedId exported_id && -- Only if this is exported
819 isLocalId local_id && -- Only if this one is defined in this
820 -- module, so that we *can* change its
821 -- binding to be the exported thing!
823 not (isExportedId local_id) && -- Only if this one is not itself exported,
824 -- since the transformation will nuke it
826 not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for
831 if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules
832 then True -- See note on "Messing up rules"
835 pprTrace "shortMeOut:" (ppr exported_id)
844 transferIdInfo :: Id -> Id -> Id
846 -- lcl_id = e; exp_id = lcl_id
847 -- and lcl_id has useful IdInfo, we don't want to discard it by going
848 -- gbl_id = e; lcl_id = gbl_id
849 -- Instead, transfer IdInfo from lcl_id to exp_id
850 -- Overwriting, rather than merging, seems to work ok.
851 transferIdInfo exported_id local_id
852 = modifyIdInfo transfer exported_id
854 local_info = idInfo local_id
855 transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
856 `setWorkerInfo` workerInfo local_info
857 `setInlinePragInfo` inlinePragInfo local_info
858 `setSpecInfo` addSpecInfo (specInfo exp_info) new_info
859 new_info = setSpecInfoHead (idName exported_id)
860 (specInfo local_info)
861 -- Remember to set the function-name field of the
862 -- rules as we transfer them from one function to another