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(..), hscEPS )
19 import CSE ( cseProgram )
20 import Rules ( RuleBase, ruleBaseIds, emptyRuleBase,
21 extendRuleBaseList, pprRuleBase, ruleCheckProgram )
22 import Module ( moduleEnvElts )
23 import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
24 import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
25 import CoreUtils ( coreBindsSize )
26 import Simplify ( simplTopBinds, simplExpr )
27 import SimplUtils ( simplBinders )
29 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
30 import CoreLint ( endPass )
31 import Subst ( mkInScopeSet )
32 import FloatIn ( floatInwards )
33 import FloatOut ( floatOutwards )
34 import Id ( idIsFrom, idSpecialisation, setIdSpecialisation )
36 import LiberateCase ( liberateCase )
37 import SAT ( doStaticArgs )
38 import Specialise ( specProgram)
39 import SpecConstr ( specConstrProgram)
40 import DmdAnal ( dmdAnalPgm )
41 import WorkWrap ( wwTopBinds )
43 import StrictAnal ( saBinds )
44 import CprAnalyse ( cprAnalyse )
47 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
48 import IO ( hPutStr, stderr )
50 import List ( partition )
51 import Maybes ( orElse )
54 %************************************************************************
56 \subsection{The driver for the simplifier}
58 %************************************************************************
65 core2core hsc_env guts
67 let dflags = hsc_dflags hsc_env
69 | Just todo <- dopt_CoreToDo dflags = todo
70 | otherwise = buildCoreToDo dflags
72 us <- mkSplitUniqSupply 's'
73 let (cp_us, ru_us) = splitUniqSupply us
75 -- COMPUTE THE RULE BASE TO USE
76 (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us
79 (stats, guts'') <- doCorePasses hsc_env cp_us
80 (zeroSimplCount dflags)
81 imp_rule_base guts' core_todos
83 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
84 "Grand total simplifier statistics"
90 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
93 -- simplifyExpr is called by the driver to simplify an
94 -- expression typed in at the interactive prompt
95 simplifyExpr dflags expr
97 ; showPass dflags "Simplify"
99 ; us <- mkSplitUniqSupply 's'
101 ; let env = emptySimplEnv SimplGently []
102 (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
104 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
110 doCorePasses :: HscEnv
111 -> UniqSupply -- uniques
112 -> SimplCount -- simplifier stats
113 -> RuleBase -- the main rule base
114 -> ModGuts -- local binds in (with rules attached)
115 -> [CoreToDo] -- which passes to do
116 -> IO (SimplCount, ModGuts)
118 doCorePasses hsc_env us stats rb guts []
119 = return (stats, guts)
121 doCorePasses hsc_env us stats rb guts (to_do : to_dos)
123 let (us1, us2) = splitUniqSupply us
124 (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
125 doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos
127 doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws
128 doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram
129 doCorePass CoreLiberateCase = _scc_ "LiberateCase" trBinds liberateCase
130 doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards
131 doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
132 doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds doStaticArgs
133 doCorePass CoreDoStrictness = _scc_ "Stranal" trBinds dmdAnalPgm
134 doCorePass CoreDoWorkerWrapper = _scc_ "WorkWrap" trBindsU wwTopBinds
135 doCorePass CoreDoSpecialising = _scc_ "Specialise" trBindsU specProgram
136 doCorePass CoreDoSpecConstr = _scc_ "SpecConstr" trBindsU specConstrProgram
137 doCorePass CoreDoGlomBinds = trBinds glomBinds
138 doCorePass CoreDoPrintCore = observe printCore
139 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
140 doCorePass CoreDoNothing = observe (\ _ _ -> return ())
141 #ifdef OLD_STRICTNESS
142 doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness
145 #ifdef OLD_STRICTNESS
146 doOldStrictness dfs binds
147 = do binds1 <- saBinds dfs binds
148 binds2 <- cprAnalyse dfs binds1
152 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
154 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
155 printDump (ruleCheckProgram phase pat binds)
157 -- Most passes return no stats and don't change rules
158 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
159 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
160 -> IO (SimplCount, RuleBase, ModGuts)
161 trBinds do_pass hsc_env us rb guts
162 = do { binds' <- do_pass dflags (mg_binds guts)
163 ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
165 dflags = hsc_dflags hsc_env
167 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
168 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
169 -> IO (SimplCount, RuleBase, ModGuts)
170 trBindsU do_pass hsc_env us rb guts
171 = do { binds' <- do_pass dflags us (mg_binds guts)
172 ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
174 dflags = hsc_dflags hsc_env
176 -- Observer passes just peek; don't modify the bindings at all
177 observe :: (DynFlags -> [CoreBind] -> IO a)
178 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
179 -> IO (SimplCount, RuleBase, ModGuts)
180 observe do_pass hsc_env us rb guts
181 = do { binds <- do_pass dflags (mg_binds guts)
182 ; return (zeroSimplCount dflags, rb, guts) }
184 dflags = hsc_dflags hsc_env
189 %************************************************************************
191 \subsection{Dealing with rules}
193 %************************************************************************
195 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
196 -- It attaches those rules that are for local Ids to their binders, and
197 -- returns the remainder attached to Ids in an IdSet.
200 prepareRules :: HscEnv
203 -> IO (RuleBase, -- Rule base for imported things, incl
204 -- (a) rules defined in this module (orphans)
205 -- (b) rules from other packages
206 -- (c) rules from other modules in home package
207 ModGuts) -- Modified fields are
208 -- (a) Bindings have rules attached,
209 -- (b) Rules are now just orphan rules
211 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
212 guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
214 = do { eps <- hscEPS hsc_env
216 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
217 -- from the local binders, to avoid warnings from Simplify.simplVar
218 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
219 env = setInScopeSet (emptySimplEnv SimplGently []) local_ids
220 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
222 (rules_for_locals, orphan_rules) = partition is_local_rule better_rules
223 is_local_rule (id,_) = idIsFrom this_mod id
224 -- Get the rules for locally-defined Ids out of the RuleBase
225 -- If we miss any rules for Ids defined here, then we end up
226 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
227 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
228 -- and hence should be cloned), and now the binding for the class method
229 -- doesn't have the same Unique as the one in the Class and the tc-env
230 -- Example: class Foo a where
232 -- {-# RULES "op" op x = x #-}
234 -- NB we can't use isLocalId, because isLocalId isn't true of class methods.
236 -- NB: we assume that the imported rules dont include
237 -- rules for Ids in this module; if there is, the above bad things may happen
239 pkg_rule_base = eps_rule_base eps
240 hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
241 imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
243 -- Update the binders in the local bindings with the lcoal rules
244 -- Update the binders of top-level bindings by
245 -- attaching the rules for each locally-defined Id to that Id.
248 -- - It makes the rules easier to look up
249 -- - It means that transformation rules and specialisations for
250 -- locally defined Ids are handled uniformly
251 -- - It keeps alive things that are referred to only from a rule
252 -- (the occurrence analyser knows about rules attached to Ids)
253 -- - It makes sure that, when we apply a rule, the free vars
254 -- of the RHS are more likely to be in scope
255 -- - The imported rules are carried in the in-scope set
256 -- which is extended on each iteration by the new wave of
257 -- local binders; any rules which aren't on the binding will
258 -- thereby get dropped
259 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
260 binds_w_rules = updateBinders local_rule_base binds
262 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
263 (vcat [text "Local rules", pprIdRules better_rules,
265 text "Imported rules", pprRuleBase imp_rule_base])
268 ; let bad_rules = filter (idIsFrom this_mod) (varSetElems (ruleBaseIds imp_rule_base))
269 ; WARN( not (null bad_rules), ppr bad_rules ) return ()
271 ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
274 add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
276 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
277 updateBinders rule_base binds
278 = map update_bndrs binds
280 rule_ids = ruleBaseIds rule_base
282 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
283 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
285 update_bndr bndr = case lookupVarSet rule_ids bndr of
287 Just id -> bndr `setIdSpecialisation` idSpecialisation id
291 We must do some gentle simplification on the template (but not the RHS)
292 of each rule. The case that forced me to add this was the fold/build rule,
293 which without simplification looked like:
294 fold k z (build (/\a. g a)) ==> ...
295 This doesn't match unless you do eta reduction on the build argument.
298 simplRule env rule@(id, BuiltinRule _ _)
300 simplRule env rule@(id, Rule act name bndrs args rhs)
301 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
302 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
303 simplExprGently env rhs `thenSmpl` \ rhs' ->
304 returnSmpl (id, Rule act name bndrs' args' rhs')
306 -- It's important that simplExprGently does eta reduction.
307 -- For example, in a rule like:
308 -- augment g (build h)
309 -- we do not want to get
310 -- augment (\a. g a) (build h)
311 -- otherwise we don't match when given an argument like
314 -- The simplifier does indeed do eta reduction (it's in
315 -- Simplify.completeLam) but only if -O is on.
319 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
320 -- Simplifies an expression
321 -- does occurrence analysis, then simplification
322 -- and repeats (twice currently) because one pass
323 -- alone leaves tons of crud.
324 -- Used (a) for user expressions typed in at the interactive prompt
325 -- (b) the LHS and RHS of a RULE
327 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
328 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
329 -- enforce that; it just simplifies the expression twice
331 simplExprGently env expr
332 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
333 simplExpr env (occurAnalyseGlobalExpr expr1)
337 %************************************************************************
339 \subsection{Glomming}
341 %************************************************************************
344 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
345 -- Glom all binds together in one Rec, in case any
346 -- transformations have introduced any new dependencies
348 -- NB: the global invariant is this:
349 -- *** the top level bindings are never cloned, and are always unique ***
351 -- We sort them into dependency order, but applying transformation rules may
352 -- make something at the top refer to something at the bottom:
356 -- RULE: p (q x) = h x
358 -- Applying this rule makes f refer to h,
359 -- although it doesn't appear to in the source program.
360 -- This pass lets us control where it happens.
362 -- NOTICE that this cannot happen for rules whose head is a locally-defined
363 -- function. It only happens for rules whose head is an imported function
364 -- (p in the example above). So, for example, the rule had been
365 -- RULE: f (p x) = h x
366 -- then the rule for f would be attached to f itself (in its IdInfo)
367 -- by prepareLocalRuleBase and h would be regarded by the occurrency
368 -- analyser as free in f.
370 glomBinds dflags binds
371 = do { showPass dflags "GlomBinds" ;
372 let { recd_binds = [Rec (flattenBinds binds)] } ;
374 -- Not much point in printing the result...
375 -- just consumes output bandwidth
379 %************************************************************************
381 \subsection{The driver for the simplifier}
383 %************************************************************************
386 simplifyPgm :: SimplifierMode
387 -> [SimplifierSwitch]
392 -> IO (SimplCount, RuleBase, ModGuts) -- New bindings
394 simplifyPgm mode switches hsc_env us rule_base guts
396 showPass dflags "Simplify";
398 (termination_msg, it_count, counts_out, rule_base', guts')
399 <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
401 dumpIfSet (dopt Opt_D_verbose_core2core dflags
402 && dopt Opt_D_dump_simpl_stats dflags)
403 "Simplifier statistics"
404 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
406 pprSimplCount counts_out]);
408 endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
410 return (counts_out, rule_base', guts')
413 dflags = hsc_dflags hsc_env
414 phase_info = case mode of
415 SimplGently -> "gentle"
416 SimplPhase n -> show n
418 simpl_env = emptySimplEnv mode switches
419 sw_chkr = getSwitchChecker simpl_env
420 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
422 do_iteration us rule_base iteration_no counts guts
423 -- iteration_no is the number of the iteration we are
424 -- about to begin, with '1' for the first
425 | iteration_no > max_iterations -- Stop if we've run out of iterations
428 if max_iterations > 2 then
429 hPutStr stderr ("NOTE: Simplifier still going after " ++
430 show max_iterations ++
431 " iterations; bailing out.\n")
435 -- Subtract 1 from iteration_no to get the
436 -- number of iterations we actually completed
437 return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts)
440 -- Try and force thunks off the binds; significantly reduces
441 -- space usage, especially with -O. JRS, 000620.
442 | let sz = coreBindsSize (mg_binds guts) in sz == sz
444 -- Occurrence analysis
445 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
447 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
448 (pprCoreBindings tagged_binds);
450 -- Get any new rules, and extend the rule base
451 -- (on the side this extends the package rule base in the
452 -- ExternalPackageTable, ready for the next complation
454 -- We need to do this regularly, because simplification can
455 -- poke on IdInfo thunks, which in turn brings in new rules
456 -- behind the scenes. Otherwise there's a danger we'll simply
457 -- miss the rules for Ids hidden inside imported inlinings
458 new_rules <- loadImportedRules hsc_env guts ;
459 let { rule_base' = extendRuleBaseList rule_base new_rules
460 ; in_scope = mkInScopeSet (ruleBaseIds rule_base')
461 ; simpl_env' = setInScopeSet simpl_env in_scope } ;
462 -- The new rule base Ids are used to initialise
463 -- the in-scope set. That way, the simplifier will change any
464 -- occurrences of the imported id to the one in the imported_rule_ids
465 -- set, which are decorated with their rules.
467 -- Simplify the program
468 -- We do this with a *case* not a *let* because lazy pattern
469 -- matching bit us with bad space leak!
470 -- With a let, we ended up with
475 -- case t of {(_,counts') -> if counts'=0 then ... }
476 -- So the conditional didn't force counts', because the
477 -- selection got duplicated. Sigh!
478 case initSmpl dflags us1 (simplTopBinds simpl_env' tagged_binds) of {
479 (binds', counts') -> do {
481 let { guts' = guts { mg_binds = binds' }
482 ; all_counts = counts `plusSimplCount` counts'
483 ; herald = "Simplifier phase " ++ phase_info ++
484 ", iteration " ++ show iteration_no ++
485 " out of " ++ show max_iterations
488 -- Stop if nothing happened; don't dump output
489 if isZeroSimplCount counts' then
490 return ("Simplifier reached fixed point", iteration_no,
491 all_counts, rule_base', guts')
494 -- Dump the result of this iteration
495 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
496 (pprSimplCount counts') ;
498 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
501 do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
504 (us1, us2) = splitUniqSupply us