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, mkForAllTys, mkTyVarTys, getTyVar_maybe,
43 splitAlgTyConApp_maybe, instantiateTy, Type
45 import TyCon ( isDataTyCon )
46 import TyVar ( elementOfTyVarSet, delFromTyVarEnv )
47 import SrcLoc ( noSrcLoc )
48 import Util ( isIn, zipWithEqual, panic, assertPanic )
53 %************************************************************************
57 %************************************************************************
60 newId :: Type -> SmplM Id
62 = getUniqueSmpl `thenSmpl` \ uniq ->
63 returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc)
65 newIds :: [Type] -> SmplM [Id]
67 = getUniquesSmpl (length tys) `thenSmpl` \ uniqs ->
68 returnSmpl (zipWithEqual "newIds" mk_id tys uniqs)
70 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
74 %************************************************************************
78 %************************************************************************
80 The function @floatExposesHNF@ tells whether let/case floating will
81 expose a head normal form. It is passed booleans indicating the
86 :: Bool -- Float let(rec)s out of rhs
87 -> Bool -- Float cheap primops out of rhs
88 -> GenCoreExpr bdr Id flexi
91 floatExposesHNF float_lets float_primops rhs
94 try (Case (Prim _ _) (PrimAlts alts deflt) )
95 | float_primops && null alts
96 = or (try_deflt deflt : map try_alt alts)
98 try (Let bind body) | float_lets = try body
102 -- because it *will* become one.
103 -- likewise for `augment g h'
105 try (App (App (Var bld) _) _) | bld == buildId = True
106 try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
108 try other = case mkFormSummary other of
112 {- but *not* necessarily "BottomForm"...
114 We may want to float a let out of a let to expose WHNFs,
115 but to do that to expose a "bottom" is a Bad Idea:
117 in ...error ...y... -- manifestly bottom using y
121 in let x = ...error ...y...
124 as y is only used in case of an error, we do not want
125 to allocate it eagerly as that's a waste.
128 try_alt (lit,rhs) = try rhs
130 try_deflt NoDefault = False
131 try_deflt (BindDefault _ rhs) = try rhs
137 mkRhsTyLam tries this transformation, when the big lambda appears as
138 the RHS of a let(rec) binding:
140 /\abc -> let(rec) x = e in b
142 let(rec) x' = /\abc -> let x = x' a b c in e
144 /\abc -> let x = x' a b c in b
146 This is good because it can turn things like:
148 let f = /\a -> letrec g = ... g ... in g
150 letrec g' = /\a -> ... g' a ...
154 which is better. In effect, it means that big lambdas don't impede
157 This optimisation is CRUCIAL in eliminating the junk introduced by
158 desugaring mutually recursive definitions. Don't eliminate it lightly!
160 So far as the implemtation is concerned:
162 Invariant: go F e = /\tvs -> F e
166 = Let x' = /\tvs -> F e
170 G = F . Let x = x' tvs
172 go F (Letrec xi=ei in b)
173 = Letrec {xi' = /\tvs -> G ei}
177 G = F . Let {xi = xi' tvs}
180 mkRhsTyLam [] body = returnSmpl body
182 mkRhsTyLam tyvars body
185 tyvar_tys = mkTyVarTys tyvars
187 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
188 = go (fn . Let bind) body
190 go fn (Let bind@(NonRec var rhs) body)
191 = mk_poly var `thenSmpl` \ (var', rhs') ->
192 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
193 returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body')
195 go fn (Let (Rec prs) body)
196 = mapAndUnzipSmpl mk_poly vars `thenSmpl` \ (vars', rhss') ->
198 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
200 go gn body `thenSmpl` \ body' ->
201 returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body')
203 (vars,rhss) = unzip prs
205 go fn body = returnSmpl (mkTyLam tyvars (fn body))
208 = newId (mkForAllTys tyvars (idType var)) `thenSmpl` \ poly_id ->
209 returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys)
211 mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
212 -- The addInlinePragma is really important! If we don't say
213 -- INLINE on these silly little bindings then look what happens!
214 -- Suppose we start with:
216 -- x = let g = /\a -> \x -> f x x
218 -- /\ b -> let g* = g b in E
220 -- Then: * the binding for g gets floated out
221 -- * but then it gets inlined into the rhs of g*
222 -- * then the binding for g* is floated out of the /\b
223 -- * so we're back to square one
224 -- The silly binding for g* must be INLINE, so that no inlining
225 -- will happen in its RHS.
230 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
232 e.g. \ x y -> f x y ===> f
235 a) Before constructing an Unfolding, to
236 try to make the unfolding smaller;
237 b) In tidyCoreExpr, which is done just before converting to STG.
239 But we only do this if it gets rid of a whole lambda, not part.
240 The idea is that lambdas are often quite helpful: they indicate
241 head normal forms, so we don't want to chuck them away lightly.
242 But if they expose a simple variable then we definitely win. Even
243 if they expose a type application we win. So we check for this special
248 f xs = [y | (y,_) <- xs]
250 gives rise to a recursive function for the list comprehension, and
251 f turns out to be just a single call to this recursive function.
253 Doing eta on type lambdas is useful too:
255 /\a -> <expr> a ===> <expr>
257 where <expr> doesn't mention a.
258 This is sometimes quite useful, because we can get the sequence:
260 f ab d = let d1 = ...d... in
261 letrec f' b x = ...d...(f' b)... in
265 f.Int b = letrec f' b x = ...dInt...(f' b)... in
270 f' b x = ...dInt...(f' b)...
273 Now we really want to simplify to
277 and then replace all the f's with f.Ints.
279 N.B. We are careful not to partially eta-reduce a sequence of type
280 applications since this breaks the specialiser:
282 /\ a -> f Char# a =NO=> f Char#
285 etaCoreExpr :: CoreExpr -> CoreExpr
288 etaCoreExpr expr@(Lam bndr body)
290 = case etaCoreExpr body of
291 App fun arg | eta_match bndr arg &&
294 other -> expr -- Can't eliminate it, so do nothing at all
296 eta_match (ValBinder v) (VarArg v') = v == v'
297 eta_match (TyBinder tv) (TyArg ty) = case getTyVar_maybe ty of
299 Just tv' -> tv == tv'
300 eta_match bndr arg = False
302 residual_ok :: CoreExpr -> Bool -- Checks for type application
303 -- and function not one of the
306 (VarArg v) `mentions` (ValBinder v') = v == v'
307 (TyArg ty) `mentions` (TyBinder tv) = tv `elementOfTyVarSet` tyVarsOfType ty
308 bndr `mentions` arg = False
311 = not (VarArg v `mentions` bndr)
312 residual_ok (App fun arg)
313 | arg `mentions` bndr = False
314 | otherwise = residual_ok fun
315 residual_ok (Note (Coerce to_ty from_ty) body)
316 | TyArg to_ty `mentions` bndr
317 || TyArg from_ty `mentions` bndr = False
318 | otherwise = residual_ok body
320 residual_ok other = False -- Safe answer
321 -- This last clause may seem conservative, but consider:
322 -- primops, constructors, and literals, are impossible here
323 -- let and case are unlikely (the argument would have been floated inside)
324 -- SCCs we probably want to be conservative about (not sure, but it's safe to be)
326 etaCoreExpr expr = expr -- The common case
332 @etaExpandCount@ takes an expression, E, and returns an integer n,
335 E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
337 is a safe transformation. In particular, the transformation should
338 not cause work to be duplicated, unless it is ``cheap'' (see
339 @manifestlyCheap@ below).
341 @etaExpandCount@ errs on the conservative side. It is always safe to
344 An application of @error@ is special, because it can absorb as many
345 arguments as you care to give it. For this special case we return
346 100, to represent "infinity", which is a bit of a hack.
349 etaExpandCount :: GenCoreExpr bdr Id flexi
350 -> Int -- Number of extra args you can safely abstract
352 etaExpandCount (Lam (ValBinder _) body)
353 = 1 + etaExpandCount body
355 etaExpandCount (Let bind body)
356 | all manifestlyCheap (rhssOfBind bind)
357 = etaExpandCount body
359 etaExpandCount (Case scrut alts)
360 | manifestlyCheap scrut
361 = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
363 etaExpandCount fun@(Var _) = eta_fun fun
364 etaExpandCount (App fun arg)
365 | notValArg arg = eta_fun fun
366 | otherwise = case etaExpandCount fun of
368 n -> n-1 -- Knock off one
370 etaExpandCount other = 0 -- Give up
373 -- Scc (pessimistic; ToDo),
374 -- Let with non-whnf rhs(s),
375 -- Case with non-whnf scrutinee
377 -----------------------------
378 eta_fun :: GenCoreExpr bdr Id flexi -- The function
379 -> Int -- How many args it can safely be applied to
381 eta_fun (App fun arg) | notValArg arg = eta_fun fun
384 | isBottomingId v -- Bottoming ids have "infinite arity"
385 = 10000 -- Blargh. Infinite enough!
387 eta_fun expr@(Var v) = idMinArity v
389 eta_fun other = 0 -- Give up
392 @manifestlyCheap@ looks at a Core expression and returns \tr{True} if
393 it is obviously in weak head normal form, or is cheap to get to WHNF.
394 By ``cheap'' we mean a computation we're willing to duplicate in order
395 to bring a couple of lambdas together. The main examples of things
396 which aren't WHNF but are ``cheap'' are:
401 where e, and all the ei are cheap; and
406 where e and b are cheap; and
410 where op is a cheap primitive operator
413 manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
415 manifestlyCheap (Var _) = True
416 manifestlyCheap (Lit _) = True
417 manifestlyCheap (Con _ _) = True
418 manifestlyCheap (Note _ e) = manifestlyCheap e
419 manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
420 manifestlyCheap (Prim op _) = primOpIsCheap op
422 manifestlyCheap (Let bind body)
423 = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
425 manifestlyCheap (Case scrut alts)
426 = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
428 manifestlyCheap other_expr -- look for manifest partial application
429 = case (collectArgs other_expr) of { (fun, _, vargs) ->
432 Var f | isBottomingId f -> True -- Application of a function which
433 -- always gives bottom; we treat this as
434 -- a WHNF, because it certainly doesn't
435 -- need to be shared!
438 num_val_args = length vargs
440 num_val_args == 0 || -- Just a type application of
441 -- a variable (f t1 t2 t3)
443 num_val_args < idMinArity f
452 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
454 simplIdWantsToBeINLINEd id env
455 = {- We used to arrange that in the final simplification pass we'd switch
456 off all INLINE pragmas, so that we'd inline workers back into the
457 body of their wrapper if the wrapper hadn't itself been inlined by then.
458 This occurred especially for methods in dictionaries.
460 We no longer do this:
461 a) there's a good chance that the exported wrapper will get
462 inlined in some importing scope, in which case we don't
463 want to lose the w/w idea.
465 b) The occurrence analyser must agree about what has an
466 INLINE pragma. Not hard, but delicate.
468 c) if the worker gets inlined we have to tell the wrapepr
469 that it's no longer a wrapper, else the interface file stuff
470 asks for a worker that no longer exists.
472 if switchIsSet env IgnoreINLINEPragma
477 idWantsToBeINLINEd id
479 idMinArity id = case getIdArity id of
484 singleConstructorType :: Type -> Bool
485 singleConstructorType ty
486 = case (splitAlgTyConApp_maybe ty) of
487 Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
490 typeOkForCase :: Type -> Bool
492 = case (splitAlgTyConApp_maybe ty) of
493 Just (tycon, ty_args, []) -> False
494 Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
496 -- Null data cons => type is abstract, which code gen can't
497 -- currently handle. (ToDo: when return-in-heap is universal we
498 -- don't need to worry about this.)
503 substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv
504 It exploits the known structure of a SpecEnv's RHS to have fewer
508 substSpecEnvRhs te ve rhs
511 go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty))
512 go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of
513 Just (SubstVar v') -> VarArg v'
514 Just (SubstLit l) -> LitArg l
516 go te ve (Var v) = case lookupIdEnv ve v of
517 Just (SubstVar v') -> Var v'
518 Just (SubstLit l) -> Lit l
521 -- These equations are a bit half baked, because
522 -- they don't deal properly wih capture.
523 -- But I'm sure it'll never matter... sigh.
524 go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e)
526 te' = delFromTyVarEnv te tyvar
528 go te ve (Lam b@(ValBinder v) e) = Lam b (go te ve' e)
530 ve' = delOneFromIdEnv ve v