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 PrimOp ( PrimOp(..) )
47 import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
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 (binds1, rule_base) = prepareRuleBase binds better_rules
99 -- Do the main business
100 (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
103 dumpIfSet opt_D_dump_simpl_stats
104 "Grand total simplifier statistics"
105 (pprSimplCount stats)
107 -- Do the post-simplification business
108 post_simpl_binds <- doPostSimplification ps_us processed_binds
111 return (post_simpl_binds, filter orphanRule better_rules)
114 doCorePasses stats us binds irs []
115 = return (stats, binds)
117 doCorePasses stats us binds irs (to_do : to_dos)
119 let (us1, us2) = splitUniqSupply us
120 (stats1, binds1) <- doCorePass us1 binds irs to_do
121 doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
123 doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
124 doCorePass us binds rb CoreCSE = _scc_ "CommonSubExpr" noStats (cseProgram binds)
125 doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
126 doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
127 doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
128 doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
129 doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
130 doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
131 doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
132 doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
133 doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
134 doCorePass us binds rb CoreDoUSPInf
135 = _scc_ "CoreUsageSPInf"
136 if opt_UsageSPOn then
137 noStats (doUsageSPInf us binds)
139 trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
140 noStats (return binds)
142 printCore binds = do dumpIfSet True "Print Core"
143 (pprCoreBindings binds)
146 noStats thing = do { result <- thing; return (zeroSimplCount, result) }
150 %************************************************************************
152 \subsection{Dealing with rules}
154 %************************************************************************
156 We must do some gentle simplifiation on the template (but not the RHS)
157 of each rule. The case that forced me to add this was the fold/build rule,
158 which without simplification looked like:
159 fold k z (build (/\a. g a)) ==> ...
160 This doesn't match unless you do eta reduction on the build argument.
163 simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
164 simplRules us rules binds
165 = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
167 dumpIfSet opt_D_dump_rules
168 "Transformation rules"
169 (vcat (map pprProtoCoreRule better_rules))
173 black_list_all v = True -- This stops all inlining
174 sw_chkr any = SwBool False -- A bit bogus
176 -- Boringly, we need to gather the in-scope set.
177 -- Typically this thunk won't even be force, but the test in
178 -- simpVar fails if it isn't right, and it might conceivably matter
179 bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
182 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
184 = returnSmpl rule -- No need to fiddle with imported rules
186 = simplBinders bndrs $ \ bndrs' ->
187 mapSmpl simplExpr args `thenSmpl` \ args' ->
188 simplExpr rhs `thenSmpl` \ rhs' ->
189 returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
192 %************************************************************************
194 \subsection{The driver for the simplifier}
196 %************************************************************************
199 simplifyPgm :: RuleBase
200 -> (SimplifierSwitch -> SwitchResult)
202 -> [CoreBind] -- Input
203 -> IO (SimplCount, [CoreBind]) -- New bindings
205 simplifyPgm (imported_rule_ids, rule_lhs_fvs)
208 beginPass "Simplify";
210 -- Glom all binds together in one Rec, in case any
211 -- transformations have introduced any new dependencies
213 -- NB: the global invariant is this:
214 -- *** the top level bindings are never cloned, and are always unique ***
216 -- We sort them into dependency order, but applying transformation rules may
217 -- make something at the top refer to something at the bottom:
221 -- RULE: p (q x) = h x
223 -- Applying this rule makes f refer to h, although it doesn't appear to in the
224 -- source program. Our solution is to do this occasional glom-together step,
225 -- just once per overall simplfication step.
227 let { recd_binds = [Rec (flattenBinds binds)] };
229 (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
231 dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
232 "Simplifier statistics"
233 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
235 pprSimplCount counts_out]);
238 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
241 return (counts_out, binds')
244 max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
245 black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
247 core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
250 iteration us iteration_no counts binds
252 -- Occurrence analysis
253 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
255 dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
256 (pprCoreBindings tagged_binds);
259 let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
261 (simplTopBinds tagged_binds);
262 -- The imported_rule_ids are used by initSmpl to initialise
263 -- the in-scope set. That way, the simplifier will change any
264 -- occurrences of the imported id to the one in the imported_rule_ids
265 -- set, which are decorated with their rules.
267 all_counts = counts `plusSimplCount` counts'
270 -- Stop if nothing happened; don't dump output
271 if isZeroSimplCount counts' then
272 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
275 -- Dump the result of this iteration
276 dumpIfSet opt_D_dump_simpl_iterations
277 ("Simplifier iteration " ++ show iteration_no
278 ++ " out of " ++ show max_iterations)
279 (pprSimplCount counts') ;
281 if opt_D_dump_simpl_iterations then
282 endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
283 opt_D_verbose_core2core
288 -- Stop if we've run out of iterations
289 if iteration_no == max_iterations then
291 if max_iterations > 2 then
292 hPutStr stderr ("NOTE: Simplifier still going after " ++
293 show max_iterations ++
294 " iterations; bailing out.\n")
297 return ("Simplifier baled out", iteration_no, all_counts, binds')
301 else iteration us2 (iteration_no + 1) all_counts binds'
304 (us1, us2) = splitUniqSupply us
308 %************************************************************************
310 \subsection{PostSimplification}
312 %************************************************************************
314 Several tasks are performed by the post-simplification pass
316 1. Make the representation of NoRep literals explicit, and
317 float their bindings to the top level. We only do the floating
318 part for NoRep lits inside a lambda (else no gain). We need to
319 take care with let x = "foo" in e
320 that we don't end up with a silly binding
322 with a floated "foo". What a bore.
324 4. Do eta reduction for lambda abstractions appearing in:
325 - the RHS of case alternatives
328 These will otherwise turn into local bindings during Core->STG;
329 better to nuke them if possible. (In general the simplifier does
330 eta expansion not eta reduction, up to this point. It does eta
331 on the RHSs of bindings but not the RHSs of case alternatives and
335 ------------------- NOT DONE ANY MORE ------------------------
336 [March 98] Indirections are now elimianted by the occurrence analyser
337 1. Eliminate indirections. The point here is to transform
343 [Dec 98] [Not now done because there is no penalty in the code
344 generator for using the former form]
346 case x of {...; x' -> ...x'...}
348 case x of {...; _ -> ...x... }
349 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
350 --------------------------------------------------------------
355 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
356 things, and we need local Ids for non-floated stuff):
358 Don't float stuff out of a binder that's marked as a bottoming Id.
359 Reason: it doesn't do any good, and creates more CAFs that increase
368 f' = unpackCString# "string"
371 hence f' and f become CAFs. Instead, the special case for
372 tidyTopBinding below makes sure this comes out as
374 f = let f' = unpackCString# "string" in error f'
376 and we can safely ignore f as a CAF, since it can only ever be entered once.
381 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
382 doPostSimplification us binds_in
384 beginPass "Post-simplification pass"
385 let binds_out = initPM us (postSimplTopBinds binds_in)
386 endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
388 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
389 postSimplTopBinds binds
390 = mapPM postSimplTopBind binds `thenPM` \ binds' ->
391 returnPM (bagToList (unionManyBags binds'))
393 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
394 postSimplTopBind (NonRec bndr rhs)
395 | isBottomingId bndr -- Don't lift out floats for bottoming Ids
397 = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
398 returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
400 postSimplTopBind bind
401 = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
402 returnPM (floats `snocBag` bind')
404 postSimplBind (NonRec bndr rhs)
405 = postSimplExpr rhs `thenPM` \ rhs' ->
406 returnPM (NonRec bndr rhs')
408 postSimplBind (Rec pairs)
409 = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
410 returnPM (Rec (bndrs `zip` rhss'))
412 (bndrs, rhss) = unzip pairs
419 postSimplExpr (Var v) = returnPM (Var v)
420 postSimplExpr (Type ty) = returnPM (Type ty)
422 postSimplExpr (App fun arg)
423 = postSimplExpr fun `thenPM` \ fun' ->
424 postSimplExpr arg `thenPM` \ arg' ->
425 returnPM (App fun' arg')
427 postSimplExpr (Con (Literal lit) args)
428 = ASSERT( null args )
429 litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
430 getInsideLambda `thenPM` \ in_lam ->
431 if in_lam && not (exprIsTrivial lit_expr) then
432 -- It must have been a no-rep literal with a
433 -- non-trivial representation; and we're inside a lambda;
434 -- so float it to the top
435 addTopFloat lit_ty lit_expr `thenPM` \ v ->
440 postSimplExpr (Con con args)
441 = mapPM postSimplExpr args `thenPM` \ args' ->
442 returnPM (Con con args')
444 postSimplExpr (Lam bndr body)
445 = insideLambda bndr $
446 postSimplExpr body `thenPM` \ body' ->
447 returnPM (Lam bndr body')
449 postSimplExpr (Let bind body)
450 = postSimplBind bind `thenPM` \ bind' ->
451 postSimplExprEta body `thenPM` \ body' ->
452 returnPM (Let bind' body')
454 postSimplExpr (Note note body)
455 = postSimplExpr body `thenPM` \ body' ->
456 -- Do *not* call postSimplExprEta here
457 -- We don't want to turn f = \x -> coerce t (\y -> f x y)
458 -- into f = \x -> coerce t (f x)
459 -- because then f has a lower arity.
460 -- This is not only bad in general, it causes the arity to
461 -- not match the [Demand] on an Id,
462 -- which confuses the importer of this module.
463 returnPM (Note note body')
465 postSimplExpr (Case scrut case_bndr alts)
466 = postSimplExpr scrut `thenPM` \ scrut' ->
467 mapPM ps_alt alts `thenPM` \ alts' ->
468 returnPM (Case scrut' case_bndr alts')
470 ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
471 returnPM (con, bndrs, rhs')
473 postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
474 returnPM (etaCoreExpr e')
478 %************************************************************************
480 \subsection[coreToStg-lits]{Converting literals}
482 %************************************************************************
484 Literals: the NoRep kind need to be de-no-rep'd.
485 We always replace them with a simple variable, and float a suitable
486 binding out to the top level.
489 litToRep :: Literal -> PostM (Type, CoreExpr)
491 litToRep (NoRepStr s ty)
494 rhs = if (any is_NUL (_UNPK_ s))
496 then -- Must cater for NULs in literal string
497 mkApps (Var unpackCString2Id)
499 mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
501 else -- No NULs in the string
502 App (Var unpackCStringId) (mkLit (MachStr s))
507 If an Integer is small enough (Haskell implementations must support
508 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
509 otherwise, wrap with @addr2Integer@.
512 litToRep (NoRepInteger i integer_ty)
513 = returnPM (integer_ty, rhs)
515 rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int
517 = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
519 | otherwise -- Big, so start from a string
520 = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
523 litToRep (NoRepRational r rational_ty)
524 = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
525 postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
526 returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
528 (ratio_data_con, integer_ty)
529 = case (splitAlgTyConApp_maybe rational_ty) of
530 Just (tycon, [i_ty], [con])
531 -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
534 _ -> (panic "ratio_data_con", panic "integer_ty")
536 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
540 %************************************************************************
542 \subsection{The monad}
544 %************************************************************************
547 type PostM a = Bool -- True <=> inside a *value* lambda
548 -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
549 -> (a, (UniqSupply, Bag CoreBind))
551 initPM :: UniqSupply -> PostM a -> a
553 = case m False {- not inside lambda -} (us, emptyBag) of
554 (result, _) -> result
556 returnPM v in_lam usf = (v, usf)
557 thenPM m k in_lam usf = case m in_lam usf of
558 (r, usf') -> k r in_lam usf'
560 mapPM f [] = returnPM []
561 mapPM f (x:xs) = f x `thenPM` \ r ->
562 mapPM f xs `thenPM` \ rs ->
565 insideLambda :: CoreBndr -> PostM a -> PostM a
566 insideLambda bndr m in_lam usf | isId bndr = m True usf
567 | otherwise = m in_lam usf
569 getInsideLambda :: PostM Bool
570 getInsideLambda in_lam usf = (in_lam, usf)
572 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
573 getFloatsPM m in_lam (us, floats)
575 (a, (us', floats')) = m in_lam (us, emptyBag)
577 ((a, floats'), (us', floats))
579 addTopFloat :: Type -> CoreExpr -> PostM Id
580 addTopFloat lit_ty lit_rhs in_lam (us, floats)
582 (us1, us2) = splitUniqSupply us
583 uniq = uniqFromSupply us1
584 lit_id = mkSysLocal SLIT("lf") uniq lit_ty
586 (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))