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 PprType ( {- instance Outputable Type -} )
40 import DataCon ( dataConRepArity )
41 import TysPrim ( statePrimTyCon )
42 import Var ( setVarUnique )
44 import VarEnv ( SubstEnv, SubstResult(..) )
45 import UniqSupply ( splitUniqSupply, uniqFromSupply )
46 import Util ( zipWithEqual, mapAccumL )
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 -- 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
84 instance Outputable SimplCont where
85 ppr (Stop _) = ptext SLIT("Stop")
86 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
87 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
88 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
89 (nest 4 (ppr alts)) $$ ppr cont
90 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
91 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
93 data DupFlag = OkToDup | NoDup
95 instance Outputable DupFlag where
96 ppr OkToDup = ptext SLIT("ok")
97 ppr NoDup = ptext SLIT("nodup")
99 contIsDupable :: SimplCont -> Bool
100 contIsDupable (Stop _) = True
101 contIsDupable (ApplyTo OkToDup _ _ _) = True
102 contIsDupable (ArgOf OkToDup _ _) = True
103 contIsDupable (Select OkToDup _ _ _ _) = True
104 contIsDupable (CoerceIt _ cont) = contIsDupable cont
105 contIsDupable (InlinePlease cont) = contIsDupable cont
106 contIsDupable other = False
108 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
109 pushArgs se [] cont = cont
110 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
112 discardCont :: SimplCont -- A continuation, expecting
113 -> SimplCont -- Replace the continuation with a suitable coerce
114 discardCont (Stop to_ty) = Stop to_ty
115 discardCont cont = CoerceIt to_ty (Stop to_ty)
117 to_ty = contResultType cont
119 contResultType :: SimplCont -> OutType
120 contResultType (Stop to_ty) = to_ty
121 contResultType (ArgOf _ to_ty _) = to_ty
122 contResultType (ApplyTo _ _ _ cont) = contResultType cont
123 contResultType (CoerceIt _ cont) = contResultType cont
124 contResultType (InlinePlease cont) = contResultType cont
125 contResultType (Select _ _ _ _ cont) = contResultType cont
127 countValArgs :: SimplCont -> Int
128 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
129 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
130 countValArgs other = 0
132 countArgs :: SimplCont -> Int
133 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
138 Comment about analyseCont
139 ~~~~~~~~~~~~~~~~~~~~~~~~~
140 We want to avoid inlining an expression where there can't possibly be
141 any gain, such as in an argument position. Hence, if the continuation
142 is interesting (eg. a case scrutinee, application etc.) then we
143 inline, otherwise we don't.
145 Previously some_benefit used to return True only if the variable was
146 applied to some value arguments. This didn't work:
148 let x = _coerce_ (T Int) Int (I# 3) in
149 case _coerce_ Int (T Int) x of
152 we want to inline x, but can't see that it's a constructor in a case
153 scrutinee position, and some_benefit is False.
157 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
159 .... case dMonadST _@_ x0 of (a,b,c) -> ....
161 we'd really like to inline dMonadST here, but we *don't* want to
162 inline if the case expression is just
164 case x of y { DEFAULT -> ... }
166 since we can just eliminate this case instead (x is in WHNF). Similar
167 applies when x is bound to a lambda expression. Hence
168 contIsInteresting looks for case expressions with just a single
172 analyseCont :: InScopeSet -> SimplCont
173 -> ([Bool], -- Arg-info flags; one for each value argument
174 Bool, -- Context of the result of the call is interesting
175 Bool) -- There was an InlinePlease
177 analyseCont in_scope cont
179 -- The "lone-variable" case is important. I spent ages
180 -- messing about with unsatisfactory varaints, but this is nice.
181 -- The idea is that if a variable appear all alone
182 -- as an arg of lazy fn, or rhs Stop
183 -- as scrutinee of a case Select
184 -- as arg of a strict fn ArgOf
185 -- then we should not inline it (unless there is some other reason,
186 -- e.g. is is the sole occurrence).
187 -- Why not? At least in the case-scrutinee situation, turning
188 -- case x of y -> ...
190 -- let y = (a,b) in ...
191 -- is bad if the binding for x will remain.
193 -- Another example: I discovered that strings
194 -- were getting inlined straight back into applications of 'error'
195 -- because the latter is strict.
197 -- f = \x -> ...(error s)...
199 -- Fundamentally such contexts should not ecourage inlining becuase
200 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
201 -- so there's no gain.
203 -- However, even a type application isn't a lone variable. Consider
204 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
205 -- We had better inline that sucker! The case won't see through it.
207 (Stop _) -> boring_result -- Don't inline a lone variable
208 (Select _ _ _ _ _) -> boring_result -- Ditto
209 (ArgOf _ _ _) -> boring_result -- Ditto
210 (ApplyTo _ (Type _) _ cont) -> analyse_ty_app cont
211 other -> analyse_app cont
213 boring_result = ([], False, False)
215 -- For now, I'm treating not treating a variable applied to types as
216 -- "lone". The motivating example was
218 -- g = /\a. \y. h (f a)
219 -- There's no advantage in inlining f here, and perhaps
220 -- a significant disadvantage.
221 analyse_ty_app (Stop _) = boring_result
222 analyse_ty_app (ArgOf _ _ _) = boring_result
223 analyse_ty_app (Select _ _ _ _ _) = ([], True, False) -- See the $fMonadST example above
224 analyse_ty_app (ApplyTo _ (Type _) _ cont) = analyse_ty_app cont
225 analyse_ty_app cont = analyse_app cont
227 analyse_app (InlinePlease cont)
228 = case analyse_app cont of
229 (infos, icont, inline) -> (infos, icont, True)
231 analyse_app (ApplyTo _ arg subst cont)
232 | isValArg arg = case analyse_app cont of
233 (infos, icont, inline) -> (analyse_arg subst arg : infos, icont, inline)
234 | otherwise = analyse_app cont
236 analyse_app cont = ([], interesting_call_context cont, False)
238 -- An argument is interesting if it has *some* structure
239 -- We are here trying to avoid unfolding a function that
240 -- is applied only to variables that have no unfolding
241 -- (i.e. they are probably lambda bound): f x y z
242 -- There is little point in inlining f here.
243 analyse_arg :: SubstEnv -> InExpr -> Bool
244 analyse_arg subst (Var v) = case lookupIdSubst (mkSubst in_scope subst) v of
245 DoneId v' _ -> isValueUnfolding (idUnfolding v')
247 analyse_arg subst (Type _) = False
248 analyse_arg subst (App fn (Type _)) = analyse_arg subst fn
249 analyse_arg subst (Note _ a) = analyse_arg subst a
250 analyse_arg subst other = True
252 interesting_call_context (Stop ty) = canUpdateInPlace ty
253 interesting_call_context (InlinePlease _) = True
254 interesting_call_context (Select _ _ _ _ _) = True
255 interesting_call_context (CoerceIt _ cont) = interesting_call_context cont
256 interesting_call_context (ApplyTo _ (Type _) _ cont) = interesting_call_context cont
257 interesting_call_context (ApplyTo _ _ _ _) = True
258 interesting_call_context (ArgOf _ _ _) = True
259 -- If this call is the arg of a strict function, the context
260 -- is a bit interesting. If we inline here, we may get useful
261 -- evaluation information to avoid repeated evals: e.g.
263 -- Here the contIsInteresting makes the '*' keener to inline,
264 -- which in turn exposes a constructor which makes the '+' inline.
265 -- Assuming that +,* aren't small enough to inline regardless.
267 -- It's also very important to inline in a strict context for things
270 -- Here, the context of (f x) is strict, and if f's unfolding is
271 -- a build it's *great* to inline it here. So we must ensure that
272 -- the context for (f x) is not totally uninteresting.
275 discardInline :: SimplCont -> SimplCont
276 discardInline (InlinePlease cont) = cont
277 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
278 discardInline cont = cont
280 -- Consider let x = <wurble> in ...
281 -- If <wurble> returns an explicit constructor, we might be able
282 -- to do update in place. So we treat even a thunk RHS context
283 -- as interesting if update in place is possible. We approximate
284 -- this by seeing if the type has a single constructor with a
285 -- small arity. But arity zero isn't good -- we share the single copy
286 -- for that case, so no point in sharing.
288 canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of
289 Just (_, _, [dc]) -> arity == 1 || arity == 2
291 arity = dataConRepArity dc
297 %************************************************************************
299 \section{Dealing with a single binder}
301 %************************************************************************
304 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
305 simplBinders bndrs thing_inside
306 = getSubst `thenSmpl` \ subst ->
308 (subst', bndrs') = substBndrs subst bndrs
310 seqBndrs bndrs' `seq`
311 setSubst subst' (thing_inside bndrs')
313 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
314 simplBinder bndr thing_inside
315 = getSubst `thenSmpl` \ subst ->
317 (subst', bndr') = substBndr subst bndr
320 setSubst subst' (thing_inside bndr')
323 -- Same semantics as simplBinders, but a little less
324 -- plumbing and hence a little more efficient.
325 -- Maybe not worth the candle?
326 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
327 simplIds ids thing_inside
328 = getSubst `thenSmpl` \ subst ->
330 (subst', bndrs') = substIds subst ids
332 seqBndrs bndrs' `seq`
333 setSubst subst' (thing_inside bndrs')
336 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
338 seqBndr b | isTyVar b = b `seq` ()
339 | otherwise = seqType (idType b) `seq`
345 %************************************************************************
347 \subsection{Transform a RHS}
349 %************************************************************************
351 Try (a) eta expansion
352 (b) type-lambda swizzling
355 transformRhs :: InExpr -> SimplM InExpr
357 = tryEtaExpansion body `thenSmpl` \ body' ->
358 mkRhsTyLam tyvars body'
360 (tyvars, body) = collectTyBinders rhs
364 %************************************************************************
366 \subsection{Local tyvar-lifting}
368 %************************************************************************
370 mkRhsTyLam tries this transformation, when the big lambda appears as
371 the RHS of a let(rec) binding:
373 /\abc -> let(rec) x = e in b
375 let(rec) x' = /\abc -> let x = x' a b c in e
377 /\abc -> let x = x' a b c in b
379 This is good because it can turn things like:
381 let f = /\a -> letrec g = ... g ... in g
383 letrec g' = /\a -> ... g' a ...
387 which is better. In effect, it means that big lambdas don't impede
390 This optimisation is CRUCIAL in eliminating the junk introduced by
391 desugaring mutually recursive definitions. Don't eliminate it lightly!
393 So far as the implemtation is concerned:
395 Invariant: go F e = /\tvs -> F e
399 = Let x' = /\tvs -> F e
403 G = F . Let x = x' tvs
405 go F (Letrec xi=ei in b)
406 = Letrec {xi' = /\tvs -> G ei}
410 G = F . Let {xi = xi' tvs}
412 [May 1999] If we do this transformation *regardless* then we can
413 end up with some pretty silly stuff. For example,
416 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
421 st = /\s -> ...[y1 s/x1, y2 s/x2]
424 Unless the "..." is a WHNF there is really no point in doing this.
425 Indeed it can make things worse. Suppose x1 is used strictly,
428 x1* = case f y of { (a,b) -> e }
430 If we abstract this wrt the tyvar we then can't do the case inline
431 as we would normally do.
435 mkRhsTyLam tyvars body -- Only does something if there's a let
436 | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that
437 = returnSmpl (mkLams tyvars body)
441 worth_it (Let _ e) = whnf_in_middle e
442 worth_it other = False
443 whnf_in_middle (Let _ e) = whnf_in_middle e
444 whnf_in_middle e = exprIsCheap e
446 main_tyvar_set = mkVarSet tyvars
448 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
449 = go (fn . Let bind) body
451 go fn (Let bind@(NonRec var rhs) body)
452 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
453 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
454 returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
457 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
458 -- tyvars_here was an attempt to reduce the number of tyvars
459 -- wrt which the new binding is abstracted. But the naive
460 -- approach of abstract wrt the tyvars free in the Id's type
462 -- /\ a b -> let t :: (a,b) = (e1, e2)
465 -- Here, b isn't free in x's type, but we must nevertheless
466 -- abstract wrt b as well, because t's type mentions b.
467 -- Since t is floated too, we'd end up with the bogus:
468 -- poly_t = /\ a b -> (e1, e2)
469 -- poly_x = /\ a -> fst (poly_t a *b*)
470 -- So for now we adopt the even more naive approach of
471 -- abstracting wrt *all* the tyvars. We'll see if that
472 -- gives rise to problems. SLPJ June 98
476 go fn (Let (Rec prs) body)
477 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
479 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
481 go gn body `thenSmpl` \ body' ->
482 returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
484 (vars,rhss) = unzip prs
486 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
487 -- See notes with tyvars_here above
489 var_tys = map idType vars
491 go fn body = returnSmpl (mkLams tyvars (fn body))
493 mk_poly tyvars_here var
494 = getUniqueSmpl `thenSmpl` \ uniq ->
496 poly_name = setNameUnique (idName var) uniq -- Keep same name
497 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
499 -- It's crucial to copy the occInfo of the original var, because
500 -- we're looking at occurrence-analysed but as yet unsimplified code!
501 -- In particular, we mustn't lose the loop breakers.
503 -- It's even right to retain single-occurrence or dead-var info:
504 -- Suppose we started with /\a -> let x = E in B
505 -- where x occurs once in E. Then we transform to:
506 -- let x' = /\a -> E in /\a -> let x* = x' a in B
507 -- where x* has an INLINE prag on it. Now, once x* is inlined,
508 -- the occurrences of x' will be just the occurrences originaly
510 poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
512 poly_id = mkId poly_name poly_ty poly_info
514 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
516 mk_silly_bind var rhs = NonRec var rhs
517 -- The Inline note is really important! If we don't say
518 -- INLINE on these silly little bindings then look what happens!
519 -- Suppose we start with:
521 -- x = let g = /\a -> \x -> f x x
523 -- /\ b -> let g* = g b in E
525 -- Then: * the binding for g gets floated out
526 -- * but then it gets inlined into the rhs of g*
527 -- * then the binding for g* is floated out of the /\b
528 -- * so we're back to square one
529 -- The silly binding for g* must be INLINEd, so that
530 -- we simply substitute for g* throughout.
534 %************************************************************************
536 \subsection{Eta expansion}
538 %************************************************************************
540 Try eta expansion for RHSs
543 \x1..xn -> N ==> \x1..xn y1..ym -> N y1..ym
545 N E1..En ==> let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
547 where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
548 wanting a suitable number of extra args.
550 NB: the Ei may have unlifted type, but the simplifier (which is applied
551 to the result) deals OK with this.
553 There is no point in looking for a combination of the two,
554 because that would leave use with some lets sandwiched between lambdas;
555 that's what the final test in the first equation is for.
558 tryEtaExpansion :: InExpr -> SimplM InExpr
560 | not opt_SimplDoLambdaEtaExpansion
561 || exprIsTrivial rhs -- Don't eta-expand a trival RHS
562 || null y_tys -- No useful expansion
563 || not (null x_bndrs || and trivial_args) -- Not (no x-binders or no z-binds)
566 | otherwise -- Consider eta expansion
567 = newIds y_tys $ ( \ y_bndrs ->
568 tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
569 mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) ->
570 returnSmpl (mkLams x_bndrs $
571 mkLets (catMaybes maybe_z_binds) $
573 mkApps (mkApps fun z_args) (map Var y_bndrs))))
575 (x_bndrs, body) = collectValBinders rhs
576 (fun, args) = collectArgs body
577 trivial_args = map exprIsTrivial args
578 fun_arity = exprEtaExpandArity fun
580 bind_z_arg (arg, trivial_arg)
581 | trivial_arg = returnSmpl (Nothing, arg)
582 | otherwise = newId (exprType arg) $ \ z ->
583 returnSmpl (Just (NonRec z arg), Var z)
585 -- Note: I used to try to avoid the exprType call by using
586 -- the type of the binder. But this type doesn't necessarily
587 -- belong to the same substitution environment as this rhs;
588 -- and we are going to make extra term binders (y_bndrs) from the type
589 -- which will be processed with the rhs substitution environment.
590 -- This only went wrong in a mind bendingly complicated case.
591 (potential_extra_arg_tys, inner_ty) = splitFunTys (exprType body)
594 y_tys = take no_extras_wanted potential_extra_arg_tys
596 no_extras_wanted :: Int
597 no_extras_wanted = 0 `max`
599 -- We used to expand the arity to the previous arity fo the
600 -- function; but this is pretty dangerous. Consdier
602 -- so that f has arity 2. Now float something into f's RHS:
603 -- f = let z = BIG in \xy -> e
604 -- The last thing we want to do now is to put some lambdas
606 -- f = \xy -> let z = BIG in e
608 -- (bndr_arity - no_of_xs) `max`
610 -- See if the body could obviously do with more args
611 (fun_arity - valArgCount args)
613 -- This case is now deal with by exprEtaExpandArity
614 -- Finally, see if it's a state transformer, and xs is non-null
615 -- (so it's also a function not a thunk) in which
616 -- case we eta-expand on principle! This can waste work,
617 -- but usually doesn't.
618 -- I originally checked for a singleton type [ty] in this case
619 -- but then I found a situation in which I had
620 -- \ x -> let {..} in \ s -> f (...) s
621 -- AND f RETURNED A FUNCTION. That is, 's' wasn't the only
622 -- potential extra arg.
623 -- case (x_bndrs, potential_extra_arg_tys) of
624 -- (_:_, ty:_) -> case splitTyConApp_maybe ty of
625 -- Just (tycon,_) | tycon == statePrimTyCon -> 1
631 %************************************************************************
633 \subsection{Case absorption and identity-case elimination}
635 %************************************************************************
638 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
641 @mkCase@ tries the following transformation (if possible):
643 case e of b { ==> case e of b {
644 p1 -> rhs1 p1 -> rhs1
646 pm -> rhsm pm -> rhsm
647 _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn}
648 {or (prim) case b of b' { _ -> rhsn}}
651 po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd}
655 which merges two cases in one case when -- the default alternative of
656 the outer case scrutises the same variable as the outer case This
657 transformation is called Case Merging. It avoids that the same
658 variable is scrutinised multiple times.
661 mkCase scrut outer_bndr outer_alts
663 && maybeToBool maybe_case_in_default
665 = tick (CaseMerge outer_bndr) `thenSmpl_`
666 returnSmpl (Case scrut outer_bndr new_alts)
667 -- Warning: don't call mkCase recursively!
668 -- Firstly, there's no point, because inner alts have already had
669 -- mkCase applied to them, so they won't have a case in their default
670 -- Secondly, if you do, you get an infinite loop, because the bindNonRec
671 -- in munge_rhs puts a case into the DEFAULT branch!
673 new_alts = outer_alts_without_deflt ++ munged_inner_alts
674 maybe_case_in_default = case findDefault outer_alts of
675 (outer_alts_without_default,
676 Just (Case (Var scrut_var) inner_bndr inner_alts))
678 | outer_bndr == scrut_var
679 -> Just (outer_alts_without_default, inner_bndr, inner_alts)
682 Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
684 -- Eliminate any inner alts which are shadowed by the outer ones
685 outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
687 munged_inner_alts = [ (con, args, munge_rhs rhs)
688 | (con, args, rhs) <- inner_alts,
689 not (con `elem` outer_cons) -- Eliminate shadowed inner alts
691 munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
694 Now the identity-case transformation:
703 mkCase scrut case_bndr alts
704 | all identity_alt alts
705 = tick (CaseIdentity case_bndr) `thenSmpl_`
708 identity_alt (DEFAULT, [], Var v) = v == case_bndr
709 identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
710 (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
711 identity_alt other = False
713 arg_tys = case splitTyConApp_maybe (idType case_bndr) of
714 Just (tycon, arg_tys) -> arg_tys
720 mkCase other_scrut case_bndr other_alts
721 = returnSmpl (Case other_scrut case_bndr other_alts)
726 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
727 findDefault [] = ([], Nothing)
728 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
730 findDefault (alt : alts) = case findDefault alts of
731 (alts', deflt) -> (alt : alts', deflt)
733 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
737 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
738 go (alt : alts) | matches alt = alt
739 | otherwise = go alts
741 matches (DEFAULT, _, _) = True
742 matches (con1, _, _) = con == con1