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 CoreFVs ( ruleRhsFreeVars )
17 import TcIface ( loadImportedRules )
18 import HscTypes ( HscEnv(..), GhciMode(..),
19 ModGuts(..), ModGuts, Avails, availsToNameSet,
21 HomeModInfo(..), ExternalPackageState(..), hscEPS
23 import CSE ( cseProgram )
24 import Rules ( RuleBase, emptyRuleBase, ruleBaseIds,
25 extendRuleBaseList, pprRuleBase, getLocalRules,
27 import Module ( moduleEnvElts )
28 import Name ( Name, isExternalName )
29 import NameSet ( elemNameSet )
30 import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules )
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, idIsFrom, 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 mod_impl@(ModGuts { mg_exports = exports,
74 mg_binds = binds_in })
76 let dflags = hsc_dflags hsc_env
77 ghci_mode = hsc_mode hsc_env
79 | Just todo <- dopt_CoreToDo dflags = todo
80 | otherwise = buildCoreToDo dflags
82 us <- mkSplitUniqSupply 's'
83 let (cp_us, ru_us) = splitUniqSupply us
85 -- COMPUTE THE RULE BASE TO USE
86 (rule_base, local_rule_ids, orphan_rules)
87 <- prepareRules hsc_env mod_impl ru_us
89 -- PREPARE THE BINDINGS
90 let binds1 = updateBinders ghci_mode local_rule_ids
91 orphan_rules exports binds_in
94 (stats, processed_binds)
95 <- doCorePasses dflags rule_base (zeroSimplCount dflags) cp_us binds1 core_todos
97 dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
98 "Grand total simplifier statistics"
102 -- We only return local orphan rules, i.e., local rules not attached to an Id
103 -- The bindings cotain more rules, embedded in the Ids
104 return (mod_impl { mg_binds = processed_binds, mg_rules = orphan_rules})
107 simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
110 -- simplifyExpr is called by the driver to simplify an
111 -- expression typed in at the interactive prompt
112 simplifyExpr dflags expr
114 ; showPass dflags "Simplify"
116 ; us <- mkSplitUniqSupply 's'
118 ; let env = emptySimplEnv SimplGently [] emptyVarSet
119 (expr', _counts) = initSmpl dflags us (simplExprGently env expr)
121 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
128 doCorePasses :: DynFlags
129 -> RuleBase -- the main rule base
130 -> SimplCount -- simplifier stats
131 -> UniqSupply -- uniques
132 -> [CoreBind] -- local binds in (with rules attached)
133 -> [CoreToDo] -- which passes to do
134 -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules
136 doCorePasses dflags rb stats us binds []
137 = return (stats, binds)
139 doCorePasses dflags rb stats us binds (to_do : to_dos)
141 let (us1, us2) = splitUniqSupply us
143 (stats1, binds1) <- doCorePass dflags rb us1 binds to_do
145 doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos
147 doCorePass dfs rb us binds (CoreDoSimplify mode switches)
148 = _scc_ "Simplify" simplifyPgm dfs rb mode switches us binds
149 doCorePass dfs rb us binds CoreCSE
150 = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds)
151 doCorePass dfs rb us binds CoreLiberateCase
152 = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds)
153 doCorePass dfs rb us binds CoreDoFloatInwards
154 = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds)
155 doCorePass dfs rb us binds (CoreDoFloatOutwards f)
156 = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds)
157 doCorePass dfs rb us binds CoreDoStaticArgs
158 = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds)
159 doCorePass dfs rb us binds CoreDoStrictness
160 = _scc_ "Stranal" noStats dfs (dmdAnalPgm dfs binds)
161 doCorePass dfs rb us binds CoreDoWorkerWrapper
162 = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds)
163 doCorePass dfs rb us binds CoreDoSpecialising
164 = _scc_ "Specialise" noStats dfs (specProgram dfs us binds)
165 doCorePass dfs rb us binds CoreDoSpecConstr
166 = _scc_ "SpecConstr" noStats dfs (specConstrProgram dfs us binds)
167 #ifdef OLD_STRICTNESS
168 doCorePass dfs rb us binds CoreDoOldStrictness
169 = _scc_ "OldStrictness" noStats dfs (doOldStrictness dfs binds)
171 doCorePass dfs rb us binds CoreDoPrintCore
172 = _scc_ "PrintCore" noStats dfs (printCore binds)
173 doCorePass dfs rb us binds CoreDoGlomBinds
174 = noStats dfs (glomBinds dfs binds)
175 doCorePass dfs rb us binds (CoreDoRuleCheck phase pat)
176 = noStats dfs (ruleCheck dfs phase pat binds)
177 doCorePass dfs rb us binds CoreDoNothing
178 = noStats dfs (return binds)
180 #ifdef OLD_STRICTNESS
181 doOldStrictness dfs binds
182 = do binds1 <- saBinds dfs binds
183 binds2 <- cprAnalyse dfs binds1
187 printCore binds = do dumpIfSet True "Print Core"
188 (pprCoreBindings binds)
191 ruleCheck dflags phase pat binds = do showPass dflags "RuleCheck"
192 printDump (ruleCheckProgram phase pat binds)
195 -- most passes return no stats and don't change rules
196 noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) }
202 %************************************************************************
204 \subsection{Dealing with rules}
206 %************************************************************************
208 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
209 -- It attaches those rules that are for local Ids to their binders, and
210 -- returns the remainder attached to Ids in an IdSet. It also returns
211 -- Ids mentioned on LHS of some rule; these should be blacklisted.
213 -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined
214 -- so that the opportunity to apply the rule isn't lost too soon
217 prepareRules :: HscEnv
220 -> IO (RuleBase, -- Full rule base
221 IdSet, -- Local rule Ids
222 [IdCoreRule]) -- Orphan rules defined in this module
224 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
225 guts@(ModGuts { mg_binds = binds, mg_rules = local_rules, mg_module = this_mod })
227 = do { pkg_rule_base <- loadImportedRules hsc_env guts
229 ; let env = emptySimplEnv SimplGently [] local_ids
230 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
232 imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
233 full_rule_base = extendRuleBaseList imp_rule_base better_rules
235 (local_rule_ids, final_rule_base) = getLocalRules this_mod full_rule_base
236 -- NB: the imported rules may include rules for Ids in this module
238 orphan_rules = filter (not . idIsFrom this_mod . fst) better_rules
240 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
241 (vcat [text "Local rules", pprIdRules better_rules,
243 text "Imported rules", pprRuleBase final_rule_base])
245 ; return (final_rule_base, local_rule_ids, orphan_rules)
248 add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
250 -- Boringly, we need to gather the in-scope set.
251 local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
254 updateBinders :: GhciMode
255 -> IdSet -- Locally defined ids with their Rules attached
256 -> [IdCoreRule] -- Orphan rules
257 -> Avails -- What is exported
258 -> [CoreBind] -> [CoreBind]
259 -- A horrible function
261 -- Update the binders of top-level bindings as follows
262 -- a) Attach the rules for each locally-defined Id to that Id.
263 -- b) Set the no-discard flag if either the Id is exported,
264 -- or it's mentioned in the RHS of a rule
266 -- You might wonder why exported Ids aren't already marked as such;
267 -- it's just because the type checker is rather busy already and
268 -- I didn't want to pass in yet another mapping.
271 -- - It makes the rules easier to look up
272 -- - It means that transformation rules and specialisations for
273 -- locally defined Ids are handled uniformly
274 -- - It keeps alive things that are referred to only from a rule
275 -- (the occurrence analyser knows about rules attached to Ids)
276 -- - It makes sure that, when we apply a rule, the free vars
277 -- of the RHS are more likely to be in scope
280 -- It means that the binding won't be discarded EVEN if the binding
281 -- ends up being trivial (v = w) -- the simplifier would usually just
282 -- substitute w for v throughout, but we don't apply the substitution to
283 -- the rules (maybe we should?), so this substitution would make the rule
286 updateBinders ghci_mode rule_ids orphan_rules exports binds
287 = map update_bndrs binds
289 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
290 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
293 | dont_discard bndr = setIdLocalExported bndr_with_rules
294 | otherwise = bndr_with_rules
296 bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
298 orph_rhs_fvs = unionVarSets (map (ruleRhsFreeVars . snd) orphan_rules)
299 -- An orphan rule must keep alive the free vars
300 -- of its right-hand side.
301 -- Non-orphan rules are attached to the Id (bndr_with_rules above)
302 -- and that keeps the rhs free vars alive
304 dont_discard bndr = is_exported (idName bndr)
305 || bndr `elemVarSet` orph_rhs_fvs
307 -- In interactive mode, we don't want to discard any top-level
308 -- entities at all (eg. do not inline them away during
309 -- simplification), and retain them all in the TypeEnv so they are
310 -- available from the command line.
312 -- isExternalName separates the user-defined top-level names from those
313 -- introduced by the type checker.
314 is_exported :: Name -> Bool
315 is_exported | ghci_mode == Interactive = isExternalName
316 | otherwise = (`elemNameSet` export_fvs)
318 export_fvs = availsToNameSet exports
322 We must do some gentle simplification on the template (but not the RHS)
323 of each rule. The case that forced me to add this was the fold/build rule,
324 which without simplification looked like:
325 fold k z (build (/\a. g a)) ==> ...
326 This doesn't match unless you do eta reduction on the build argument.
329 simplRule env rule@(id, BuiltinRule _ _)
331 simplRule env rule@(id, Rule act name bndrs args rhs)
332 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
333 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
334 simplExprGently env rhs `thenSmpl` \ rhs' ->
335 returnSmpl (id, Rule act name bndrs' args' rhs')
337 -- It's important that simplExprGently does eta reduction.
338 -- For example, in a rule like:
339 -- augment g (build h)
340 -- we do not want to get
341 -- augment (\a. g a) (build h)
342 -- otherwise we don't match when given an argument like
345 -- The simplifier does indeed do eta reduction (it's in
346 -- Simplify.completeLam) but only if -O is on.
350 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
351 -- Simplifies an expression
352 -- does occurrence analysis, then simplification
353 -- and repeats (twice currently) because one pass
354 -- alone leaves tons of crud.
355 -- Used (a) for user expressions typed in at the interactive prompt
356 -- (b) the LHS and RHS of a RULE
358 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
359 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
360 -- enforce that; it just simplifies the expression twice
362 simplExprGently env expr
363 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
364 simplExpr env (occurAnalyseGlobalExpr expr1)
368 %************************************************************************
370 \subsection{Glomming}
372 %************************************************************************
375 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
376 -- Glom all binds together in one Rec, in case any
377 -- transformations have introduced any new dependencies
379 -- NB: the global invariant is this:
380 -- *** the top level bindings are never cloned, and are always unique ***
382 -- We sort them into dependency order, but applying transformation rules may
383 -- make something at the top refer to something at the bottom:
387 -- RULE: p (q x) = h x
389 -- Applying this rule makes f refer to h,
390 -- although it doesn't appear to in the source program.
391 -- This pass lets us control where it happens.
393 -- NOTICE that this cannot happen for rules whose head is a locally-defined
394 -- function. It only happens for rules whose head is an imported function
395 -- (p in the example above). So, for example, the rule had been
396 -- RULE: f (p x) = h x
397 -- then the rule for f would be attached to f itself (in its IdInfo)
398 -- by prepareLocalRuleBase and h would be regarded by the occurrency
399 -- analyser as free in f.
401 glomBinds dflags binds
402 = do { showPass dflags "GlomBinds" ;
403 let { recd_binds = [Rec (flattenBinds binds)] } ;
405 -- Not much point in printing the result...
406 -- just consumes output bandwidth
410 %************************************************************************
412 \subsection{The driver for the simplifier}
414 %************************************************************************
417 simplifyPgm :: DynFlags
420 -> [SimplifierSwitch]
422 -> [CoreBind] -- Input
423 -> IO (SimplCount, [CoreBind]) -- New bindings
425 simplifyPgm dflags rule_base
426 mode switches us binds
428 showPass dflags "Simplify";
430 (termination_msg, it_count, counts_out, binds')
431 <- iteration us 1 (zeroSimplCount dflags) binds;
433 dumpIfSet (dopt Opt_D_verbose_core2core dflags
434 && dopt Opt_D_dump_simpl_stats dflags)
435 "Simplifier statistics"
436 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
438 pprSimplCount counts_out]);
440 endPass dflags "Simplify" Opt_D_verbose_core2core binds';
442 return (counts_out, binds')
445 phase_info = case mode of
446 SimplGently -> "gentle"
447 SimplPhase n -> show n
449 imported_rule_ids = ruleBaseIds rule_base
450 simpl_env = emptySimplEnv mode switches imported_rule_ids
451 sw_chkr = getSwitchChecker simpl_env
452 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
454 iteration us iteration_no counts binds
455 -- iteration_no is the number of the iteration we are
456 -- about to begin, with '1' for the first
457 | iteration_no > max_iterations -- Stop if we've run out of iterations
460 if max_iterations > 2 then
461 hPutStr stderr ("NOTE: Simplifier still going after " ++
462 show max_iterations ++
463 " iterations; bailing out.\n")
467 -- Subtract 1 from iteration_no to get the
468 -- number of iterations we actually completed
469 return ("Simplifier baled out", iteration_no - 1, counts, binds)
472 -- Try and force thunks off the binds; significantly reduces
473 -- space usage, especially with -O. JRS, 000620.
474 | let sz = coreBindsSize binds in sz == sz
476 -- Occurrence analysis
477 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
479 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
480 (pprCoreBindings tagged_binds);
483 -- We do this with a *case* not a *let* because lazy pattern
484 -- matching bit us with bad space leak!
485 -- With a let, we ended up with
490 -- case t of {(_,counts') -> if counts'=0 then ... }
491 -- So the conditional didn't force counts', because the
492 -- selection got duplicated. Sigh!
493 case initSmpl dflags us1 (simplTopBinds simpl_env tagged_binds) of {
494 (binds', counts') -> do {
495 -- The imported_rule_ids are used by initSmpl to initialise
496 -- the in-scope set. That way, the simplifier will change any
497 -- occurrences of the imported id to the one in the imported_rule_ids
498 -- set, which are decorated with their rules.
500 let { all_counts = counts `plusSimplCount` counts' ;
501 herald = "Simplifier phase " ++ phase_info ++
502 ", iteration " ++ show iteration_no ++
503 " out of " ++ show max_iterations
506 -- Stop if nothing happened; don't dump output
507 if isZeroSimplCount counts' then
508 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
511 -- Dump the result of this iteration
512 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
513 (pprSimplCount counts') ;
515 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
518 iteration us2 (iteration_no + 1) all_counts binds'
521 (us1, us2) = splitUniqSupply us