2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[SimplCase]{Simplification of `case' expression}
6 Support code for @Simplify@.
9 #include "HsVersions.h"
11 module SimplCase ( simplCase, bindLargeRhs ) where
14 IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
16 import BinderInfo -- too boring to try to select things...
17 import CmdLineOpts ( SimplifierSwitch(..) )
19 import CoreUnfold ( Unfolding, SimpleUnfolding )
20 import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
23 import Id ( idType, isDataCon, getIdDemandInfo,
24 SYN_IE(DataCon), GenId{-instance Eq-}
26 import IdInfo ( willBeDemanded, DemandInfo )
27 import Literal ( isNoRepLit, Literal{-instance Eq-} )
28 import Maybes ( maybeToBool )
29 import PrelVals ( voidId )
30 import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
33 import SimplUtils ( mkValLamTryingEta )
34 import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
35 import TysPrim ( voidTy )
36 import Unique ( Unique{-instance Eq-} )
37 import Usage ( GenUsage{-instance Eq-} )
38 import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
41 Float let out of case.
45 -> InExpr -- Scrutinee
46 -> InAlts -- Alternatives
47 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
48 -> OutType -- Type of result expression
51 simplCase env (Let bind body) alts rhs_c result_ty
52 | not (switchIsSet env SimplNoLetFromCase)
53 = -- Float the let outside the case scrutinee (if not disabled by flag)
54 tick LetFloatFromCase `thenSmpl_`
55 simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
58 OK to do case-of-case if
60 * we allow arbitrary code duplication
64 * the inner case has one alternative
65 case (case e of (a,b) -> rhs) of
76 IF neither of these two things are the case, we avoid code-duplication
77 by abstracting the outer rhss wrt the pattern variables. For example
79 case (case e of { p1->rhs1; ...; pn -> rhsn }) of
85 p1 -> case rhs1 of (x,y) -> b x y
87 pn -> case rhsn of (x,y) -> b x y
90 OK, so outer case expression gets duplicated, but that's all. Furthermore,
91 (a) the binding for "b" will be let-no-escaped, so no heap allocation
92 will take place; the "call" to b will simply be a stack adjustment
94 (b) very commonly, at least some of the rhsi's will be constructors, which
95 makes life even simpler.
97 All of this works equally well if the outer case has multiple rhss.
101 simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
102 | switchIsSet env SimplCaseOfCase
103 = -- Ha! Do case-of-case
104 tick CaseOfCase `thenSmpl_`
106 if no_need_to_bind_large_alts
108 simplCase env inner_scrut inner_alts
109 (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
111 bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
113 rhs_c' = \env rhs -> simplExpr env rhs []
115 simplCase env inner_scrut inner_alts
116 (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
118 `thenSmpl` \ case_expr ->
119 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
122 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
123 isSingleton (nonErrorRHSs inner_alts)
126 Case of an application of error.
129 simplCase env scrut alts rhs_c result_ty
130 | maybeToBool maybe_error_app
131 = -- Look for an application of an error id
132 tick CaseOfError `thenSmpl_`
133 rhs_c env retyped_error_app
135 alts_ty = coreAltsType (unTagBindersAlts alts)
136 maybe_error_app = maybeErrorApp scrut (Just alts_ty)
137 Just retyped_error_app = maybe_error_app
140 Finally the default case
143 simplCase env other_scrut alts rhs_c result_ty
144 = -- Float the let outside the case scrutinee
145 simplExpr env other_scrut [] `thenSmpl` \ scrut' ->
146 completeCase env scrut' alts rhs_c
150 %************************************************************************
152 \subsection[Simplify-case]{Completing case-expression simplification}
154 %************************************************************************
159 -> OutExpr -- The already-simplified scrutinee
160 -> InAlts -- The un-simplified alternatives
161 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
162 -> SmplM OutExpr -- The whole case expression
165 Scrutinising a literal or constructor.
166 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
167 It's an obvious win to do:
169 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
171 and the similar thing for primitive case. If we have
175 and x is known to be of constructor form, then we'll already have
176 inlined the constructor to give (case (C a b) of ...), so we don't
177 need to check for the variable case separately.
179 Sanity check: we don't have a good
180 story to tell about case analysis on NoRep things. ToDo.
183 completeCase env (Lit lit) alts rhs_c
184 | not (isNoRepLit lit)
185 = -- Ha! Select the appropriate alternative
186 tick KnownBranch `thenSmpl_`
187 completePrimCaseWithKnownLit env lit alts rhs_c
189 completeCase env expr@(Con con con_args) alts rhs_c
190 = -- Ha! Staring us in the face -- select the appropriate alternative
191 tick KnownBranch `thenSmpl_`
192 completeAlgCaseWithKnownCon env con con_args alts rhs_c
197 Start with a simple situation:
199 case x# of ===> e[x#/y#]
202 (when x#, y# are of primitive type, of course).
203 We can't (in general) do this for algebraic cases, because we might
204 turn bottom into non-bottom!
206 Actually, we generalise this idea to look for a case where we're
207 scrutinising a variable, and we know that only the default case can
212 other -> ...(case x of
216 Here the inner case can be eliminated. This really only shows up in
217 eliminating error-checking code.
219 Lastly, we generalise the transformation to handle this:
225 We only do this for very cheaply compared r's (constructors, literals
226 and variables). If pedantic bottoms is on, we only do it when the
227 scrutinee is a PrimOp which can't fail.
229 We do it *here*, looking at un-simplified alternatives, because we
230 have to check that r doesn't mention the variables bound by the
231 pattern in each alternative, so the binder-info is rather useful.
233 So the case-elimination algorithm is:
235 1. Eliminate alternatives which can't match
237 2. Check whether all the remaining alternatives
238 (a) do not mention in their rhs any of the variables bound in their pattern
239 and (b) have equal rhss
241 3. Check we can safely ditch the case:
242 * PedanticBottoms is off,
243 or * the scrutinee is an already-evaluated variable
244 or * the scrutinee is a primop which is ok for speculation
245 -- ie we want to preserve divide-by-zero errors, and
246 -- calls to error itself!
248 or * [Prim cases] the scrutinee is a primitive variable
250 or * [Alg cases] the scrutinee is a variable and
251 either * the rhs is the same variable
252 (eg case x of C a b -> x ===> x)
253 or * there is only one alternative, the default alternative,
254 and the binder is used strictly in its scope.
255 [NB this is helped by the "use default binder where
256 possible" transformation; see below.]
259 If so, then we can replace the case with one of the rhss.
262 completeCase env scrut alts rhs_c
263 | switchIsSet env SimplDoCaseElim &&
269 (not (switchIsSet env SimplPedanticBottoms) ||
271 scrut_is_eliminable_primitive ||
273 scrut_is_var_and_single_strict_default
276 = tick CaseElim `thenSmpl_`
279 -- Find the non-excluded rhss of the case; always at least one
280 (rhs1:rhss) = possible_rhss
281 all_rhss_same = all (cheap_eq rhs1) rhss
283 -- Find the reduced set of possible rhss, along with an indication of
284 -- whether none of their binders are used
285 (binders_unused, possible_rhss, new_env)
287 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
291 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
293 -- Eliminate unused rhss if poss
294 rhss = case scrut_form of
295 OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
296 not (alt_lit `is_elem` not_these)
298 other -> [rhs | (_,rhs) <- alts]
300 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
301 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
304 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
306 -- Eliminate unused alts if poss
307 possible_alts = case scrut_form of
308 OtherCon not_these ->
309 -- Remove alts which can't match
310 [alt | alt@(alt_con,_,_) <- alts,
311 not (alt_con `is_elem` not_these)]
315 alt_binders_unused (con, args, rhs) = all is_dead args
316 is_dead (_, DeadCode) = True
317 is_dead other_arg = False
319 -- If the scrutinee is a variable, look it up to see what we know about it
320 scrut_form = case scrut of
321 Var v -> lookupRhsInfo env v
324 -- If the scrut is already eval'd then there's no worry about
325 -- eliminating the case
326 scrut_is_evald = isEvaluated scrut_form
328 scrut_is_eliminable_primitive
330 Prim op _ -> primOpOkForSpeculation op
331 Var _ -> case alts of
332 PrimAlts _ _ -> True -- Primitive, hence non-bottom
333 AlgAlts _ _ -> False -- Not primitive
336 -- case v of w -> e{strict in w} ===> e[v/w]
337 scrut_is_var_and_single_strict_default
339 Var _ -> case alts of
340 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
344 elim_deflt_binder NoDefault -- No Binder
346 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
348 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
350 Var v -> -- Binder used, but can be eliminated in favour of scrut
351 (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
352 non_var -> -- Binder used, and can't be elimd
355 -- Check whether the chosen unique rhs (ie rhs1) is the same as
356 -- the scrutinee. Remember that the rhs is as yet unsimplified.
357 rhs1_is_scrutinee = case (scrut, rhs1) of
358 (Var scrut_var, Var rhs_var)
359 -> case lookupId env rhs_var of
360 VarArg rhs_var' -> rhs_var' == scrut_var
364 is_elem x ys = isIn "completeCase" x ys
367 Scrutinising anything else. If it's a variable, it can't be bound to a
368 constructor or literal, because that would have been inlined
371 completeCase env scrut alts rhs_c
372 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
373 mkCoCase env scrut alts'
380 bindLargeAlts :: SimplEnv
382 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
383 -> OutType -- Result type
384 -> SmplM ([OutBinding], -- Extra bindings
385 InAlts) -- Modified alts
387 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
388 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
389 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
390 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
392 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
393 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
394 returnSmpl (bind, (con,args,rhs'))
396 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
397 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
398 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
399 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
401 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
402 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
403 returnSmpl (bind, (lit,rhs'))
405 bindLargeDefault env NoDefault rhs_ty rhs_c
406 = returnSmpl ([], NoDefault)
407 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
408 = bindLargeRhs env [binder] rhs_ty
409 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
410 returnSmpl ([bind], BindDefault binder rhs')
413 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
414 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
418 bindLargeRhs :: SimplEnv
419 -> [InBinder] -- The args wrt which the rhs should be abstracted
421 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
422 -> SmplM (OutBinding, -- New bindings (singleton or empty)
423 InExpr) -- Modified rhs
425 bindLargeRhs env args rhs_ty rhs_c
426 | null used_args && isPrimType rhs_ty
427 -- If we try to lift a primitive-typed something out
428 -- for let-binding-purposes, we will *caseify* it (!),
429 -- with potentially-disastrous strictness results. So
430 -- instead we turn it into a function: \v -> e
431 -- where v::Void. Since arguments of type
432 -- VoidPrim don't generate any code, this gives the
435 -- The general structure is just the same as for the common "otherwise~ case
436 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
437 newId voidTy `thenSmpl` \ void_arg_id ->
438 rhs_c env `thenSmpl` \ prim_new_body ->
440 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
441 App (Var prim_rhs_fun_id) (VarArg voidId))
444 = -- Make the new binding Id. NB: it's an OutId
445 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
448 cloneIds env used_args `thenSmpl` \ used_args' ->
450 new_env = extendIdEnvWithClones env used_args used_args'
452 rhs_c new_env `thenSmpl` \ rhs' ->
455 = (if switchIsSet new_env SimplDoEtaReduction
456 then mkValLamTryingEta
457 else mkValLam) used_args' rhs'
459 returnSmpl (NonRec rhs_fun_id final_rhs,
460 foldl App (Var rhs_fun_id) used_arg_atoms)
461 -- This is slightly wierd. We're retuning an OutId as part of the
462 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
463 -- it's processed the OutId won't be found in the environment, so it
464 -- will be left unmodified.
466 rhs_fun_ty :: OutType
467 rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
469 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
470 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
474 prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
477 Case alternatives when we don't know the scrutinee
478 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
480 A special case for case default. If we have
486 it is best to make sure that \tr{default_e} mentions \tr{x} in
487 preference to \tr{y}. The code generator can do a cheaper job if it
488 doesn't have to come up with a binding for \tr{y}.
491 simplAlts :: SimplEnv
492 -> OutExpr -- Simplified scrutinee;
493 -- only of interest if its a var,
494 -- in which case we record its form
496 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
499 simplAlts env scrut (AlgAlts alts deflt) rhs_c
500 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
501 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
502 returnSmpl (AlgAlts alts' deflt')
504 deflt_form = OtherCon [con | (con,_,_) <- alts]
505 do_alt (con, con_args, rhs)
506 = cloneIds env con_args `thenSmpl` \ con_args' ->
508 env1 = extendIdEnvWithClones env con_args con_args'
509 new_env = case scrut of
510 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
512 (_, ty_args, _) = --trace "SimplCase.getAppData..." $
513 getAppDataTyConExpandingDicts (idType v)
514 args = map TyArg ty_args ++ map VarArg con_args'
518 rhs_c new_env rhs `thenSmpl` \ rhs' ->
519 returnSmpl (con, con_args', rhs')
521 simplAlts env scrut (PrimAlts alts deflt) rhs_c
522 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
523 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
524 returnSmpl (PrimAlts alts' deflt')
526 deflt_form = OtherLit [lit | (lit,_) <- alts]
529 new_env = case scrut of
530 Var v -> extendEnvGivenNewRhs env v (Lit lit)
533 rhs_c new_env rhs `thenSmpl` \ rhs' ->
534 returnSmpl (lit, rhs')
537 Use default binder where possible
538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
539 There's one complication when simplifying the default clause of
540 a case expression. If we see
545 we'd like to convert it to
550 Reason 1: then there might be just one occurrence of x, and it can be
551 inlined as the case scrutinee. So we spot this case when dealing with
552 the default clause, and add a binding to the environment mapping x to
555 Reason 2: if the body is strict in x' then we can eliminate the
556 case altogether. By using x' in preference to x we give the max chance
557 of the strictness analyser finding that the body is strict in x'.
559 On the other hand, if x does *not* get inlined, then we'll actually
560 get somewhat better code from the former expression. So when
561 doing Core -> STG we convert back!
566 -> OutExpr -- Simplified scrutinee
567 -> InDefault -- Default alternative to be completed
568 -> RhsInfo -- Gives form of scrutinee
569 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
572 simplDefault env scrut NoDefault form rhs_c
573 = returnSmpl NoDefault
575 -- Special case for variable scrutinee; see notes above.
576 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
577 info_from_this_case rhs_c
578 = cloneId env binder `thenSmpl` \ binder' ->
580 env1 = extendIdEnvWithClone env binder binder'
581 env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
583 -- Add form details for the default binder
584 scrut_info = lookupRhsInfo env scrut_var
585 env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
586 new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
588 rhs_c new_env rhs `thenSmpl` \ rhs' ->
589 returnSmpl (BindDefault binder' rhs')
591 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
592 info_from_this_case rhs_c
593 = cloneId env binder `thenSmpl` \ binder' ->
595 env1 = extendIdEnvWithClone env binder binder'
596 new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
598 rhs_c new_env rhs `thenSmpl` \ rhs' ->
599 returnSmpl (BindDefault binder' rhs')
602 Case alternatives when we know what the scrutinee is
603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
606 completePrimCaseWithKnownLit
610 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
613 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
616 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
618 search_alts ((alt_lit, rhs) : _)
620 = -- Matching alternative!
623 search_alts (_ : other_alts)
624 = -- This alternative doesn't match; keep looking
625 search_alts other_alts
629 NoDefault -> -- Blargh!
630 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
632 BindDefault binder rhs -> -- OK, there's a default case
633 -- Just bind the Id to the atom and continue
635 new_env = extendIdEnvWithAtom env binder (LitArg lit)
640 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
641 select one case alternative (or default). If we choose the default:
642 we do different things depending on whether the constructor was
643 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
644 [let-bind it] or we just know the \tr{y} is now the same as some other
645 var [substitute \tr{y} out of existence].
648 completeAlgCaseWithKnownCon
650 -> DataCon -> [InArg]
651 -- Scrutinee is (con, type, value arguments)
653 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
656 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
657 = ASSERT(isDataCon con)
660 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
662 search_alts ((alt_con, alt_args, rhs) : _)
664 = -- Matching alternative!
666 new_env = extendIdEnvWithAtoms env
667 (zipEqual "SimplCase" alt_args (filter isValArg con_args))
671 search_alts (_ : other_alts)
672 = -- This alternative doesn't match; keep looking
673 search_alts other_alts
676 = -- No matching alternative
678 NoDefault -> -- Blargh!
679 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
681 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
682 -- let-bind the binder to the constructor
683 cloneId env binder `thenSmpl` \ id' ->
685 env1 = extendIdEnvWithClone env binder id'
686 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
688 rhs_c new_env rhs `thenSmpl` \ rhs' ->
689 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
692 Case absorption and identity-case elimination
693 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
696 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
699 @mkCoCase@ tries the following transformation (if possible):
701 case v of ==> case v of
702 p1 -> rhs1 p1 -> rhs1
704 pm -> rhsm pm -> rhsm
705 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
706 {or (prim) case v of d -> rhsn}
709 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
712 which merges two cases in one case when -- the default alternative of
713 the outer case scrutises the same variable as the outer case This
714 transformation is called Case Merging. It avoids that the same
715 variable is scrutinised multiple times.
717 There's a closely-related transformation:
719 case e of ==> case e of
720 p1 -> rhs1 p1 -> rhs1
722 pm -> rhsm pm -> rhsm
723 d -> case d of pn -> let d = pn in rhsn
725 ... po -> let d = po in rhso
726 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
729 Here, the let's are essential, because d isn't in scope any more.
730 Sigh. Of course, they may be unused, in which case they'll be
731 eliminated on the next round. Unfortunately, we can't figure out
732 whether or not they are used at this juncture.
734 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
735 scrutinee is a variable, because it'll be mapped to the scrutinised
736 variable. Hence the [v/d] substitions can be omitted.
738 ALAS, now the default binder is used by preference, so we have to
739 generate trivial lets to express the substitutions, which will be
740 eliminated on the next pass.
742 The following code handles *both* these transformations (one
743 equation for AlgAlts, one for PrimAlts):
746 mkCoCase env scrut (AlgAlts outer_alts
747 (BindDefault deflt_var
748 (Case (Var scrut_var')
749 (AlgAlts inner_alts inner_deflt))))
750 | switchIsSet env SimplCaseMerge &&
751 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
752 deflt_var == scrut_var') -- Second transformation
753 = -- Aha! The default-absorption rule applies
754 tick CaseMerge `thenSmpl_`
755 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
756 (munge_alg_deflt deflt_var inner_deflt)))
757 -- NB: see comment in this location for the PrimAlts case
760 scrut_is_var = case scrut of {Var v -> True; other -> False}
761 scrut_var = case scrut of Var v -> v
763 -- Eliminate any inner alts which are shadowed by the outer ones
764 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
765 not (con `is_elem` outer_cons)]
766 outer_cons = [con | (con,_,_) <- outer_alts]
767 is_elem = isIn "mkAlgAlts"
769 -- Add the lets if necessary
770 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
772 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
774 v | scrut_is_var = Var scrut_var
775 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
777 arg_tys = --trace "SimplCase:getAppData...:2" $
778 case (getAppDataTyConExpandingDicts (idType deflt_var)) of
779 (_, arg_tys, _) -> arg_tys
781 mkCoCase env scrut (PrimAlts
783 (BindDefault deflt_var (Case
785 (PrimAlts inner_alts inner_deflt))))
786 | switchIsSet env SimplCaseMerge &&
787 ((scrut_is_var && scrut_var == scrut_var') ||
788 deflt_var == scrut_var')
789 = -- Aha! The default-absorption rule applies
790 tick CaseMerge `thenSmpl_`
791 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
792 (munge_prim_deflt deflt_var inner_deflt)))
794 -- Nota Bene: we don't recurse to mkCoCase again, because the
795 -- default will now have a binding in it that prevents
796 -- mkCoCase doing anything useful. Much worse, in this
797 -- PrimAlts case the binding in the default branch is another
798 -- Case, so if we recurse to mkCoCase we will get into an
801 -- ToDo: think of a better way to do this. At the moment
802 -- there is at most one case merge per round. That's probably
803 -- plenty but it seems unclean somehow.
806 scrut_is_var = case scrut of {Var v -> True; other -> False}
807 scrut_var = case scrut of Var v -> v
809 -- Eliminate any inner alts which are shadowed by the outer ones
810 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
811 not (lit `is_elem` outer_lits)]
812 outer_lits = [lit | (lit,_) <- outer_alts]
813 is_elem = isIn "mkPrimAlts"
815 -- Add the lets (well cases actually) if necessary
816 -- The munged alternative looks like
817 -- lit -> case lit of d -> rhs
818 -- The next pass will certainly eliminate the inner case, but
819 -- it isn't easy to do so right away.
820 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
823 | scrut_is_var = (lit, Case (Var scrut_var)
824 (PrimAlts [] (BindDefault deflt_var rhs)))
825 | otherwise = (lit, Case (Lit lit)
826 (PrimAlts [] (BindDefault deflt_var rhs)))
829 Now the identity-case transformation:
838 mkCoCase env scrut alts
840 = tick CaseIdentity `thenSmpl_`
843 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
844 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
846 identity_alg_alt (con, args, Con con' args')
848 && and (zipWith eq_arg args args')
849 && length args == length args'
850 identity_alg_alt other
853 identity_prim_alt (lit, Lit lit') = lit == lit'
854 identity_prim_alt other = False
856 -- For the default case we want to spot both
859 -- case y of { ... ; x -> y }
860 -- as "identity" defaults
861 identity_deflt NoDefault = True
862 identity_deflt (BindDefault binder (Var x)) = x == binder ||
866 identity_deflt _ = False
868 eq_arg binder (VarArg x) = binder == x
875 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
878 Boring local functions used above. They simply introduce a trivial binding
879 for the binder, d', in an inner default; either
880 let d' = deflt_var in rhs
882 case deflt_var of d' -> rhs
883 depending on whether it's an algebraic or primitive case.
886 munge_prim_deflt _ NoDefault = NoDefault
888 munge_prim_deflt deflt_var (BindDefault d' rhs)
889 = BindDefault deflt_var (Case (Var deflt_var)
890 (PrimAlts [] (BindDefault d' rhs)))
892 munge_alg_deflt _ NoDefault = NoDefault
894 munge_alg_deflt deflt_var (BindDefault d' rhs)
895 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
897 -- This line caused a generic version of munge_deflt (ie one used for
898 -- both alg and prim) to space leak massively. No idea why.
899 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
903 cheap_eq :: InExpr -> InExpr -> Bool
904 -- A cheap equality test which bales out fast!
906 cheap_eq (Var v1) (Var v2) = v1==v2
907 cheap_eq (Lit l1) (Lit l2) = l1==l2
908 cheap_eq (Con con1 args1) (Con con2 args2)
909 = con1 == con2 && args1 `eq_args` args2
911 cheap_eq (Prim op1 args1) (Prim op2 args2)
912 = op1 ==op2 && args1 `eq_args` args2
914 cheap_eq (App f1 a1) (App f2 a2)
915 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
919 -- ToDo: make CoreArg an instance of Eq
920 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
924 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
925 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
926 eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2
927 eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2