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 SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
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 (expr', _counts) = initSmpl dflags us $
102 simplExprGently gentleSimplEnv expr
104 ; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
110 gentleSimplEnv :: SimplEnv
111 gentleSimplEnv = mkSimplEnv SimplGently
115 doCorePasses :: HscEnv
116 -> UniqSupply -- uniques
117 -> SimplCount -- simplifier stats
118 -> RuleBase -- the main rule base
119 -> ModGuts -- local binds in (with rules attached)
120 -> [CoreToDo] -- which passes to do
121 -> IO (SimplCount, ModGuts)
123 doCorePasses hsc_env us stats rb guts []
124 = return (stats, guts)
126 doCorePasses hsc_env us stats rb guts (to_do : to_dos)
128 let (us1, us2) = splitUniqSupply us
129 (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts
130 doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos
132 doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws
133 doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram
134 doCorePass CoreLiberateCase = _scc_ "LiberateCase" trBinds liberateCase
135 doCorePass CoreDoFloatInwards = _scc_ "FloatInwards" trBinds floatInwards
136 doCorePass (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" trBindsU (floatOutwards f)
137 doCorePass CoreDoStaticArgs = _scc_ "StaticArgs" trBinds doStaticArgs
138 doCorePass CoreDoStrictness = _scc_ "Stranal" trBinds dmdAnalPgm
139 doCorePass CoreDoWorkerWrapper = _scc_ "WorkWrap" trBindsU wwTopBinds
140 doCorePass CoreDoSpecialising = _scc_ "Specialise" trBindsU specProgram
141 doCorePass CoreDoSpecConstr = _scc_ "SpecConstr" trBindsU specConstrProgram
142 doCorePass CoreDoGlomBinds = trBinds glomBinds
143 doCorePass CoreDoPrintCore = observe printCore
144 doCorePass (CoreDoRuleCheck phase pat) = observe (ruleCheck phase pat)
145 doCorePass CoreDoNothing = observe (\ _ _ -> return ())
146 #ifdef OLD_STRICTNESS
147 doCorePass CoreDoOldStrictness = _scc_ "OldStrictness" trBinds doOldStrictness
150 #ifdef OLD_STRICTNESS
151 doOldStrictness dfs binds
152 = do binds1 <- saBinds dfs binds
153 binds2 <- cprAnalyse dfs binds1
157 printCore _ binds = dumpIfSet True "Print Core" (pprCoreBindings binds)
159 ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck"
160 printDump (ruleCheckProgram phase pat binds)
162 -- Most passes return no stats and don't change rules
163 trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind])
164 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
165 -> IO (SimplCount, RuleBase, ModGuts)
166 trBinds do_pass hsc_env us rb guts
167 = do { binds' <- do_pass dflags (mg_binds guts)
168 ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
170 dflags = hsc_dflags hsc_env
172 trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind])
173 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
174 -> IO (SimplCount, RuleBase, ModGuts)
175 trBindsU do_pass hsc_env us rb guts
176 = do { binds' <- do_pass dflags us (mg_binds guts)
177 ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) }
179 dflags = hsc_dflags hsc_env
181 -- Observer passes just peek; don't modify the bindings at all
182 observe :: (DynFlags -> [CoreBind] -> IO a)
183 -> HscEnv -> UniqSupply -> RuleBase -> ModGuts
184 -> IO (SimplCount, RuleBase, ModGuts)
185 observe do_pass hsc_env us rb guts
186 = do { binds <- do_pass dflags (mg_binds guts)
187 ; return (zeroSimplCount dflags, rb, guts) }
189 dflags = hsc_dflags hsc_env
194 %************************************************************************
196 \subsection{Dealing with rules}
198 %************************************************************************
200 -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
201 -- It attaches those rules that are for local Ids to their binders, and
202 -- returns the remainder attached to Ids in an IdSet.
205 prepareRules :: HscEnv
208 -> IO (RuleBase, -- Rule base for imported things, incl
209 -- (a) rules defined in this module (orphans)
210 -- (b) rules from other packages
211 -- (c) rules from other modules in home package
212 ModGuts) -- Modified fields are
213 -- (a) Bindings have rules attached,
214 -- (b) Rules are now just orphan rules
216 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
217 guts@(ModGuts { mg_binds = binds, mg_rules = local_rules })
219 = do { eps <- hscEPS hsc_env
221 ; let -- Simplify the local rules; boringly, we need to make an in-scope set
222 -- from the local binders, to avoid warnings from Simplify.simplVar
223 local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds))
224 env = setInScopeSet gentleSimplEnv local_ids
225 (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules)
227 (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules
228 -- Get the rules for locally-defined Ids out of the RuleBase
229 -- If we miss any rules for Ids defined here, then we end up
230 -- giving the local decl a new Unique (because the in-scope-set is (hackily) the
231 -- same as the non-local-rule-id set, so the Id looks as if it's in scope
232 -- and hence should be cloned), and now the binding for the class method
233 -- doesn't have the same Unique as the one in the Class and the tc-env
234 -- Example: class Foo a where
236 -- {-# RULES "op" op x = x #-}
238 -- NB: we assume that the imported rules dont include
239 -- rules for Ids in this module; if there is, the above bad things may happen
241 pkg_rule_base = eps_rule_base eps
242 hpt_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt)
243 imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules
245 -- Update the binders in the local bindings with the lcoal rules
246 -- Update the binders of top-level bindings by
247 -- attaching the rules for each locally-defined Id to that Id.
250 -- - It makes the rules easier to look up
251 -- - It means that transformation rules and specialisations for
252 -- locally defined Ids are handled uniformly
253 -- - It keeps alive things that are referred to only from a rule
254 -- (the occurrence analyser knows about rules attached to Ids)
255 -- - It makes sure that, when we apply a rule, the free vars
256 -- of the RHS are more likely to be in scope
257 -- - The imported rules are carried in the in-scope set
258 -- which is extended on each iteration by the new wave of
259 -- local binders; any rules which aren't on the binding will
260 -- thereby get dropped
261 local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
262 binds_w_rules = updateBinders local_rule_base binds
264 ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
265 (vcat [text "Local rules", pprIdRules better_rules,
267 text "Imported rules", pprRuleBase imp_rule_base])
270 ; let bad_rules = filter (idIsFrom (mg_module guts))
271 (varSetElems (ruleBaseIds imp_rule_base))
272 ; WARN( not (null bad_rules), ppr bad_rules ) return ()
274 ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules })
277 add_rules rule_base mod_info = extendRuleBaseList rule_base (md_rules (hm_details mod_info))
279 updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
280 updateBinders rule_base binds
281 = map update_bndrs binds
283 rule_ids = ruleBaseIds rule_base
285 update_bndrs (NonRec b r) = NonRec (update_bndr b) r
286 update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
288 update_bndr bndr = case lookupVarSet rule_ids bndr of
290 Just id -> bndr `setIdSpecialisation` idSpecialisation id
294 We must do some gentle simplification on the template (but not the RHS)
295 of each rule. The case that forced me to add this was the fold/build rule,
296 which without simplification looked like:
297 fold k z (build (/\a. g a)) ==> ...
298 This doesn't match unless you do eta reduction on the build argument.
301 simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _))
303 simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs))
304 = simplBinders env bndrs `thenSmpl` \ (env, bndrs') ->
305 mapSmpl (simplExprGently env) args `thenSmpl` \ args' ->
306 simplExprGently env rhs `thenSmpl` \ rhs' ->
307 returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs'))
309 -- It's important that simplExprGently does eta reduction.
310 -- For example, in a rule like:
311 -- augment g (build h)
312 -- we do not want to get
313 -- augment (\a. g a) (build h)
314 -- otherwise we don't match when given an argument like
317 -- The simplifier does indeed do eta reduction (it's in
318 -- Simplify.completeLam) but only if -O is on.
322 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
323 -- Simplifies an expression
324 -- does occurrence analysis, then simplification
325 -- and repeats (twice currently) because one pass
326 -- alone leaves tons of crud.
327 -- Used (a) for user expressions typed in at the interactive prompt
328 -- (b) the LHS and RHS of a RULE
330 -- The name 'Gently' suggests that the SimplifierMode is SimplGently,
331 -- and in fact that is so.... but the 'Gently' in simplExprGently doesn't
332 -- enforce that; it just simplifies the expression twice
334 simplExprGently env expr
335 = simplExpr env (occurAnalyseGlobalExpr expr) `thenSmpl` \ expr1 ->
336 simplExpr env (occurAnalyseGlobalExpr expr1)
340 %************************************************************************
342 \subsection{Glomming}
344 %************************************************************************
347 glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind]
348 -- Glom all binds together in one Rec, in case any
349 -- transformations have introduced any new dependencies
351 -- NB: the global invariant is this:
352 -- *** the top level bindings are never cloned, and are always unique ***
354 -- We sort them into dependency order, but applying transformation rules may
355 -- make something at the top refer to something at the bottom:
359 -- RULE: p (q x) = h x
361 -- Applying this rule makes f refer to h,
362 -- although it doesn't appear to in the source program.
363 -- This pass lets us control where it happens.
365 -- NOTICE that this cannot happen for rules whose head is a locally-defined
366 -- function. It only happens for rules whose head is an imported function
367 -- (p in the example above). So, for example, the rule had been
368 -- RULE: f (p x) = h x
369 -- then the rule for f would be attached to f itself (in its IdInfo)
370 -- by prepareLocalRuleBase and h would be regarded by the occurrency
371 -- analyser as free in f.
373 glomBinds dflags binds
374 = do { showPass dflags "GlomBinds" ;
375 let { recd_binds = [Rec (flattenBinds binds)] } ;
377 -- Not much point in printing the result...
378 -- just consumes output bandwidth
382 %************************************************************************
384 \subsection{The driver for the simplifier}
386 %************************************************************************
389 simplifyPgm :: SimplifierMode
390 -> [SimplifierSwitch]
395 -> IO (SimplCount, RuleBase, ModGuts) -- New bindings
397 simplifyPgm mode switches hsc_env us rule_base guts
399 showPass dflags "Simplify";
401 (termination_msg, it_count, counts_out, rule_base', guts')
402 <- do_iteration us rule_base 1 (zeroSimplCount dflags) guts;
404 dumpIfSet (dopt Opt_D_verbose_core2core dflags
405 && dopt Opt_D_dump_simpl_stats dflags)
406 "Simplifier statistics"
407 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
409 pprSimplCount counts_out]);
411 endPass dflags "Simplify" Opt_D_verbose_core2core (mg_binds guts');
413 return (counts_out, rule_base', guts')
416 dflags = hsc_dflags hsc_env
417 phase_info = case mode of
418 SimplGently -> "gentle"
419 SimplPhase n -> show n
421 sw_chkr = isAmongSimpl switches
422 max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2
424 do_iteration us rule_base iteration_no counts guts
425 -- iteration_no is the number of the iteration we are
426 -- about to begin, with '1' for the first
427 | iteration_no > max_iterations -- Stop if we've run out of iterations
430 if max_iterations > 2 then
431 hPutStr stderr ("NOTE: Simplifier still going after " ++
432 show max_iterations ++
433 " iterations; bailing out.\n")
437 -- Subtract 1 from iteration_no to get the
438 -- number of iterations we actually completed
439 return ("Simplifier baled out", iteration_no - 1, counts, rule_base, guts)
442 -- Try and force thunks off the binds; significantly reduces
443 -- space usage, especially with -O. JRS, 000620.
444 | let sz = coreBindsSize (mg_binds guts) in sz == sz
446 -- Occurrence analysis
447 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds (mg_binds guts) } ;
449 dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
450 (pprCoreBindings tagged_binds);
452 -- Get any new rules, and extend the rule base
453 -- (on the side this extends the package rule base in the
454 -- ExternalPackageTable, ready for the next complation
456 -- We need to do this regularly, because simplification can
457 -- poke on IdInfo thunks, which in turn brings in new rules
458 -- behind the scenes. Otherwise there's a danger we'll simply
459 -- miss the rules for Ids hidden inside imported inlinings
460 new_rules <- loadImportedRules hsc_env guts ;
461 let { rule_base' = extendRuleBaseList rule_base new_rules
462 ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ;
463 -- The new rule base Ids are used to initialise
464 -- the in-scope set. That way, the simplifier will change any
465 -- occurrences of the imported id to the one in the imported_rule_ids
466 -- set, which are decorated with their rules.
468 -- Simplify the program
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 {
482 let { guts' = guts { mg_binds = binds' }
483 ; all_counts = counts `plusSimplCount` counts'
484 ; herald = "Simplifier phase " ++ phase_info ++
485 ", iteration " ++ show iteration_no ++
486 " out of " ++ show max_iterations
489 -- Stop if nothing happened; don't dump output
490 if isZeroSimplCount counts' then
491 return ("Simplifier reached fixed point", iteration_no,
492 all_counts, rule_base', guts')
495 -- Dump the result of this iteration
496 dumpIfSet_dyn dflags Opt_D_dump_simpl_iterations herald
497 (pprSimplCount counts') ;
499 endPass dflags herald Opt_D_dump_simpl_iterations binds' ;
502 do_iteration us2 rule_base' (iteration_no + 1) all_counts guts'
505 (us1, us2) = splitUniqSupply us