2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
7 module SimplCore ( core2core ) where
9 #include "HsVersions.h"
11 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
12 SwitchResult(..), switchIsOn, intSwitchSet,
13 opt_D_dump_occur_anal, opt_D_dump_rules,
14 opt_D_dump_simpl_iterations,
15 opt_D_dump_simpl_stats,
16 opt_D_dump_simpl, opt_D_dump_rules,
17 opt_D_verbose_core2core,
18 opt_D_dump_occur_anal,
21 import CoreLint ( beginPass, endPass )
23 import CSE ( cseProgram )
24 import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
26 import PprCore ( pprCoreBindings )
27 import OccurAnal ( occurAnalyseBinds )
28 import CoreUtils ( exprIsTrivial, coreExprType )
29 import Simplify ( simplTopBinds, simplExpr )
30 import SimplUtils ( etaCoreExpr, findDefault, simplBinders )
32 import Const ( Con(..), Literal(..), literalType, mkMachInt )
33 import ErrUtils ( dumpIfSet )
34 import FloatIn ( floatInwards )
35 import FloatOut ( floatOutwards )
36 import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
37 idType, setIdType, idName, idInfo, setIdNoDiscard
41 import Module ( Module )
42 import Name ( mkLocalName, tidyOccName, tidyTopName,
43 NamedThing(..), OccName
45 import TyCon ( TyCon, isDataTyCon )
46 import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
47 import PrelRules ( builtinRules )
48 import Type ( Type, splitAlgTyConApp_maybe,
50 tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
53 import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
54 import LiberateCase ( liberateCase )
55 import SAT ( doStaticArgs )
56 import Specialise ( specProgram)
57 import UsageSPInf ( doUsageSPInf )
58 import StrictAnal ( saBinds )
59 import WorkWrap ( wwTopBinds )
60 import CprAnalyse ( cprAnalyse )
62 import Unique ( Unique, Uniquable(..),
65 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
66 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
67 import Util ( mapAccumL )
68 import SrcLoc ( noSrcLoc )
71 import IO ( hPutStr, stderr )
74 import Ratio ( numerator, denominator )
77 %************************************************************************
79 \subsection{The driver for the simplifier}
81 %************************************************************************
84 core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
85 -> [CoreBind] -- Binds in
86 -> [ProtoCoreRule] -- Rules
87 -> IO ([CoreBind], [ProtoCoreRule])
89 core2core core_todos binds rules
91 us <- mkSplitUniqSupply 's'
92 let (cp_us, us1) = splitUniqSupply us
93 (ru_us, ps_us) = splitUniqSupply us1
95 better_rules <- simplRules ru_us rules binds
97 let all_rules = builtinRules ++ better_rules
98 -- Here is where we add in the built-in rules
100 let (binds1, rule_base) = prepareRuleBase binds all_rules
102 -- Do the main business
103 (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
106 dumpIfSet opt_D_dump_simpl_stats
107 "Grand total simplifier statistics"
108 (pprSimplCount stats)
110 -- Do the post-simplification business
111 post_simpl_binds <- doPostSimplification ps_us processed_binds
114 return (post_simpl_binds, filter orphanRule better_rules)
117 doCorePasses stats us binds irs []
118 = return (stats, binds)
120 doCorePasses stats us binds irs (to_do : to_dos)
122 let (us1, us2) = splitUniqSupply us
123 (stats1, binds1) <- doCorePass us1 binds irs to_do
124 doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
126 doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
127 doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
128 doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
129 doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
130 doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
131 doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
132 doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
133 doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
134 doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
135 doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
136 doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
137 doCorePass us binds rb CoreDoUSPInf
138 = _scc_ "CoreUsageSPInf"
139 if opt_UsageSPOn then
140 noStats (doUsageSPInf us binds)
142 trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
143 noStats (return binds)
145 printCore binds = do dumpIfSet True "Print Core"
146 (pprCoreBindings binds)
149 noStats thing = do { result <- thing; return (zeroSimplCount, result) }
153 %************************************************************************
155 \subsection{Dealing with rules}
157 %************************************************************************
159 We must do some gentle simplifiation on the template (but not the RHS)
160 of each rule. The case that forced me to add this was the fold/build rule,
161 which without simplification looked like:
162 fold k z (build (/\a. g a)) ==> ...
163 This doesn't match unless you do eta reduction on the build argument.
166 simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
167 simplRules us rules binds
168 = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
170 dumpIfSet opt_D_dump_rules
171 "Transformation rules"
172 (vcat (map pprProtoCoreRule better_rules))
176 black_list_all v = True -- This stops all inlining
177 sw_chkr any = SwBool False -- A bit bogus
179 -- Boringly, we need to gather the in-scope set.
180 -- Typically this thunk won't even be force, but the test in
181 -- simpVar fails if it isn't right, and it might conceivably matter
182 bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
185 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
187 = returnSmpl rule -- No need to fiddle with imported rules
189 = simplBinders bndrs $ \ bndrs' ->
190 mapSmpl simpl_arg args `thenSmpl` \ args' ->
191 simplExpr rhs `thenSmpl` \ rhs' ->
192 returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
195 -- I've seen rules in which a LHS like
196 -- augment g (build h)
198 -- augment (\a. g a) (build h)
199 -- So it's a help to eta-reduce the args as we simplify them.
200 -- Otherwise we don't match when given an argument like
202 = simplExpr e `thenSmpl` \ e' ->
203 returnSmpl (etaCoreExpr e')
206 %************************************************************************
208 \subsection{The driver for the simplifier}
210 %************************************************************************
213 simplifyPgm :: RuleBase
214 -> (SimplifierSwitch -> SwitchResult)
216 -> [CoreBind] -- Input
217 -> IO (SimplCount, [CoreBind]) -- New bindings
219 simplifyPgm (imported_rule_ids, rule_lhs_fvs)
222 beginPass "Simplify";
224 -- Glom all binds together in one Rec, in case any
225 -- transformations have introduced any new dependencies
227 -- NB: the global invariant is this:
228 -- *** the top level bindings are never cloned, and are always unique ***
230 -- We sort them into dependency order, but applying transformation rules may
231 -- make something at the top refer to something at the bottom:
235 -- RULE: p (q x) = h x
237 -- Applying this rule makes f refer to h, although it doesn't appear to in the
238 -- source program. Our solution is to do this occasional glom-together step,
239 -- just once per overall simplfication step.
241 let { recd_binds = [Rec (flattenBinds binds)] };
243 (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
245 dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
246 "Simplifier statistics"
247 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
249 pprSimplCount counts_out]);
252 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
255 return (counts_out, binds')
258 max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
259 black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
261 core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
264 iteration us iteration_no counts binds
266 -- Occurrence analysis
267 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
269 dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
270 (pprCoreBindings tagged_binds);
273 let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
275 (simplTopBinds tagged_binds);
276 -- The imported_rule_ids are used by initSmpl to initialise
277 -- the in-scope set. That way, the simplifier will change any
278 -- occurrences of the imported id to the one in the imported_rule_ids
279 -- set, which are decorated with their rules.
281 all_counts = counts `plusSimplCount` counts'
284 -- Stop if nothing happened; don't dump output
285 if isZeroSimplCount counts' then
286 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
289 -- Dump the result of this iteration
290 dumpIfSet opt_D_dump_simpl_iterations
291 ("Simplifier iteration " ++ show iteration_no
292 ++ " out of " ++ show max_iterations)
293 (pprSimplCount counts') ;
295 if opt_D_dump_simpl_iterations then
296 endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
297 opt_D_verbose_core2core
302 -- Stop if we've run out of iterations
303 if iteration_no == max_iterations then
306 if max_iterations > 2 then
307 hPutStr stderr ("NOTE: Simplifier still going after " ++
308 show max_iterations ++
309 " iterations; bailing out.\n")
314 return ("Simplifier baled out", iteration_no, all_counts, binds')
318 else iteration us2 (iteration_no + 1) all_counts binds'
321 (us1, us2) = splitUniqSupply us
325 %************************************************************************
327 \subsection{PostSimplification}
329 %************************************************************************
331 Several tasks are performed by the post-simplification pass
333 1. Make the representation of NoRep literals explicit, and
334 float their bindings to the top level. We only do the floating
335 part for NoRep lits inside a lambda (else no gain). We need to
336 take care with let x = "foo" in e
337 that we don't end up with a silly binding
339 with a floated "foo". What a bore.
341 4. Do eta reduction for lambda abstractions appearing in:
342 - the RHS of case alternatives
345 These will otherwise turn into local bindings during Core->STG;
346 better to nuke them if possible. (In general the simplifier does
347 eta expansion not eta reduction, up to this point. It does eta
348 on the RHSs of bindings but not the RHSs of case alternatives and
352 ------------------- NOT DONE ANY MORE ------------------------
353 [March 98] Indirections are now elimianted by the occurrence analyser
354 1. Eliminate indirections. The point here is to transform
360 [Dec 98] [Not now done because there is no penalty in the code
361 generator for using the former form]
363 case x of {...; x' -> ...x'...}
365 case x of {...; _ -> ...x... }
366 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
367 --------------------------------------------------------------
372 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
373 things, and we need local Ids for non-floated stuff):
375 Don't float stuff out of a binder that's marked as a bottoming Id.
376 Reason: it doesn't do any good, and creates more CAFs that increase
385 f' = unpackCString# "string"
388 hence f' and f become CAFs. Instead, the special case for
389 tidyTopBinding below makes sure this comes out as
391 f = let f' = unpackCString# "string" in error f'
393 and we can safely ignore f as a CAF, since it can only ever be entered once.
398 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
399 doPostSimplification us binds_in
401 beginPass "Post-simplification pass"
402 let binds_out = initPM us (postSimplTopBinds binds_in)
403 endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
405 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
406 postSimplTopBinds binds
407 = mapPM postSimplTopBind binds `thenPM` \ binds' ->
408 returnPM (bagToList (unionManyBags binds'))
410 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
411 postSimplTopBind (NonRec bndr rhs)
412 | isBottomingId bndr -- Don't lift out floats for bottoming Ids
414 = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
415 returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
417 postSimplTopBind bind
418 = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
419 returnPM (floats `snocBag` bind')
421 postSimplBind (NonRec bndr rhs)
422 = postSimplExpr rhs `thenPM` \ rhs' ->
423 returnPM (NonRec bndr rhs')
425 postSimplBind (Rec pairs)
426 = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
427 returnPM (Rec (bndrs `zip` rhss'))
429 (bndrs, rhss) = unzip pairs
436 postSimplExpr (Var v) = returnPM (Var v)
437 postSimplExpr (Type ty) = returnPM (Type ty)
439 postSimplExpr (App fun arg)
440 = postSimplExpr fun `thenPM` \ fun' ->
441 postSimplExpr arg `thenPM` \ arg' ->
442 returnPM (App fun' arg')
444 postSimplExpr (Con (Literal lit) args)
445 = ASSERT( null args )
446 litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
447 getInsideLambda `thenPM` \ in_lam ->
448 if in_lam && not (exprIsTrivial lit_expr) then
449 -- It must have been a no-rep literal with a
450 -- non-trivial representation; and we're inside a lambda;
451 -- so float it to the top
452 addTopFloat lit_ty lit_expr `thenPM` \ v ->
457 postSimplExpr (Con con args)
458 = mapPM postSimplExpr args `thenPM` \ args' ->
459 returnPM (Con con args')
461 postSimplExpr (Lam bndr body)
462 = insideLambda bndr $
463 postSimplExpr body `thenPM` \ body' ->
464 returnPM (Lam bndr body')
466 postSimplExpr (Let bind body)
467 = postSimplBind bind `thenPM` \ bind' ->
468 postSimplExprEta body `thenPM` \ body' ->
469 returnPM (Let bind' body')
471 postSimplExpr (Note note body)
472 = postSimplExpr body `thenPM` \ body' ->
473 -- Do *not* call postSimplExprEta here
474 -- We don't want to turn f = \x -> coerce t (\y -> f x y)
475 -- into f = \x -> coerce t (f x)
476 -- because then f has a lower arity.
477 -- This is not only bad in general, it causes the arity to
478 -- not match the [Demand] on an Id,
479 -- which confuses the importer of this module.
480 returnPM (Note note body')
482 postSimplExpr (Case scrut case_bndr alts)
483 = postSimplExpr scrut `thenPM` \ scrut' ->
484 mapPM ps_alt alts `thenPM` \ alts' ->
485 returnPM (Case scrut' case_bndr alts')
487 ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
488 returnPM (con, bndrs, rhs')
490 postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
491 returnPM (etaCoreExpr e')
495 %************************************************************************
497 \subsection[coreToStg-lits]{Converting literals}
499 %************************************************************************
501 Literals: the NoRep kind need to be de-no-rep'd.
502 We always replace them with a simple variable, and float a suitable
503 binding out to the top level.
506 litToRep :: Literal -> PostM (Type, CoreExpr)
508 litToRep (NoRepStr s ty)
511 rhs = if (any is_NUL (_UNPK_ s))
513 then -- Must cater for NULs in literal string
514 mkApps (Var unpackCString2Id)
516 mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
518 else -- No NULs in the string
519 App (Var unpackCStringId) (mkLit (MachStr s))
524 If an Integer is small enough (Haskell implementations must support
525 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
526 otherwise, wrap with @addr2Integer@.
529 litToRep (NoRepInteger i integer_ty)
530 = returnPM (integer_ty, rhs)
532 rhs | i >= tARGET_MIN_INT && -- Small enough, so start from an Int
534 = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
536 | otherwise -- Big, so start from a string
537 = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
540 litToRep (NoRepRational r rational_ty)
541 = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
542 postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
543 returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
545 (ratio_data_con, integer_ty)
546 = case (splitAlgTyConApp_maybe rational_ty) of
547 Just (tycon, [i_ty], [con])
548 -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
551 _ -> (panic "ratio_data_con", panic "integer_ty")
553 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
557 %************************************************************************
559 \subsection{The monad}
561 %************************************************************************
564 type PostM a = Bool -- True <=> inside a *value* lambda
565 -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
566 -> (a, (UniqSupply, Bag CoreBind))
568 initPM :: UniqSupply -> PostM a -> a
570 = case m False {- not inside lambda -} (us, emptyBag) of
571 (result, _) -> result
573 returnPM v in_lam usf = (v, usf)
574 thenPM m k in_lam usf = case m in_lam usf of
575 (r, usf') -> k r in_lam usf'
577 mapPM f [] = returnPM []
578 mapPM f (x:xs) = f x `thenPM` \ r ->
579 mapPM f xs `thenPM` \ rs ->
582 insideLambda :: CoreBndr -> PostM a -> PostM a
583 insideLambda bndr m in_lam usf | isId bndr = m True usf
584 | otherwise = m in_lam usf
586 getInsideLambda :: PostM Bool
587 getInsideLambda in_lam usf = (in_lam, usf)
589 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
590 getFloatsPM m in_lam (us, floats)
592 (a, (us', floats')) = m in_lam (us, emptyBag)
594 ((a, floats'), (us', floats))
596 addTopFloat :: Type -> CoreExpr -> PostM Id
597 addTopFloat lit_ty lit_rhs in_lam (us, floats)
599 (us1, us2) = splitUniqSupply us
600 uniq = uniqFromSupply us1
601 lit_id = mkSysLocal SLIT("lf") uniq lit_ty
603 (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))