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(..), ModGuts,
18 ModDetails(..), HomeModInfo(..) )
19 import CSE ( cseProgram )
20 import Rules ( RuleBase, ruleBaseIds,
21 extendRuleBaseList, pprRuleBase, getLocalRules,
23 import Module ( moduleEnvElts )
24 import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
25 import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
26 import CoreUtils ( coreBindsSize )
27 import Simplify ( simplTopBinds, simplExpr )
28 import SimplUtils ( simplBinders )
30 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
31 import CoreLint ( endPass )
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 )
51 import Maybes ( orElse )
54 %************************************************************************
56 \subsection{The driver for the simplifier}
58 %************************************************************************
66 mod_impl@(ModGuts { mg_binds = binds_in })
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 (rule_base, local_rule_ids, orphan_rules)
78 <- prepareRules hsc_env mod_impl ru_us
80 -- PREPARE THE BINDINGS
81 let binds1 = updateBinders local_rule_ids binds_in
84 (stats, processed_binds)
85 <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
87 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
88 "Grand total simplifier statistics"
92 -- We only return local orphan rules, i.e., local rules not attached to an Id
93 -- The bindings cotain more rules, embedded in the Ids
94 return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
97 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
100 -- simplifyExpr is called by the driver to simplify an
101 -- expression typed in at the interactive prompt
102 simplifyExpr dflags expr
104 ; showPass dflags "Simplify"
106 ; us <- mkSplitUniqSupply 's'
108 ; let env = emptySimplEnv SimplGently [] emptyVarSet
109 (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
111 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
118 doCorePasses :: DynFlags
119 -> RuleBase -- the main rule base
120 -> SimplCount -- simplifier stats
121 -> UniqSupply -- uniques
122 -> [CoreBind] -- local binds in (with rules attached)
123 -> [CoreToDo] -- which passes to do
124 -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
126 doCorePasses dflags rb stats us binds []
127 = return (stats, binds)
129 doCorePasses dflags rb stats us binds (to_do : to_dos)
131 let (us1, us2) = splitUniqSupply us
133 (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
135 doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
137 doCorePass dfs rb us binds (CoreDoSimplify mode switches)
138 = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
139 doCorePass dfs rb us binds CoreCSE
140 = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
141 doCorePass dfs rb us binds CoreLiberateCase
142 = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
143 doCorePass dfs rb us binds CoreDoFloatInwards
144 = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
145 doCorePass dfs rb us binds (CoreDoFloatOutwards f)
146 = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
147 doCorePass dfs rb us binds CoreDoStaticArgs
148 = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
149 doCorePass dfs rb us binds CoreDoStrictness
150 = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds)
151 doCorePass dfs rb us binds CoreDoWorkerWrapper
152 = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
153 doCorePass dfs rb us binds CoreDoSpecialising
154 = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
155 doCorePass dfs rb us binds CoreDoSpecConstr
156 = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
157 #ifdef OLD_STRICTNESS
158 doCorePass dfs rb us binds CoreDoOldStrictness
159 = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds)
161 doCorePass dfs rb us binds CoreDoPrintCore
162 = _scc_ "PrintCore" noStats dfs (printCore binds)
163 doCorePass dfs rb us binds CoreDoGlomBinds
164 = noStats dfs (glomBinds dfs binds)
165 doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
166 = noStats dfs (ruleCheck dfs phase pat binds)
167 doCorePass dfs rb us binds CoreDoNothing
168 = noStats dfs (return binds)
170 #ifdef OLD_STRICTNESS
171 doOldStrictness dfs binds
172 = do binds1 <- saBinds dfs binds
173 binds2 <- cprAnalyse dfs binds1
177 printCore binds = do dumpIfSet True "Print Core"
178 (pprCoreBindings binds)
181 ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
182 printDump (ruleCheckProgram phase pat binds)
185 -- most passes return no stats and don't change rules
186 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
192 %************************************************************************
194 \subsection{Dealing with rules}
196 %************************************************************************
198 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
199 -- It attaches those rules that are for local Ids to their binders, and
200 -- returns the remainder attached to Ids in an IdSet. It also returns
201 -- Ids mentioned on LHS of some rule; these should be blacklisted.
203 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
204 -- so that the opportunity to apply the rule isn't lost too soon
207 prepareRules :: HscEnv
210 -> IO (RuleBase, -- Full rule base
211 IdSet, -- Local rule Ids
212 [IdCoreRule]) -- Orphan rules defined in this module
214 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
215 guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
217 = do { pkg_rule_base <- loadImportedRules hsc_env guts
219 ; let env = emptySimplEnv SimplGently [] local_ids
220 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
222 imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
223 full_rule_base = extendRuleBaseList imp_rule_base better_rules
225 (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base
226 -- NB: the imported rules may include rules for Ids in this module
227 -- which is why we suck the local rules out of full_rule_base
229 orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules
231 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
232 (vcat [text "Local rules", pprIdRules better_rules,
234 text "Imported rules", pprRuleBase final_rule_base])
236 ; return (final_rule_base, local_rule_ids, orphan_rules)
239 add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
241 -- Boringly, we need to gather the in-scope set.
242 local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
245 updateBinders :: IdSet -- Locally defined ids with their Rules attached
246 -> [CoreBind] -> [CoreBind]
247 -- A horrible function
249 -- Update the binders of top-level bindings by
250 -- attaching the rules for each locally-defined Id to that Id.
253 -- - It makes the rules easier to look up
254 -- - It means that transformation rules and specialisations for
255 -- locally defined Ids are handled uniformly
256 -- - It keeps alive things that are referred to only from a rule
257 -- (the occurrence analyser knows about rules attached to Ids)
258 -- - It makes sure that, when we apply a rule, the free vars
259 -- of the RHS are more likely to be in scope
261 updateBinders rule_ids binds
262 = map update_bndrs binds
264 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
265 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
267 update_bndr bndr = case lookupVarSet rule_ids bndr of
269 Just id -> bndr `setIdSpecialisation` idSpecialisation id
273 We must do some gentle simplification on the template (but not the RHS)
274 of each rule. The case that forced me to add this was the fold/build rule,
275 which without simplification looked like:
276 fold k z (build (/\a. g a)) ==> ...
277 This doesn't match unless you do eta reduction on the build argument.
280 simplRule env rule@(id, BuiltinRule _ _)
282 simplRule env rule@(id, Rule act name bndrs args rhs)
283 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
284 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
285 simplExprGently env rhs `thenSmpl` \ rhs' ->
286 returnSmpl (id, Rule act name bndrs' args' rhs')
288 -- It's important that simplExprGently does eta reduction.
289 -- For example, in a rule like:
290 -- augment g (build h)
291 -- we do not want to get
292 -- augment (\a. g a) (build h)
293 -- otherwise we don't match when given an argument like
296 -- The simplifier does indeed do eta reduction (it's in
297 -- Simplify.completeLam) but only if -O is on.
301 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
302 -- Simplifies an expression
303 -- does occurrence analysis, then simplification
304 -- and repeats (twice currently) because one pass
305 -- alone leaves tons of crud.
306 -- Used (a) for user expressions typed in at the interactive prompt
307 -- (b) the LHS and RHS of a RULE
309 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
310 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
311 -- enforce that; it just simplifies the expression twice
313 simplExprGently env expr
314 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
315 simplExpr env (occurAnalyseGlobalExpr expr1)
319 %************************************************************************
321 \subsection{Glomming}
323 %************************************************************************
326 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
327 -- Glom all binds together in one Rec, in case any
328 -- transformations have introduced any new dependencies
330 -- NB: the global invariant is this:
331 -- *** the top level bindings are never cloned, and are always unique ***
333 -- We sort them into dependency order, but applying transformation rules may
334 -- make something at the top refer to something at the bottom:
338 -- RULE: p (q x) = h x
340 -- Applying this rule makes f refer to h,
341 -- although it doesn't appear to in the source program.
342 -- This pass lets us control where it happens.
344 -- NOTICE that this cannot happen for rules whose head is a locally-defined
345 -- function. It only happens for rules whose head is an imported function
346 -- (p in the example above). So, for example, the rule had been
347 -- RULE: f (p x) = h x
348 -- then the rule for f would be attached to f itself (in its IdInfo)
349 -- by prepareLocalRuleBase and h would be regarded by the occurrency
350 -- analyser as free in f.
352 glomBinds dflags binds
353 = do { showPass dflags "GlomBinds" ;
354 let { recd_binds = [Rec (flattenBinds binds)] } ;
356 -- Not much point in printing the result...
357 -- just consumes output bandwidth
361 %************************************************************************
363 \subsection{The driver for the simplifier}
365 %************************************************************************
368 simplifyPgm :: DynFlags
371 -> [SimplifierSwitch]
373 -> [CoreBind] -- Input
374 -> IO (SimplCount, [CoreBind]) -- New bindings
376 simplifyPgm dflags rule_base
377 mode switches us binds
379 showPass dflags "Simplify";
381 (termination_msg, it_count, counts_out, binds')
382 <- iteration us 1 (zeroSimplCount dflags) binds;
384 dumpIfSet (dopt Opt_D_verbose_core2core dflags
385 && dopt Opt_D_dump_simpl_stats dflags)
386 "Simplifier statistics"
387 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
389 pprSimplCount counts_out]);
391 endPass dflags "Simplify" Opt_D_verbose_core2core binds';
393 return (counts_out, binds')
396 phase_info = case mode of
397 SimplGently -> "gentle"
398 SimplPhase n -> show n
400 imported_rule_ids = ruleBaseIds rule_base
401 simpl_env = emptySimplEnv mode switches imported_rule_ids
402 sw_chkr = getSwitchChecker simpl_env
403 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
405 iteration us iteration_no counts binds
406 -- iteration_no is the number of the iteration we are
407 -- about to begin, with '1' for the first
408 | iteration_no > max_iterations -- Stop if we've run out of iterations
411 if max_iterations > 2 then
412 hPutStr stderr ("NOTE: Simplifier still going after " ++
413 show max_iterations ++
414 " iterations; bailing out.\n")
418 -- Subtract 1 from iteration_no to get the
419 -- number of iterations we actually completed
420 return ("Simplifier baled out", iteration_no - 1, counts, binds)
423 -- Try and force thunks off the binds; significantly reduces
424 -- space usage, especially with -O. JRS, 000620.
425 | let sz = coreBindsSize binds in sz == sz
427 -- Occurrence analysis
428 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
430 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
431 (pprCoreBindings tagged_binds);
434 -- We do this with a *case* not a *let* because lazy pattern
435 -- matching bit us with bad space leak!
436 -- With a let, we ended up with
441 -- case t of {(_,counts') -> if counts'=0 then ... }
442 -- So the conditional didn't force counts', because the
443 -- selection got duplicated. Sigh!
444 case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
445 (binds', counts') -> do {
446 -- The imported_rule_ids are used by initSmpl to initialise
447 -- the in-scope set. That way, the simplifier will change any
448 -- occurrences of the imported id to the one in the imported_rule_ids
449 -- set, which are decorated with their rules.
451 let { all_counts = counts `plusSimplCount` counts' ;
452 herald = "Simplifier phase " ++ phase_info ++
453 ", iteration " ++ show iteration_no ++
454 " out of " ++ show max_iterations
457 -- Stop if nothing happened; don't dump output
458 if isZeroSimplCount counts' then
459 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
462 -- Dump the result of this iteration
463 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
464 (pprSimplCount counts') ;
466 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
469 iteration us2 (iteration_no + 1) all_counts binds'
472 (us1, us2) = splitUniqSupply us