2 % (c) The AQUA Project, Glasgow University, 1993-1996
4 \section[SimplUtils]{The simplifier utilities}
13 etaCoreExpr, mkRhsTyLam,
17 simplIdWantsToBeINLINEd,
19 singleConstructorType, typeOkForCase
22 #include "HsVersions.h"
25 import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
27 import CoreUnfold ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) )
28 import Id ( idType, isBottomingId, mkSysLocal,
29 addInlinePragma, addIdDemandInfo,
30 idWantsToBeINLINEd, dataConArgTys, Id,
33 import IdInfo ( ArityInfo(..), DemandInfo )
34 import Maybes ( maybeToBool )
35 import PrelVals ( augmentId, buildId )
36 import PrimOp ( primOpIsCheap )
39 import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe,
40 splitAlgTyConApp_maybe, Type
42 import TyCon ( isDataTyCon )
43 import TyVar ( elementOfTyVarSet )
44 import SrcLoc ( noSrcLoc )
45 import Util ( isIn, zipWithEqual, panic, assertPanic )
50 %************************************************************************
54 %************************************************************************
57 newId :: Type -> SmplM Id
59 = getUniqueSmpl `thenSmpl` \ uniq ->
60 returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc)
62 newIds :: [Type] -> SmplM [Id]
64 = getUniquesSmpl (length tys) `thenSmpl` \ uniqs ->
65 returnSmpl (zipWithEqual "newIds" mk_id tys uniqs)
67 mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
71 %************************************************************************
75 %************************************************************************
77 The function @floatExposesHNF@ tells whether let/case floating will
78 expose a head normal form. It is passed booleans indicating the
83 :: Bool -- Float let(rec)s out of rhs
84 -> Bool -- Float cheap primops out of rhs
85 -> Bool -- OK to duplicate code
86 -> GenCoreExpr bdr Id flexi
89 floatExposesHNF float_lets float_primops ok_to_dup rhs
92 try (Case (Prim _ _) (PrimAlts alts deflt) )
93 | float_primops && (null alts || ok_to_dup)
94 = or (try_deflt deflt : map try_alt alts)
96 try (Let bind body) | float_lets = try body
100 -- because it *will* become one.
101 -- likewise for `augment g h'
103 try (App (App (Var bld) _) _) | bld == buildId = True
104 try (App (App (App (Var aug) _) _) _) | aug == augmentId = True
106 try other = case mkFormSummary other of
110 {- but *not* necessarily "BottomForm"...
112 We may want to float a let out of a let to expose WHNFs,
113 but to do that to expose a "bottom" is a Bad Idea:
115 in ...error ...y... -- manifestly bottom using y
119 in let x = ...error ...y...
122 as y is only used in case of an error, we do not want
123 to allocate it eagerly as that's a waste.
126 try_alt (lit,rhs) = try rhs
128 try_deflt NoDefault = False
129 try_deflt (BindDefault _ rhs) = try rhs
135 mkRhsTyLam tries this transformation, when the big lambda appears as
136 the RHS of a let(rec) binding:
138 /\abc -> let(rec) x = e in b
140 let(rec) x' = /\abc -> let x = x' a b c in e
142 /\abc -> let x = x' a b c in b
144 This is good because it can turn things like:
146 let f = /\a -> letrec g = ... g ... in g
148 letrec g' = /\a -> ... g' a ...
152 which is better. In effect, it means that big lambdas don't impede
155 This optimisation is CRUCIAL in eliminating the junk introduced by
156 desugaring mutually recursive definitions. Don't eliminate it lightly!
158 So far as the implemtation is concerned:
160 Invariant: go F e = /\tvs -> F e
164 = Let x' = /\tvs -> F e
168 G = F . Let x = x' tvs
170 go F (Letrec xi=ei in b)
171 = Letrec {xi' = /\tvs -> G ei}
175 G = F . Let {xi = xi' tvs}
178 mkRhsTyLam [] body = returnSmpl body
180 mkRhsTyLam tyvars body
183 tyvar_tys = mkTyVarTys tyvars
185 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
186 = go (fn . Let bind) body
188 go fn (Let bind@(NonRec var rhs) body)
189 = mk_poly var `thenSmpl` \ (var', rhs') ->
190 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
191 returnSmpl (Let (NonRec var' (mkTyLam tyvars (fn rhs))) body')
193 go fn (Let (Rec prs) body)
194 = mapAndUnzipSmpl mk_poly vars `thenSmpl` \ (vars', rhss') ->
196 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
198 go gn body `thenSmpl` \ body' ->
199 returnSmpl (Let (Rec (vars' `zip` [mkTyLam tyvars (gn rhs) | rhs <- rhss])) body')
201 (vars,rhss) = unzip prs
203 go fn body = returnSmpl (mkTyLam tyvars (fn body))
206 = newId (mkForAllTys tyvars (idType var)) `thenSmpl` \ poly_id ->
207 returnSmpl (poly_id, mkTyApp (Var poly_id) tyvar_tys)
209 mk_silly_bind var rhs = NonRec (addInlinePragma var) rhs
210 -- The addInlinePragma is really important! If we don't say
211 -- INLINE on these silly little bindings then look what happens!
212 -- Suppose we start with:
214 -- x = let g = /\a -> \x -> f x x
216 -- /\ b -> let g* = g b in E
218 -- Then: * the binding for g gets floated out
219 -- * but then it gets inlined into the rhs of g*
220 -- * then the binding for g* is floated out of the /\b
221 -- * so we're back to square one
222 -- The silly binding for g* must be INLINE, so that no inlining
223 -- will happen in its RHS.
228 @etaCoreExpr@ trys an eta reduction at the top level of a Core Expr.
230 e.g. \ x y -> f x y ===> f
233 a) Before constructing an Unfolding, to
234 try to make the unfolding smaller;
235 b) In tidyCoreExpr, which is done just before converting to STG.
237 But we only do this if it gets rid of a whole lambda, not part.
238 The idea is that lambdas are often quite helpful: they indicate
239 head normal forms, so we don't want to chuck them away lightly.
240 But if they expose a simple variable then we definitely win. Even
241 if they expose a type application we win. So we check for this special
246 f xs = [y | (y,_) <- xs]
248 gives rise to a recursive function for the list comprehension, and
249 f turns out to be just a single call to this recursive function.
251 Doing eta on type lambdas is useful too:
253 /\a -> <expr> a ===> <expr>
255 where <expr> doesn't mention a.
256 This is sometimes quite useful, because we can get the sequence:
258 f ab d = let d1 = ...d... in
259 letrec f' b x = ...d...(f' b)... in
263 f.Int b = letrec f' b x = ...dInt...(f' b)... in
268 f' b x = ...dInt...(f' b)...
271 Now we really want to simplify to
275 and then replace all the f's with f.Ints.
277 N.B. We are careful not to partially eta-reduce a sequence of type
278 applications since this breaks the specialiser:
280 /\ a -> f Char# a =NO=> f Char#
283 etaCoreExpr :: CoreExpr -> CoreExpr
286 etaCoreExpr expr@(Lam bndr body)
288 = case etaCoreExpr body of
289 App fun arg | eta_match bndr arg &&
292 other -> expr -- Can't eliminate it, so do nothing at all
294 eta_match (ValBinder v) (VarArg v') = v == v'
295 eta_match (TyBinder tv) (TyArg ty) = case getTyVar_maybe ty of
297 Just tv' -> tv == tv'
298 eta_match bndr arg = False
300 residual_ok :: CoreExpr -> Bool -- Checks for type application
301 -- and function not one of the
304 (VarArg v) `mentions` (ValBinder v') = v == v'
305 (TyArg ty) `mentions` (TyBinder tv) = tv `elementOfTyVarSet` tyVarsOfType ty
306 bndr `mentions` arg = False
309 = not (VarArg v `mentions` bndr)
310 residual_ok (App fun arg)
311 | arg `mentions` bndr = False
312 | otherwise = residual_ok fun
313 residual_ok (Coerce coercion ty body)
314 | TyArg ty `mentions` bndr = False
315 | otherwise = residual_ok body
317 residual_ok other = False -- Safe answer
318 -- This last clause may seem conservative, but consider:
319 -- primops, constructors, and literals, are impossible here
320 -- let and case are unlikely (the argument would have been floated inside)
321 -- SCCs we probably want to be conservative about (not sure, but it's safe to be)
323 etaCoreExpr expr = expr -- The common case
329 @etaExpandCount@ takes an expression, E, and returns an integer n,
332 E ===> (\x1::t1 x1::t2 ... xn::tn -> E x1 x2 ... xn)
334 is a safe transformation. In particular, the transformation should
335 not cause work to be duplicated, unless it is ``cheap'' (see
336 @manifestlyCheap@ below).
338 @etaExpandCount@ errs on the conservative side. It is always safe to
341 An application of @error@ is special, because it can absorb as many
342 arguments as you care to give it. For this special case we return
343 100, to represent "infinity", which is a bit of a hack.
346 etaExpandCount :: GenCoreExpr bdr Id flexi
347 -> Int -- Number of extra args you can safely abstract
349 etaExpandCount (Lam (ValBinder _) body)
350 = 1 + etaExpandCount body
352 etaExpandCount (Let bind body)
353 | all manifestlyCheap (rhssOfBind bind)
354 = etaExpandCount body
356 etaExpandCount (Case scrut alts)
357 | manifestlyCheap scrut
358 = minimum [etaExpandCount rhs | rhs <- rhssOfAlts alts]
360 etaExpandCount fun@(Var _) = eta_fun fun
361 etaExpandCount (App fun arg)
362 | notValArg arg = eta_fun fun
363 | otherwise = case etaExpandCount fun of
365 n -> n-1 -- Knock off one
367 etaExpandCount other = 0 -- Give up
370 -- Scc (pessimistic; ToDo),
371 -- Let with non-whnf rhs(s),
372 -- Case with non-whnf scrutinee
374 -----------------------------
375 eta_fun :: GenCoreExpr bdr Id flexi -- The function
376 -> Int -- How many args it can safely be applied to
378 eta_fun (App fun arg) | notValArg arg = eta_fun fun
381 | isBottomingId v -- Bottoming ids have "infinite arity"
382 = 10000 -- Blargh. Infinite enough!
384 eta_fun expr@(Var v) = idMinArity v
386 eta_fun other = 0 -- Give up
389 @manifestlyCheap@ looks at a Core expression and returns \tr{True} if
390 it is obviously in weak head normal form, or is cheap to get to WHNF.
391 By ``cheap'' we mean a computation we're willing to duplicate in order
392 to bring a couple of lambdas together. The main examples of things
393 which aren't WHNF but are ``cheap'' are:
398 where e, and all the ei are cheap; and
403 where e and b are cheap; and
407 where op is a cheap primitive operator
410 manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
412 manifestlyCheap (Var _) = True
413 manifestlyCheap (Lit _) = True
414 manifestlyCheap (Con _ _) = True
415 manifestlyCheap (SCC _ e) = manifestlyCheap e
416 manifestlyCheap (Coerce _ _ e) = manifestlyCheap e
417 manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
418 manifestlyCheap (Prim op _) = primOpIsCheap op
420 manifestlyCheap (Let bind body)
421 = manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
423 manifestlyCheap (Case scrut alts)
424 = manifestlyCheap scrut && all manifestlyCheap (rhssOfAlts alts)
426 manifestlyCheap other_expr -- look for manifest partial application
427 = case (collectArgs other_expr) of { (fun, _, vargs) ->
430 Var f | isBottomingId f -> True -- Application of a function which
431 -- always gives bottom; we treat this as
432 -- a WHNF, because it certainly doesn't
433 -- need to be shared!
436 num_val_args = length vargs
438 num_val_args == 0 || -- Just a type application of
439 -- a variable (f t1 t2 t3)
441 num_val_args < idMinArity f
450 simplIdWantsToBeINLINEd :: Id -> SimplEnv -> Bool
452 simplIdWantsToBeINLINEd id env
453 = {- We used to arrange that in the final simplification pass we'd switch
454 off all INLINE pragmas, so that we'd inline workers back into the
455 body of their wrapper if the wrapper hadn't itself been inlined by then.
456 This occurred especially for methods in dictionaries.
458 We no longer do this:
459 a) there's a good chance that the exported wrapper will get
460 inlined in some importing scope, in which case we don't
461 want to lose the w/w idea.
463 b) The occurrence analyser must agree about what has an
464 INLINE pragma. Not hard, but delicate.
466 c) if the worker gets inlined we have to tell the wrapepr
467 that it's no longer a wrapper, else the interface file stuff
468 asks for a worker that no longer exists.
470 if switchIsSet env IgnoreINLINEPragma
475 idWantsToBeINLINEd id
477 idMinArity id = case getIdArity id of
482 singleConstructorType :: Type -> Bool
483 singleConstructorType ty
484 = case (splitAlgTyConApp_maybe ty) of
485 Just (tycon, ty_args, [con]) | isDataTyCon tycon -> True
488 typeOkForCase :: Type -> Bool
490 = case (splitAlgTyConApp_maybe ty) of
491 Just (tycon, ty_args, []) -> False
492 Just (tycon, ty_args, non_null_data_cons) | isDataTyCon tycon -> True
494 -- Null data cons => type is abstract, which code gen can't
495 -- currently handle. (ToDo: when return-in-heap is universal we
496 -- don't need to worry about this.)