2 % (c) The AQUA Project, Glasgow University, 1993-1998
4 \section[SimplUtils]{The simplifier utilities}
8 simplBinder, simplBinders, simplIds,
10 mkCase, findAlt, findDefault,
12 -- The continuation type
13 SimplCont(..), DupFlag(..), contIsDupable, contResultType,
14 countValArgs, countArgs, mkRhsStop, mkStop,
15 getContArgs, interestingCallContext, interestingArg, isStrictType, discardInline
19 #include "HsVersions.h"
21 import CmdLineOpts ( switchIsOn, SimplifierSwitch(..),
22 opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict
25 import CoreUnfold ( isValueUnfolding )
26 import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
27 import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
28 import Id ( Id, idType, isId, idName,
29 idOccInfo, idUnfolding, idStrictness,
32 import IdInfo ( StrictnessInfo(..), arityLowerBound, setOccInfo, vanillaIdInfo )
33 import Maybes ( maybeToBool, catMaybes )
34 import Name ( isLocalName, setNameUnique )
35 import Demand ( Demand, isStrict, wwLazy, wwLazy )
37 import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
38 splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys,
39 isDictTy, isDataType, applyTy, splitFunTy, isUnLiftedType,
42 import TyCon ( tyConDataConsIfAvailable )
43 import DataCon ( dataConRepArity )
45 import VarEnv ( SubstEnv, SubstResult(..) )
46 import Util ( lengthExceeds )
47 import BasicTypes ( Arity )
52 %************************************************************************
54 \subsection{The continuation data type}
56 %************************************************************************
59 data SimplCont -- Strict contexts
60 = Stop OutType -- Type of the result
61 Bool -- True => This is the RHS of a thunk whose type suggests
62 -- that update-in-place would be possible
63 -- (This makes the inliner a little keener.)
65 | CoerceIt OutType -- The To-type, simplified
68 | InlinePlease -- This continuation makes a function very
69 SimplCont -- keen to inline itelf
72 InExpr SubstEnv -- The argument, as yet unsimplified,
73 SimplCont -- and its subst-env
76 InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
79 | ArgOf DupFlag -- An arbitrary strict context: the argument
80 -- of a strict function, or a primitive-arg fn
82 OutType -- cont_ty: the type of the expression being sought by the context
83 -- f (error "foo") ==> coerce t (error "foo")
85 -- We need to know the type t, to which to coerce.
86 (OutExpr -> SimplM OutExprStuff) -- What to do with the result
87 -- The result expression in the OutExprStuff has type cont_ty
89 instance Outputable SimplCont where
90 ppr (Stop _ _) = ptext SLIT("Stop")
91 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
92 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
93 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
94 (nest 4 (ppr alts)) $$ ppr cont
95 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
96 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
98 data DupFlag = OkToDup | NoDup
100 instance Outputable DupFlag where
101 ppr OkToDup = ptext SLIT("ok")
102 ppr NoDup = ptext SLIT("nodup")
106 mkRhsStop, mkStop :: OutType -> SimplCont
107 mkStop ty = Stop ty False
108 mkRhsStop ty = Stop ty (canUpdateInPlace ty)
112 contIsDupable :: SimplCont -> Bool
113 contIsDupable (Stop _ _) = True
114 contIsDupable (ApplyTo OkToDup _ _ _) = True
115 contIsDupable (ArgOf OkToDup _ _) = True
116 contIsDupable (Select OkToDup _ _ _ _) = True
117 contIsDupable (CoerceIt _ cont) = contIsDupable cont
118 contIsDupable (InlinePlease cont) = contIsDupable cont
119 contIsDupable other = False
122 discardInline :: SimplCont -> SimplCont
123 discardInline (InlinePlease cont) = cont
124 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
125 discardInline cont = cont
128 discardableCont :: SimplCont -> Bool
129 discardableCont (Stop _ _) = False
130 discardableCont (CoerceIt _ cont) = discardableCont cont
131 discardableCont (InlinePlease cont) = discardableCont cont
132 discardableCont other = True
134 discardCont :: SimplCont -- A continuation, expecting
135 -> SimplCont -- Replace the continuation with a suitable coerce
136 discardCont cont = case cont of
138 other -> CoerceIt to_ty (mkStop to_ty)
140 to_ty = contResultType cont
143 contResultType :: SimplCont -> OutType
144 contResultType (Stop to_ty _) = to_ty
145 contResultType (ArgOf _ to_ty _) = to_ty
146 contResultType (ApplyTo _ _ _ cont) = contResultType cont
147 contResultType (CoerceIt _ cont) = contResultType cont
148 contResultType (InlinePlease cont) = contResultType cont
149 contResultType (Select _ _ _ _ cont) = contResultType cont
152 countValArgs :: SimplCont -> Int
153 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
154 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
155 countValArgs other = 0
157 countArgs :: SimplCont -> Int
158 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
164 getContArgs :: OutId -> SimplCont
165 -> SimplM ([(InExpr, SubstEnv, Bool)], -- Arguments; the Bool is true for strict args
166 SimplCont, -- Remaining continuation
167 Bool) -- Whether we came across an InlineCall
168 -- getContArgs id k = (args, k', inl)
169 -- args are the leading ApplyTo items in k
170 -- (i.e. outermost comes first)
171 -- augmented with demand info from the functionn
172 getContArgs fun orig_cont
173 = getSwitchChecker `thenSmpl` \ chkr ->
175 -- Ignore strictness info if the no-case-of-case
176 -- flag is on. Strictness changes evaluation order
177 -- and that can change full laziness
178 stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
179 | otherwise = computed_stricts
181 go [] stricts False orig_cont
183 ----------------------------
186 go acc ss inl (ApplyTo _ arg@(Type _) se cont)
187 = go ((arg,se,False) : acc) ss inl cont
188 -- NB: don't bother to instantiate the function type
191 go acc (s:ss) inl (ApplyTo _ arg se cont)
192 = go ((arg,se,s) : acc) ss inl cont
194 -- An Inline continuation
195 go acc ss inl (InlinePlease cont)
196 = go acc ss True cont
198 -- We're run out of arguments, or else we've run out of demands
199 -- The latter only happens if the result is guaranteed bottom
200 -- This is the case for
201 -- * case (error "hello") of { ... }
202 -- * (error "Hello") arg
203 -- * f (error "Hello") where f is strict
206 | null ss && discardableCont cont = tick BottomFound `thenSmpl_`
207 returnSmpl (reverse acc, discardCont cont, inl)
208 | otherwise = returnSmpl (reverse acc, cont, inl)
210 ----------------------------
211 vanilla_stricts, computed_stricts :: [Bool]
212 vanilla_stricts = repeat False
213 computed_stricts = zipWith (||) fun_stricts arg_stricts
215 ----------------------------
216 (val_arg_tys, _) = splitRepFunTys (idType fun)
217 arg_stricts = map isStrictType val_arg_tys ++ repeat False
218 -- These argument types are used as a cheap and cheerful way to find
219 -- unboxed arguments, which must be strict. But it's an InType
220 -- and so there might be a type variable where we expect a function
221 -- type (the substitution hasn't happened yet). And we don't bother
222 -- doing the type applications for a polymorphic function.
223 -- Hence the split*Rep*FunTys
225 ----------------------------
226 -- If fun_stricts is finite, it means the function returns bottom
227 -- after that number of value args have been consumed
228 -- Otherwise it's infinite, extended with False
230 = case idStrictness fun of
231 StrictnessInfo demands result_bot
232 | not (demands `lengthExceeds` countValArgs orig_cont)
233 -> -- Enough args, use the strictness given.
234 -- For bottoming functions we used to pretend that the arg
235 -- is lazy, so that we don't treat the arg as an
236 -- interesting context. This avoids substituting
237 -- top-level bindings for (say) strings into
238 -- calls to error. But now we are more careful about
239 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
241 map isStrict demands -- Finite => result is bottom
243 map isStrict demands ++ vanilla_stricts
245 other -> vanilla_stricts -- Not enough args, or no strictness
249 isStrictType :: Type -> Bool
250 -- isStrictType computes whether an argument (or let RHS) should
251 -- be computed strictly or lazily, based only on its type
253 | isUnLiftedType ty = True
254 | opt_DictsStrict && isDictTy ty && isDataType ty = True
256 -- Return true only for dictionary types where the dictionary
257 -- has more than one component (else we risk poking on the component
258 -- of a newtype dictionary)
261 interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
262 -- An argument is interesting if it has *some* structure
263 -- We are here trying to avoid unfolding a function that
264 -- is applied only to variables that have no unfolding
265 -- (i.e. they are probably lambda bound): f x y z
266 -- There is little point in inlining f here.
267 interestingArg in_scope arg subst
271 = case lookupIdSubst (mkSubst in_scope subst) v of
272 ContEx subst arg -> interestingArg in_scope arg subst
273 DoneEx arg -> analyse arg
274 DoneId v' _ -> hasSomeUnfolding (idUnfolding v')
275 -- Was: isValueUnfolding (idUnfolding v')
276 -- But that seems over-pessimistic
278 -- NB: it's too pessimistic to return False for ContEx/DoneEx
279 -- Consider let x = 3 in f x
280 -- The substitution will contain (x -> ContEx 3)
281 -- It's also too optimistic to return True for the ContEx/DoneEx case
282 -- Consider (\x. f x y) y
283 -- The substitution will contain (x -> ContEx y).
285 analyse (Type _) = False
286 analyse (App fn (Type _)) = analyse fn
287 analyse (Note _ a) = analyse a
291 Comment about interestingCallContext
292 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
293 We want to avoid inlining an expression where there can't possibly be
294 any gain, such as in an argument position. Hence, if the continuation
295 is interesting (eg. a case scrutinee, application etc.) then we
296 inline, otherwise we don't.
298 Previously some_benefit used to return True only if the variable was
299 applied to some value arguments. This didn't work:
301 let x = _coerce_ (T Int) Int (I# 3) in
302 case _coerce_ Int (T Int) x of
305 we want to inline x, but can't see that it's a constructor in a case
306 scrutinee position, and some_benefit is False.
310 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
312 .... case dMonadST _@_ x0 of (a,b,c) -> ....
314 we'd really like to inline dMonadST here, but we *don't* want to
315 inline if the case expression is just
317 case x of y { DEFAULT -> ... }
319 since we can just eliminate this case instead (x is in WHNF). Similar
320 applies when x is bound to a lambda expression. Hence
321 contIsInteresting looks for case expressions with just a single
325 interestingCallContext :: Bool -- False <=> no args at all
326 -> Bool -- False <=> no value args
328 -- The "lone-variable" case is important. I spent ages
329 -- messing about with unsatisfactory varaints, but this is nice.
330 -- The idea is that if a variable appear all alone
331 -- as an arg of lazy fn, or rhs Stop
332 -- as scrutinee of a case Select
333 -- as arg of a strict fn ArgOf
334 -- then we should not inline it (unless there is some other reason,
335 -- e.g. is is the sole occurrence). We achieve this by making
336 -- interestingCallContext return False for a lone variable.
338 -- Why? At least in the case-scrutinee situation, turning
339 -- let x = (a,b) in case x of y -> ...
341 -- let x = (a,b) in case (a,b) of y -> ...
343 -- let x = (a,b) in let y = (a,b) in ...
344 -- is bad if the binding for x will remain.
346 -- Another example: I discovered that strings
347 -- were getting inlined straight back into applications of 'error'
348 -- because the latter is strict.
350 -- f = \x -> ...(error s)...
352 -- Fundamentally such contexts should not ecourage inlining becuase
353 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
354 -- so there's no gain.
356 -- However, even a type application or coercion isn't a lone variable.
358 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
359 -- We had better inline that sucker! The case won't see through it.
361 -- For now, I'm treating treating a variable applied to types
362 -- in a *lazy* context "lone". The motivating example was
364 -- g = /\a. \y. h (f a)
365 -- There's no advantage in inlining f here, and perhaps
366 -- a significant disadvantage. Hence some_val_args in the Stop case
368 interestingCallContext some_args some_val_args cont
371 interesting (InlinePlease _) = True
372 interesting (Select _ _ _ _ _) = some_args
373 interesting (ApplyTo _ _ _ _) = some_args -- Can happen if we have (coerce t (f x)) y
374 interesting (ArgOf _ _ _) = some_val_args
375 interesting (Stop ty upd_in_place) = some_val_args && upd_in_place
376 interesting (CoerceIt _ cont) = interesting cont
377 -- If this call is the arg of a strict function, the context
378 -- is a bit interesting. If we inline here, we may get useful
379 -- evaluation information to avoid repeated evals: e.g.
381 -- Here the contIsInteresting makes the '*' keener to inline,
382 -- which in turn exposes a constructor which makes the '+' inline.
383 -- Assuming that +,* aren't small enough to inline regardless.
385 -- It's also very important to inline in a strict context for things
388 -- Here, the context of (f x) is strict, and if f's unfolding is
389 -- a build it's *great* to inline it here. So we must ensure that
390 -- the context for (f x) is not totally uninteresting.
394 canUpdateInPlace :: Type -> Bool
395 -- Consider let x = <wurble> in ...
396 -- If <wurble> returns an explicit constructor, we might be able
397 -- to do update in place. So we treat even a thunk RHS context
398 -- as interesting if update in place is possible. We approximate
399 -- this by seeing if the type has a single constructor with a
400 -- small arity. But arity zero isn't good -- we share the single copy
401 -- for that case, so no point in sharing.
403 -- Note the repType: we want to look through newtypes for this purpose
405 canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of {
409 case tyConDataConsIfAvailable tycon of
410 [dc] -> arity == 1 || arity == 2
412 arity = dataConRepArity dc
419 %************************************************************************
421 \section{Dealing with a single binder}
423 %************************************************************************
426 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
427 simplBinders bndrs thing_inside
428 = getSubst `thenSmpl` \ subst ->
430 (subst', bndrs') = substBndrs subst bndrs
432 seqBndrs bndrs' `seq`
433 setSubst subst' (thing_inside bndrs')
435 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
436 simplBinder bndr thing_inside
437 = getSubst `thenSmpl` \ subst ->
439 (subst', bndr') = substBndr subst bndr
442 setSubst subst' (thing_inside bndr')
445 -- Same semantics as simplBinders, but a little less
446 -- plumbing and hence a little more efficient.
447 -- Maybe not worth the candle?
448 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
449 simplIds ids thing_inside
450 = getSubst `thenSmpl` \ subst ->
452 (subst', bndrs') = substIds subst ids
454 seqBndrs bndrs' `seq`
455 setSubst subst' (thing_inside bndrs')
458 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
460 seqBndr b | isTyVar b = b `seq` ()
461 | otherwise = seqType (idType b) `seq`
467 %************************************************************************
469 \subsection{Transform a RHS}
471 %************************************************************************
473 Try (a) eta expansion
474 (b) type-lambda swizzling
477 transformRhs :: OutExpr
478 -> (Arity -> OutExpr -> SimplM (OutStuff a))
479 -> SimplM (OutStuff a)
481 transformRhs rhs thing_inside
482 = tryRhsTyLam rhs $ \ rhs1 ->
483 tryEtaExpansion rhs1 thing_inside
487 %************************************************************************
489 \subsection{Local tyvar-lifting}
491 %************************************************************************
493 mkRhsTyLam tries this transformation, when the big lambda appears as
494 the RHS of a let(rec) binding:
496 /\abc -> let(rec) x = e in b
498 let(rec) x' = /\abc -> let x = x' a b c in e
500 /\abc -> let x = x' a b c in b
502 This is good because it can turn things like:
504 let f = /\a -> letrec g = ... g ... in g
506 letrec g' = /\a -> ... g' a ...
510 which is better. In effect, it means that big lambdas don't impede
513 This optimisation is CRUCIAL in eliminating the junk introduced by
514 desugaring mutually recursive definitions. Don't eliminate it lightly!
516 So far as the implementation is concerned:
518 Invariant: go F e = /\tvs -> F e
522 = Let x' = /\tvs -> F e
526 G = F . Let x = x' tvs
528 go F (Letrec xi=ei in b)
529 = Letrec {xi' = /\tvs -> G ei}
533 G = F . Let {xi = xi' tvs}
535 [May 1999] If we do this transformation *regardless* then we can
536 end up with some pretty silly stuff. For example,
539 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
544 st = /\s -> ...[y1 s/x1, y2 s/x2]
547 Unless the "..." is a WHNF there is really no point in doing this.
548 Indeed it can make things worse. Suppose x1 is used strictly,
551 x1* = case f y of { (a,b) -> e }
553 If we abstract this wrt the tyvar we then can't do the case inline
554 as we would normally do.
558 tryRhsTyLam rhs thing_inside -- Only does something if there's a let
559 | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that
562 = go (\x -> x) body $ \ body' ->
563 thing_inside (mkLams tyvars body')
566 (tyvars, body) = collectTyBinders rhs
568 worth_it (Let _ e) = whnf_in_middle e
569 worth_it other = False
570 whnf_in_middle (Let _ e) = whnf_in_middle e
571 whnf_in_middle e = exprIsCheap e
574 go fn (Let bind@(NonRec var rhs) body) thing_inside
576 = go (fn . Let bind) body thing_inside
578 go fn (Let bind@(NonRec var rhs) body) thing_inside
579 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
580 addAuxiliaryBind (NonRec var' (mkLams tyvars_here (fn rhs))) $
581 go (fn . Let (mk_silly_bind var rhs')) body thing_inside
585 -- main_tyvar_set = mkVarSet tyvars
586 -- var_ty = idType var
587 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
588 -- tyvars_here was an attempt to reduce the number of tyvars
589 -- wrt which the new binding is abstracted. But the naive
590 -- approach of abstract wrt the tyvars free in the Id's type
592 -- /\ a b -> let t :: (a,b) = (e1, e2)
595 -- Here, b isn't free in x's type, but we must nevertheless
596 -- abstract wrt b as well, because t's type mentions b.
597 -- Since t is floated too, we'd end up with the bogus:
598 -- poly_t = /\ a b -> (e1, e2)
599 -- poly_x = /\ a -> fst (poly_t a *b*)
600 -- So for now we adopt the even more naive approach of
601 -- abstracting wrt *all* the tyvars. We'll see if that
602 -- gives rise to problems. SLPJ June 98
604 go fn (Let (Rec prs) body) thing_inside
605 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
607 gn body = fn (foldr Let body (zipWith mk_silly_bind vars rhss'))
609 addAuxiliaryBind (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) $
610 go gn body thing_inside
612 (vars,rhss) = unzip prs
614 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
615 -- var_tys = map idType vars
616 -- See notes with tyvars_here above
619 go fn body thing_inside = thing_inside (fn body)
621 mk_poly tyvars_here var
622 = getUniqueSmpl `thenSmpl` \ uniq ->
624 poly_name = setNameUnique (idName var) uniq -- Keep same name
625 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
626 poly_id = mkId poly_name poly_ty vanillaIdInfo
628 -- In the olden days, it was crucial to copy the occInfo of the original var,
629 -- because we were looking at occurrence-analysed but as yet unsimplified code!
630 -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking
631 -- at already simplified code, so it doesn't matter
633 -- It's even right to retain single-occurrence or dead-var info:
634 -- Suppose we started with /\a -> let x = E in B
635 -- where x occurs once in B. Then we transform to:
636 -- let x' = /\a -> E in /\a -> let x* = x' a in B
637 -- where x* has an INLINE prag on it. Now, once x* is inlined,
638 -- the occurrences of x' will be just the occurrences originally
640 -- poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
642 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
644 mk_silly_bind var rhs = NonRec var rhs
645 -- Suppose we start with:
647 -- x = let g = /\a -> \x -> f x x
649 -- /\ b -> let g* = g b in E
651 -- Then: * the binding for g gets floated out
652 -- * but then it MIGHT get inlined into the rhs of g*
653 -- * then the binding for g* is floated out of the /\b
654 -- * so we're back to square one
655 -- We rely on the simplifier not to inline g into the RHS of g*,
656 -- because it's a "lone" occurrence, and there is no benefit in
657 -- inlining. But it's a slightly delicate property; hence this comment
661 %************************************************************************
663 \subsection{Eta expansion}
665 %************************************************************************
667 Try eta expansion for RHSs
670 Case 1 f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym
673 Case 2 f = N E1..En ==> z1=E1
676 f = \y1..ym -> N z1..zn y1..ym
678 where (in both cases)
680 * The xi can include type variables
682 * The yi are all value variables
684 * N is a NORMAL FORM (i.e. no redexes anywhere)
685 wanting a suitable number of extra args.
687 * the Ei must not have unlifted type
689 There is no point in looking for a combination of the two, because
690 that would leave use with some lets sandwiched between lambdas; that's
691 what the final test in the first equation is for.
694 tryEtaExpansion :: OutExpr
695 -> (Arity -> OutExpr -> SimplM (OutStuff a))
696 -> SimplM (OutStuff a)
697 tryEtaExpansion rhs thing_inside
698 | not opt_SimplDoLambdaEtaExpansion
699 || null y_tys -- No useful expansion
700 || not (is_case1 || is_case2) -- Neither case matches
701 = thing_inside final_arity rhs -- So, no eta expansion, but
702 -- return a good arity
705 = make_y_bndrs $ \ y_bndrs ->
706 thing_inside final_arity
707 (mkLams x_bndrs $ mkLams y_bndrs $
708 mkApps body (map Var y_bndrs))
710 | otherwise -- Must be case 2
711 = mapAndUnzipSmpl bind_z_arg arg_infos `thenSmpl` \ (maybe_z_binds, z_args) ->
712 addAuxiliaryBinds (catMaybes maybe_z_binds) $
713 make_y_bndrs $ \ y_bndrs ->
714 thing_inside final_arity
716 mkApps (mkApps fun z_args) (map Var y_bndrs))
718 all_trivial_args = all is_trivial arg_infos
719 is_case1 = all_trivial_args
720 is_case2 = null x_bndrs && not (any unlifted_non_trivial arg_infos)
722 (x_bndrs, body) = collectBinders rhs -- NB: x_bndrs can include type variables
723 x_arity = valBndrCount x_bndrs
725 (fun, args) = collectArgs body
726 arg_infos = [(arg, exprType arg, exprIsTrivial arg) | arg <- args]
728 is_trivial (_, _, triv) = triv
729 unlifted_non_trivial (_, ty, triv) = not triv && isUnLiftedType ty
731 fun_arity = exprEtaExpandArity fun
733 final_arity | all_trivial_args = x_arity + extra_args_wanted
734 | otherwise = x_arity
735 -- Arity can be more than the number of lambdas
736 -- because of coerces. E.g. \x -> coerce t (\y -> e)
737 -- will have arity at least 2
738 -- The worker/wrapper pass will bring the coerce out to the top
740 bind_z_arg (arg, arg_ty, trivial_arg)
741 | trivial_arg = returnSmpl (Nothing, arg)
742 | otherwise = newId SLIT("z") arg_ty $ \ z ->
743 returnSmpl (Just (NonRec z arg), Var z)
745 make_y_bndrs thing_inside
746 = ASSERT( not (exprIsTrivial rhs) )
747 newIds SLIT("y") y_tys $ \ y_bndrs ->
748 tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
751 (potential_extra_arg_tys, _) = splitFunTys (exprType body)
754 y_tys = take extra_args_wanted potential_extra_arg_tys
756 extra_args_wanted :: Int -- Number of extra args we want
757 extra_args_wanted = 0 `max` (fun_arity - valArgCount args)
759 -- We used to expand the arity to the previous arity fo the
760 -- function; but this is pretty dangerous. Consdier
762 -- so that f has arity 2. Now float something into f's RHS:
763 -- f = let z = BIG in \xy -> e
764 -- The last thing we want to do now is to put some lambdas
766 -- f = \xy -> let z = BIG in e
768 -- (bndr_arity - no_of_xs) `max`
772 %************************************************************************
774 \subsection{Case absorption and identity-case elimination}
776 %************************************************************************
779 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
782 @mkCase@ tries the following transformation (if possible):
784 case e of b { ==> case e of b {
785 p1 -> rhs1 p1 -> rhs1
787 pm -> rhsm pm -> rhsm
788 _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn}
789 {or (prim) case b of b' { _ -> rhsn}}
792 po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd}
796 which merges two cases in one case when -- the default alternative of
797 the outer case scrutises the same variable as the outer case This
798 transformation is called Case Merging. It avoids that the same
799 variable is scrutinised multiple times.
802 mkCase scrut outer_bndr outer_alts
804 && maybeToBool maybe_case_in_default
806 = tick (CaseMerge outer_bndr) `thenSmpl_`
807 returnSmpl (Case scrut outer_bndr new_alts)
808 -- Warning: don't call mkCase recursively!
809 -- Firstly, there's no point, because inner alts have already had
810 -- mkCase applied to them, so they won't have a case in their default
811 -- Secondly, if you do, you get an infinite loop, because the bindNonRec
812 -- in munge_rhs puts a case into the DEFAULT branch!
814 new_alts = outer_alts_without_deflt ++ munged_inner_alts
815 maybe_case_in_default = case findDefault outer_alts of
816 (outer_alts_without_default,
817 Just (Case (Var scrut_var) inner_bndr inner_alts))
819 | outer_bndr == scrut_var
820 -> Just (outer_alts_without_default, inner_bndr, inner_alts)
823 Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
825 -- Eliminate any inner alts which are shadowed by the outer ones
826 outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
828 munged_inner_alts = [ (con, args, munge_rhs rhs)
829 | (con, args, rhs) <- inner_alts,
830 not (con `elem` outer_cons) -- Eliminate shadowed inner alts
832 munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
835 Now the identity-case transformation:
844 mkCase scrut case_bndr alts
845 | all identity_alt alts
846 = tick (CaseIdentity case_bndr) `thenSmpl_`
849 identity_alt (DEFAULT, [], Var v) = v == case_bndr
850 identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
851 (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
852 identity_alt other = False
854 arg_tys = case splitTyConApp_maybe (idType case_bndr) of
855 Just (tycon, arg_tys) -> arg_tys
861 mkCase other_scrut case_bndr other_alts
862 = returnSmpl (Case other_scrut case_bndr other_alts)
867 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
868 findDefault [] = ([], Nothing)
869 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
871 findDefault (alt : alts) = case findDefault alts of
872 (alts', deflt) -> (alt : alts', deflt)
874 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
878 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
879 go (alt : alts) | matches alt = alt
880 | otherwise = go alts
882 matches (DEFAULT, _, _) = True
883 matches (con1, _, _) = con == con1