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,
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 )
51 %************************************************************************
53 \subsection{The continuation data type}
55 %************************************************************************
58 data SimplCont -- Strict contexts
59 = Stop OutType -- Type of the result
61 | CoerceIt OutType -- The To-type, simplified
64 | InlinePlease -- This continuation makes a function very
65 SimplCont -- keen to inline itelf
68 InExpr SubstEnv -- The argument, as yet unsimplified,
69 SimplCont -- and its subst-env
72 InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
75 | ArgOf DupFlag -- An arbitrary strict context: the argument
76 -- of a strict function, or a primitive-arg fn
78 OutType -- cont_ty: the type of the expression being sought by the context
79 -- f (error "foo") ==> coerce t (error "foo")
81 -- We need to know the type t, to which to coerce.
82 (OutExpr -> SimplM OutExprStuff) -- What to do with the result
83 -- The result expression in the OutExprStuff has type cont_ty
85 instance Outputable SimplCont where
86 ppr (Stop _) = ptext SLIT("Stop")
87 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
88 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
89 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
90 (nest 4 (ppr alts)) $$ ppr cont
91 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
92 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
94 data DupFlag = OkToDup | NoDup
96 instance Outputable DupFlag where
97 ppr OkToDup = ptext SLIT("ok")
98 ppr NoDup = ptext SLIT("nodup")
101 contIsDupable :: SimplCont -> Bool
102 contIsDupable (Stop _) = True
103 contIsDupable (ApplyTo OkToDup _ _ _) = True
104 contIsDupable (ArgOf OkToDup _ _) = True
105 contIsDupable (Select OkToDup _ _ _ _) = True
106 contIsDupable (CoerceIt _ cont) = contIsDupable cont
107 contIsDupable (InlinePlease cont) = contIsDupable cont
108 contIsDupable other = False
111 discardInline :: SimplCont -> SimplCont
112 discardInline (InlinePlease cont) = cont
113 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
114 discardInline cont = cont
117 discardableCont :: SimplCont -> Bool
118 discardableCont (Stop _) = False
119 discardableCont (CoerceIt _ cont) = discardableCont cont
120 discardableCont (InlinePlease cont) = discardableCont cont
121 discardableCont other = True
123 discardCont :: SimplCont -- A continuation, expecting
124 -> SimplCont -- Replace the continuation with a suitable coerce
125 discardCont (Stop to_ty) = Stop to_ty
126 discardCont cont = CoerceIt to_ty (Stop to_ty)
128 to_ty = contResultType cont
131 contResultType :: SimplCont -> OutType
132 contResultType (Stop to_ty) = to_ty
133 contResultType (ArgOf _ to_ty _) = to_ty
134 contResultType (ApplyTo _ _ _ cont) = contResultType cont
135 contResultType (CoerceIt _ cont) = contResultType cont
136 contResultType (InlinePlease cont) = contResultType cont
137 contResultType (Select _ _ _ _ cont) = contResultType cont
140 countValArgs :: SimplCont -> Int
141 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
142 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
143 countValArgs other = 0
145 countArgs :: SimplCont -> Int
146 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
152 getContArgs :: OutId -> SimplCont
153 -> SimplM ([(InExpr, SubstEnv, Bool)], -- Arguments; the Bool is true for strict args
154 SimplCont, -- Remaining continuation
155 Bool) -- Whether we came across an InlineCall
156 -- getContArgs id k = (args, k', inl)
157 -- args are the leading ApplyTo items in k
158 -- (i.e. outermost comes first)
159 -- augmented with demand info from the functionn
160 getContArgs fun orig_cont
161 = getSwitchChecker `thenSmpl` \ chkr ->
163 -- Ignore strictness info if the no-case-of-case
164 -- flag is on. Strictness changes evaluation order
165 -- and that can change full laziness
166 stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
167 | otherwise = computed_stricts
169 go [] stricts False orig_cont
171 ----------------------------
174 go acc ss inl (ApplyTo _ arg@(Type _) se cont)
175 = go ((arg,se,False) : acc) ss inl cont
176 -- NB: don't bother to instantiate the function type
179 go acc (s:ss) inl (ApplyTo _ arg se cont)
180 = go ((arg,se,s) : acc) ss inl cont
182 -- An Inline continuation
183 go acc ss inl (InlinePlease cont)
184 = go acc ss True cont
186 -- We're run out of arguments, or else we've run out of demands
187 -- The latter only happens if the result is guaranteed bottom
188 -- This is the case for
189 -- * case (error "hello") of { ... }
190 -- * (error "Hello") arg
191 -- * f (error "Hello") where f is strict
194 | null ss && discardableCont cont = tick BottomFound `thenSmpl_`
195 returnSmpl (reverse acc, discardCont cont, inl)
196 | otherwise = returnSmpl (reverse acc, cont, inl)
198 ----------------------------
199 vanilla_stricts, computed_stricts :: [Bool]
200 vanilla_stricts = repeat False
201 computed_stricts = zipWith (||) fun_stricts arg_stricts
203 ----------------------------
204 (val_arg_tys, _) = splitRepFunTys (idType fun)
205 arg_stricts = map isStrictType val_arg_tys ++ repeat False
206 -- These argument types are used as a cheap and cheerful way to find
207 -- unboxed arguments, which must be strict. But it's an InType
208 -- and so there might be a type variable where we expect a function
209 -- type (the substitution hasn't happened yet). And we don't bother
210 -- doing the type applications for a polymorphic function.
211 -- Hence the split*Rep*FunTys
213 ----------------------------
214 -- If fun_stricts is finite, it means the function returns bottom
215 -- after that number of value args have been consumed
216 -- Otherwise it's infinite, extended with False
218 = case idStrictness fun of
219 StrictnessInfo demands result_bot
220 | not (demands `lengthExceeds` countValArgs orig_cont)
221 -> -- Enough args, use the strictness given.
222 -- For bottoming functions we used to pretend that the arg
223 -- is lazy, so that we don't treat the arg as an
224 -- interesting context. This avoids substituting
225 -- top-level bindings for (say) strings into
226 -- calls to error. But now we are more careful about
227 -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
229 map isStrict demands -- Finite => result is bottom
231 map isStrict demands ++ vanilla_stricts
233 other -> vanilla_stricts -- Not enough args, or no strictness
237 isStrictType :: Type -> Bool
238 -- isStrictType computes whether an argument (or let RHS) should
239 -- be computed strictly or lazily, based only on its type
241 | isUnLiftedType ty = True
242 | opt_DictsStrict && isDictTy ty && isDataType ty = True
244 -- Return true only for dictionary types where the dictionary
245 -- has more than one component (else we risk poking on the component
246 -- of a newtype dictionary)
249 interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
250 -- An argument is interesting if it has *some* structure
251 -- We are here trying to avoid unfolding a function that
252 -- is applied only to variables that have no unfolding
253 -- (i.e. they are probably lambda bound): f x y z
254 -- There is little point in inlining f here.
255 interestingArg in_scope arg subst
259 = case lookupIdSubst (mkSubst in_scope subst) v of
260 DoneId v' _ -> hasSomeUnfolding (idUnfolding v')
261 -- was: isValueUnfolding (idUnfolding v')
262 -- But that seems over-pessimistic
264 other -> True -- was: False
265 -- But that is *definitely* too pessimistic.
266 -- E.g. let x = 3 in f
267 -- Here, x will be unconditionally substituted, via
269 analyse (Type _) = False
270 analyse (App fn (Type _)) = analyse fn
271 analyse (Note _ a) = analyse a
275 Comment about interestingCallContext
276 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
277 We want to avoid inlining an expression where there can't possibly be
278 any gain, such as in an argument position. Hence, if the continuation
279 is interesting (eg. a case scrutinee, application etc.) then we
280 inline, otherwise we don't.
282 Previously some_benefit used to return True only if the variable was
283 applied to some value arguments. This didn't work:
285 let x = _coerce_ (T Int) Int (I# 3) in
286 case _coerce_ Int (T Int) x of
289 we want to inline x, but can't see that it's a constructor in a case
290 scrutinee position, and some_benefit is False.
294 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
296 .... case dMonadST _@_ x0 of (a,b,c) -> ....
298 we'd really like to inline dMonadST here, but we *don't* want to
299 inline if the case expression is just
301 case x of y { DEFAULT -> ... }
303 since we can just eliminate this case instead (x is in WHNF). Similar
304 applies when x is bound to a lambda expression. Hence
305 contIsInteresting looks for case expressions with just a single
309 interestingCallContext :: Bool -- False <=> no args at all
310 -> Bool -- False <=> no value args
312 -- The "lone-variable" case is important. I spent ages
313 -- messing about with unsatisfactory varaints, but this is nice.
314 -- The idea is that if a variable appear all alone
315 -- as an arg of lazy fn, or rhs Stop
316 -- as scrutinee of a case Select
317 -- as arg of a strict fn ArgOf
318 -- then we should not inline it (unless there is some other reason,
319 -- e.g. is is the sole occurrence).
320 -- Why not? At least in the case-scrutinee situation, turning
321 -- case x of y -> ...
323 -- let y = (a,b) in ...
324 -- is bad if the binding for x will remain.
326 -- Another example: I discovered that strings
327 -- were getting inlined straight back into applications of 'error'
328 -- because the latter is strict.
330 -- f = \x -> ...(error s)...
332 -- Fundamentally such contexts should not ecourage inlining becuase
333 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
334 -- so there's no gain.
336 -- However, even a type application isn't a lone variable. Consider
337 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
338 -- We had better inline that sucker! The case won't see through it.
340 -- For now, I'm treating treating a variable applied to types as
341 -- "lone". The motivating example was
343 -- g = /\a. \y. h (f a)
344 -- There's no advantage in inlining f here, and perhaps
345 -- a significant disadvantage. Hence some_val_args in the Stop case
347 interestingCallContext some_args some_val_args cont
350 interesting (InlinePlease _) = True
351 interesting (ApplyTo _ _ _ _) = some_args -- Can happen if we have (coerce t (f x)) y
352 interesting (Select _ _ _ _ _) = some_args
353 interesting (ArgOf _ _ _) = some_val_args
354 interesting (Stop ty) = some_val_args && canUpdateInPlace ty
355 interesting (CoerceIt _ cont) = interesting cont
356 -- If this call is the arg of a strict function, the context
357 -- is a bit interesting. If we inline here, we may get useful
358 -- evaluation information to avoid repeated evals: e.g.
360 -- Here the contIsInteresting makes the '*' keener to inline,
361 -- which in turn exposes a constructor which makes the '+' inline.
362 -- Assuming that +,* aren't small enough to inline regardless.
364 -- It's also very important to inline in a strict context for things
367 -- Here, the context of (f x) is strict, and if f's unfolding is
368 -- a build it's *great* to inline it here. So we must ensure that
369 -- the context for (f x) is not totally uninteresting.
373 canUpdateInPlace :: Type -> Bool
374 -- Consider let x = <wurble> in ...
375 -- If <wurble> returns an explicit constructor, we might be able
376 -- to do update in place. So we treat even a thunk RHS context
377 -- as interesting if update in place is possible. We approximate
378 -- this by seeing if the type has a single constructor with a
379 -- small arity. But arity zero isn't good -- we share the single copy
380 -- for that case, so no point in sharing.
382 -- Note the repType: we want to look through newtypes for this purpose
384 canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of {
388 case tyConDataConsIfAvailable tycon of
389 [dc] -> arity == 1 || arity == 2
391 arity = dataConRepArity dc
398 %************************************************************************
400 \section{Dealing with a single binder}
402 %************************************************************************
405 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
406 simplBinders bndrs thing_inside
407 = getSubst `thenSmpl` \ subst ->
409 (subst', bndrs') = substBndrs subst bndrs
411 seqBndrs bndrs' `seq`
412 setSubst subst' (thing_inside bndrs')
414 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
415 simplBinder bndr thing_inside
416 = getSubst `thenSmpl` \ subst ->
418 (subst', bndr') = substBndr subst bndr
421 setSubst subst' (thing_inside bndr')
424 -- Same semantics as simplBinders, but a little less
425 -- plumbing and hence a little more efficient.
426 -- Maybe not worth the candle?
427 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
428 simplIds ids thing_inside
429 = getSubst `thenSmpl` \ subst ->
431 (subst', bndrs') = substIds subst ids
433 seqBndrs bndrs' `seq`
434 setSubst subst' (thing_inside bndrs')
437 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
439 seqBndr b | isTyVar b = b `seq` ()
440 | otherwise = seqType (idType b) `seq`
446 %************************************************************************
448 \subsection{Transform a RHS}
450 %************************************************************************
452 Try (a) eta expansion
453 (b) type-lambda swizzling
456 transformRhs :: InExpr -> SimplM InExpr
458 = tryEtaExpansion body `thenSmpl` \ body' ->
459 mkRhsTyLam tyvars body'
461 (tyvars, body) = collectTyBinders rhs
465 %************************************************************************
467 \subsection{Local tyvar-lifting}
469 %************************************************************************
471 mkRhsTyLam tries this transformation, when the big lambda appears as
472 the RHS of a let(rec) binding:
474 /\abc -> let(rec) x = e in b
476 let(rec) x' = /\abc -> let x = x' a b c in e
478 /\abc -> let x = x' a b c in b
480 This is good because it can turn things like:
482 let f = /\a -> letrec g = ... g ... in g
484 letrec g' = /\a -> ... g' a ...
488 which is better. In effect, it means that big lambdas don't impede
491 This optimisation is CRUCIAL in eliminating the junk introduced by
492 desugaring mutually recursive definitions. Don't eliminate it lightly!
494 So far as the implemtation is concerned:
496 Invariant: go F e = /\tvs -> F e
500 = Let x' = /\tvs -> F e
504 G = F . Let x = x' tvs
506 go F (Letrec xi=ei in b)
507 = Letrec {xi' = /\tvs -> G ei}
511 G = F . Let {xi = xi' tvs}
513 [May 1999] If we do this transformation *regardless* then we can
514 end up with some pretty silly stuff. For example,
517 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
522 st = /\s -> ...[y1 s/x1, y2 s/x2]
525 Unless the "..." is a WHNF there is really no point in doing this.
526 Indeed it can make things worse. Suppose x1 is used strictly,
529 x1* = case f y of { (a,b) -> e }
531 If we abstract this wrt the tyvar we then can't do the case inline
532 as we would normally do.
536 mkRhsTyLam tyvars body -- Only does something if there's a let
537 | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that
538 = returnSmpl (mkLams tyvars body)
542 worth_it (Let _ e) = whnf_in_middle e
543 worth_it other = False
544 whnf_in_middle (Let _ e) = whnf_in_middle e
545 whnf_in_middle e = exprIsCheap e
548 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
549 = go (fn . Let bind) body
551 go fn (Let bind@(NonRec var rhs) body)
552 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
553 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
554 returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
557 -- main_tyvar_set = mkVarSet tyvars
558 -- var_ty = idType var
559 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
560 -- tyvars_here was an attempt to reduce the number of tyvars
561 -- wrt which the new binding is abstracted. But the naive
562 -- approach of abstract wrt the tyvars free in the Id's type
564 -- /\ a b -> let t :: (a,b) = (e1, e2)
567 -- Here, b isn't free in x's type, but we must nevertheless
568 -- abstract wrt b as well, because t's type mentions b.
569 -- Since t is floated too, we'd end up with the bogus:
570 -- poly_t = /\ a b -> (e1, e2)
571 -- poly_x = /\ a -> fst (poly_t a *b*)
572 -- So for now we adopt the even more naive approach of
573 -- abstracting wrt *all* the tyvars. We'll see if that
574 -- gives rise to problems. SLPJ June 98
576 go fn (Let (Rec prs) body)
577 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
579 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
581 go gn body `thenSmpl` \ body' ->
582 returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
584 (vars,rhss) = unzip prs
586 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
587 -- var_tys = map idType vars
588 -- See notes with tyvars_here above
591 go fn body = returnSmpl (mkLams tyvars (fn body))
593 mk_poly tyvars_here var
594 = getUniqueSmpl `thenSmpl` \ uniq ->
596 poly_name = setNameUnique (idName var) uniq -- Keep same name
597 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
599 -- It's crucial to copy the occInfo of the original var, because
600 -- we're looking at occurrence-analysed but as yet unsimplified code!
601 -- In particular, we mustn't lose the loop breakers.
603 -- It's even right to retain single-occurrence or dead-var info:
604 -- Suppose we started with /\a -> let x = E in B
605 -- where x occurs once in B. Then we transform to:
606 -- let x' = /\a -> E in /\a -> let x* = x' a in B
607 -- where x* has an INLINE prag on it. Now, once x* is inlined,
608 -- the occurrences of x' will be just the occurrences originally
610 poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
612 poly_id = mkId poly_name poly_ty poly_info
614 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
616 mk_silly_bind var rhs = NonRec var rhs
617 -- We need to be careful about inlining.
618 -- Suppose we start with:
620 -- x = let g = /\a -> \x -> f x x
622 -- /\ b -> let g* = g b in E
624 -- Then: * the binding for g gets floated out
625 -- * but then it MIGHT get inlined into the rhs of g*
626 -- * then the binding for g* is floated out of the /\b
627 -- * so we're back to square one
628 -- We rely on the simplifier not to inline g into the RHS of g*,
629 -- because it's a "lone" occurrence, and there is no benefit in
630 -- inlining. But it's a slightly delicate property, and there's
631 -- a danger of making the simplifier loop here.
635 %************************************************************************
637 \subsection{Eta expansion}
639 %************************************************************************
641 Try eta expansion for RHSs
644 \x1..xn -> N ==> \x1..xn y1..ym -> N y1..ym
646 N E1..En ==> let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
648 where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
649 wanting a suitable number of extra args.
651 NB: the Ei may have unlifted type, but the simplifier (which is applied
652 to the result) deals OK with this.
654 There is no point in looking for a combination of the two,
655 because that would leave use with some lets sandwiched between lambdas;
656 that's what the final test in the first equation is for.
659 tryEtaExpansion :: InExpr -> SimplM InExpr
661 | not opt_SimplDoLambdaEtaExpansion
662 || exprIsTrivial rhs -- Don't eta-expand a trival RHS
663 || null y_tys -- No useful expansion
664 || not (null x_bndrs || and trivial_args) -- Not (no x-binders or no z-binds)
667 | otherwise -- Consider eta expansion
668 = newIds SLIT("y") y_tys $ ( \ y_bndrs ->
669 tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
670 mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) ->
671 returnSmpl (mkLams x_bndrs $
672 mkLets (catMaybes maybe_z_binds) $
674 mkApps (mkApps fun z_args) (map Var y_bndrs))))
676 (x_bndrs, body) = collectValBinders rhs
677 (fun, args) = collectArgs body
678 trivial_args = map exprIsTrivial args
679 fun_arity = exprEtaExpandArity fun
681 bind_z_arg (arg, trivial_arg)
682 | trivial_arg = returnSmpl (Nothing, arg)
683 | otherwise = newId SLIT("z") (exprType arg) $ \ z ->
684 returnSmpl (Just (NonRec z arg), Var z)
686 -- Note: I used to try to avoid the exprType call by using
687 -- the type of the binder. But this type doesn't necessarily
688 -- belong to the same substitution environment as this rhs;
689 -- and we are going to make extra term binders (y_bndrs) from the type
690 -- which will be processed with the rhs substitution environment.
691 -- This only went wrong in a mind bendingly complicated case.
692 (potential_extra_arg_tys, _) = splitFunTys (exprType body)
695 y_tys = take no_extras_wanted potential_extra_arg_tys
697 no_extras_wanted :: Int
698 no_extras_wanted = 0 `max`
700 -- We used to expand the arity to the previous arity fo the
701 -- function; but this is pretty dangerous. Consdier
703 -- so that f has arity 2. Now float something into f's RHS:
704 -- f = let z = BIG in \xy -> e
705 -- The last thing we want to do now is to put some lambdas
707 -- f = \xy -> let z = BIG in e
709 -- (bndr_arity - no_of_xs) `max`
711 -- See if the body could obviously do with more args
712 (fun_arity - valArgCount args)
714 -- This case is now deal with by exprEtaExpandArity
715 -- Finally, see if it's a state transformer, and xs is non-null
716 -- (so it's also a function not a thunk) in which
717 -- case we eta-expand on principle! This can waste work,
718 -- but usually doesn't.
719 -- I originally checked for a singleton type [ty] in this case
720 -- but then I found a situation in which I had
721 -- \ x -> let {..} in \ s -> f (...) s
722 -- AND f RETURNED A FUNCTION. That is, 's' wasn't the only
723 -- potential extra arg.
724 -- case (x_bndrs, potential_extra_arg_tys) of
725 -- (_:_, ty:_) -> case splitTyConApp_maybe ty of
726 -- Just (tycon,_) | tycon == statePrimTyCon -> 1
732 %************************************************************************
734 \subsection{Case absorption and identity-case elimination}
736 %************************************************************************
739 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
742 @mkCase@ tries the following transformation (if possible):
744 case e of b { ==> case e of b {
745 p1 -> rhs1 p1 -> rhs1
747 pm -> rhsm pm -> rhsm
748 _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn}
749 {or (prim) case b of b' { _ -> rhsn}}
752 po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd}
756 which merges two cases in one case when -- the default alternative of
757 the outer case scrutises the same variable as the outer case This
758 transformation is called Case Merging. It avoids that the same
759 variable is scrutinised multiple times.
762 mkCase scrut outer_bndr outer_alts
764 && maybeToBool maybe_case_in_default
766 = tick (CaseMerge outer_bndr) `thenSmpl_`
767 returnSmpl (Case scrut outer_bndr new_alts)
768 -- Warning: don't call mkCase recursively!
769 -- Firstly, there's no point, because inner alts have already had
770 -- mkCase applied to them, so they won't have a case in their default
771 -- Secondly, if you do, you get an infinite loop, because the bindNonRec
772 -- in munge_rhs puts a case into the DEFAULT branch!
774 new_alts = outer_alts_without_deflt ++ munged_inner_alts
775 maybe_case_in_default = case findDefault outer_alts of
776 (outer_alts_without_default,
777 Just (Case (Var scrut_var) inner_bndr inner_alts))
779 | outer_bndr == scrut_var
780 -> Just (outer_alts_without_default, inner_bndr, inner_alts)
783 Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
785 -- Eliminate any inner alts which are shadowed by the outer ones
786 outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
788 munged_inner_alts = [ (con, args, munge_rhs rhs)
789 | (con, args, rhs) <- inner_alts,
790 not (con `elem` outer_cons) -- Eliminate shadowed inner alts
792 munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
795 Now the identity-case transformation:
804 mkCase scrut case_bndr alts
805 | all identity_alt alts
806 = tick (CaseIdentity case_bndr) `thenSmpl_`
809 identity_alt (DEFAULT, [], Var v) = v == case_bndr
810 identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
811 (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
812 identity_alt other = False
814 arg_tys = case splitTyConApp_maybe (idType case_bndr) of
815 Just (tycon, arg_tys) -> arg_tys
821 mkCase other_scrut case_bndr other_alts
822 = returnSmpl (Case other_scrut case_bndr other_alts)
827 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
828 findDefault [] = ([], Nothing)
829 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
831 findDefault (alt : alts) = case findDefault alts of
832 (alts', deflt) -> (alt : alts', deflt)
834 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
838 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
839 go (alt : alts) | matches alt = alt
840 | otherwise = go alts
842 matches (DEFAULT, _, _) = True
843 matches (con1, _, _) = con == con1