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,
16 import CoreFVs ( ruleRhsFreeVars )
17 import HscTypes ( PersistentCompilerState(..), ExternalPackageState(..),
18 HscEnv(..), GhciMode(..),
19 ModGuts(..), ModGuts, Avails, availsToNameSet,
20 PackageRuleBase, HomePackageTable, ModDetails(..),
23 import CSE ( cseProgram )
24 import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
25 extendRuleBaseList, addRuleBaseFVs, pprRuleBase,
27 import Module ( moduleEnvElts )
28 import Name ( Name, isExternalName )
29 import NameSet ( elemNameSet )
30 import PprCore ( pprCoreBindings, pprCoreExpr )
31 import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
32 import CoreUtils ( coreBindsSize )
33 import Simplify ( simplTopBinds, simplExpr )
34 import SimplUtils ( simplBinders )
36 import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
37 import CoreLint ( endPass )
38 import FloatIn ( floatInwards )
39 import FloatOut ( floatOutwards )
40 import Id ( idName, setIdLocalExported )
42 import LiberateCase ( liberateCase )
43 import SAT ( doStaticArgs )
44 import Specialise ( specProgram)
45 import SpecConstr ( specConstrProgram)
46 import DmdAnal ( dmdAnalPgm )
47 import WorkWrap ( wwTopBinds )
49 import StrictAnal ( saBinds )
50 import CprAnalyse ( cprAnalyse )
53 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
54 import IO ( hPutStr, stderr )
57 import Maybes ( orElse )
58 import List ( partition )
61 %************************************************************************
63 \subsection{The driver for the simplifier}
65 %************************************************************************
73 core2core hsc_env pkg_rule_base
74 mod_impl@(ModGuts { mg_exports = exports,
76 mg_rules = rules_in })
78 let dflags = hsc_dflags hsc_env
80 ghci_mode = hsc_mode hsc_env
81 core_todos = dopt_CoreToDo dflags
83 us <- mkSplitUniqSupply 's'
84 let (cp_us, ru_us) = splitUniqSupply us
86 -- COMPUTE THE RULE BASE TO USE
87 (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
88 <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in
90 -- PREPARE THE BINDINGS
91 let binds1 = updateBinders ghci_mode local_rule_ids
92 rule_rhs_fvs exports binds_in
95 (stats, processed_binds)
96 <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
98 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
99 "Grand total simplifier statistics"
100 (pprSimplCount stats)
103 -- We only return local orphan rules, i.e., local rules not attached to an Id
104 -- The bindings cotain more rules, embedded in the Ids
105 return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
108 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
111 -- simplifyExpr is called by the driver to simplify an
112 -- expression typed in at the interactive prompt
113 simplifyExpr dflags expr
115 ; showPass dflags "Simplify"
117 ; us <- mkSplitUniqSupply 's'
119 ; let env = emptySimplEnv SimplGently [] emptyVarSet
120 (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
122 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
129 doCorePasses :: DynFlags
130 -> RuleBase -- the main rule base
131 -> SimplCount -- simplifier stats
132 -> UniqSupply -- uniques
133 -> [CoreBind] -- local binds in (with rules attached)
134 -> [CoreToDo] -- which passes to do
135 -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
137 doCorePasses dflags rb stats us binds []
138 = return (stats, binds)
140 doCorePasses dflags rb stats us binds (to_do : to_dos)
142 let (us1, us2) = splitUniqSupply us
144 (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
146 doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
148 doCorePass dfs rb us binds (CoreDoSimplify mode switches)
149 = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
150 doCorePass dfs rb us binds CoreCSE
151 = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
152 doCorePass dfs rb us binds CoreLiberateCase
153 = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
154 doCorePass dfs rb us binds CoreDoFloatInwards
155 = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
156 doCorePass dfs rb us binds (CoreDoFloatOutwards f)
157 = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
158 doCorePass dfs rb us binds CoreDoStaticArgs
159 = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
160 doCorePass dfs rb us binds CoreDoStrictness
161 = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds)
162 doCorePass dfs rb us binds CoreDoWorkerWrapper
163 = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
164 doCorePass dfs rb us binds CoreDoSpecialising
165 = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
166 doCorePass dfs rb us binds CoreDoSpecConstr
167 = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
168 #ifdef OLD_STRICTNESS
169 doCorePass dfs rb us binds CoreDoOldStrictness
170 = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds)
172 doCorePass dfs rb us binds CoreDoPrintCore
173 = _scc_ "PrintCore" noStats dfs (printCore binds)
174 doCorePass dfs rb us binds CoreDoGlomBinds
175 = noStats dfs (glomBinds dfs binds)
176 doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
177 = noStats dfs (ruleCheck dfs phase pat binds)
178 doCorePass dfs rb us binds CoreDoNothing
179 = noStats dfs (return binds)
181 #ifdef OLD_STRICTNESS
182 doOldStrictness dfs binds
183 = do binds1 <- saBinds dfs binds
184 binds2 <- cprAnalyse dfs binds1
188 printCore binds = do dumpIfSet True "Print Core"
189 (pprCoreBindings binds)
192 ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
193 printDump (ruleCheckProgram phase pat binds)
196 -- most passes return no stats and don't change rules
197 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
203 %************************************************************************
205 \subsection{Dealing with rules}
207 %************************************************************************
209 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
210 -- It attaches those rules that are for local Ids to their binders, and
211 -- returns the remainder attached to Ids in an IdSet. It also returns
212 -- Ids mentioned on LHS of some rule; these should be blacklisted.
214 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
215 -- so that the opportunity to apply the rule isn't lost too soon
218 prepareRules :: DynFlags -> PackageRuleBase -> HomePackageTable
221 -> [IdCoreRule] -- Local rules
222 -> IO (RuleBase, -- Full rule base
223 IdSet, -- Local rule Ids
224 [IdCoreRule], -- Orphan rules
225 IdSet) -- RHS free vars of all rules
227 prepareRules dflags pkg_rule_base hpt us binds local_rules
228 = do { let env = emptySimplEnv SimplGently [] local_ids
229 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
231 ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
232 -- We use (`elemVarSet` local_ids) rather than isLocalId because
233 -- isLocalId isn't true of class methods.
234 -- If we miss any rules for Ids defined here, then we end up
235 -- giving the local decl a new Unique (because the in-scope-set is the
236 -- same as the rule-id set), and now the binding for the class method
237 -- doesn't have the same Unique as the one in the Class and the tc-env
238 -- Example: class Foo a where
240 -- {-# RULES "op" op x = x #-}
242 rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
243 local_rule_base = extendRuleBaseList emptyRuleBase local_rules
244 local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached
245 imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
246 rule_base = extendRuleBaseList imp_rule_base orphan_rules
247 final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
248 -- The last step black-lists the free vars of local rules too
250 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
251 (vcat [text "Local rules", pprRuleBase local_rule_base,
253 text "Imported rules", pprRuleBase final_rule_base])
255 ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
258 add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
260 -- Boringly, we need to gather the in-scope set.
261 local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
264 updateBinders :: GhciMode
265 -> IdSet -- Locally defined ids with their Rules attached
266 -> IdSet -- Ids free in the RHS of local rules
267 -> Avails -- What is exported
268 -> [CoreBind] -> [CoreBind]
269 -- A horrible function
271 -- Update the binders of top-level bindings as follows
272 -- a) Attach the rules for each locally-defined Id to that Id.
273 -- b) Set the no-discard flag if either the Id is exported,
274 -- or it's mentioned in the RHS of a rule
276 -- You might wonder why exported Ids aren't already marked as such;
277 -- it's just because the type checker is rather busy already and
278 -- I didn't want to pass in yet another mapping.
281 -- - It makes the rules easier to look up
282 -- - It means that transformation rules and specialisations for
283 -- locally defined Ids are handled uniformly
284 -- - It keeps alive things that are referred to only from a rule
285 -- (the occurrence analyser knows about rules attached to Ids)
286 -- - It makes sure that, when we apply a rule, the free vars
287 -- of the RHS are more likely to be in scope
290 -- It means that the binding won't be discarded EVEN if the binding
291 -- ends up being trivial (v = w) -- the simplifier would usually just
292 -- substitute w for v throughout, but we don't apply the substitution to
293 -- the rules (maybe we should?), so this substitution would make the rule
296 updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds
297 = map update_bndrs binds
299 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
300 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
303 | dont_discard bndr = setIdLocalExported bndr_with_rules
304 | otherwise = bndr_with_rules
306 bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
308 dont_discard bndr = is_exported (idName bndr)
309 || bndr `elemVarSet` rule_rhs_fvs
311 -- In interactive mode, we don't want to discard any top-level
312 -- entities at all (eg. do not inline them away during
313 -- simplification), and retain them all in the TypeEnv so they are
314 -- available from the command line.
316 -- isExternalName separates the user-defined top-level names from those
317 -- introduced by the type checker.
318 is_exported :: Name -> Bool
319 is_exported | ghci_mode == Interactive = isExternalName
320 | otherwise = (`elemNameSet` export_fvs)
322 export_fvs = availsToNameSet exports
326 We must do some gentle simplification on the template (but not the RHS)
327 of each rule. The case that forced me to add this was the fold/build rule,
328 which without simplification looked like:
329 fold k z (build (/\a. g a)) ==> ...
330 This doesn't match unless you do eta reduction on the build argument.
333 simplRule env rule@(id, BuiltinRule _ _)
335 simplRule env rule@(id, Rule act name bndrs args rhs)
336 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
337 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
338 simplExprGently env rhs `thenSmpl` \ rhs' ->
339 returnSmpl (id, Rule act name bndrs' args' rhs')
341 -- It's important that simplExprGently does eta reduction.
342 -- For example, in a rule like:
343 -- augment g (build h)
344 -- we do not want to get
345 -- augment (\a. g a) (build h)
346 -- otherwise we don't match when given an argument like
349 -- The simplifier does indeed do eta reduction (it's in
350 -- Simplify.completeLam) but only if -O is on.
354 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
355 -- Simplifies an expression
356 -- does occurrence analysis, then simplification
357 -- and repeats (twice currently) because one pass
358 -- alone leaves tons of crud.
359 -- Used (a) for user expressions typed in at the interactive prompt
360 -- (b) the LHS and RHS of a RULE
362 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
363 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
364 -- enforce that; it just simplifies the expression twice
366 simplExprGently env expr
367 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
368 simplExpr env (occurAnalyseGlobalExpr expr1)
372 %************************************************************************
374 \subsection{Glomming}
376 %************************************************************************
379 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
380 -- Glom all binds together in one Rec, in case any
381 -- transformations have introduced any new dependencies
383 -- NB: the global invariant is this:
384 -- *** the top level bindings are never cloned, and are always unique ***
386 -- We sort them into dependency order, but applying transformation rules may
387 -- make something at the top refer to something at the bottom:
391 -- RULE: p (q x) = h x
393 -- Applying this rule makes f refer to h,
394 -- although it doesn't appear to in the source program.
395 -- This pass lets us control where it happens.
397 -- NOTICE that this cannot happen for rules whose head is a locally-defined
398 -- function. It only happens for rules whose head is an imported function
399 -- (p in the example above). So, for example, the rule had been
400 -- RULE: f (p x) = h x
401 -- then the rule for f would be attached to f itself (in its IdInfo)
402 -- by prepareLocalRuleBase and h would be regarded by the occurrency
403 -- analyser as free in f.
405 glomBinds dflags binds
406 = do { showPass dflags "GlomBinds" ;
407 let { recd_binds = [Rec (flattenBinds binds)] } ;
409 -- Not much point in printing the result...
410 -- just consumes output bandwidth
414 %************************************************************************
416 \subsection{The driver for the simplifier}
418 %************************************************************************
421 simplifyPgm :: DynFlags
424 -> [SimplifierSwitch]
426 -> [CoreBind] -- Input
427 -> IO (SimplCount, [CoreBind]) -- New bindings
429 simplifyPgm dflags rule_base
430 mode switches us binds
432 showPass dflags "Simplify";
434 (termination_msg, it_count, counts_out, binds')
435 <- iteration us 1 (zeroSimplCount dflags) binds;
437 dumpIfSet (dopt Opt_D_verbose_core2core dflags
438 && dopt Opt_D_dump_simpl_stats dflags)
439 "Simplifier statistics"
440 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
442 pprSimplCount counts_out]);
444 endPass dflags "Simplify" Opt_D_verbose_core2core binds';
446 return (counts_out, binds')
449 phase_info = case mode of
450 SimplGently -> "gentle"
451 SimplPhase n -> show n
453 imported_rule_ids = ruleBaseIds rule_base
454 simpl_env = emptySimplEnv mode switches imported_rule_ids
455 sw_chkr = getSwitchChecker simpl_env
456 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
458 iteration us iteration_no counts binds
459 -- iteration_no is the number of the iteration we are
460 -- about to begin, with '1' for the first
461 | iteration_no > max_iterations -- Stop if we've run out of iterations
464 if max_iterations > 2 then
465 hPutStr stderr ("NOTE: Simplifier still going after " ++
466 show max_iterations ++
467 " iterations; bailing out.\n")
471 -- Subtract 1 from iteration_no to get the
472 -- number of iterations we actually completed
473 return ("Simplifier baled out", iteration_no - 1, counts, binds)
476 -- Try and force thunks off the binds; significantly reduces
477 -- space usage, especially with -O. JRS, 000620.
478 | let sz = coreBindsSize binds in sz == sz
480 -- Occurrence analysis
481 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
483 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
484 (pprCoreBindings tagged_binds);
487 -- We do this with a *case* not a *let* because lazy pattern
488 -- matching bit us with bad space leak!
489 -- With a let, we ended up with
494 -- case t of {(_,counts') -> if counts'=0 then ... }
495 -- So the conditional didn't force counts', because the
496 -- selection got duplicated. Sigh!
497 case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
498 (binds', counts') -> do {
499 -- The imported_rule_ids are used by initSmpl to initialise
500 -- the in-scope set. That way, the simplifier will change any
501 -- occurrences of the imported id to the one in the imported_rule_ids
502 -- set, which are decorated with their rules.
504 let { all_counts = counts `plusSimplCount` counts' ;
505 herald = "Simplifier phase " ++ phase_info ++
506 ", iteration " ++ show iteration_no ++
507 " out of " ++ show max_iterations
510 -- Stop if nothing happened; don't dump output
511 if isZeroSimplCount counts' then
512 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
515 -- Dump the result of this iteration
516 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
517 (pprSimplCount counts') ;
519 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
522 iteration us2 (iteration_no + 1) all_counts binds'
525 (us1, us2) = splitUniqSupply us