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 UsageSPInf ( doUsageSPInf )
47 import DmdAnal ( dmdAnalPgm )
48 import WorkWrap ( wwTopBinds )
50 import StrictAnal ( saBinds )
51 import CprAnalyse ( cprAnalyse )
54 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
55 import IO ( hPutStr, stderr )
58 import Maybes ( orElse )
59 import List ( partition )
62 %************************************************************************
64 \subsection{The driver for the simplifier}
66 %************************************************************************
70 -> PersistentCompilerState
75 mod_impl@(ModGuts { mg_exports = exports,
77 mg_rules = rules_in })
79 let dflags = hsc_dflags hsc_env
81 ghci_mode = hsc_mode hsc_env
82 core_todos = dopt_CoreToDo dflags
83 pkg_rule_base = eps_rule_base (pcs_EPS pcs) -- Rule-base accumulated from imported packages
85 us <- mkSplitUniqSupply 's'
86 let (cp_us, ru_us) = splitUniqSupply us
88 -- COMPUTE THE RULE BASE TO USE
89 (rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
90 <- prepareRules dflags pkg_rule_base hpt ru_us binds_in rules_in
92 -- PREPARE THE BINDINGS
93 let binds1 = updateBinders ghci_mode local_rule_ids
94 rule_rhs_fvs exports binds_in
97 (stats, processed_binds)
98 <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
100 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
101 "Grand total simplifier statistics"
102 (pprSimplCount stats)
105 -- We only return local orphan rules, i.e., local rules not attached to an Id
106 -- The bindings cotain more rules, embedded in the Ids
107 return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
110 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
113 -- simplifyExpr is called by the driver to simplify an
114 -- expression typed in at the interactive prompt
115 simplifyExpr dflags expr
117 ; showPass dflags "Simplify"
119 ; us <- mkSplitUniqSupply 's'
121 ; let env = emptySimplEnv (SimplPhase 0) [] emptyVarSet
122 (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
124 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
131 doCorePasses :: DynFlags
132 -> RuleBase -- the main rule base
133 -> SimplCount -- simplifier stats
134 -> UniqSupply -- uniques
135 -> [CoreBind] -- local binds in (with rules attached)
136 -> [CoreToDo] -- which passes to do
137 -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
139 doCorePasses dflags rb stats us binds []
140 = return (stats, binds)
142 doCorePasses dflags rb stats us binds (to_do : to_dos)
144 let (us1, us2) = splitUniqSupply us
146 (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
148 doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
150 doCorePass dfs rb us binds (CoreDoSimplify mode switches)
151 = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
152 doCorePass dfs rb us binds CoreCSE
153 = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
154 doCorePass dfs rb us binds CoreLiberateCase
155 = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
156 doCorePass dfs rb us binds CoreDoFloatInwards
157 = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
158 doCorePass dfs rb us binds (CoreDoFloatOutwards f)
159 = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
160 doCorePass dfs rb us binds CoreDoStaticArgs
161 = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
162 doCorePass dfs rb us binds CoreDoStrictness
163 = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds)
164 doCorePass dfs rb us binds CoreDoWorkerWrapper
165 = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
166 doCorePass dfs rb us binds CoreDoSpecialising
167 = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
168 doCorePass dfs rb us binds CoreDoSpecConstr
169 = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
170 #ifdef OLD_STRICTNESS
171 doCorePass dfs rb us binds CoreDoOldStrictness
172 = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds)
174 doCorePass dfs rb us binds CoreDoPrintCore
175 = _scc_ "PrintCore" noStats dfs (printCore binds)
176 doCorePass dfs rb us binds CoreDoUSPInf
177 = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds)
178 doCorePass dfs rb us binds CoreDoGlomBinds
179 = noStats dfs (glomBinds dfs binds)
180 doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
181 = noStats dfs (ruleCheck dfs phase pat binds)
182 doCorePass dfs rb us binds CoreDoNothing
183 = noStats dfs (return binds)
185 #ifdef OLD_STRICTNESS
186 doOldStrictness dfs binds
187 = do binds1 <- saBinds dfs binds
188 binds2 <- cprAnalyse dfs binds1
192 printCore binds = do dumpIfSet True "Print Core"
193 (pprCoreBindings binds)
196 ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
197 printDump (ruleCheckProgram phase pat binds)
200 -- most passes return no stats and don't change rules
201 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
207 %************************************************************************
209 \subsection{Dealing with rules}
211 %************************************************************************
213 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
214 -- It attaches those rules that are for local Ids to their binders, and
215 -- returns the remainder attached to Ids in an IdSet. It also returns
216 -- Ids mentioned on LHS of some rule; these should be blacklisted.
218 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
219 -- so that the opportunity to apply the rule isn't lost too soon
222 prepareRules :: DynFlags -> PackageRuleBase -> HomePackageTable
225 -> [IdCoreRule] -- Local rules
226 -> IO (RuleBase, -- Full rule base
227 IdSet, -- Local rule Ids
228 [IdCoreRule], -- Orphan rules
229 IdSet) -- RHS free vars of all rules
231 prepareRules dflags pkg_rule_base hpt us binds local_rules
232 = do { let env = emptySimplEnv SimplGently [] local_ids
233 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
235 ; let (local_rules, orphan_rules) = partition ((`elemVarSet` local_ids) . fst) better_rules
236 -- We use (`elemVarSet` local_ids) rather than isLocalId because
237 -- isLocalId isn't true of class methods.
238 -- If we miss any rules for Ids defined here, then we end up
239 -- giving the local decl a new Unique (because the in-scope-set is the
240 -- same as the rule-id set), and now the binding for the class method
241 -- doesn't have the same Unique as the one in the Class and the tc-env
242 -- Example: class Foo a where
244 -- {-# RULES "op" op x = x #-}
246 rule_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) better_rules)
247 local_rule_base = extendRuleBaseList emptyRuleBase local_rules
248 local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached
249 imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
250 rule_base = extendRuleBaseList imp_rule_base orphan_rules
251 final_rule_base = addRuleBaseFVs rule_base (ruleBaseFVs local_rule_base)
252 -- The last step black-lists the free vars of local rules too
254 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
255 (vcat [text "Local rules", pprRuleBase local_rule_base,
257 text "Imported rules", pprRuleBase final_rule_base])
259 ; return (final_rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
262 add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
264 -- Boringly, we need to gather the in-scope set.
265 local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
268 updateBinders :: GhciMode
269 -> IdSet -- Locally defined ids with their Rules attached
270 -> IdSet -- Ids free in the RHS of local rules
271 -> Avails -- What is exported
272 -> [CoreBind] -> [CoreBind]
273 -- A horrible function
275 -- Update the binders of top-level bindings as follows
276 -- a) Attach the rules for each locally-defined Id to that Id.
277 -- b) Set the no-discard flag if either the Id is exported,
278 -- or it's mentioned in the RHS of a rule
280 -- You might wonder why exported Ids aren't already marked as such;
281 -- it's just because the type checker is rather busy already and
282 -- I didn't want to pass in yet another mapping.
285 -- - It makes the rules easier to look up
286 -- - It means that transformation rules and specialisations for
287 -- locally defined Ids are handled uniformly
288 -- - It keeps alive things that are referred to only from a rule
289 -- (the occurrence analyser knows about rules attached to Ids)
290 -- - It makes sure that, when we apply a rule, the free vars
291 -- of the RHS are more likely to be in scope
294 -- It means that the binding won't be discarded EVEN if the binding
295 -- ends up being trivial (v = w) -- the simplifier would usually just
296 -- substitute w for v throughout, but we don't apply the substitution to
297 -- the rules (maybe we should?), so this substitution would make the rule
300 updateBinders ghci_mode rule_ids rule_rhs_fvs exports binds
301 = map update_bndrs binds
303 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
304 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
307 | dont_discard bndr = setIdLocalExported bndr_with_rules
308 | otherwise = bndr_with_rules
310 bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
312 dont_discard bndr = is_exported (idName bndr)
313 || bndr `elemVarSet` rule_rhs_fvs
315 -- In interactive mode, we don't want to discard any top-level
316 -- entities at all (eg. do not inline them away during
317 -- simplification), and retain them all in the TypeEnv so they are
318 -- available from the command line.
320 -- isExternalName separates the user-defined top-level names from those
321 -- introduced by the type checker.
322 is_exported :: Name -> Bool
323 is_exported | ghci_mode == Interactive = isExternalName
324 | otherwise = (`elemNameSet` export_fvs)
326 export_fvs = availsToNameSet exports
330 We must do some gentle simplification on the template (but not the RHS)
331 of each rule. The case that forced me to add this was the fold/build rule,
332 which without simplification looked like:
333 fold k z (build (/\a. g a)) ==> ...
334 This doesn't match unless you do eta reduction on the build argument.
337 simplRule env rule@(id, BuiltinRule _ _)
339 simplRule env rule@(id, Rule act name bndrs args rhs)
340 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
341 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
342 simplExprGently env rhs `thenSmpl` \ rhs' ->
343 returnSmpl (id, Rule act name bndrs' args' rhs')
345 -- It's important that simplExprGently does eta reduction.
346 -- For example, in a rule like:
347 -- augment g (build h)
348 -- we do not want to get
349 -- augment (\a. g a) (build h)
350 -- otherwise we don't match when given an argument like
353 -- The simplifier does indeed do eta reduction (it's in
354 -- Simplify.completeLam) but only if -O is on.
358 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
359 -- Simplifies an expression
360 -- does occurrence analysis, then simplification
361 -- and repeats (twice currently) because one pass
362 -- alone leaves tons of crud.
363 -- Used (a) for user expressions typed in at the interactive prompt
364 -- (b) the LHS and RHS of a RULE
365 simplExprGently env expr
366 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
367 simplExpr env (occurAnalyseGlobalExpr expr1)
371 %************************************************************************
373 \subsection{Glomming}
375 %************************************************************************
378 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
379 -- Glom all binds together in one Rec, in case any
380 -- transformations have introduced any new dependencies
382 -- NB: the global invariant is this:
383 -- *** the top level bindings are never cloned, and are always unique ***
385 -- We sort them into dependency order, but applying transformation rules may
386 -- make something at the top refer to something at the bottom:
390 -- RULE: p (q x) = h x
392 -- Applying this rule makes f refer to h,
393 -- although it doesn't appear to in the source program.
394 -- This pass lets us control where it happens.
396 -- NOTICE that this cannot happen for rules whose head is a locally-defined
397 -- function. It only happens for rules whose head is an imported function
398 -- (p in the example above). So, for example, the rule had been
399 -- RULE: f (p x) = h x
400 -- then the rule for f would be attached to f itself (in its IdInfo)
401 -- by prepareLocalRuleBase and h would be regarded by the occurrency
402 -- analyser as free in f.
404 glomBinds dflags binds
405 = do { showPass dflags "GlomBinds" ;
406 let { recd_binds = [Rec (flattenBinds binds)] } ;
408 -- Not much point in printing the result...
409 -- just consumes output bandwidth
413 %************************************************************************
415 \subsection{The driver for the simplifier}
417 %************************************************************************
420 simplifyPgm :: DynFlags
423 -> [SimplifierSwitch]
425 -> [CoreBind] -- Input
426 -> IO (SimplCount, [CoreBind]) -- New bindings
428 simplifyPgm dflags rule_base
429 mode switches us binds
431 showPass dflags "Simplify";
433 (termination_msg, it_count, counts_out, binds')
434 <- iteration us 1 (zeroSimplCount dflags) binds;
436 dumpIfSet (dopt Opt_D_verbose_core2core dflags
437 && dopt Opt_D_dump_simpl_stats dflags)
438 "Simplifier statistics"
439 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
441 pprSimplCount counts_out]);
443 endPass dflags "Simplify" Opt_D_verbose_core2core binds';
445 return (counts_out, binds')
448 phase_info = case mode of
449 SimplGently -> "gentle"
450 SimplPhase n -> show n
452 imported_rule_ids = ruleBaseIds rule_base
453 simpl_env = emptySimplEnv mode switches imported_rule_ids
454 sw_chkr = getSwitchChecker simpl_env
455 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
457 iteration us iteration_no counts binds
458 -- Try and force thunks off the binds; significantly reduces
459 -- space usage, especially with -O. JRS, 000620.
460 | let sz = coreBindsSize binds in sz == sz
462 -- Occurrence analysis
463 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
465 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
466 (pprCoreBindings tagged_binds);
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 {
481 -- The imported_rule_ids are used by initSmpl to initialise
482 -- the in-scope set. That way, the simplifier will change any
483 -- occurrences of the imported id to the one in the imported_rule_ids
484 -- set, which are decorated with their rules.
486 let { all_counts = counts `plusSimplCount` counts' ;
487 herald = "Simplifier phase " ++ phase_info ++
488 ", iteration " ++ show iteration_no ++
489 " out of " ++ show max_iterations
492 -- Stop if nothing happened; don't dump output
493 if isZeroSimplCount counts' then
494 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
497 -- Dump the result of this iteration
498 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
499 (pprSimplCount counts') ;
501 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
503 -- Stop if we've run out of iterations
504 if iteration_no == max_iterations then
507 if max_iterations > 2 then
508 hPutStr stderr ("NOTE: Simplifier still going after " ++
509 show max_iterations ++
510 " iterations; bailing out.\n")
515 return ("Simplifier baled out", iteration_no, all_counts, binds')
519 else iteration us2 (iteration_no + 1) all_counts binds'
522 (us1, us2) = splitUniqSupply us