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 PprCore ( {- instance Outputable Expr -} )
25 import CoreUnfold ( isValueUnfolding )
26 import CoreFVs ( exprFreeVars )
27 import CoreUtils ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
28 import Subst ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
29 import Id ( Id, idType, isId, idName,
30 idOccInfo, idUnfolding,
33 import IdInfo ( arityLowerBound, setOccInfo, vanillaIdInfo )
34 import Maybes ( maybeToBool, catMaybes )
35 import Name ( isLocalName, setNameUnique )
37 import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
38 splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
40 import TyCon ( tyConDataConsIfAvailable )
41 import PprType ( {- instance Outputable Type -} )
42 import DataCon ( dataConRepArity )
43 import TysPrim ( statePrimTyCon )
44 import Var ( setVarUnique )
46 import VarEnv ( SubstEnv, SubstResult(..) )
47 import UniqSupply ( splitUniqSupply, uniqFromSupply )
48 import Util ( zipWithEqual, mapAccumL )
53 %************************************************************************
55 \subsection{The continuation data type}
57 %************************************************************************
60 data SimplCont -- Strict contexts
61 = Stop OutType -- Type of the result
63 | CoerceIt OutType -- The To-type, simplified
66 | InlinePlease -- This continuation makes a function very
67 SimplCont -- keen to inline itelf
70 InExpr SubstEnv -- The argument, as yet unsimplified,
71 SimplCont -- and its subst-env
74 InId [InAlt] SubstEnv -- The case binder, alts, and subst-env
77 | ArgOf DupFlag -- An arbitrary strict context: the argument
78 -- of a strict function, or a primitive-arg fn
80 OutType -- The type of the expression being sought by the context
81 -- f (error "foo") ==> coerce t (error "foo")
83 -- We need to know the type t, to which to coerce.
84 (OutExpr -> SimplM OutExprStuff) -- What to do with the result
86 instance Outputable SimplCont where
87 ppr (Stop _) = ptext SLIT("Stop")
88 ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
89 ppr (ArgOf dup _ _) = ptext SLIT("ArgOf...") <+> ppr dup
90 ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
91 (nest 4 (ppr alts)) $$ ppr cont
92 ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
93 ppr (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
95 data DupFlag = OkToDup | NoDup
97 instance Outputable DupFlag where
98 ppr OkToDup = ptext SLIT("ok")
99 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
110 pushArgs :: SubstEnv -> [InExpr] -> SimplCont -> SimplCont
111 pushArgs se [] cont = cont
112 pushArgs se (arg:args) cont = ApplyTo NoDup arg se (pushArgs se args cont)
114 discardCont :: SimplCont -- A continuation, expecting
115 -> SimplCont -- Replace the continuation with a suitable coerce
116 discardCont (Stop to_ty) = Stop to_ty
117 discardCont cont = CoerceIt to_ty (Stop to_ty)
119 to_ty = contResultType cont
121 contResultType :: SimplCont -> OutType
122 contResultType (Stop to_ty) = to_ty
123 contResultType (ArgOf _ to_ty _) = to_ty
124 contResultType (ApplyTo _ _ _ cont) = contResultType cont
125 contResultType (CoerceIt _ cont) = contResultType cont
126 contResultType (InlinePlease cont) = contResultType cont
127 contResultType (Select _ _ _ _ cont) = contResultType cont
129 countValArgs :: SimplCont -> Int
130 countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
131 countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
132 countValArgs other = 0
134 countArgs :: SimplCont -> Int
135 countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
140 Comment about analyseCont
141 ~~~~~~~~~~~~~~~~~~~~~~~~~
142 We want to avoid inlining an expression where there can't possibly be
143 any gain, such as in an argument position. Hence, if the continuation
144 is interesting (eg. a case scrutinee, application etc.) then we
145 inline, otherwise we don't.
147 Previously some_benefit used to return True only if the variable was
148 applied to some value arguments. This didn't work:
150 let x = _coerce_ (T Int) Int (I# 3) in
151 case _coerce_ Int (T Int) x of
154 we want to inline x, but can't see that it's a constructor in a case
155 scrutinee position, and some_benefit is False.
159 dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)
161 .... case dMonadST _@_ x0 of (a,b,c) -> ....
163 we'd really like to inline dMonadST here, but we *don't* want to
164 inline if the case expression is just
166 case x of y { DEFAULT -> ... }
168 since we can just eliminate this case instead (x is in WHNF). Similar
169 applies when x is bound to a lambda expression. Hence
170 contIsInteresting looks for case expressions with just a single
174 analyseCont :: InScopeSet -> SimplCont
175 -> ([Bool], -- Arg-info flags; one for each value argument
176 Bool, -- Context of the result of the call is interesting
177 Bool) -- There was an InlinePlease
179 analyseCont in_scope cont
181 -- The "lone-variable" case is important. I spent ages
182 -- messing about with unsatisfactory varaints, but this is nice.
183 -- The idea is that if a variable appear all alone
184 -- as an arg of lazy fn, or rhs Stop
185 -- as scrutinee of a case Select
186 -- as arg of a strict fn ArgOf
187 -- then we should not inline it (unless there is some other reason,
188 -- e.g. is is the sole occurrence).
189 -- Why not? At least in the case-scrutinee situation, turning
190 -- case x of y -> ...
192 -- let y = (a,b) in ...
193 -- is bad if the binding for x will remain.
195 -- Another example: I discovered that strings
196 -- were getting inlined straight back into applications of 'error'
197 -- because the latter is strict.
199 -- f = \x -> ...(error s)...
201 -- Fundamentally such contexts should not ecourage inlining becuase
202 -- the context can ``see'' the unfolding of the variable (e.g. case or a RULE)
203 -- so there's no gain.
205 -- However, even a type application isn't a lone variable. Consider
206 -- case $fMonadST @ RealWorld of { :DMonad a b c -> c }
207 -- We had better inline that sucker! The case won't see through it.
209 (Stop _) -> boring_result -- Don't inline a lone variable
210 (Select _ _ _ _ _) -> boring_result -- Ditto
211 (ArgOf _ _ _) -> boring_result -- Ditto
212 (ApplyTo _ (Type _) _ cont) -> analyse_ty_app cont
213 other -> analyse_app cont
215 boring_result = ([], False, False)
217 -- For now, I'm treating not treating a variable applied to types as
218 -- "lone". The motivating example was
220 -- g = /\a. \y. h (f a)
221 -- There's no advantage in inlining f here, and perhaps
222 -- a significant disadvantage.
223 analyse_ty_app (Stop _) = boring_result
224 analyse_ty_app (ArgOf _ _ _) = boring_result
225 analyse_ty_app (Select _ _ _ _ _) = ([], True, False) -- See the $fMonadST example above
226 analyse_ty_app (ApplyTo _ (Type _) _ cont) = analyse_ty_app cont
227 analyse_ty_app cont = analyse_app cont
229 analyse_app (InlinePlease cont)
230 = case analyse_app cont of
231 (infos, icont, inline) -> (infos, icont, True)
233 analyse_app (ApplyTo _ arg subst cont)
234 | isValArg arg = case analyse_app cont of
235 (infos, icont, inline) -> (analyse_arg subst arg : infos, icont, inline)
236 | otherwise = analyse_app cont
238 analyse_app cont = ([], interesting_call_context cont, False)
240 -- An argument is interesting if it has *some* structure
241 -- We are here trying to avoid unfolding a function that
242 -- is applied only to variables that have no unfolding
243 -- (i.e. they are probably lambda bound): f x y z
244 -- There is little point in inlining f here.
245 analyse_arg :: SubstEnv -> InExpr -> Bool
246 analyse_arg subst (Var v) = case lookupIdSubst (mkSubst in_scope subst) v of
247 DoneId v' _ -> isValueUnfolding (idUnfolding v')
249 analyse_arg subst (Type _) = False
250 analyse_arg subst (App fn (Type _)) = analyse_arg subst fn
251 analyse_arg subst (Note _ a) = analyse_arg subst a
252 analyse_arg subst other = True
254 interesting_call_context (Stop ty) = canUpdateInPlace ty
255 interesting_call_context (InlinePlease _) = True
256 interesting_call_context (Select _ _ _ _ _) = True
257 interesting_call_context (CoerceIt _ cont) = interesting_call_context cont
258 interesting_call_context (ApplyTo _ (Type _) _ cont) = interesting_call_context cont
259 interesting_call_context (ApplyTo _ _ _ _) = True
260 interesting_call_context (ArgOf _ _ _) = True
261 -- If this call is the arg of a strict function, the context
262 -- is a bit interesting. If we inline here, we may get useful
263 -- evaluation information to avoid repeated evals: e.g.
265 -- Here the contIsInteresting makes the '*' keener to inline,
266 -- which in turn exposes a constructor which makes the '+' inline.
267 -- Assuming that +,* aren't small enough to inline regardless.
269 -- It's also very important to inline in a strict context for things
272 -- Here, the context of (f x) is strict, and if f's unfolding is
273 -- a build it's *great* to inline it here. So we must ensure that
274 -- the context for (f x) is not totally uninteresting.
277 discardInline :: SimplCont -> SimplCont
278 discardInline (InlinePlease cont) = cont
279 discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
280 discardInline cont = cont
282 -- Consider let x = <wurble> in ...
283 -- If <wurble> returns an explicit constructor, we might be able
284 -- to do update in place. So we treat even a thunk RHS context
285 -- as interesting if update in place is possible. We approximate
286 -- this by seeing if the type has a single constructor with a
287 -- small arity. But arity zero isn't good -- we share the single copy
288 -- for that case, so no point in sharing.
290 -- Note the repType: we want to look through newtypes for this purpose
292 canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of {
296 case tyConDataConsIfAvailable tycon of
297 [dc] -> arity == 1 || arity == 2
299 arity = dataConRepArity dc
306 %************************************************************************
308 \section{Dealing with a single binder}
310 %************************************************************************
313 simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
314 simplBinders bndrs thing_inside
315 = getSubst `thenSmpl` \ subst ->
317 (subst', bndrs') = substBndrs subst bndrs
319 seqBndrs bndrs' `seq`
320 setSubst subst' (thing_inside bndrs')
322 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
323 simplBinder bndr thing_inside
324 = getSubst `thenSmpl` \ subst ->
326 (subst', bndr') = substBndr subst bndr
329 setSubst subst' (thing_inside bndr')
332 -- Same semantics as simplBinders, but a little less
333 -- plumbing and hence a little more efficient.
334 -- Maybe not worth the candle?
335 simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
336 simplIds ids thing_inside
337 = getSubst `thenSmpl` \ subst ->
339 (subst', bndrs') = substIds subst ids
341 seqBndrs bndrs' `seq`
342 setSubst subst' (thing_inside bndrs')
345 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
347 seqBndr b | isTyVar b = b `seq` ()
348 | otherwise = seqType (idType b) `seq`
354 %************************************************************************
356 \subsection{Transform a RHS}
358 %************************************************************************
360 Try (a) eta expansion
361 (b) type-lambda swizzling
364 transformRhs :: InExpr -> SimplM InExpr
366 = tryEtaExpansion body `thenSmpl` \ body' ->
367 mkRhsTyLam tyvars body'
369 (tyvars, body) = collectTyBinders rhs
373 %************************************************************************
375 \subsection{Local tyvar-lifting}
377 %************************************************************************
379 mkRhsTyLam tries this transformation, when the big lambda appears as
380 the RHS of a let(rec) binding:
382 /\abc -> let(rec) x = e in b
384 let(rec) x' = /\abc -> let x = x' a b c in e
386 /\abc -> let x = x' a b c in b
388 This is good because it can turn things like:
390 let f = /\a -> letrec g = ... g ... in g
392 letrec g' = /\a -> ... g' a ...
396 which is better. In effect, it means that big lambdas don't impede
399 This optimisation is CRUCIAL in eliminating the junk introduced by
400 desugaring mutually recursive definitions. Don't eliminate it lightly!
402 So far as the implemtation is concerned:
404 Invariant: go F e = /\tvs -> F e
408 = Let x' = /\tvs -> F e
412 G = F . Let x = x' tvs
414 go F (Letrec xi=ei in b)
415 = Letrec {xi' = /\tvs -> G ei}
419 G = F . Let {xi = xi' tvs}
421 [May 1999] If we do this transformation *regardless* then we can
422 end up with some pretty silly stuff. For example,
425 st = /\ s -> let { x1=r1 ; x2=r2 } in ...
430 st = /\s -> ...[y1 s/x1, y2 s/x2]
433 Unless the "..." is a WHNF there is really no point in doing this.
434 Indeed it can make things worse. Suppose x1 is used strictly,
437 x1* = case f y of { (a,b) -> e }
439 If we abstract this wrt the tyvar we then can't do the case inline
440 as we would normally do.
444 mkRhsTyLam tyvars body -- Only does something if there's a let
445 | null tyvars || not (worth_it body) -- inside a type lambda, and a WHNF inside that
446 = returnSmpl (mkLams tyvars body)
450 worth_it (Let _ e) = whnf_in_middle e
451 worth_it other = False
452 whnf_in_middle (Let _ e) = whnf_in_middle e
453 whnf_in_middle e = exprIsCheap e
455 main_tyvar_set = mkVarSet tyvars
457 go fn (Let bind@(NonRec var rhs) body) | exprIsTrivial rhs
458 = go (fn . Let bind) body
460 go fn (Let bind@(NonRec var rhs) body)
461 = mk_poly tyvars_here var `thenSmpl` \ (var', rhs') ->
462 go (fn . Let (mk_silly_bind var rhs')) body `thenSmpl` \ body' ->
463 returnSmpl (Let (NonRec var' (mkLams tyvars_here (fn rhs))) body')
466 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfType var_ty)
467 -- tyvars_here was an attempt to reduce the number of tyvars
468 -- wrt which the new binding is abstracted. But the naive
469 -- approach of abstract wrt the tyvars free in the Id's type
471 -- /\ a b -> let t :: (a,b) = (e1, e2)
474 -- Here, b isn't free in x's type, but we must nevertheless
475 -- abstract wrt b as well, because t's type mentions b.
476 -- Since t is floated too, we'd end up with the bogus:
477 -- poly_t = /\ a b -> (e1, e2)
478 -- poly_x = /\ a -> fst (poly_t a *b*)
479 -- So for now we adopt the even more naive approach of
480 -- abstracting wrt *all* the tyvars. We'll see if that
481 -- gives rise to problems. SLPJ June 98
485 go fn (Let (Rec prs) body)
486 = mapAndUnzipSmpl (mk_poly tyvars_here) vars `thenSmpl` \ (vars', rhss') ->
488 gn body = fn $ foldr Let body (zipWith mk_silly_bind vars rhss')
490 go gn body `thenSmpl` \ body' ->
491 returnSmpl (Let (Rec (vars' `zip` [mkLams tyvars_here (gn rhs) | rhs <- rhss])) body')
493 (vars,rhss) = unzip prs
495 -- varSetElems (main_tyvar_set `intersectVarSet` tyVarsOfTypes var_tys)
496 -- See notes with tyvars_here above
498 var_tys = map idType vars
500 go fn body = returnSmpl (mkLams tyvars (fn body))
502 mk_poly tyvars_here var
503 = getUniqueSmpl `thenSmpl` \ uniq ->
505 poly_name = setNameUnique (idName var) uniq -- Keep same name
506 poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
508 -- It's crucial to copy the occInfo of the original var, because
509 -- we're looking at occurrence-analysed but as yet unsimplified code!
510 -- In particular, we mustn't lose the loop breakers.
512 -- It's even right to retain single-occurrence or dead-var info:
513 -- Suppose we started with /\a -> let x = E in B
514 -- where x occurs once in E. Then we transform to:
515 -- let x' = /\a -> E in /\a -> let x* = x' a in B
516 -- where x* has an INLINE prag on it. Now, once x* is inlined,
517 -- the occurrences of x' will be just the occurrences originaly
519 poly_info = vanillaIdInfo `setOccInfo` idOccInfo var
521 poly_id = mkId poly_name poly_ty poly_info
523 returnSmpl (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tyvars_here))
525 mk_silly_bind var rhs = NonRec var rhs
526 -- The Inline note is really important! If we don't say
527 -- INLINE on these silly little bindings then look what happens!
528 -- Suppose we start with:
530 -- x = let g = /\a -> \x -> f x x
532 -- /\ b -> let g* = g b in E
534 -- Then: * the binding for g gets floated out
535 -- * but then it gets inlined into the rhs of g*
536 -- * then the binding for g* is floated out of the /\b
537 -- * so we're back to square one
538 -- The silly binding for g* must be INLINEd, so that
539 -- we simply substitute for g* throughout.
543 %************************************************************************
545 \subsection{Eta expansion}
547 %************************************************************************
549 Try eta expansion for RHSs
552 \x1..xn -> N ==> \x1..xn y1..ym -> N y1..ym
554 N E1..En ==> let z1=E1 .. zn=En in \y1..ym -> N z1..zn y1..ym
556 where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
557 wanting a suitable number of extra args.
559 NB: the Ei may have unlifted type, but the simplifier (which is applied
560 to the result) deals OK with this.
562 There is no point in looking for a combination of the two,
563 because that would leave use with some lets sandwiched between lambdas;
564 that's what the final test in the first equation is for.
567 tryEtaExpansion :: InExpr -> SimplM InExpr
569 | not opt_SimplDoLambdaEtaExpansion
570 || exprIsTrivial rhs -- Don't eta-expand a trival RHS
571 || null y_tys -- No useful expansion
572 || not (null x_bndrs || and trivial_args) -- Not (no x-binders or no z-binds)
575 | otherwise -- Consider eta expansion
576 = newIds SLIT("y") y_tys $ ( \ y_bndrs ->
577 tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
578 mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) ->
579 returnSmpl (mkLams x_bndrs $
580 mkLets (catMaybes maybe_z_binds) $
582 mkApps (mkApps fun z_args) (map Var y_bndrs))))
584 (x_bndrs, body) = collectValBinders rhs
585 (fun, args) = collectArgs body
586 trivial_args = map exprIsTrivial args
587 fun_arity = exprEtaExpandArity fun
589 bind_z_arg (arg, trivial_arg)
590 | trivial_arg = returnSmpl (Nothing, arg)
591 | otherwise = newId SLIT("z") (exprType arg) $ \ z ->
592 returnSmpl (Just (NonRec z arg), Var z)
594 -- Note: I used to try to avoid the exprType call by using
595 -- the type of the binder. But this type doesn't necessarily
596 -- belong to the same substitution environment as this rhs;
597 -- and we are going to make extra term binders (y_bndrs) from the type
598 -- which will be processed with the rhs substitution environment.
599 -- This only went wrong in a mind bendingly complicated case.
600 (potential_extra_arg_tys, inner_ty) = splitFunTys (exprType body)
603 y_tys = take no_extras_wanted potential_extra_arg_tys
605 no_extras_wanted :: Int
606 no_extras_wanted = 0 `max`
608 -- We used to expand the arity to the previous arity fo the
609 -- function; but this is pretty dangerous. Consdier
611 -- so that f has arity 2. Now float something into f's RHS:
612 -- f = let z = BIG in \xy -> e
613 -- The last thing we want to do now is to put some lambdas
615 -- f = \xy -> let z = BIG in e
617 -- (bndr_arity - no_of_xs) `max`
619 -- See if the body could obviously do with more args
620 (fun_arity - valArgCount args)
622 -- This case is now deal with by exprEtaExpandArity
623 -- Finally, see if it's a state transformer, and xs is non-null
624 -- (so it's also a function not a thunk) in which
625 -- case we eta-expand on principle! This can waste work,
626 -- but usually doesn't.
627 -- I originally checked for a singleton type [ty] in this case
628 -- but then I found a situation in which I had
629 -- \ x -> let {..} in \ s -> f (...) s
630 -- AND f RETURNED A FUNCTION. That is, 's' wasn't the only
631 -- potential extra arg.
632 -- case (x_bndrs, potential_extra_arg_tys) of
633 -- (_:_, ty:_) -> case splitTyConApp_maybe ty of
634 -- Just (tycon,_) | tycon == statePrimTyCon -> 1
640 %************************************************************************
642 \subsection{Case absorption and identity-case elimination}
644 %************************************************************************
647 mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
650 @mkCase@ tries the following transformation (if possible):
652 case e of b { ==> case e of b {
653 p1 -> rhs1 p1 -> rhs1
655 pm -> rhsm pm -> rhsm
656 _ -> case b of b' { pn -> rhsn[b/b'] {or (alg) let b=b' in rhsn}
657 {or (prim) case b of b' { _ -> rhsn}}
660 po -> rhso _ -> rhsd[b/b'] {or let b'=b in rhsd}
664 which merges two cases in one case when -- the default alternative of
665 the outer case scrutises the same variable as the outer case This
666 transformation is called Case Merging. It avoids that the same
667 variable is scrutinised multiple times.
670 mkCase scrut outer_bndr outer_alts
672 && maybeToBool maybe_case_in_default
674 = tick (CaseMerge outer_bndr) `thenSmpl_`
675 returnSmpl (Case scrut outer_bndr new_alts)
676 -- Warning: don't call mkCase recursively!
677 -- Firstly, there's no point, because inner alts have already had
678 -- mkCase applied to them, so they won't have a case in their default
679 -- Secondly, if you do, you get an infinite loop, because the bindNonRec
680 -- in munge_rhs puts a case into the DEFAULT branch!
682 new_alts = outer_alts_without_deflt ++ munged_inner_alts
683 maybe_case_in_default = case findDefault outer_alts of
684 (outer_alts_without_default,
685 Just (Case (Var scrut_var) inner_bndr inner_alts))
687 | outer_bndr == scrut_var
688 -> Just (outer_alts_without_default, inner_bndr, inner_alts)
691 Just (outer_alts_without_deflt, inner_bndr, inner_alts) = maybe_case_in_default
693 -- Eliminate any inner alts which are shadowed by the outer ones
694 outer_cons = [con | (con,_,_) <- outer_alts_without_deflt]
696 munged_inner_alts = [ (con, args, munge_rhs rhs)
697 | (con, args, rhs) <- inner_alts,
698 not (con `elem` outer_cons) -- Eliminate shadowed inner alts
700 munge_rhs rhs = bindNonRec inner_bndr (Var outer_bndr) rhs
703 Now the identity-case transformation:
712 mkCase scrut case_bndr alts
713 | all identity_alt alts
714 = tick (CaseIdentity case_bndr) `thenSmpl_`
717 identity_alt (DEFAULT, [], Var v) = v == case_bndr
718 identity_alt (DataAlt con, args, rhs) = cheapEqExpr rhs
719 (mkConApp con (map Type arg_tys ++ map varToCoreExpr args))
720 identity_alt other = False
722 arg_tys = case splitTyConApp_maybe (idType case_bndr) of
723 Just (tycon, arg_tys) -> arg_tys
729 mkCase other_scrut case_bndr other_alts
730 = returnSmpl (Case other_scrut case_bndr other_alts)
735 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
736 findDefault [] = ([], Nothing)
737 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
739 findDefault (alt : alts) = case findDefault alts of
740 (alts', deflt) -> (alt : alts', deflt)
742 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
746 go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
747 go (alt : alts) | matches alt = alt
748 | otherwise = go alts
750 matches (DEFAULT, _, _) = True
751 matches (con1, _, _) = con == con1