2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplUtils]{The simplifier utilities}
7 #include "HsVersions.h"
13 etaCoreExpr, mkRhsTyLam,
17 simplIdWantsToBeINLINEd,
19 singleConstructorType, typeOkForCase
23 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
24 IMPORT_DELOOPER(SmplLoop) -- paranoia checking
28 import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
30 import CoreUnfold ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) )
31 import Id ( idType, isBottomingId, addInlinePragma, addIdDemandInfo,
32 idWantsToBeINLINEd, dataConArgTys, SYN_IE(Id),
33 getIdArity, GenId{-instance Eq-}
35 import IdInfo ( ArityInfo(..), DemandInfo )
36 import Maybes ( maybeToBool )
37 import PrelVals ( augmentId, buildId )
38 import PrimOp ( primOpIsCheap )
41 import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, isPrimType, getTyVar_maybe,
42 maybeAppDataTyConExpandingDicts, SYN_IE(Type)
44 import TyCon ( isDataTyCon )
45 import TyVar ( elementOfTyVarSet,
46 GenTyVar{-instance Eq-} )
47 import Util ( isIn, panic, assertPanic )
54 The function @floatExposesHNF@ tells whether let/case floating will
55 expose a head normal form. It is passed booleans indicating the
60 :: Bool -- Float let(rec)s out of rhs
61 -> Bool -- Float cheap primops out of rhs
62 -> Bool -- OK to duplicate code
63 -> GenCoreExpr bdr Id tyvar uvar
66 floatExposesHNF float_lets float_primops ok_to_dup rhs
69 try (Case (Prim _ _) (PrimAlts alts deflt) )
70 | float_primops && (null alts || ok_to_dup)
71 = or (try_deflt deflt : map try_alt alts)
73 try (Let bind body) | float_lets = try body
77 -- because it *will* become one.
78 -- likewise for `augment g h'
80 try (App (App (Var bld) _) _) | bld == buildId = True
81 try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
83 try other = case mkFormSummary other of
87 {- but *not* necessarily "BottomForm"...
89 We may want to float a let out of a let to expose WHNFs,
90 but to do that to expose a "bottom" is a Bad Idea:
92 in ...error ...y... -- manifestly bottom using y
96 in let x = ...error ...y...
99 as y is only used in case of an error, we do not want
100 to allocate it eagerly as that's a waste.
103 try_alt (lit,rhs) = try rhs
105 try_deflt NoDefault = False
106 try_deflt (BindDefault _ rhs) = try rhs
112 mkRhsTyLam tries this transformation, when the big lambda appears as
113 the RHS of a let(rec) binding:
115 /\abc -> let(rec) x = e in b
117 let(rec) x' = /\abc -> let x = x' a b c in e
119 /\abc -> let x = x' a b c in b
121 This is good because it can turn things like:
123 let f = /\a -> letrec g = ... g ... in g
125 letrec g' = /\a -> ... g' a ...
129 which is better. In effect, it means that big lambdas don't impede
132 This optimisation is CRUCIAL in eliminating the junk introduced by
133 desugaring mutually recursive definitions. Don't eliminate it lightly!
135 So far as the implemtation is concerned:
137 Invariant: go F e = /\tvs -> F e
141 = Let x' = /\tvs -> F e
145 G = F . Let x = x' tvs
147 go F (Letrec xi=ei in b)
148 = Letrec {xi' = /\tvs -> G ei}
152 G = F . Let {xi = xi' tvs}
155 mkRhsTyLam [] body = returnSmpl body
157 mkRhsTyLam tyvars body
160 tyvar_tys = mkTyVarTys tyvars
162 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
163 = go (fn . Let bind) body
165 go fn (Let bind@(NonRec var rhs) body)
166 = mk_poly var `thenSmpl` \ (var', rhs') ->
167 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
168 returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body')
170 go fn (Let (Rec prs) body)
171 = mapAndUnzipSmpl mk_poly vars `thenSmpl` \ (vars', rhss') ->
173 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
175 go gn body `thenSmpl` \ body' ->
176 returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body')
178 (vars,rhss) = unzip prs
180 go fn body = returnSmpl (mkTyLam tyvars (fn body))
183 = newId (mkForAllTys tyvars (idType var)) `thenSmpl` \ poly_id ->
184 returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys)
186 mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
187 -- The addInlinePragma is really important! If we don't say
188 -- INLINE on these silly little bindings then look what happens!
189 -- Suppose we start with:
191 -- x = let g = /\a -> \x -> f x x
193 -- /\ b -> let g* = g b in E
195 -- Then: * the binding for g gets floated out
196 -- * but then it gets inlined into the rhs of g*
197 -- * then the binding for g* is floated out of the /\b
198 -- * so we're back to square one
199 -- The silly binding for g* must be INLINE, so that no inlining
200 -- will happen in its RHS.
205 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
207 e.g. \ x y -> f x y ===> f
210 a) Before constructing an Unfolding, to
211 try to make the unfolding smaller;
212 b) In tidyCoreExpr, which is done just before converting to STG.
214 But we only do this if it gets rid of a whole lambda, not part.
215 The idea is that lambdas are often quite helpful: they indicate
216 head normal forms, so we don't want to chuck them away lightly.
217 But if they expose a simple variable then we definitely win. Even
218 if they expose a type application we win. So we check for this special
223 f xs = [y | (y,_) <- xs]
225 gives rise to a recursive function for the list comprehension, and
226 f turns out to be just a single call to this recursive function.
228 Doing eta on type lambdas is useful too:
230 /\a -> <expr> a ===> <expr>
232 where <expr> doesn't mention a.
233 This is sometimes quite useful, because we can get the sequence:
235 f ab d = let d1 = ...d... in
236 letrec f' b x = ...d...(f' b)... in
240 f.Int b = letrec f' b x = ...dInt...(f' b)... in
245 f' b x = ...dInt...(f' b)...
248 Now we really want to simplify to
252 and then replace all the f's with f.Ints.
254 N.B. We are careful not to partially eta-reduce a sequence of type
255 applications since this breaks the specialiser:
257 /\ a -> f Char# a =NO=> f Char#
260 etaCoreExpr :: CoreExpr -> CoreExpr
263 etaCoreExpr expr@(Lam bndr body)
265 = case etaCoreExpr body of
266 App fun arg | eta_match bndr arg &&
269 other -> expr -- Can't eliminate it, so do nothing at all
271 eta_match (ValBinder v) (VarArg v') = v == v'
272 eta_match (TyBinder tv) (TyArg ty) = case getTyVar_maybe ty of
274 Just tv' -> tv == tv'
275 eta_match bndr arg = False
277 residual_ok :: CoreExpr -> Bool -- Checks for type application
278 -- and function not one of the
281 (VarArg v) `mentions` (ValBinder v') = v == v'
282 (TyArg ty) `mentions` (TyBinder tv) = tv `elementOfTyVarSet` tyVarsOfType ty
283 bndr `mentions` arg = False
286 = not (VarArg v `mentions` bndr)
287 residual_ok (App fun arg)
288 | arg `mentions` bndr = False
289 | otherwise = residual_ok fun
290 residual_ok (Coerce coercion ty body)
291 | TyArg ty `mentions` bndr = False
292 | otherwise = residual_ok body
294 residual_ok other = False -- Safe answer
295 -- This last clause may seem conservative, but consider:
296 -- primops, constructors, and literals, are impossible here
297 -- let and case are unlikely (the argument would have been floated inside)
298 -- SCCs we probably want to be conservative about (not sure, but it's safe to be)
300 etaCoreExpr expr = expr -- The common case
306 @etaExpandCount@ takes an expression, E, and returns an integer n,
309 E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
311 is a safe transformation. In particular, the transformation should
312 not cause work to be duplicated, unless it is ``cheap'' (see
313 @manifestlyCheap@ below).
315 @etaExpandCount@ errs on the conservative side. It is always safe to
318 An application of @error@ is special, because it can absorb as many
319 arguments as you care to give it. For this special case we return
320 100, to represent "infinity", which is a bit of a hack.
323 etaExpandCount :: GenCoreExpr bdr Id tyvar uvar
324 -> Int -- Number of extra args you can safely abstract
326 etaExpandCount (Lam (ValBinder _) body)
327 = 1 + etaExpandCount body
329 etaExpandCount (Let bind body)
330 | all manifestlyCheap (rhssOfBind bind)
331 = etaExpandCount body
333 etaExpandCount (Case scrut alts)
334 | manifestlyCheap scrut
335 = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
337 etaExpandCount fun@(Var _) = eta_fun fun
338 etaExpandCount (App fun arg)
339 | notValArg arg = eta_fun fun
340 | otherwise = case etaExpandCount fun of
342 n -> n-1 -- Knock off one
344 etaExpandCount other = 0 -- Give up
347 -- Scc (pessimistic; ToDo),
348 -- Let with non-whnf rhs(s),
349 -- Case with non-whnf scrutinee
351 -----------------------------
352 eta_fun :: GenCoreExpr bdr Id tv uv -- The function
353 -> Int -- How many args it can safely be applied to
355 eta_fun (App fun arg) | notValArg arg = eta_fun fun
358 | isBottomingId v -- Bottoming ids have "infinite arity"
359 = 10000 -- Blargh. Infinite enough!
361 eta_fun expr@(Var v) = idMinArity v
363 eta_fun other = 0 -- Give up
366 @manifestlyCheap@ looks at a Core expression and returns \tr{True} if
367 it is obviously in weak head normal form, or is cheap to get to WHNF.
368 By ``cheap'' we mean a computation we're willing to duplicate in order
369 to bring a couple of lambdas together. The main examples of things
370 which aren't WHNF but are ``cheap'' are:
375 where e, and all the ei are cheap; and
380 where e and b are cheap; and
384 where op is a cheap primitive operator
387 manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool
389 manifestlyCheap (Var _) = True
390 manifestlyCheap (Lit _) = True
391 manifestlyCheap (Con _ _) = True
392 manifestlyCheap (SCC _ e) = manifestlyCheap e
393 manifestlyCheap (Coerce _ _ e) = manifestlyCheap e
394 manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
395 manifestlyCheap (Prim op _) = primOpIsCheap op
397 manifestlyCheap (Let bind body)
398 = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
400 manifestlyCheap (Case scrut alts)
401 = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
403 manifestlyCheap other_expr -- look for manifest partial application
404 = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
407 Var f | isBottomingId f -> True -- Application of a function which
408 -- always gives bottom; we treat this as
409 -- a WHNF, because it certainly doesn't
410 -- need to be shared!
413 num_val_args = length vargs
415 num_val_args == 0 || -- Just a type application of
416 -- a variable (f t1 t2 t3)
418 num_val_args < idMinArity f
427 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
429 simplIdWantsToBeINLINEd id env
430 = {- We used to arrange that in the final simplification pass we'd switch
431 off all INLINE pragmas, so that we'd inline workers back into the
432 body of their wrapper if the wrapper hadn't itself been inlined by then.
433 This occurred especially for methods in dictionaries.
435 We no longer do this:
436 a) there's a good chance that the exported wrapper will get
437 inlined in some importing scope, in which case we don't
438 want to lose the w/w idea.
440 b) The occurrence analyser must agree about what has an
441 INLINE pragma. Not hard, but delicate.
443 c) if the worker gets inlined we have to tell the wrapepr
444 that it's no longer a wrapper, else the interface file stuff
445 asks for a worker that no longer exists.
447 if switchIsSet env IgnoreINLINEPragma
452 idWantsToBeINLINEd id
454 idMinArity id = case getIdArity id of
459 singleConstructorType :: Type -> Bool
460 singleConstructorType ty
461 = case (maybeAppDataTyConExpandingDicts ty) of
462 Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
465 typeOkForCase :: Type -> Bool
467 = case (maybeAppDataTyConExpandingDicts ty) of
468 Just (tycon, ty_args, []) -> False
469 Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
471 -- Null data cons => type is abstract, which code gen can't
472 -- currently handle. (ToDo: when return-in-heap is universal we
473 -- don't need to worry about this.)