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 pushArgs, discardCont, countValArgs, countArgs,
15 analyseCont, discardInline
19 #include "HsVersions.h"
22 import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
24 import CoreUnfold ( isValueUnfolding )
25 import CoreFVs ( exprFreeVars )
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,
30 idDemandInfo, mkId, idInfo
32 import IdInfo ( arityLowerBound, setOccInfo, vanillaIdInfo )
33 import Maybes ( maybeToBool, catMaybes )
34 import Name ( isLocalName, setNameUnique )
36 import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
37 splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
39 import DataCon ( dataConRepArity )
40 import TysPrim ( statePrimTyCon )
41 import Var ( setVarUnique )
43 import VarEnv ( SubstEnv, SubstResult(..) )
44 import UniqSupply ( splitUniqSupply, uniqFromSupply )
45 import Util ( zipWithEqual, mapAccumL )
50 %************************************************************************
52 \subsection{The continuation data type}
54 %************************************************************************
57 data SimplCont -- Strict contexts
58 = Stop OutType -- Type of the result
60 | CoerceIt OutType -- The To-type, simplified
63 | InlinePlease -- This continuation makes a function very
64 SimplCont -- keen to inline itelf
67 InExpr SubstEnv -- The argument, as yet unsimplified,
68 SimplCont -- and its subst-env
71 InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
74 | ArgOf DupFlag -- An arbitrary strict context: the argument
75 -- of a strict function, or a primitive-arg fn
77 OutType -- The type of the expression being sought by the context
78 -- f (error "foo") ==> coerce t (error "foo")
80 -- We need to know the type t, to which to coerce.
81 (OutExpr -> SimplM OutExprStuff) -- What to do with the result
83 instance Outputable SimplCont where
84 ppr (Stop _) = ptext SLIT("Stop")
85 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
86 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
87 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
88 (nest 4 (ppr alts)) $$ ppr cont
89 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
90 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
92 data DupFlag = OkToDup | NoDup
94 instance Outputable DupFlag where
95 ppr OkToDup = ptext SLIT("ok")
96 ppr NoDup = ptext SLIT("nodup")
98 contIsDupable :: SimplCont -> Bool
99 contIsDupable (Stop _) = True
100 contIsDupable (ApplyTo OkToDup _ _ _) = True
101 contIsDupable (ArgOf OkToDup _ _) = True
102 contIsDupable (Select OkToDup _ _ _ _) = True
103 contIsDupable (CoerceIt _ cont) = contIsDupable cont
104 contIsDupable (InlinePlease cont) = contIsDupable cont
105 contIsDupable other = False
107 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
108 pushArgs se [] cont = cont
109 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
111 discardCont :: SimplCont -- A continuation, expecting
112 -> SimplCont -- Replace the continuation with a suitable coerce
113 discardCont (Stop to_ty) = Stop to_ty
114 discardCont cont = CoerceIt to_ty (Stop to_ty)
116 to_ty = contResultType cont
118 contResultType :: SimplCont -> OutType
119 contResultType (Stop to_ty) = to_ty
120 contResultType (ArgOf _ to_ty _) = to_ty
121 contResultType (ApplyTo _ _ _ cont) = contResultType cont
122 contResultType (CoerceIt _ cont) = contResultType cont
123 contResultType (InlinePlease cont) = contResultType cont
124 contResultType (Select _ _ _ _ cont) = contResultType cont
126 countValArgs :: SimplCont -> Int
127 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
128 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
129 countValArgs other = 0
131 countArgs :: SimplCont -> Int
132 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
137 Comment about analyseCont
138 ~~~~~~~~~~~~~~~~~~~~~~~~~
139 We want to avoid inlining an expression where there can't possibly be
140 any gain, such as in an argument position. Hence, if the continuation
141 is interesting (eg. a case scrutinee, application etc.) then we
142 inline, otherwise we don't.
144 Previously some_benefit used to return True only if the variable was
145 applied to some value arguments. This didn't work:
147 let x = _coerce_ (T Int) Int (I# 3) in
148 case _coerce_ Int (T Int) x of
151 we want to inline x, but can't see that it's a constructor in a case
152 scrutinee position, and some_benefit is False.
156 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
158 .... case dMonadST _@_ x0 of (a,b,c) -> ....
160 we'd really like to inline dMonadST here, but we *don't* want to
161 inline if the case expression is just
163 case x of y { DEFAULT -> ... }
165 since we can just eliminate this case instead (x is in WHNF). Similar
166 applies when x is bound to a lambda expression. Hence
167 contIsInteresting looks for case expressions with just a single
171 analyseCont :: InScopeSet -> SimplCont
172 -> ([Bool], -- Arg-info flags; one for each value argument
173 Bool, -- Context of the result of the call is interesting
174 Bool) -- There was an InlinePlease
176 analyseCont in_scope cont
178 -- The "lone-variable" case is important. I spent ages
179 -- messing about with unsatisfactory varaints, but this is nice.
180 -- The idea is that if a variable appear all alone
181 -- as an arg of lazy fn, or rhs Stop
182 -- as scrutinee of a case Select
183 -- as arg of a strict fn ArgOf
184 -- then we should not inline it (unless there is some other reason,
185 -- e.g. is is the sole occurrence).
186 -- Why not? At least in the case-scrutinee situation, turning
187 -- case x of y -> ...
189 -- let y = (a,b) in ...
190 -- is bad if the binding for x will remain.
192 -- Another example: I discovered that strings
193 -- were getting inlined straight back into applications of 'error'
194 -- because the latter is strict.
196 -- f = \x -> ...(error s)...
198 -- Fundamentally such contexts should not ecourage inlining becuase
199 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
200 -- so there's no gain.
202 -- However, even a type application isn't a lone variable. Consider
203 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
204 -- We had better inline that sucker! The case won't see through it.
206 (Stop _) -> boring_result -- Don't inline a lone variable
207 (Select _ _ _ _ _) -> boring_result -- Ditto
208 (ArgOf _ _ _) -> boring_result -- Ditto
209 (ApplyTo _ (Type _) _ cont) -> analyse_ty_app cont
210 other -> analyse_app cont
212 boring_result = ([], False, False)
214 -- For now, I'm treating not treating a variable applied to types as
215 -- "lone". The motivating example was
217 -- g = /\a. \y. h (f a)
218 -- There's no advantage in inlining f here, and perhaps
219 -- a significant disadvantage.
220 analyse_ty_app (Stop _) = boring_result
221 analyse_ty_app (ArgOf _ _ _) = boring_result
222 analyse_ty_app (Select _ _ _ _ _) = ([], True, False) -- See the $fMonadST example above
223 analyse_ty_app (ApplyTo _ (Type _) _ cont) = analyse_ty_app cont
224 analyse_ty_app cont = analyse_app cont
226 analyse_app (InlinePlease cont)
227 = case analyse_app cont of
228 (infos, icont, inline) -> (infos, icont, True)
230 analyse_app (ApplyTo _ arg subst cont)
231 | isValArg arg = case analyse_app cont of
232 (infos, icont, inline) -> (analyse_arg subst arg : infos, icont, inline)
233 | otherwise = analyse_app cont
235 analyse_app cont = ([], interesting_call_context cont, False)
237 -- An argument is interesting if it has *some* structure
238 -- We are here trying to avoid unfolding a function that
239 -- is applied only to variables that have no unfolding
240 -- (i.e. they are probably lambda bound): f x y z
241 -- There is little point in inlining f here.
242 analyse_arg :: SubstEnv -> InExpr -> Bool
243 analyse_arg subst (Var v) = case lookupIdSubst (mkSubst in_scope subst) v of
244 DoneId v' _ -> isValueUnfolding (idUnfolding v')
246 analyse_arg subst (Type _) = False
247 analyse_arg subst (App fn (Type _)) = analyse_arg subst fn
248 analyse_arg subst (Note _ a) = analyse_arg subst a
249 analyse_arg subst other = True
251 interesting_call_context (Stop ty) = canUpdateInPlace ty
252 interesting_call_context (InlinePlease _) = True
253 interesting_call_context (Select _ _ _ _ _) = True
254 interesting_call_context (CoerceIt _ cont) = interesting_call_context cont
255 interesting_call_context (ApplyTo _ (Type _) _ cont) = interesting_call_context cont
256 interesting_call_context (ApplyTo _ _ _ _) = True
257 interesting_call_context (ArgOf _ _ _) = True
258 -- If this call is the arg of a strict function, the context
259 -- is a bit interesting. If we inline here, we may get useful
260 -- evaluation information to avoid repeated evals: e.g.
262 -- Here the contIsInteresting makes the '*' keener to inline,
263 -- which in turn exposes a constructor which makes the '+' inline.
264 -- Assuming that +,* aren't small enough to inline regardless.
266 -- It's also very important to inline in a strict context for things
269 -- Here, the context of (f x) is strict, and if f's unfolding is
270 -- a build it's *great* to inline it here. So we must ensure that
271 -- the context for (f x) is not totally uninteresting.
274 discardInline :: SimplCont -> SimplCont
275 discardInline (InlinePlease cont) = cont
276 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
277 discardInline cont = cont
279 -- Consider let x = <wurble> in ...
280 -- If <wurble> returns an explicit constructor, we might be able
281 -- to do update in place. So we treat even a thunk RHS context
282 -- as interesting if update in place is possible. We approximate
283 -- this by seeing if the type has a single constructor with a
284 -- small arity. But arity zero isn't good -- we share the single copy
285 -- for that case, so no point in sharing.
287 canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of
288 Just (_, _, [dc]) -> arity == 1 || arity == 2
290 arity = dataConRepArity dc
296 %************************************************************************
298 \section{Dealing with a single binder}
300 %************************************************************************
303 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
304 simplBinders bndrs thing_inside
305 = getSubst `thenSmpl` \ subst ->
307 (subst', bndrs') = substBndrs subst bndrs
309 seqBndrs bndrs' `seq`
310 setSubst subst' (thing_inside bndrs')
312 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
313 simplBinder bndr thing_inside
314 = getSubst `thenSmpl` \ subst ->
316 (subst', bndr') = substBndr subst bndr
319 setSubst subst' (thing_inside bndr')
322 -- Same semantics as simplBinders, but a little less
323 -- plumbing and hence a little more efficient.
324 -- Maybe not worth the candle?
325 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
326 simplIds ids thing_inside
327 = getSubst `thenSmpl` \ subst ->
329 (subst', bndrs') = substIds subst ids
331 seqBndrs bndrs' `seq`
332 setSubst subst' (thing_inside bndrs')
335 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
337 seqBndr b | isTyVar b = b `seq` ()
338 | otherwise = seqType (idType b) `seq`
344 %************************************************************************
346 \subsection{Transform a RHS}
348 %************************************************************************
350 Try (a) eta expansion
351 (b) type-lambda swizzling
354 transformRhs :: InExpr -> SimplM InExpr
356 = tryEtaExpansion body `thenSmpl` \ body' ->
357 mkRhsTyLam tyvars body'
359 (tyvars, body) = collectTyBinders rhs
363 %************************************************************************
365 \subsection{Local tyvar-lifting}
367 %************************************************************************
369 mkRhsTyLam tries this transformation, when the big lambda appears as
370 the RHS of a let(rec) binding:
372 /\abc -> let(rec) x = e in b
374 let(rec) x' = /\abc -> let x = x' a b c in e
376 /\abc -> let x = x' a b c in b
378 This is good because it can turn things like:
380 let f = /\a -> letrec g = ... g ... in g
382 letrec g' = /\a -> ... g' a ...
386 which is better. In effect, it means that big lambdas don't impede
389 This optimisation is CRUCIAL in eliminating the junk introduced by
390 desugaring mutually recursive definitions. Don't eliminate it lightly!
392 So far as the implemtation is concerned:
394 Invariant: go F e = /\tvs -> F e
398 = Let x' = /\tvs -> F e
402 G = F . Let x = x' tvs
404 go F (Letrec xi=ei in b)
405 = Letrec {xi' = /\tvs -> G ei}
409 G = F . Let {xi = xi' tvs}
411 [May 1999] If we do this transformation *regardless* then we can
412 end up with some pretty silly stuff. For example,
415 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
420 st = /\s -> ...[y1 s/x1, y2 s/x2]
423 Unless the "..." is a WHNF there is really no point in doing this.
424 Indeed it can make things worse. Suppose x1 is used strictly,
427 x1* = case f y of { (a,b) -> e }
429 If we abstract this wrt the tyvar we then can't do the case inline
430 as we would normally do.
434 mkRhsTyLam tyvars body -- Only does something if there's a let
435 | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that
436 = returnSmpl (mkLams tyvars body)
440 worth_it (Let _ e) = whnf_in_middle e
441 worth_it other = False
442 whnf_in_middle (Let _ e) = whnf_in_middle e
443 whnf_in_middle e = exprIsCheap e
445 main_tyvar_set = mkVarSet tyvars
447 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
448 = go (fn . Let bind) body
450 go fn (Let bind@(NonRec var rhs) body)
451 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
452 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
453 returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
456 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
457 -- tyvars_here was an attempt to reduce the number of tyvars
458 -- wrt which the new binding is abstracted. But the naive
459 -- approach of abstract wrt the tyvars free in the Id's type
461 -- /\ a b -> let t :: (a,b) = (e1, e2)
464 -- Here, b isn't free in x's type, but we must nevertheless
465 -- abstract wrt b as well, because t's type mentions b.
466 -- Since t is floated too, we'd end up with the bogus:
467 -- poly_t = /\ a b -> (e1, e2)
468 -- poly_x = /\ a -> fst (poly_t a *b*)
469 -- So for now we adopt the even more naive approach of
470 -- abstracting wrt *all* the tyvars. We'll see if that
471 -- gives rise to problems. SLPJ June 98
475 go fn (Let (Rec prs) body)
476 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
478 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
480 go gn body `thenSmpl` \ body' ->
481 returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
483 (vars,rhss) = unzip prs
485 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
486 -- See notes with tyvars_here above
488 var_tys = map idType vars
490 go fn body = returnSmpl (mkLams tyvars (fn body))
492 mk_poly tyvars_here var
493 = getUniqueSmpl `thenSmpl` \ uniq ->
495 poly_name = setNameUnique (idName var) uniq -- Keep same name
496 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
498 -- It's crucial to copy the occInfo of the original var, because
499 -- we're looking at occurrence-analysed but as yet unsimplified code!
500 -- In particular, we mustn't lose the loop breakers.
502 -- It's even right to retain single-occurrence or dead-var info:
503 -- Suppose we started with /\a -> let x = E in B
504 -- where x occurs once in E. Then we transform to:
505 -- let x' = /\a -> E in /\a -> let x* = x' a in B
506 -- where x* has an INLINE prag on it. Now, once x* is inlined,
507 -- the occurrences of x' will be just the occurrences originaly
509 poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
511 poly_id = mkId poly_name poly_ty poly_info
513 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
515 mk_silly_bind var rhs = NonRec var rhs
516 -- The Inline note is really important! If we don't say
517 -- INLINE on these silly little bindings then look what happens!
518 -- Suppose we start with:
520 -- x = let g = /\a -> \x -> f x x
522 -- /\ b -> let g* = g b in E
524 -- Then: * the binding for g gets floated out
525 -- * but then it gets inlined into the rhs of g*
526 -- * then the binding for g* is floated out of the /\b
527 -- * so we're back to square one
528 -- The silly binding for g* must be INLINEd, so that
529 -- we simply substitute for g* throughout.
533 %************************************************************************
535 \subsection{Eta expansion}
537 %************************************************************************
539 Try eta expansion for RHSs
542 \x1..xn -> N ==> \x1..xn y1..ym -> N y1..ym
544 N E1..En ==> let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
546 where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
547 wanting a suitable number of extra args.
549 NB: the Ei may have unlifted type, but the simplifier (which is applied
550 to the result) deals OK with this.
552 There is no point in looking for a combination of the two,
553 because that would leave use with some lets sandwiched between lambdas;
554 that's what the final test in the first equation is for.
557 tryEtaExpansion :: InExpr -> SimplM InExpr
559 | not opt_SimplDoLambdaEtaExpansion
560 || exprIsTrivial rhs -- Don't eta-expand a trival RHS
561 || null y_tys -- No useful expansion
562 || not (null x_bndrs || and trivial_args) -- Not (no x-binders or no z-binds)
565 | otherwise -- Consider eta expansion
566 = newIds y_tys $ ( \ y_bndrs ->
567 tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
568 mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) ->
569 returnSmpl (mkLams x_bndrs $
570 mkLets (catMaybes maybe_z_binds) $
572 mkApps (mkApps fun z_args) (map Var y_bndrs))))
574 (x_bndrs, body) = collectValBinders rhs
575 (fun, args) = collectArgs body
576 trivial_args = map exprIsTrivial args
577 fun_arity = exprEtaExpandArity fun
579 bind_z_arg (arg, trivial_arg)
580 | trivial_arg = returnSmpl (Nothing, arg)
581 | otherwise = newId (exprType arg) $ \ z ->
582 returnSmpl (Just (NonRec z arg), Var z)
584 -- Note: I used to try to avoid the exprType call by using
585 -- the type of the binder. But this type doesn't necessarily
586 -- belong to the same substitution environment as this rhs;
587 -- and we are going to make extra term binders (y_bndrs) from the type
588 -- which will be processed with the rhs substitution environment.
589 -- This only went wrong in a mind bendingly complicated case.
590 (potential_extra_arg_tys, inner_ty) = splitFunTys (exprType body)
593 y_tys = take no_extras_wanted potential_extra_arg_tys
595 no_extras_wanted :: Int
596 no_extras_wanted = 0 `max`
598 -- We used to expand the arity to the previous arity fo the
599 -- function; but this is pretty dangerous. Consdier
601 -- so that f has arity 2. Now float something into f's RHS:
602 -- f = let z = BIG in \xy -> e
603 -- The last thing we want to do now is to put some lambdas
605 -- f = \xy -> let z = BIG in e
607 -- (bndr_arity - no_of_xs) `max`
609 -- See if the body could obviously do with more args
610 (fun_arity - valArgCount args)
612 -- This case is now deal with by exprEtaExpandArity
613 -- Finally, see if it's a state transformer, and xs is non-null
614 -- (so it's also a function not a thunk) in which
615 -- case we eta-expand on principle! This can waste work,
616 -- but usually doesn't.
617 -- I originally checked for a singleton type [ty] in this case
618 -- but then I found a situation in which I had
619 -- \ x -> let {..} in \ s -> f (...) s
620 -- AND f RETURNED A FUNCTION. That is, 's' wasn't the only
621 -- potential extra arg.
622 -- case (x_bndrs, potential_extra_arg_tys) of
623 -- (_:_, ty:_) -> case splitTyConApp_maybe ty of
624 -- Just (tycon,_) | tycon == statePrimTyCon -> 1
630 %************************************************************************
632 \subsection{Case absorption and identity-case elimination}
634 %************************************************************************
637 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
640 @mkCase@ tries the following transformation (if possible):
642 case e of b { ==> case e of b {
643 p1 -> rhs1 p1 -> rhs1
645 pm -> rhsm pm -> rhsm
646 _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn}
647 {or (prim) case b of b' { _ -> rhsn}}
650 po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd}
654 which merges two cases in one case when -- the default alternative of
655 the outer case scrutises the same variable as the outer case This
656 transformation is called Case Merging. It avoids that the same
657 variable is scrutinised multiple times.
660 mkCase scrut outer_bndr outer_alts
662 && maybeToBool maybe_case_in_default
664 = tick (CaseMerge outer_bndr) `thenSmpl_`
665 returnSmpl (Case scrut outer_bndr new_alts)
666 -- Warning: don't call mkCase recursively!
667 -- Firstly, there's no point, because inner alts have already had
668 -- mkCase applied to them, so they won't have a case in their default
669 -- Secondly, if you do, you get an infinite loop, because the bindNonRec
670 -- in munge_rhs puts a case into the DEFAULT branch!
672 new_alts = outer_alts_without_deflt ++ munged_inner_alts
673 maybe_case_in_default = case findDefault outer_alts of
674 (outer_alts_without_default,
675 Just (Case (Var scrut_var) inner_bndr inner_alts))
677 | outer_bndr == scrut_var
678 -> Just (outer_alts_without_default, inner_bndr, inner_alts)
681 Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
683 -- Eliminate any inner alts which are shadowed by the outer ones
684 outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
686 munged_inner_alts = [ (con, args, munge_rhs rhs)
687 | (con, args, rhs) <- inner_alts,
688 not (con `elem` outer_cons) -- Eliminate shadowed inner alts
690 munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
693 Now the identity-case transformation:
702 mkCase scrut case_bndr alts
703 | all identity_alt alts
704 = tick (CaseIdentity case_bndr) `thenSmpl_`
707 identity_alt (DEFAULT, [], Var v) = v == case_bndr
708 identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
709 (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
710 identity_alt other = False
712 arg_tys = case splitTyConApp_maybe (idType case_bndr) of
713 Just (tycon, arg_tys) -> arg_tys
719 mkCase other_scrut case_bndr other_alts
720 = returnSmpl (Case other_scrut case_bndr other_alts)
725 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
726 findDefault [] = ([], Nothing)
727 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
729 findDefault (alt : alts) = case findDefault alts of
730 (alts', deflt) -> (alt : alts', deflt)
732 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
736 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
737 go (alt : alts) | matches alt = alt
738 | otherwise = go alts
740 matches (DEFAULT, _, _) = True
741 matches (con1, _, _) = con == con1