2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 module SimplCore ( core2core, simplifyExpr ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
12 SimplifierMode(..), DynFlags, DynFlag(..), dopt,
13 dopt_CoreToDo, buildCoreToDo
16 import TcIface ( loadImportedRules )
17 import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..),
18 ModDetails(..), HomeModInfo(..), HomePackageTable, Dependencies( dep_mods ),
20 import CSE ( cseProgram )
21 import Rules ( RuleBase, ruleBaseIds, emptyRuleBase,
22 extendRuleBaseList, pprRuleBase, ruleCheckProgram )
23 import Module ( elemModuleEnv, lookupModuleEnv )
24 import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
25 import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
26 import CoreUtils ( coreBindsSize )
27 import Simplify ( simplTopBinds, simplExpr )
28 import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
30 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
31 import CoreLint ( endPass )
32 import VarEnv ( mkInScopeSet )
33 import FloatIn ( floatInwards )
34 import FloatOut ( floatOutwards )
35 import Id ( idIsFrom, idSpecialisation, setIdSpecialisation )
37 import LiberateCase ( liberateCase )
38 import SAT ( doStaticArgs )
39 import Specialise ( specProgram)
40 import SpecConstr ( specConstrProgram)
41 import DmdAnal ( dmdAnalPgm )
42 import WorkWrap ( wwTopBinds )
44 import StrictAnal ( saBinds )
45 import CprAnalyse ( cprAnalyse )
48 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
49 import IO ( hPutStr, stderr )
51 import List ( partition )
52 import Maybes ( orElse, fromJust )
55 %************************************************************************
57 \subsection{The driver for the simplifier}
59 %************************************************************************
66 core2core hsc_env guts
68 let dflags = hsc_dflags hsc_env
70 | Just todo <- dopt_CoreToDo dflags = todo
71 | otherwise = buildCoreToDo dflags
73 us <- mkSplitUniqSupply 's'
74 let (cp_us, ru_us) = splitUniqSupply us
76 -- COMPUTE THE RULE BASE TO USE
77 (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
80 (stats, guts'') <- doCorePasses hsc_env cp_us
81 (zeroSimplCount dflags)
82 imp_rule_base guts' core_todos
84 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
85 "Grand total simplifier statistics"
91 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
94 -- simplifyExpr is called by the driver to simplify an
95 -- expression typed in at the interactive prompt
96 simplifyExpr dflags expr
98 ; showPass dflags "Simplify"
100 ; us <- mkSplitUniqSupply 's'
102 ; let (expr', _counts) = initSmpl dflags us $
103 simplExprGently gentleSimplEnv expr
105 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
111 gentleSimplEnv :: SimplEnv
112 gentleSimplEnv = mkSimplEnv SimplGently
116 doCorePasses :: HscEnv
117 -> UniqSupply -- uniques
118 -> SimplCount -- simplifier stats
119 -> RuleBase -- the main rule base
120 -> ModGuts -- local binds in (with rules attached)
121 -> [CoreToDo] -- which passes to do
122 -> IO (SimplCount, ModGuts)
124 doCorePasses hsc_env us stats rb guts []
125 = return (stats, guts)
127 doCorePasses hsc_env us stats rb guts (to_do : to_dos)
129 let (us1, us2) = splitUniqSupply us
130 (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
131 doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos
133 doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws
134 doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram
135 doCorePass CoreLiberateCase = _scc_ "LiberateCase" trBinds liberateCase
136 doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards
137 doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
138 doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds doStaticArgs
139 doCorePass CoreDoStrictness = _scc_ "Stranal" trBinds dmdAnalPgm
140 doCorePass CoreDoWorkerWrapper = _scc_ "WorkWrap" trBindsU wwTopBinds
141 doCorePass CoreDoSpecialising = _scc_ "Specialise" trBindsU specProgram
142 doCorePass CoreDoSpecConstr = _scc_ "SpecConstr" trBindsU specConstrProgram
143 doCorePass CoreDoGlomBinds = trBinds glomBinds
144 doCorePass CoreDoPrintCore = observe printCore
145 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
146 doCorePass CoreDoNothing = observe (\ _ _ -> return ())
147 #ifdef OLD_STRICTNESS
148 doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness
151 #ifdef OLD_STRICTNESS
152 doOldStrictness dfs binds
153 = do binds1 <- saBinds dfs binds
154 binds2 <- cprAnalyse dfs binds1
158 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
160 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
161 printDump (ruleCheckProgram phase pat binds)
163 -- Most passes return no stats and don't change rules
164 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
165 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
166 -> IO (SimplCount, RuleBase, ModGuts)
167 trBinds do_pass hsc_env us rb guts
168 = do { binds' <- do_pass dflags (mg_binds guts)
169 ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
171 dflags = hsc_dflags hsc_env
173 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
174 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
175 -> IO (SimplCount, RuleBase, ModGuts)
176 trBindsU do_pass hsc_env us rb guts
177 = do { binds' <- do_pass dflags us (mg_binds guts)
178 ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
180 dflags = hsc_dflags hsc_env
182 -- Observer passes just peek; don't modify the bindings at all
183 observe :: (DynFlags -> [CoreBind] -> IO a)
184 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
185 -> IO (SimplCount, RuleBase, ModGuts)
186 observe do_pass hsc_env us rb guts
187 = do { binds <- do_pass dflags (mg_binds guts)
188 ; return (zeroSimplCount dflags, rb, guts) }
190 dflags = hsc_dflags hsc_env
195 %************************************************************************
197 \subsection{Dealing with rules}
199 %************************************************************************
201 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
202 -- It attaches those rules that are for local Ids to their binders, and
203 -- returns the remainder attached to Ids in an IdSet.
206 prepareRules :: HscEnv
209 -> IO (RuleBase, -- Rule base for imported things, incl
210 -- (a) rules defined in this module (orphans)
211 -- (b) rules from other packages
212 -- (c) rules from other modules in home package
213 ModGuts) -- Modified fields are
214 -- (a) Bindings have rules attached,
215 -- (b) Rules are now just orphan rules
217 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
218 guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules })
220 = do { eps <- hscEPS hsc_env
222 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
223 -- from the local binders, to avoid warnings from Simplify.simplVar
224 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
225 env = setInScopeSet gentleSimplEnv local_ids
226 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
227 home_pkg_rules = hptRules hsc_env (dep_mods deps)
229 (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
230 -- Get the rules for locally-defined Ids out of the RuleBase
231 -- If we miss any rules for Ids defined here, then we end up
232 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
233 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
234 -- and hence should be cloned), and now the binding for the class method
235 -- doesn't have the same Unique as the one in the Class and the tc-env
236 -- Example: class Foo a where
238 -- {-# RULES "op" op x = x #-}
240 -- NB: we assume that the imported rules dont include
241 -- rules for Ids in this module; if there is, the above bad things may happen
243 pkg_rule_base = eps_rule_base eps
244 hpt_rule_base = extendRuleBaseList pkg_rule_base home_pkg_rules
245 imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
247 -- Update the binders in the local bindings with the lcoal rules
248 -- Update the binders of top-level bindings by
249 -- attaching the rules for each locally-defined Id to that Id.
252 -- - It makes the rules easier to look up
253 -- - It means that transformation rules and specialisations for
254 -- locally defined Ids are handled uniformly
255 -- - It keeps alive things that are referred to only from a rule
256 -- (the occurrence analyser knows about rules attached to Ids)
257 -- - It makes sure that, when we apply a rule, the free vars
258 -- of the RHS are more likely to be in scope
259 -- - The imported rules are carried in the in-scope set
260 -- which is extended on each iteration by the new wave of
261 -- local binders; any rules which aren't on the binding will
262 -- thereby get dropped
263 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
264 binds_w_rules = updateBinders local_rule_base binds
266 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
267 (vcat [text "Local rules", pprIdRules better_rules,
269 text "Imported rules", pprRuleBase imp_rule_base])
272 ; let bad_rules = filter (idIsFrom (mg_module guts))
273 (varSetElems (ruleBaseIds imp_rule_base))
274 ; WARN( not (null bad_rules), ppr bad_rules ) return ()
276 ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
279 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
280 updateBinders rule_base binds
281 = map update_bndrs binds
283 rule_ids = ruleBaseIds rule_base
285 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
286 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
288 update_bndr bndr = case lookupVarSet rule_ids bndr of
290 Just id -> bndr `setIdSpecialisation` idSpecialisation id
294 We must do some gentle simplification on the template (but not the RHS)
295 of each rule. The case that forced me to add this was the fold/build rule,
296 which without simplification looked like:
297 fold k z (build (/\a. g a)) ==> ...
298 This doesn't match unless you do eta reduction on the build argument.
301 simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _))
303 simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
304 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
305 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
306 simplExprGently env rhs `thenSmpl` \ rhs' ->
307 returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs'))
309 -- It's important that simplExprGently does eta reduction.
310 -- For example, in a rule like:
311 -- augment g (build h)
312 -- we do not want to get
313 -- augment (\a. g a) (build h)
314 -- otherwise we don't match when given an argument like
317 -- The simplifier does indeed do eta reduction (it's in
318 -- Simplify.completeLam) but only if -O is on.
322 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
323 -- Simplifies an expression
324 -- does occurrence analysis, then simplification
325 -- and repeats (twice currently) because one pass
326 -- alone leaves tons of crud.
327 -- Used (a) for user expressions typed in at the interactive prompt
328 -- (b) the LHS and RHS of a RULE
330 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
331 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
332 -- enforce that; it just simplifies the expression twice
334 simplExprGently env expr
335 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
336 simplExpr env (occurAnalyseGlobalExpr expr1)
340 %************************************************************************
342 \subsection{Glomming}
344 %************************************************************************
347 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
348 -- Glom all binds together in one Rec, in case any
349 -- transformations have introduced any new dependencies
351 -- NB: the global invariant is this:
352 -- *** the top level bindings are never cloned, and are always unique ***
354 -- We sort them into dependency order, but applying transformation rules may
355 -- make something at the top refer to something at the bottom:
359 -- RULE: p (q x) = h x
361 -- Applying this rule makes f refer to h,
362 -- although it doesn't appear to in the source program.
363 -- This pass lets us control where it happens.
365 -- NOTICE that this cannot happen for rules whose head is a locally-defined
366 -- function. It only happens for rules whose head is an imported function
367 -- (p in the example above). So, for example, the rule had been
368 -- RULE: f (p x) = h x
369 -- then the rule for f would be attached to f itself (in its IdInfo)
370 -- by prepareLocalRuleBase and h would be regarded by the occurrency
371 -- analyser as free in f.
373 glomBinds dflags binds
374 = do { showPass dflags "GlomBinds" ;
375 let { recd_binds = [Rec (flattenBinds binds)] } ;
377 -- Not much point in printing the result...
378 -- just consumes output bandwidth
382 %************************************************************************
384 \subsection{The driver for the simplifier}
386 %************************************************************************
389 simplifyPgm :: SimplifierMode
390 -> [SimplifierSwitch]
395 -> IO (SimplCount, RuleBase, ModGuts) -- New bindings
397 simplifyPgm mode switches hsc_env us rule_base guts
399 showPass dflags "Simplify";
401 (termination_msg, it_count, counts_out, rule_base', guts')
402 <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
404 dumpIfSet (dopt Opt_D_verbose_core2core dflags
405 && dopt Opt_D_dump_simpl_stats dflags)
406 "Simplifier statistics"
407 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
409 pprSimplCount counts_out]);
411 endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
413 return (counts_out, rule_base', guts')
416 dflags = hsc_dflags hsc_env
417 phase_info = case mode of
418 SimplGently -> "gentle"
419 SimplPhase n -> show n
421 sw_chkr = isAmongSimpl switches
422 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
424 do_iteration us rule_base iteration_no counts guts
425 -- iteration_no is the number of the iteration we are
426 -- about to begin, with '1' for the first
427 | iteration_no > max_iterations -- Stop if we've run out of iterations
430 if max_iterations > 2 then
431 hPutStr stderr ("NOTE: Simplifier still going after " ++
432 show max_iterations ++
433 " iterations; bailing out.\n")
437 -- Subtract 1 from iteration_no to get the
438 -- number of iterations we actually completed
439 return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts)
442 -- Try and force thunks off the binds; significantly reduces
443 -- space usage, especially with -O. JRS, 000620.
444 | let sz = coreBindsSize (mg_binds guts) in sz == sz
446 -- Occurrence analysis
447 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
449 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
450 (pprCoreBindings tagged_binds);
452 -- Get any new rules, and extend the rule base
453 -- (on the side this extends the package rule base in the
454 -- ExternalPackageTable, ready for the next complation
456 -- We need to do this regularly, because simplification can
457 -- poke on IdInfo thunks, which in turn brings in new rules
458 -- behind the scenes. Otherwise there's a danger we'll simply
459 -- miss the rules for Ids hidden inside imported inlinings
460 new_rules <- loadImportedRules hsc_env guts ;
461 let { rule_base' = extendRuleBaseList rule_base new_rules
462 ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
463 -- The new rule base Ids are used to initialise
464 -- the in-scope set. That way, the simplifier will change any
465 -- occurrences of the imported id to the one in the imported_rule_ids
466 -- set, which are decorated with their rules.
468 -- Simplify the program
469 -- We do this with a *case* not a *let* because lazy pattern
470 -- matching bit us with bad space leak!
471 -- With a let, we ended up with
476 -- case t of {(_,counts') -> if counts'=0 then ... }
477 -- So the conditional didn't force counts', because the
478 -- selection got duplicated. Sigh!
479 case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
480 (binds', counts') -> do {
482 let { guts' = guts { mg_binds = binds' }
483 ; all_counts = counts `plusSimplCount` counts'
484 ; herald = "Simplifier phase " ++ phase_info ++
485 ", iteration " ++ show iteration_no ++
486 " out of " ++ show max_iterations
489 -- Stop if nothing happened; don't dump output
490 if isZeroSimplCount counts' then
491 return ("Simplifier reached fixed point", iteration_no,
492 all_counts, rule_base', guts')
495 -- Dump the result of this iteration
496 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
497 (pprSimplCount counts') ;
499 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
502 do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
505 (us1, us2) = splitUniqSupply us