2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplUtils]{The simplifier utilities}
13 etaCoreExpr, mkRhsTyLam,
17 simplIdWantsToBeINLINEd,
19 singleConstructorType, typeOkForCase,
24 #include "HsVersions.h"
27 import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
29 import CoreUnfold ( mkFormSummary, exprIsTrivial, FormSummary(..) )
30 import MkId ( mkSysLocal )
31 import Id ( idType, isBottomingId, getIdArity,
32 addInlinePragma, addIdDemandInfo,
33 idWantsToBeINLINEd, dataConArgTys, Id,
34 lookupIdEnv, delOneFromIdEnv
36 import IdInfo ( ArityInfo(..), DemandInfo )
37 import Maybes ( maybeToBool )
38 import PrelVals ( augmentId, buildId )
39 import PrimOp ( primOpIsCheap )
42 import Type ( tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, getTyVar_maybe,
43 splitAlgTyConApp_maybe, instantiateTy, Type
45 import TyCon ( isDataTyCon )
46 import TyVar ( mkTyVarSet, intersectTyVarSets, elementOfTyVarSet, tyVarSetToList,
49 import SrcLoc ( noSrcLoc )
50 import Util ( isIn, zipWithEqual, panic, assertPanic )
55 %************************************************************************
59 %************************************************************************
62 newId :: Type -> SmplM Id
64 = getUniqueSmpl `thenSmpl` \ uniq ->
65 returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc)
67 newIds :: [Type] -> SmplM [Id]
69 = getUniquesSmpl (length tys) `thenSmpl` \ uniqs ->
70 returnSmpl (zipWithEqual "newIds" mk_id tys uniqs)
72 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
76 %************************************************************************
80 %************************************************************************
82 The function @floatExposesHNF@ tells whether let/case floating will
83 expose a head normal form. It is passed booleans indicating the
88 :: Bool -- Float let(rec)s out of rhs
89 -> Bool -- Float cheap primops out of rhs
90 -> GenCoreExpr bdr Id flexi
93 floatExposesHNF float_lets float_primops rhs
96 try (Case (Prim _ _) (PrimAlts alts deflt) )
97 | float_primops && null alts
98 = or (try_deflt deflt : map try_alt alts)
100 try (Let bind body) | float_lets = try body
104 -- because it *will* become one.
105 -- likewise for `augment g h'
107 try (App (App (Var bld) _) _) | bld == buildId = True
108 try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
110 try other = case mkFormSummary other of
114 {- but *not* necessarily "BottomForm"...
116 We may want to float a let out of a let to expose WHNFs,
117 but to do that to expose a "bottom" is a Bad Idea:
119 in ...error ...y... -- manifestly bottom using y
123 in let x = ...error ...y...
126 as y is only used in case of an error, we do not want
127 to allocate it eagerly as that's a waste.
130 try_alt (lit,rhs) = try rhs
132 try_deflt NoDefault = False
133 try_deflt (BindDefault _ rhs) = try rhs
139 mkRhsTyLam tries this transformation, when the big lambda appears as
140 the RHS of a let(rec) binding:
142 /\abc -> let(rec) x = e in b
144 let(rec) x' = /\abc -> let x = x' a b c in e
146 /\abc -> let x = x' a b c in b
148 This is good because it can turn things like:
150 let f = /\a -> letrec g = ... g ... in g
152 letrec g' = /\a -> ... g' a ...
156 which is better. In effect, it means that big lambdas don't impede
159 This optimisation is CRUCIAL in eliminating the junk introduced by
160 desugaring mutually recursive definitions. Don't eliminate it lightly!
162 So far as the implemtation is concerned:
164 Invariant: go F e = /\tvs -> F e
168 = Let x' = /\tvs -> F e
172 G = F . Let x = x' tvs
174 go F (Letrec xi=ei in b)
175 = Letrec {xi' = /\tvs -> G ei}
179 G = F . Let {xi = xi' tvs}
182 mkRhsTyLam [] body = returnSmpl body
184 mkRhsTyLam tyvars body
187 main_tyvar_set = mkTyVarSet tyvars
189 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
190 = go (fn . Let bind) body
192 go fn (Let bind@(NonRec var rhs) body)
193 = mk_poly tyvars_here var_ty `thenSmpl` \ (var', rhs') ->
194 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
195 returnSmpl (Let (NonRec var' (mkTyLam tyvars_here (fn rhs))) body')
197 tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfType var_ty)
200 go fn (Let (Rec prs) body)
201 = mapAndUnzipSmpl (mk_poly tyvars_here) var_tys `thenSmpl` \ (vars', rhss') ->
203 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
205 go gn body `thenSmpl` \ body' ->
206 returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars_here (gn rhs) | rhs <- rhss])) body')
208 (vars,rhss) = unzip prs
209 tyvars_here = tyVarSetToList (main_tyvar_set `intersectTyVarSets` tyVarsOfTypes var_tys)
210 var_tys = map idType vars
212 go fn body = returnSmpl (mkTyLam tyvars (fn body))
214 mk_poly tyvars_here var_ty
215 = newId (mkForAllTys tyvars_here var_ty) `thenSmpl` \ poly_id ->
216 returnSmpl (poly_id, mkTyApp (Var poly_id) (mkTyVarTys tyvars_here))
218 mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
219 -- The addInlinePragma is really important! If we don't say
220 -- INLINE on these silly little bindings then look what happens!
221 -- Suppose we start with:
223 -- x = let g = /\a -> \x -> f x x
225 -- /\ b -> let g* = g b in E
227 -- Then: * the binding for g gets floated out
228 -- * but then it gets inlined into the rhs of g*
229 -- * then the binding for g* is floated out of the /\b
230 -- * so we're back to square one
231 -- The silly binding for g* must be INLINE, so that no inlining
232 -- will happen in its RHS.
237 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
239 e.g. \ x y -> f x y ===> f
242 a) Before constructing an Unfolding, to
243 try to make the unfolding smaller;
244 b) In tidyCoreExpr, which is done just before converting to STG.
246 But we only do this if it gets rid of a whole lambda, not part.
247 The idea is that lambdas are often quite helpful: they indicate
248 head normal forms, so we don't want to chuck them away lightly.
249 But if they expose a simple variable then we definitely win. Even
250 if they expose a type application we win. So we check for this special
255 f xs = [y | (y,_) <- xs]
257 gives rise to a recursive function for the list comprehension, and
258 f turns out to be just a single call to this recursive function.
260 Doing eta on type lambdas is useful too:
262 /\a -> <expr> a ===> <expr>
264 where <expr> doesn't mention a.
265 This is sometimes quite useful, because we can get the sequence:
267 f ab d = let d1 = ...d... in
268 letrec f' b x = ...d...(f' b)... in
272 f.Int b = letrec f' b x = ...dInt...(f' b)... in
277 f' b x = ...dInt...(f' b)...
280 Now we really want to simplify to
284 and then replace all the f's with f.Ints.
286 N.B. We are careful not to partially eta-reduce a sequence of type
287 applications since this breaks the specialiser:
289 /\ a -> f Char# a =NO=> f Char#
292 etaCoreExpr :: CoreExpr -> CoreExpr
295 etaCoreExpr expr@(Lam bndr body)
297 = case etaCoreExpr body of
298 App fun arg | eta_match bndr arg &&
301 other -> expr -- Can't eliminate it, so do nothing at all
303 eta_match (ValBinder v) (VarArg v') = v == v'
304 eta_match (TyBinder tv) (TyArg ty) = case getTyVar_maybe ty of
306 Just tv' -> tv == tv'
307 eta_match bndr arg = False
309 residual_ok :: CoreExpr -> Bool -- Checks for type application
310 -- and function not one of the
313 (VarArg v) `mentions` (ValBinder v') = v == v'
314 (TyArg ty) `mentions` (TyBinder tv) = tv `elementOfTyVarSet` tyVarsOfType ty
315 bndr `mentions` arg = False
318 = not (VarArg v `mentions` bndr)
319 residual_ok (App fun arg)
320 | arg `mentions` bndr = False
321 | otherwise = residual_ok fun
322 residual_ok (Note (Coerce to_ty from_ty) body)
323 | TyArg to_ty `mentions` bndr
324 || TyArg from_ty `mentions` bndr = False
325 | otherwise = residual_ok body
327 residual_ok other = False -- Safe answer
328 -- This last clause may seem conservative, but consider:
329 -- primops, constructors, and literals, are impossible here
330 -- let and case are unlikely (the argument would have been floated inside)
331 -- SCCs we probably want to be conservative about (not sure, but it's safe to be)
333 etaCoreExpr expr = expr -- The common case
339 @etaExpandCount@ takes an expression, E, and returns an integer n,
342 E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
344 is a safe transformation. In particular, the transformation should
345 not cause work to be duplicated, unless it is ``cheap'' (see
346 @manifestlyCheap@ below).
348 @etaExpandCount@ errs on the conservative side. It is always safe to
351 An application of @error@ is special, because it can absorb as many
352 arguments as you care to give it. For this special case we return
353 100, to represent "infinity", which is a bit of a hack.
356 etaExpandCount :: GenCoreExpr bdr Id flexi
357 -> Int -- Number of extra args you can safely abstract
359 etaExpandCount (Lam (ValBinder _) body)
360 = 1 + etaExpandCount body
362 etaExpandCount (Let bind body)
363 | all manifestlyCheap (rhssOfBind bind)
364 = etaExpandCount body
366 etaExpandCount (Case scrut alts)
367 | manifestlyCheap scrut
368 = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
370 etaExpandCount fun@(Var _) = eta_fun fun
371 etaExpandCount (App fun arg)
372 | notValArg arg = eta_fun fun
373 | otherwise = case etaExpandCount fun of
375 n -> n-1 -- Knock off one
377 etaExpandCount other = 0 -- Give up
380 -- Scc (pessimistic; ToDo),
381 -- Let with non-whnf rhs(s),
382 -- Case with non-whnf scrutinee
384 -----------------------------
385 eta_fun :: GenCoreExpr bdr Id flexi -- The function
386 -> Int -- How many args it can safely be applied to
388 eta_fun (App fun arg) | notValArg arg = eta_fun fun
391 | isBottomingId v -- Bottoming ids have "infinite arity"
392 = 10000 -- Blargh. Infinite enough!
394 eta_fun expr@(Var v) = idMinArity v
396 eta_fun other = 0 -- Give up
399 @manifestlyCheap@ looks at a Core expression and returns \tr{True} if
400 it is obviously in weak head normal form, or is cheap to get to WHNF.
401 By ``cheap'' we mean a computation we're willing to duplicate in order
402 to bring a couple of lambdas together. The main examples of things
403 which aren't WHNF but are ``cheap'' are:
408 where e, and all the ei are cheap; and
413 where e and b are cheap; and
417 where op is a cheap primitive operator
420 manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
422 manifestlyCheap (Var _) = True
423 manifestlyCheap (Lit _) = True
424 manifestlyCheap (Con _ _) = True
425 manifestlyCheap (Note _ e) = manifestlyCheap e
426 manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
427 manifestlyCheap (Prim op _) = primOpIsCheap op
429 manifestlyCheap (Let bind body)
430 = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
432 manifestlyCheap (Case scrut alts)
433 = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
435 manifestlyCheap other_expr -- look for manifest partial application
436 = case (collectArgs other_expr) of { (fun, _, vargs) ->
439 Var f | isBottomingId f -> True -- Application of a function which
440 -- always gives bottom; we treat this as
441 -- a WHNF, because it certainly doesn't
442 -- need to be shared!
445 num_val_args = length vargs
447 num_val_args == 0 || -- Just a type application of
448 -- a variable (f t1 t2 t3)
450 num_val_args < idMinArity f
459 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
461 simplIdWantsToBeINLINEd id env
462 = {- We used to arrange that in the final simplification pass we'd switch
463 off all INLINE pragmas, so that we'd inline workers back into the
464 body of their wrapper if the wrapper hadn't itself been inlined by then.
465 This occurred especially for methods in dictionaries.
467 We no longer do this:
468 a) there's a good chance that the exported wrapper will get
469 inlined in some importing scope, in which case we don't
470 want to lose the w/w idea.
472 b) The occurrence analyser must agree about what has an
473 INLINE pragma. Not hard, but delicate.
475 c) if the worker gets inlined we have to tell the wrapepr
476 that it's no longer a wrapper, else the interface file stuff
477 asks for a worker that no longer exists.
479 if switchIsSet env IgnoreINLINEPragma
484 idWantsToBeINLINEd id
486 idMinArity id = case getIdArity id of
491 singleConstructorType :: Type -> Bool
492 singleConstructorType ty
493 = case (splitAlgTyConApp_maybe ty) of
494 Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
497 typeOkForCase :: Type -> Bool
499 = case (splitAlgTyConApp_maybe ty) of
500 Just (tycon, ty_args, []) -> False
501 Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
503 -- Null data cons => type is abstract, which code gen can't
504 -- currently handle. (ToDo: when return-in-heap is universal we
505 -- don't need to worry about this.)
510 substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
511 It exploits the known structure of a SpecEnv's RHS to have fewer
515 substSpecEnvRhs te ve rhs
518 go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
519 go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
520 Just (SubstVar v') -> VarArg v'
521 Just (SubstLit l) -> LitArg l
523 go te ve (Var v) = case lookupIdEnv ve v of
524 Just (SubstVar v') -> Var v'
525 Just (SubstLit l) -> Lit l
528 -- These equations are a bit half baked, because
529 -- they don't deal properly wih capture.
530 -- But I'm sure it'll never matter... sigh.
531 go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
533 te' = delFromTyVarEnv te tyvar
535 go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
537 ve' = delOneFromIdEnv ve v