2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\r
4 \section[SimplCore]{Driver for simplifying @Core@ programs}
\r
7 module SimplCore ( core2core ) where
\r
9 #include "HsVersions.h"
\r
11 import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
\r
12 SwitchResult(..), switchIsOn, intSwitchSet,
\r
13 opt_D_dump_occur_anal, opt_D_dump_rules,
\r
14 opt_D_dump_simpl_iterations,
\r
15 opt_D_dump_simpl_stats,
\r
16 opt_D_dump_simpl, opt_D_dump_rules,
\r
17 opt_D_verbose_core2core,
\r
18 opt_D_dump_occur_anal,
\r
21 import CoreLint ( beginPass, endPass )
\r
22 import CoreTidy ( tidyCorePgm )
\r
24 import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareRuleBase, orphanRule )
\r
26 import PprCore ( pprCoreBindings )
\r
27 import OccurAnal ( occurAnalyseBinds )
\r
28 import CoreUtils ( exprIsTrivial, coreExprType )
\r
29 import Simplify ( simplTopBinds, simplExpr )
\r
30 import SimplUtils ( etaCoreExpr, findDefault, simplBinders )
\r
32 import Const ( Con(..), Literal(..), literalType, mkMachInt )
\r
33 import ErrUtils ( dumpIfSet )
\r
34 import FloatIn ( floatInwards )
\r
35 import FloatOut ( floatOutwards )
\r
36 import Id ( Id, mkSysLocal, mkVanillaId, isBottomingId,
\r
37 idType, setIdType, idName, idInfo, setIdNoDiscard
\r
41 import Module ( Module )
\r
42 import Name ( mkLocalName, tidyOccName, tidyTopName,
\r
43 NamedThing(..), OccName
\r
45 import TyCon ( TyCon, isDataTyCon )
\r
46 import PrimOp ( PrimOp(..) )
\r
47 import PrelInfo ( unpackCStringId, unpackCString2Id, addr2IntegerId )
\r
48 import Type ( Type, splitAlgTyConApp_maybe,
\r
50 tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
\r
53 import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
\r
54 import LiberateCase ( liberateCase )
\r
55 import SAT ( doStaticArgs )
\r
56 import Specialise ( specProgram)
\r
57 import UsageSPInf ( doUsageSPInf )
\r
58 import StrictAnal ( saBinds )
\r
59 import WorkWrap ( wwTopBinds )
\r
60 import CprAnalyse ( cprAnalyse )
\r
62 import Unique ( Unique, Uniquable(..),
\r
65 import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupply )
\r
66 import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
\r
67 import Util ( mapAccumL )
\r
68 import SrcLoc ( noSrcLoc )
\r
71 import IO ( hPutStr, stderr )
\r
74 import Ratio ( numerator, denominator )
\r
77 %************************************************************************
\r
79 \subsection{The driver for the simplifier}
\r
81 %************************************************************************
\r
84 core2core :: [CoreToDo] -- Spec of what core-to-core passes to do
\r
85 -> [CoreBind] -- Binds in
\r
86 -> [ProtoCoreRule] -- Rules
\r
87 -> IO ([CoreBind], [ProtoCoreRule])
\r
89 core2core core_todos binds rules
\r
91 us <- mkSplitUniqSupply 's'
\r
92 let (cp_us, us1) = splitUniqSupply us
\r
93 (ru_us, ps_us) = splitUniqSupply us1
\r
95 better_rules <- simplRules ru_us rules binds
\r
97 let (binds1, rule_base) = prepareRuleBase binds better_rules
\r
99 -- Do the main business
\r
100 (stats, processed_binds) <- doCorePasses zeroSimplCount cp_us binds1
\r
101 rule_base core_todos
\r
103 dumpIfSet opt_D_dump_simpl_stats
\r
104 "Grand total simplifier statistics"
\r
105 (pprSimplCount stats)
\r
107 -- Do the post-simplification business
\r
108 post_simpl_binds <- doPostSimplification ps_us processed_binds
\r
111 return (post_simpl_binds, filter orphanRule better_rules)
\r
114 doCorePasses stats us binds irs []
\r
115 = return (stats, binds)
\r
117 doCorePasses stats us binds irs (to_do : to_dos)
\r
119 let (us1, us2) = splitUniqSupply us
\r
120 (stats1, binds1) <- doCorePass us1 binds irs to_do
\r
121 doCorePasses (stats `plusSimplCount` stats1) us2 binds1 irs to_dos
\r
123 doCorePass us binds rb (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm rb sw_chkr us binds
\r
124 doCorePass us binds rb CoreLiberateCase = _scc_ "LiberateCase" noStats (liberateCase binds)
\r
125 doCorePass us binds rb CoreDoFloatInwards = _scc_ "FloatInwards" noStats (floatInwards binds)
\r
126 doCorePass us binds rb CoreDoFullLaziness = _scc_ "FloatOutwards" noStats (floatOutwards us binds)
\r
127 doCorePass us binds rb CoreDoStaticArgs = _scc_ "StaticArgs" noStats (doStaticArgs us binds)
\r
128 doCorePass us binds rb CoreDoStrictness = _scc_ "Stranal" noStats (saBinds binds)
\r
129 doCorePass us binds rb CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats (wwTopBinds us binds)
\r
130 doCorePass us binds rb CoreDoSpecialising = _scc_ "Specialise" noStats (specProgram us binds)
\r
131 doCorePass us binds rb CoreDoCPResult = _scc_ "CPResult" noStats (cprAnalyse binds)
\r
132 doCorePass us binds rb CoreDoPrintCore = _scc_ "PrintCore" noStats (printCore binds)
\r
133 doCorePass us binds rb CoreDoUSPInf
\r
134 = _scc_ "CoreUsageSPInf"
\r
135 if opt_UsageSPOn then
\r
136 noStats (doUsageSPInf us binds)
\r
138 trace "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on" $
\r
139 noStats (return binds)
\r
141 printCore binds = do dumpIfSet True "Print Core"
\r
142 (pprCoreBindings binds)
\r
145 noStats thing = do { result <- thing; return (zeroSimplCount, result) }
\r
149 %************************************************************************
\r
151 \subsection{Dealing with rules}
\r
153 %************************************************************************
\r
155 We must do some gentle simplifiation on the template (but not the RHS)
\r
156 of each rule. The case that forced me to add this was the fold/build rule,
\r
157 which without simplification looked like:
\r
158 fold k z (build (/\a. g a)) ==> ...
\r
159 This doesn't match unless you do eta reduction on the build argument.
\r
162 simplRules :: UniqSupply -> [ProtoCoreRule] -> [CoreBind] -> IO [ProtoCoreRule]
\r
163 simplRules us rules binds
\r
164 = do let (better_rules,_) = initSmpl sw_chkr us bind_vars black_list_all (mapSmpl simplRule rules)
\r
166 dumpIfSet opt_D_dump_rules
\r
167 "Transformation rules"
\r
168 (vcat (map pprProtoCoreRule better_rules))
\r
170 return better_rules
\r
172 black_list_all v = True -- This stops all inlining
\r
173 sw_chkr any = SwBool False -- A bit bogus
\r
175 -- Boringly, we need to gather the in-scope set.
\r
176 -- Typically this thunk won't even be force, but the test in
\r
177 -- simpVar fails if it isn't right, and it might conceivably matter
\r
178 bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds
\r
181 simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs))
\r
183 = returnSmpl rule -- No need to fiddle with imported rules
\r
185 = simplBinders bndrs $ \ bndrs' ->
\r
186 mapSmpl simplExpr args `thenSmpl` \ args' ->
\r
187 simplExpr rhs `thenSmpl` \ rhs' ->
\r
188 returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs'))
\r
191 %************************************************************************
\r
193 \subsection{The driver for the simplifier}
\r
195 %************************************************************************
\r
198 simplifyPgm :: RuleBase
\r
199 -> (SimplifierSwitch -> SwitchResult)
\r
201 -> [CoreBind] -- Input
\r
202 -> IO (SimplCount, [CoreBind]) -- New bindings
\r
204 simplifyPgm (imported_rule_ids, rule_lhs_fvs)
\r
207 beginPass "Simplify";
\r
209 -- Glom all binds together in one Rec, in case any
\r
210 -- transformations have introduced any new dependencies
\r
211 let { recd_binds = [Rec (flattenBinds binds)] };
\r
213 (termination_msg, it_count, counts_out, binds') <- iteration us 1 zeroSimplCount recd_binds;
\r
215 dumpIfSet (opt_D_verbose_core2core && opt_D_dump_simpl_stats)
\r
216 "Simplifier statistics"
\r
217 (vcat [text termination_msg <+> text "after" <+> ppr it_count <+> text "iterations",
\r
219 pprSimplCount counts_out]);
\r
221 endPass "Simplify"
\r
222 (opt_D_verbose_core2core && not opt_D_dump_simpl_iterations)
\r
225 return (counts_out, binds')
\r
228 max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations
\r
229 black_list_fn = blackListed rule_lhs_fvs (intSwitchSet sw_chkr SimplInlinePhase)
\r
231 core_iter_dump binds | opt_D_verbose_core2core = pprCoreBindings binds
\r
232 | otherwise = empty
\r
234 iteration us iteration_no counts binds
\r
236 -- Occurrence analysis
\r
237 let { tagged_binds = _scc_ "OccAnal" occurAnalyseBinds binds } ;
\r
239 dumpIfSet opt_D_dump_occur_anal "Occurrence analysis"
\r
240 (pprCoreBindings tagged_binds);
\r
243 let { (binds', counts') = initSmpl sw_chkr us1 imported_rule_ids
\r
245 (simplTopBinds tagged_binds);
\r
246 all_counts = counts `plusSimplCount` counts'
\r
249 -- Stop if nothing happened; don't dump output
\r
250 if isZeroSimplCount counts' then
\r
251 return ("Simplifier reached fixed point", iteration_no, all_counts, binds')
\r
254 -- Dump the result of this iteration
\r
255 dumpIfSet opt_D_dump_simpl_iterations
\r
256 ("Simplifier iteration " ++ show iteration_no
\r
257 ++ " out of " ++ show max_iterations)
\r
258 (pprSimplCount counts') ;
\r
260 if opt_D_dump_simpl_iterations then
\r
261 endPass ("Simplifier iteration " ++ show iteration_no ++ " result")
\r
262 opt_D_verbose_core2core
\r
267 -- Stop if we've run out of iterations
\r
268 if iteration_no == max_iterations then
\r
270 if max_iterations > 2 then
\r
271 hPutStr stderr ("NOTE: Simplifier still going after " ++
\r
272 show max_iterations ++
\r
273 " iterations; bailing out.\n")
\r
276 return ("Simplifier baled out", iteration_no, all_counts, binds')
\r
280 else iteration us2 (iteration_no + 1) all_counts binds'
\r
283 (us1, us2) = splitUniqSupply us
\r
287 %************************************************************************
\r
289 \subsection{PostSimplification}
\r
291 %************************************************************************
\r
293 Several tasks are performed by the post-simplification pass
\r
295 1. Make the representation of NoRep literals explicit, and
\r
296 float their bindings to the top level. We only do the floating
\r
297 part for NoRep lits inside a lambda (else no gain). We need to
\r
298 take care with let x = "foo" in e
\r
299 that we don't end up with a silly binding
\r
301 with a floated "foo". What a bore.
\r
303 4. Do eta reduction for lambda abstractions appearing in:
\r
304 - the RHS of case alternatives
\r
305 - the body of a let
\r
307 These will otherwise turn into local bindings during Core->STG;
\r
308 better to nuke them if possible. (In general the simplifier does
\r
309 eta expansion not eta reduction, up to this point. It does eta
\r
310 on the RHSs of bindings but not the RHSs of case alternatives and
\r
314 ------------------- NOT DONE ANY MORE ------------------------
\r
315 [March 98] Indirections are now elimianted by the occurrence analyser
\r
316 1. Eliminate indirections. The point here is to transform
\r
318 x_exported = x_local
\r
322 [Dec 98] [Not now done because there is no penalty in the code
\r
323 generator for using the former form]
\r
325 case x of {...; x' -> ...x'...}
\r
327 case x of {...; _ -> ...x... }
\r
328 See notes in SimplCase.lhs, near simplDefault for the reasoning here.
\r
329 --------------------------------------------------------------
\r
334 NOT ENABLED AT THE MOMENT (because the floated Ids are global-ish
\r
335 things, and we need local Ids for non-floated stuff):
\r
337 Don't float stuff out of a binder that's marked as a bottoming Id.
\r
338 Reason: it doesn't do any good, and creates more CAFs that increase
\r
347 f' = unpackCString# "string"
\r
350 hence f' and f become CAFs. Instead, the special case for
\r
351 tidyTopBinding below makes sure this comes out as
\r
353 f = let f' = unpackCString# "string" in error f'
\r
355 and we can safely ignore f as a CAF, since it can only ever be entered once.
\r
360 doPostSimplification :: UniqSupply -> [CoreBind] -> IO [CoreBind]
\r
361 doPostSimplification us binds_in
\r
363 beginPass "Post-simplification pass"
\r
364 let binds_out = initPM us (postSimplTopBinds binds_in)
\r
365 endPass "Post-simplification pass" opt_D_verbose_core2core binds_out
\r
367 postSimplTopBinds :: [CoreBind] -> PostM [CoreBind]
\r
368 postSimplTopBinds binds
\r
369 = mapPM postSimplTopBind binds `thenPM` \ binds' ->
\r
370 returnPM (bagToList (unionManyBags binds'))
\r
372 postSimplTopBind :: CoreBind -> PostM (Bag CoreBind)
\r
373 postSimplTopBind (NonRec bndr rhs)
\r
374 | isBottomingId bndr -- Don't lift out floats for bottoming Ids
\r
376 = getFloatsPM (postSimplExpr rhs) `thenPM` \ (rhs', floats) ->
\r
377 returnPM (unitBag (NonRec bndr (foldrBag Let rhs' floats)))
\r
379 postSimplTopBind bind
\r
380 = getFloatsPM (postSimplBind bind) `thenPM` \ (bind', floats) ->
\r
381 returnPM (floats `snocBag` bind')
\r
383 postSimplBind (NonRec bndr rhs)
\r
384 = postSimplExpr rhs `thenPM` \ rhs' ->
\r
385 returnPM (NonRec bndr rhs')
\r
387 postSimplBind (Rec pairs)
\r
388 = mapPM postSimplExpr rhss `thenPM` \ rhss' ->
\r
389 returnPM (Rec (bndrs `zip` rhss'))
\r
391 (bndrs, rhss) = unzip pairs
\r
398 postSimplExpr (Var v) = returnPM (Var v)
\r
399 postSimplExpr (Type ty) = returnPM (Type ty)
\r
401 postSimplExpr (App fun arg)
\r
402 = postSimplExpr fun `thenPM` \ fun' ->
\r
403 postSimplExpr arg `thenPM` \ arg' ->
\r
404 returnPM (App fun' arg')
\r
406 postSimplExpr (Con (Literal lit) args)
\r
407 = ASSERT( null args )
\r
408 litToRep lit `thenPM` \ (lit_ty, lit_expr) ->
\r
409 getInsideLambda `thenPM` \ in_lam ->
\r
410 if in_lam && not (exprIsTrivial lit_expr) then
\r
411 -- It must have been a no-rep literal with a
\r
412 -- non-trivial representation; and we're inside a lambda;
\r
413 -- so float it to the top
\r
414 addTopFloat lit_ty lit_expr `thenPM` \ v ->
\r
419 postSimplExpr (Con con args)
\r
420 = mapPM postSimplExpr args `thenPM` \ args' ->
\r
421 returnPM (Con con args')
\r
423 postSimplExpr (Lam bndr body)
\r
424 = insideLambda bndr $
\r
425 postSimplExpr body `thenPM` \ body' ->
\r
426 returnPM (Lam bndr body')
\r
428 postSimplExpr (Let bind body)
\r
429 = postSimplBind bind `thenPM` \ bind' ->
\r
430 postSimplExprEta body `thenPM` \ body' ->
\r
431 returnPM (Let bind' body')
\r
433 postSimplExpr (Note note body)
\r
434 = postSimplExprEta body `thenPM` \ body' ->
\r
435 returnPM (Note note body')
\r
437 postSimplExpr (Case scrut case_bndr alts)
\r
438 = postSimplExpr scrut `thenPM` \ scrut' ->
\r
439 mapPM ps_alt alts `thenPM` \ alts' ->
\r
440 returnPM (Case scrut' case_bndr alts')
\r
442 ps_alt (con,bndrs,rhs) = postSimplExprEta rhs `thenPM` \ rhs' ->
\r
443 returnPM (con, bndrs, rhs')
\r
445 postSimplExprEta e = postSimplExpr e `thenPM` \ e' ->
\r
446 returnPM (etaCoreExpr e')
\r
450 %************************************************************************
\r
452 \subsection[coreToStg-lits]{Converting literals}
\r
454 %************************************************************************
\r
456 Literals: the NoRep kind need to be de-no-rep'd.
\r
457 We always replace them with a simple variable, and float a suitable
\r
458 binding out to the top level.
\r
461 litToRep :: Literal -> PostM (Type, CoreExpr)
\r
463 litToRep (NoRepStr s ty)
\r
464 = returnPM (ty, rhs)
\r
466 rhs = if (any is_NUL (_UNPK_ s))
\r
468 then -- Must cater for NULs in literal string
\r
469 mkApps (Var unpackCString2Id)
\r
470 [mkLit (MachStr s),
\r
471 mkLit (mkMachInt (toInteger (_LENGTH_ s)))]
\r
473 else -- No NULs in the string
\r
474 App (Var unpackCStringId) (mkLit (MachStr s))
\r
476 is_NUL c = c == '\0'
\r
479 If an Integer is small enough (Haskell implementations must support
\r
480 Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
\r
481 otherwise, wrap with @addr2Integer@.
\r
484 litToRep (NoRepInteger i integer_ty)
\r
485 = returnPM (integer_ty, rhs)
\r
487 rhs | i > tARGET_MIN_INT && -- Small enough, so start from an Int
\r
489 = Con (DataCon smallIntegerDataCon) [Con (Literal (mkMachInt i)) []]
\r
491 | otherwise -- Big, so start from a string
\r
492 = App (Var addr2IntegerId) (Con (Literal (MachStr (_PK_ (show i)))) [])
\r
495 litToRep (NoRepRational r rational_ty)
\r
496 = postSimplExpr (mkLit (NoRepInteger (numerator r) integer_ty)) `thenPM` \ num_arg ->
\r
497 postSimplExpr (mkLit (NoRepInteger (denominator r) integer_ty)) `thenPM` \ denom_arg ->
\r
498 returnPM (rational_ty, mkConApp ratio_data_con [Type integer_ty, num_arg, denom_arg])
\r
500 (ratio_data_con, integer_ty)
\r
501 = case (splitAlgTyConApp_maybe rational_ty) of
\r
502 Just (tycon, [i_ty], [con])
\r
503 -> ASSERT(isIntegerTy i_ty && getUnique tycon == ratioTyConKey)
\r
506 _ -> (panic "ratio_data_con", panic "integer_ty")
\r
508 litToRep other_lit = returnPM (literalType other_lit, mkLit other_lit)
\r
512 %************************************************************************
\r
514 \subsection{The monad}
\r
516 %************************************************************************
\r
519 type PostM a = Bool -- True <=> inside a *value* lambda
\r
520 -> (UniqSupply, Bag CoreBind) -- Unique supply and Floats in
\r
521 -> (a, (UniqSupply, Bag CoreBind))
\r
523 initPM :: UniqSupply -> PostM a -> a
\r
525 = case m False {- not inside lambda -} (us, emptyBag) of
\r
526 (result, _) -> result
\r
528 returnPM v in_lam usf = (v, usf)
\r
529 thenPM m k in_lam usf = case m in_lam usf of
\r
530 (r, usf') -> k r in_lam usf'
\r
532 mapPM f [] = returnPM []
\r
533 mapPM f (x:xs) = f x `thenPM` \ r ->
\r
534 mapPM f xs `thenPM` \ rs ->
\r
537 insideLambda :: CoreBndr -> PostM a -> PostM a
\r
538 insideLambda bndr m in_lam usf | isId bndr = m True usf
\r
539 | otherwise = m in_lam usf
\r
541 getInsideLambda :: PostM Bool
\r
542 getInsideLambda in_lam usf = (in_lam, usf)
\r
544 getFloatsPM :: PostM a -> PostM (a, Bag CoreBind)
\r
545 getFloatsPM m in_lam (us, floats)
\r
547 (a, (us', floats')) = m in_lam (us, emptyBag)
\r
549 ((a, floats'), (us', floats))
\r
551 addTopFloat :: Type -> CoreExpr -> PostM Id
\r
552 addTopFloat lit_ty lit_rhs in_lam (us, floats)
\r
554 (us1, us2) = splitUniqSupply us
\r
555 uniq = uniqFromSupply us1
\r
556 lit_id = mkSysLocal SLIT("lf") uniq lit_ty
\r
558 (lit_id, (us2, floats `snocBag` NonRec lit_id lit_rhs))
\r