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 VarEnv ( 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 })
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 (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
223 -- Get the rules for locally-defined Ids out of the RuleBase
224 -- If we miss any rules for Ids defined here, then we end up
225 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
226 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
227 -- and hence should be cloned), and now the binding for the class method
228 -- doesn't have the same Unique as the one in the Class and the tc-env
229 -- Example: class Foo a where
231 -- {-# RULES "op" op x = x #-}
233 -- NB: we assume that the imported rules dont include
234 -- rules for Ids in this module; if there is, the above bad things may happen
236 pkg_rule_base = eps_rule_base eps
237 hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
238 imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
240 -- Update the binders in the local bindings with the lcoal rules
241 -- Update the binders of top-level bindings by
242 -- attaching the rules for each locally-defined Id to that Id.
245 -- - It makes the rules easier to look up
246 -- - It means that transformation rules and specialisations for
247 -- locally defined Ids are handled uniformly
248 -- - It keeps alive things that are referred to only from a rule
249 -- (the occurrence analyser knows about rules attached to Ids)
250 -- - It makes sure that, when we apply a rule, the free vars
251 -- of the RHS are more likely to be in scope
252 -- - The imported rules are carried in the in-scope set
253 -- which is extended on each iteration by the new wave of
254 -- local binders; any rules which aren't on the binding will
255 -- thereby get dropped
256 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
257 binds_w_rules = updateBinders local_rule_base binds
259 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
260 (vcat [text "Local rules", pprIdRules better_rules,
262 text "Imported rules", pprRuleBase imp_rule_base])
265 ; let bad_rules = filter (idIsFrom (mg_module guts))
266 (varSetElems (ruleBaseIds imp_rule_base))
267 ; WARN( not (null bad_rules), ppr bad_rules ) return ()
269 ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
272 add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
274 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
275 updateBinders rule_base binds
276 = map update_bndrs binds
278 rule_ids = ruleBaseIds rule_base
280 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
281 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
283 update_bndr bndr = case lookupVarSet rule_ids bndr of
285 Just id -> bndr `setIdSpecialisation` idSpecialisation id
289 We must do some gentle simplification on the template (but not the RHS)
290 of each rule. The case that forced me to add this was the fold/build rule,
291 which without simplification looked like:
292 fold k z (build (/\a. g a)) ==> ...
293 This doesn't match unless you do eta reduction on the build argument.
296 simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _))
298 simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
299 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
300 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
301 simplExprGently env rhs `thenSmpl` \ rhs' ->
302 returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs'))
304 -- It's important that simplExprGently does eta reduction.
305 -- For example, in a rule like:
306 -- augment g (build h)
307 -- we do not want to get
308 -- augment (\a. g a) (build h)
309 -- otherwise we don't match when given an argument like
312 -- The simplifier does indeed do eta reduction (it's in
313 -- Simplify.completeLam) but only if -O is on.
317 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
318 -- Simplifies an expression
319 -- does occurrence analysis, then simplification
320 -- and repeats (twice currently) because one pass
321 -- alone leaves tons of crud.
322 -- Used (a) for user expressions typed in at the interactive prompt
323 -- (b) the LHS and RHS of a RULE
325 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
326 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
327 -- enforce that; it just simplifies the expression twice
329 simplExprGently env expr
330 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
331 simplExpr env (occurAnalyseGlobalExpr expr1)
335 %************************************************************************
337 \subsection{Glomming}
339 %************************************************************************
342 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
343 -- Glom all binds together in one Rec, in case any
344 -- transformations have introduced any new dependencies
346 -- NB: the global invariant is this:
347 -- *** the top level bindings are never cloned, and are always unique ***
349 -- We sort them into dependency order, but applying transformation rules may
350 -- make something at the top refer to something at the bottom:
354 -- RULE: p (q x) = h x
356 -- Applying this rule makes f refer to h,
357 -- although it doesn't appear to in the source program.
358 -- This pass lets us control where it happens.
360 -- NOTICE that this cannot happen for rules whose head is a locally-defined
361 -- function. It only happens for rules whose head is an imported function
362 -- (p in the example above). So, for example, the rule had been
363 -- RULE: f (p x) = h x
364 -- then the rule for f would be attached to f itself (in its IdInfo)
365 -- by prepareLocalRuleBase and h would be regarded by the occurrency
366 -- analyser as free in f.
368 glomBinds dflags binds
369 = do { showPass dflags "GlomBinds" ;
370 let { recd_binds = [Rec (flattenBinds binds)] } ;
372 -- Not much point in printing the result...
373 -- just consumes output bandwidth
377 %************************************************************************
379 \subsection{The driver for the simplifier}
381 %************************************************************************
384 simplifyPgm :: SimplifierMode
385 -> [SimplifierSwitch]
390 -> IO (SimplCount, RuleBase, ModGuts) -- New bindings
392 simplifyPgm mode switches hsc_env us rule_base guts
394 showPass dflags "Simplify";
396 (termination_msg, it_count, counts_out, rule_base', guts')
397 <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
399 dumpIfSet (dopt Opt_D_verbose_core2core dflags
400 && dopt Opt_D_dump_simpl_stats dflags)
401 "Simplifier statistics"
402 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
404 pprSimplCount counts_out]);
406 endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
408 return (counts_out, rule_base', guts')
411 dflags = hsc_dflags hsc_env
412 phase_info = case mode of
413 SimplGently -> "gentle"
414 SimplPhase n -> show n
416 simpl_env = emptySimplEnv mode switches
417 sw_chkr = getSwitchChecker simpl_env
418 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
420 do_iteration us rule_base iteration_no counts guts
421 -- iteration_no is the number of the iteration we are
422 -- about to begin, with '1' for the first
423 | iteration_no > max_iterations -- Stop if we've run out of iterations
426 if max_iterations > 2 then
427 hPutStr stderr ("NOTE: Simplifier still going after " ++
428 show max_iterations ++
429 " iterations; bailing out.\n")
433 -- Subtract 1 from iteration_no to get the
434 -- number of iterations we actually completed
435 return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts)
438 -- Try and force thunks off the binds; significantly reduces
439 -- space usage, especially with -O. JRS, 000620.
440 | let sz = coreBindsSize (mg_binds guts) in sz == sz
442 -- Occurrence analysis
443 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
445 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
446 (pprCoreBindings tagged_binds);
448 -- Get any new rules, and extend the rule base
449 -- (on the side this extends the package rule base in the
450 -- ExternalPackageTable, ready for the next complation
452 -- We need to do this regularly, because simplification can
453 -- poke on IdInfo thunks, which in turn brings in new rules
454 -- behind the scenes. Otherwise there's a danger we'll simply
455 -- miss the rules for Ids hidden inside imported inlinings
456 new_rules <- loadImportedRules hsc_env guts ;
457 let { rule_base' = extendRuleBaseList rule_base new_rules
458 ; in_scope = mkInScopeSet (ruleBaseIds rule_base')
459 ; simpl_env' = setInScopeSet simpl_env in_scope } ;
460 -- The new rule base Ids are used to initialise
461 -- the in-scope set. That way, the simplifier will change any
462 -- occurrences of the imported id to the one in the imported_rule_ids
463 -- set, which are decorated with their rules.
465 -- Simplify the program
466 -- We do this with a *case* not a *let* because lazy pattern
467 -- matching bit us with bad space leak!
468 -- With a let, we ended up with
473 -- case t of {(_,counts') -> if counts'=0 then ... }
474 -- So the conditional didn't force counts', because the
475 -- selection got duplicated. Sigh!
476 case initSmpl dflags us1 (simplTopBinds simpl_env' tagged_binds) of {
477 (binds', counts') -> do {
479 let { guts' = guts { mg_binds = binds' }
480 ; all_counts = counts `plusSimplCount` counts'
481 ; herald = "Simplifier phase " ++ phase_info ++
482 ", iteration " ++ show iteration_no ++
483 " out of " ++ show max_iterations
486 -- Stop if nothing happened; don't dump output
487 if isZeroSimplCount counts' then
488 return ("Simplifier reached fixed point", iteration_no,
489 all_counts, rule_base', guts')
492 -- Dump the result of this iteration
493 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
494 (pprSimplCount counts') ;
496 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
499 do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
502 (us1, us2) = splitUniqSupply us