2 % (c) The AQUA Project, Glasgow University, 1994-1995
4 \section[SimplCase]{Simplification of `case' expression}
6 Support code for @Simplify@.
9 #include "HsVersions.h"
11 module SimplCase ( simplCase, bindLargeRhs ) where
16 import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), PrimOp,
17 voidPrimTy, voidPrimId, mkFunTy, primOpOkForSpeculation
18 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
19 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
21 import Type ( splitSigmaTy, splitTyArgs, glueTyArgs,
22 getTyConFamilySize, isPrimType,
25 import Literal ( isNoRepLit, Literal )
26 import CmdLineOpts ( SimplifierSwitch(..) )
29 import Maybes ( catMaybes, maybeToBool, Maybe(..) )
32 import SimplVar ( completeVar )
40 Float let out of case.
44 -> InExpr -- Scrutinee
45 -> InAlts -- Alternatives
46 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
47 -> OutUniType -- Type of result expression
50 simplCase env (Let bind body) alts rhs_c result_ty
51 | not (switchIsSet env SimplNoLetFromCase)
52 = -- Float the let outside the case scrutinee (if not disabled by flag)
53 tick LetFloatFromCase `thenSmpl_`
54 simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
57 OK to do case-of-case if
59 * we allow arbitrary code duplication
63 * the inner case has one alternative
64 case (case e of (a,b) -> rhs) of
75 IF neither of these two things are the case, we avoid code-duplication
76 by abstracting the outer rhss wrt the pattern variables. For example
78 case (case e of { p1->rhs1; ...; pn -> rhsn }) of
84 p1 -> case rhs1 of (x,y) -> b x y
86 pn -> case rhsn of (x,y) -> b x y
89 OK, so outer case expression gets duplicated, but that's all. Furthermore,
90 (a) the binding for "b" will be let-no-escaped, so no heap allocation
91 will take place; the "call" to b will simply be a stack adjustment
93 (b) very commonly, at least some of the rhsi's will be constructors, which
94 makes life even simpler.
96 All of this works equally well if the outer case has multiple rhss.
100 simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
101 | switchIsSet env SimplCaseOfCase
102 = -- Ha! Do case-of-case
103 tick CaseOfCase `thenSmpl_`
105 if no_need_to_bind_large_alts
107 simplCase env inner_scrut inner_alts
108 (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
110 bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
112 rhs_c' = \env rhs -> simplExpr env rhs []
114 simplCase env inner_scrut inner_alts
115 (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
117 `thenSmpl` \ case_expr ->
118 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
121 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
122 isSingleton (nonErrorRHSs inner_alts)
125 Case of an application of error.
128 simplCase env scrut alts rhs_c result_ty
129 | maybeToBool maybe_error_app
130 = -- Look for an application of an error id
131 tick CaseOfError `thenSmpl_`
132 rhs_c env retyped_error_app
134 alts_ty = coreAltsType (unTagBindersAlts alts)
135 maybe_error_app = maybeErrorApp scrut (Just alts_ty)
136 Just retyped_error_app = maybe_error_app
139 Finally the default case
142 simplCase env other_scrut alts rhs_c result_ty
143 = -- Float the let outside the case scrutinee
144 simplExpr env other_scrut [] `thenSmpl` \ scrut' ->
145 completeCase env scrut' alts rhs_c
149 %************************************************************************
151 \subsection[Simplify-case]{Completing case-expression simplification}
153 %************************************************************************
158 -> OutExpr -- The already-simplified scrutinee
159 -> InAlts -- The un-simplified alternatives
160 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
161 -> SmplM OutExpr -- The whole case expression
164 Scrutinising a literal or constructor.
165 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
166 It's an obvious win to do:
168 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
170 and the similar thing for primitive case. If we have
174 and x is known to be of constructor form, then we'll already have
175 inlined the constructor to give (case (C a b) of ...), so we don't
176 need to check for the variable case separately.
178 Sanity check: we don't have a good
179 story to tell about case analysis on NoRep things. ToDo.
182 completeCase env (Lit lit) alts rhs_c
183 | not (isNoRepLit lit)
184 = -- Ha! Select the appropriate alternative
185 tick KnownBranch `thenSmpl_`
186 completePrimCaseWithKnownLit env lit alts rhs_c
188 completeCase env expr@(Con con tys con_args) alts rhs_c
189 = -- Ha! Staring us in the face -- select the appropriate alternative
190 tick KnownBranch `thenSmpl_`
191 completeAlgCaseWithKnownCon env con tys con_args alts rhs_c
196 Start with a simple situation:
198 case x# of ===> e[x#/y#]
201 (when x#, y# are of primitive type, of course).
202 We can't (in general) do this for algebraic cases, because we might
203 turn bottom into non-bottom!
205 Actually, we generalise this idea to look for a case where we're
206 scrutinising a variable, and we know that only the default case can
211 other -> ...(case x of
215 Here the inner case can be eliminated. This really only shows up in
216 eliminating error-checking code.
218 Lastly, we generalise the transformation to handle this:
224 We only do this for very cheaply compared r's (constructors, literals
225 and variables). If pedantic bottoms is on, we only do it when the
226 scrutinee is a PrimOp which can't fail.
228 We do it *here*, looking at un-simplified alternatives, because we
229 have to check that r doesn't mention the variables bound by the
230 pattern in each alternative, so the binder-info is rather useful.
232 So the case-elimination algorithm is:
234 1. Eliminate alternatives which can't match
236 2. Check whether all the remaining alternatives
237 (a) do not mention in their rhs any of the variables bound in their pattern
238 and (b) have equal rhss
240 3. Check we can safely ditch the case:
241 * PedanticBottoms is off,
242 or * the scrutinee is an already-evaluated variable
243 or * the scrutinee is a primop which is ok for speculation
244 -- ie we want to preserve divide-by-zero errors, and
245 -- calls to error itself!
247 or * [Prim cases] the scrutinee is a primitive variable
249 or * [Alg cases] the scrutinee is a variable and
250 either * the rhs is the same variable
251 (eg case x of C a b -> x ===> x)
252 or * there is only one alternative, the default alternative,
253 and the binder is used strictly in its scope.
254 [NB this is helped by the "use default binder where
255 possible" transformation; see below.]
258 If so, then we can replace the case with one of the rhss.
261 completeCase env scrut alts rhs_c
262 | switchIsSet env SimplDoCaseElim &&
268 (not (switchIsSet env SimplPedanticBottoms) ||
270 scrut_is_eliminable_primitive ||
272 scrut_is_var_and_single_strict_default
275 = tick CaseElim `thenSmpl_`
278 -- Find the non-excluded rhss of the case; always at least one
279 (rhs1:rhss) = possible_rhss
280 all_rhss_same = all (cheap_eq rhs1) rhss
282 -- Find the reduced set of possible rhss, along with an indication of
283 -- whether none of their binders are used
284 (binders_unused, possible_rhss, new_env)
286 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
290 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
292 -- Eliminate unused rhss if poss
293 rhss = case scrut_form of
294 OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
295 not (alt_lit `is_elem` not_these)
297 other -> [rhs | (_,rhs) <- alts]
299 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
300 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
303 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
305 -- Eliminate unused alts if poss
306 possible_alts = case scrut_form of
307 OtherConForm not_these ->
308 -- Remove alts which can't match
309 [alt | alt@(alt_con,_,_) <- alts,
310 not (alt_con `is_elem` not_these)]
313 -- ConForm c t v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppr PprDebug t, ppr PprDebug v]) (ppr PprDebug alts))
314 -- ConForm can't happen, since we'd have
315 -- inlined it, and be in completeCaseWithKnownCon by now
319 alt_binders_unused (con, args, rhs) = all is_dead args
320 is_dead (_, DeadCode) = True
321 is_dead other_arg = False
323 -- If the scrutinee is a variable, look it up to see what we know about it
324 scrut_form = case scrut of
325 Var v -> lookupUnfolding env v
326 other -> NoUnfoldingDetails
328 -- If the scrut is already eval'd then there's no worry about
329 -- eliminating the case
330 scrut_is_evald = case scrut_form of
331 OtherLitForm _ -> True
332 ConForm _ _ _ -> True
333 OtherConForm _ -> True
337 scrut_is_eliminable_primitive
339 Prim op _ _ -> primOpOkForSpeculation op
340 Var _ -> case alts of
341 PrimAlts _ _ -> True -- Primitive, hence non-bottom
342 AlgAlts _ _ -> False -- Not primitive
345 -- case v of w -> e{strict in w} ===> e[v/w]
346 scrut_is_var_and_single_strict_default
348 Var _ -> case alts of
349 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
353 elim_deflt_binder NoDefault -- No Binder
355 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
357 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
359 Var v -> -- Binder used, but can be eliminated in favour of scrut
360 (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
361 non_var -> -- Binder used, and can't be elimd
364 -- Check whether the chosen unique rhs (ie rhs1) is the same as
365 -- the scrutinee. Remember that the rhs is as yet unsimplified.
366 rhs1_is_scrutinee = case (scrut, rhs1) of
367 (Var scrut_var, Var rhs_var)
368 -> case lookupId env rhs_var of
369 Just (ItsAnAtom (VarArg rhs_var'))
370 -> rhs_var' == scrut_var
374 is_elem x ys = isIn "completeCase" x ys
377 Scrutinising anything else. If it's a variable, it can't be bound to a
378 constructor or literal, because that would have been inlined
381 completeCase env scrut alts rhs_c
382 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
390 bindLargeAlts :: SimplEnv
392 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
393 -> OutUniType -- Result type
394 -> SmplM ([OutBinding], -- Extra bindings
395 InAlts) -- Modified alts
397 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
398 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
399 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
400 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
402 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
403 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
404 returnSmpl (bind, (con,args,rhs'))
406 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
407 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
408 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
409 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
411 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
412 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
413 returnSmpl (bind, (lit,rhs'))
415 bindLargeDefault env NoDefault rhs_ty rhs_c
416 = returnSmpl ([], NoDefault)
417 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
418 = bindLargeRhs env [binder] rhs_ty
419 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
420 returnSmpl ([bind], BindDefault binder rhs')
423 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
424 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
428 bindLargeRhs :: SimplEnv
429 -> [InBinder] -- The args wrt which the rhs should be abstracted
431 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
432 -> SmplM (OutBinding, -- New bindings (singleton or empty)
433 InExpr) -- Modified rhs
435 bindLargeRhs env args rhs_ty rhs_c
436 | null used_args && isPrimType rhs_ty
437 -- If we try to lift a primitive-typed something out
438 -- for let-binding-purposes, we will *caseify* it (!),
439 -- with potentially-disastrous strictness results. So
440 -- instead we turn it into a function: \v -> e
441 -- where v::VoidPrim. Since arguments of type
442 -- VoidPrim don't generate any code, this gives the
445 -- The general structure is just the same as for the common "otherwise~ case
446 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
447 newId voidPrimTy `thenSmpl` \ void_arg_id ->
448 rhs_c env `thenSmpl` \ prim_new_body ->
450 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
451 App (Var prim_rhs_fun_id) (VarArg voidPrimId))
454 = -- Make the new binding Id. NB: it's an OutId
455 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
458 cloneIds env used_args `thenSmpl` \ used_args' ->
460 new_env = extendIdEnvWithClones env used_args used_args'
462 rhs_c new_env `thenSmpl` \ rhs' ->
465 = (if switchIsSet new_env SimplDoEtaReduction
466 then mkValLamTryingEta
467 else mkValLam) used_args' rhs'
469 returnSmpl (NonRec rhs_fun_id final_rhs,
470 foldl App (Var rhs_fun_id) used_arg_atoms)
471 -- This is slightly wierd. We're retuning an OutId as part of the
472 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
473 -- it's processed the OutId won't be found in the environment, so it
474 -- will be left unmodified.
476 rhs_fun_ty :: OutUniType
477 rhs_fun_ty = glueTyArgs [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
479 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
480 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
484 prim_rhs_fun_ty = mkFunTy voidPrimTy rhs_ty
487 Case alternatives when we don't know the scrutinee
488 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
490 A special case for case default. If we have
496 it is best to make sure that \tr{default_e} mentions \tr{x} in
497 preference to \tr{y}. The code generator can do a cheaper job if it
498 doesn't have to come up with a binding for \tr{y}.
501 simplAlts :: SimplEnv
502 -> OutExpr -- Simplified scrutinee;
503 -- only of interest if its a var,
504 -- in which case we record its form
506 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
509 simplAlts env scrut (AlgAlts alts deflt) rhs_c
510 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
511 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
512 returnSmpl (AlgAlts alts' deflt')
514 deflt_form = OtherConForm [con | (con,_,_) <- alts]
515 do_alt (con, con_args, rhs)
516 = cloneIds env con_args `thenSmpl` \ con_args' ->
518 env1 = extendIdEnvWithClones env con_args con_args'
519 new_env = case scrut of
520 Var var -> _scc_ "euegC1" (extendUnfoldEnvGivenConstructor env1 var con con_args')
523 rhs_c new_env rhs `thenSmpl` \ rhs' ->
524 returnSmpl (con, con_args', rhs')
526 simplAlts env scrut (PrimAlts alts deflt) rhs_c
527 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
528 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
529 returnSmpl (PrimAlts alts' deflt')
531 deflt_form = OtherLitForm [lit | (lit,_) <- alts]
534 new_env = case scrut of
535 Var var -> _scc_ "euegFD1" (extendUnfoldEnvGivenFormDetails env var (LitForm lit))
538 rhs_c new_env rhs `thenSmpl` \ rhs' ->
539 returnSmpl (lit, rhs')
542 Use default binder where possible
543 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
544 There's one complication when simplifying the default clause of
545 a case expression. If we see
550 we'd like to convert it to
555 Reason 1: then there might be just one occurrence of x, and it can be
556 inlined as the case scrutinee. So we spot this case when dealing with
557 the default clause, and add a binding to the environment mapping x to
560 Reason 2: if the body is strict in x' then we can eliminate the
561 case altogether. By using x' in preference to x we give the max chance
562 of the strictness analyser finding that the body is strict in x'.
564 On the other hand, if x does *not* get inlined, then we'll actually
565 get somewhat better code from the former expression. So when
566 doing Core -> STG we convert back!
571 -> OutExpr -- Simplified scrutinee
572 -> InDefault -- Default alternative to be completed
573 -> UnfoldingDetails -- Gives form of scrutinee
574 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
577 simplDefault env scrut NoDefault form rhs_c
578 = returnSmpl NoDefault
580 -- Special case for variable scrutinee; see notes above.
581 simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
582 = cloneId env binder `thenSmpl` \ binder' ->
584 env1 = extendIdEnvWithAtom env binder (VarArg binder')
586 -- Add form details for the default binder
587 scrut_form = lookupUnfolding env scrut_var
589 = case (form_from_this_case, scrut_form) of
590 (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
591 (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
592 -- ConForm, LitForm impossible
593 -- (ASSERT? ASSERT? Hello? WDP 95/05)
594 other -> form_from_this_case
596 env2 = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' final_form)
598 -- Change unfold details for scrut var. We now want to unfold it
600 new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
601 (Var binder') UnfoldAlways
602 new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
605 rhs_c new_env rhs `thenSmpl` \ rhs' ->
606 returnSmpl (BindDefault binder' rhs')
608 simplDefault env scrut (BindDefault binder rhs) form rhs_c
609 = cloneId env binder `thenSmpl` \ binder' ->
611 env1 = extendIdEnvWithAtom env binder (VarArg binder')
612 new_env = _scc_ "euegFD2" (extendUnfoldEnvGivenFormDetails env1 binder' form)
614 rhs_c new_env rhs `thenSmpl` \ rhs' ->
615 returnSmpl (BindDefault binder' rhs')
618 Case alternatives when we know what the scrutinee is
619 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
622 completePrimCaseWithKnownLit
626 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
629 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
632 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
634 search_alts ((alt_lit, rhs) : _)
636 = -- Matching alternative!
639 search_alts (_ : other_alts)
640 = -- This alternative doesn't match; keep looking
641 search_alts other_alts
645 NoDefault -> -- Blargh!
646 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
648 BindDefault binder rhs -> -- OK, there's a default case
649 -- Just bind the Id to the atom and continue
651 new_env = extendIdEnvWithAtom env binder (LitArg lit)
656 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
657 select one case alternative (or default). If we choose the default:
658 we do different things depending on whether the constructor was
659 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
660 [let-bind it] or we just know the \tr{y} is now the same as some other
661 var [substitute \tr{y} out of existence].
664 completeAlgCaseWithKnownCon
666 -> DataCon -> [Type] -> [InAtom]
667 -- Scrutinee is (con, type, value arguments)
669 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
672 completeAlgCaseWithKnownCon env con tys con_args (AlgAlts alts deflt) rhs_c
673 = ASSERT(isDataCon con)
676 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
678 search_alts ((alt_con, alt_args, rhs) : _)
680 = -- Matching alternative!
682 new_env = extendIdEnvWithAtomList env (zip alt_args con_args)
686 search_alts (_ : other_alts)
687 = -- This alternative doesn't match; keep looking
688 search_alts other_alts
691 = -- No matching alternative
693 NoDefault -> -- Blargh!
694 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
696 BindDefault binder rhs -> -- OK, there's a default case
697 -- let-bind the binder to the constructor
698 cloneId env binder `thenSmpl` \ id' ->
700 env1 = extendIdEnvWithClone env binder id'
701 new_env = _scc_ "euegFD3" (extendUnfoldEnvGivenFormDetails env1 id'
702 (ConForm con tys con_args))
704 rhs_c new_env rhs `thenSmpl` \ rhs' ->
705 returnSmpl (Let (NonRec id' (Con con tys con_args)) rhs')
708 Case absorption and identity-case elimination
709 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
712 mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
715 @mkCoCase@ tries the following transformation (if possible):
717 case v of ==> case v of
718 p1 -> rhs1 p1 -> rhs1
720 pm -> rhsm pm -> rhsm
721 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
722 {or (prim) case v of d -> rhsn}
725 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
728 which merges two cases in one case when -- the default alternative of
729 the outer case scrutises the same variable as the outer case This
730 transformation is called Case Merging. It avoids that the same
731 variable is scrutinised multiple times.
733 There's a closely-related transformation:
735 case e of ==> case e of
736 p1 -> rhs1 p1 -> rhs1
738 pm -> rhsm pm -> rhsm
739 d -> case d of pn -> let d = pn in rhsn
741 ... po -> let d = po in rhso
742 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
745 Here, the let's are essential, because d isn't in scope any more.
746 Sigh. Of course, they may be unused, in which case they'll be
747 eliminated on the next round. Unfortunately, we can't figure out
748 whether or not they are used at this juncture.
750 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
751 scrutinee is a variable, because it'll be mapped to the scrutinised
752 variable. Hence the [v/d] substitions can be omitted.
754 ALAS, now the default binder is used by preference, so we have to
755 generate trivial lets to express the substitutions, which will be
756 eliminated on the next pass.
758 The following code handles *both* these transformations (one
759 equation for AlgAlts, one for PrimAlts):
762 mkCoCase scrut (AlgAlts outer_alts
763 (BindDefault deflt_var
764 (Case (Var scrut_var')
765 (AlgAlts inner_alts inner_deflt))))
766 | (scrut_is_var && scrut_var == scrut_var') -- First transformation
767 || deflt_var == scrut_var' -- Second transformation
768 = -- Aha! The default-absorption rule applies
769 tick CaseMerge `thenSmpl_`
770 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
771 (munge_alg_deflt deflt_var inner_deflt)))
772 -- NB: see comment in this location for the PrimAlts case
775 scrut_is_var = case scrut of {Var v -> True; other -> False}
776 scrut_var = case scrut of Var v -> v
778 -- Eliminate any inner alts which are shadowed by the outer ones
779 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
780 not (con `is_elem` outer_cons)]
781 outer_cons = [con | (con,_,_) <- outer_alts]
782 is_elem = isIn "mkAlgAlts"
784 -- Add the lets if necessary
785 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
787 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
789 v | scrut_is_var = Var scrut_var
790 | otherwise = Con con arg_tys (map VarArg args)
792 arg_tys = case maybeAppDataTyCon (idType deflt_var) of
793 Just (_, arg_tys, _) -> arg_tys
795 mkCoCase scrut (PrimAlts
797 (BindDefault deflt_var (Case
799 (PrimAlts inner_alts inner_deflt))))
800 | (scrut_is_var && scrut_var == scrut_var') ||
801 deflt_var == scrut_var'
802 = -- Aha! The default-absorption rule applies
803 tick CaseMerge `thenSmpl_`
804 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
805 (munge_prim_deflt deflt_var inner_deflt)))
807 -- Nota Bene: we don't recurse to mkCoCase again, because the
808 -- default will now have a binding in it that prevents
809 -- mkCoCase doing anything useful. Much worse, in this
810 -- PrimAlts case the binding in the default branch is another
811 -- Case, so if we recurse to mkCoCase we will get into an
814 -- ToDo: think of a better way to do this. At the moment
815 -- there is at most one case merge per round. That's probably
816 -- plenty but it seems unclean somehow.
819 scrut_is_var = case scrut of {Var v -> True; other -> False}
820 scrut_var = case scrut of Var v -> v
822 -- Eliminate any inner alts which are shadowed by the outer ones
823 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
824 not (lit `is_elem` outer_lits)]
825 outer_lits = [lit | (lit,_) <- outer_alts]
826 is_elem = isIn "mkPrimAlts"
828 -- Add the lets (well cases actually) if necessary
829 -- The munged alternative looks like
830 -- lit -> case lit of d -> rhs
831 -- The next pass will certainly eliminate the inner case, but
832 -- it isn't easy to do so right away.
833 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
836 | scrut_is_var = (lit, Case (Var scrut_var)
837 (PrimAlts [] (BindDefault deflt_var rhs)))
838 | otherwise = (lit, Case (Lit lit)
839 (PrimAlts [] (BindDefault deflt_var rhs)))
842 Now the identity-case transformation:
853 = tick CaseIdentity `thenSmpl_`
856 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
857 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
859 identity_alg_alt (con, args, Con con' _ args')
861 && and (zipWith eq_arg args args')
862 && length args == length args'
863 identity_alg_alt other
866 identity_prim_alt (lit, Lit lit') = lit == lit'
867 identity_prim_alt other = False
869 -- For the default case we want to spot both
872 -- case y of { ... ; x -> y }
873 -- as "identity" defaults
874 identity_deflt NoDefault = True
875 identity_deflt (BindDefault binder (Var x)) = x == binder ||
879 identity_deflt _ = False
881 eq_arg binder (VarArg x) = binder == x
888 mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
891 Boring local functions used above. They simply introduce a trivial binding
892 for the binder, d', in an inner default; either
893 let d' = deflt_var in rhs
895 case deflt_var of d' -> rhs
896 depending on whether it's an algebraic or primitive case.
899 munge_prim_deflt _ NoDefault = NoDefault
901 munge_prim_deflt deflt_var (BindDefault d' rhs)
902 = BindDefault deflt_var (Case (Var deflt_var)
903 (PrimAlts [] (BindDefault d' rhs)))
905 munge_alg_deflt _ NoDefault = NoDefault
907 munge_alg_deflt deflt_var (BindDefault d' rhs)
908 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
910 -- This line caused a generic version of munge_deflt (ie one used for
911 -- both alg and prim) to space leak massively. No idea why.
912 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
916 -- A cheap equality test which bales out fast!
917 cheap_eq :: InExpr -> InExpr -> Bool
918 cheap_eq (Var v1) (Var v2) = v1==v2
919 cheap_eq (Lit l1) (Lit l2) = l1==l2
920 cheap_eq (Con con1 tys1 args1) (Con con2 tys2 args2) = (con1==con2) &&
921 (args1 `eq_args` args2)
922 -- Types bound to be equal
923 cheap_eq (Prim op1 tys1 args1) (Prim op2 tys2 args2) = (op1==op2) &&
924 (args1 `eq_args` args2)
925 -- Types bound to be equal
926 cheap_eq (App f1 a1) (App f2 a2) = (f1 `cheap_eq` f2) && (a1 `eq_atom` a2)
927 cheap_eq (CoTyApp f1 t1) (CoTyApp f2 t2) = (f1 `cheap_eq` f2) && (t1 == t2)
930 -- ToDo: make CoreArg an instance of Eq
931 eq_args (arg1: args1) (arg2 : args2) = (arg1 `eq_atom` arg2) && (args1 `eq_args` args2)
933 eq_args other1 other2 = False
935 eq_atom (LitArg l1) (LitArg l2) = l1==l2
936 eq_atom (VarArg v1) (VarArg v2) = v1==v2
937 eq_atom other1 other2 = False