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,
21 unTagBindersAlts, unTagBinders, coreExprType
23 import Id ( idType, isDataCon, getIdDemandInfo,
24 SYN_IE(DataCon), GenId{-instance Eq-},
27 import IdInfo ( willBeDemanded, DemandInfo )
28 import Literal ( isNoRepLit, Literal{-instance Eq-} )
29 import Maybes ( maybeToBool )
30 import PrelVals ( voidId )
31 import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
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 ( SYN_IE(Eager), runEager, appEager,
39 isIn, isSingleton, zipEqual, panic, assertPanic )
42 Float let out of case.
46 -> InExpr -- Scrutinee
47 -> InAlts -- Alternatives
48 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
49 -> OutType -- Type of result expression
52 simplCase env (Let bind body) alts rhs_c result_ty
53 | not (switchIsSet env SimplNoLetFromCase)
54 = -- Float the let outside the case scrutinee (if not disabled by flag)
55 tick LetFloatFromCase `thenSmpl_`
56 simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
59 OK to do case-of-case if
61 * we allow arbitrary code duplication
65 * the inner case has one alternative
66 case (case e of (a,b) -> rhs) of
77 IF neither of these two things are the case, we avoid code-duplication
78 by abstracting the outer rhss wrt the pattern variables. For example
80 case (case e of { p1->rhs1; ...; pn -> rhsn }) of
86 p1 -> case rhs1 of (x,y) -> b x y
88 pn -> case rhsn of (x,y) -> b x y
91 OK, so outer case expression gets duplicated, but that's all. Furthermore,
92 (a) the binding for "b" will be let-no-escaped, so no heap allocation
93 will take place; the "call" to b will simply be a stack adjustment
95 (b) very commonly, at least some of the rhsi's will be constructors, which
96 makes life even simpler.
98 All of this works equally well if the outer case has multiple rhss.
102 simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
103 | switchIsSet env SimplCaseOfCase
104 = -- Ha! Do case-of-case
105 tick CaseOfCase `thenSmpl_`
107 if no_need_to_bind_large_alts
109 simplCase env inner_scrut inner_alts
110 (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
112 bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
114 rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
116 simplCase env inner_scrut inner_alts
117 (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
119 `thenSmpl` \ case_expr ->
120 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
123 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
124 isSingleton (nonErrorRHSs inner_alts)
127 Case of an application of error.
130 simplCase env scrut alts rhs_c result_ty
131 | maybeToBool maybe_error_app
132 = -- Look for an application of an error id
133 tick CaseOfError `thenSmpl_`
134 returnSmpl retyped_error_app
136 maybe_error_app = maybeErrorApp scrut (Just result_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 = simplTy env scrut_ty `appEager` \ scrut_ty' ->
145 simplExpr env' other_scrut [] scrut_ty `thenSmpl` \ scrut' ->
146 completeCase env scrut' alts rhs_c
148 -- When simplifying the scrutinee of a complete case that
149 -- has no default alternative
151 AlgAlts _ NoDefault -> setCaseScrutinee env
152 PrimAlts _ NoDefault -> setCaseScrutinee env
155 scrut_ty = coreExprType (unTagBinders other_scrut)
159 %************************************************************************
161 \subsection[Simplify-case]{Completing case-expression simplification}
163 %************************************************************************
168 -> OutExpr -- The already-simplified scrutinee
169 -> InAlts -- The un-simplified alternatives
170 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
171 -> SmplM OutExpr -- The whole case expression
174 Scrutinising a literal or constructor.
175 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
176 It's an obvious win to do:
178 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
180 and the similar thing for primitive case. If we have
184 and x is known to be of constructor form, then we'll already have
185 inlined the constructor to give (case (C a b) of ...), so we don't
186 need to check for the variable case separately.
188 Sanity check: we don't have a good
189 story to tell about case analysis on NoRep things. ToDo.
192 completeCase env (Lit lit) alts rhs_c
193 | not (isNoRepLit lit)
194 = -- Ha! Select the appropriate alternative
195 tick KnownBranch `thenSmpl_`
196 completePrimCaseWithKnownLit env lit alts rhs_c
198 completeCase env expr@(Con con con_args) alts rhs_c
199 = -- Ha! Staring us in the face -- select the appropriate alternative
200 tick KnownBranch `thenSmpl_`
201 completeAlgCaseWithKnownCon env con con_args alts rhs_c
206 Start with a simple situation:
208 case x# of ===> e[x#/y#]
211 (when x#, y# are of primitive type, of course).
212 We can't (in general) do this for algebraic cases, because we might
213 turn bottom into non-bottom!
215 Actually, we generalise this idea to look for a case where we're
216 scrutinising a variable, and we know that only the default case can
221 other -> ...(case x of
225 Here the inner case can be eliminated. This really only shows up in
226 eliminating error-checking code.
228 Lastly, we generalise the transformation to handle this:
234 We only do this for very cheaply compared r's (constructors, literals
235 and variables). If pedantic bottoms is on, we only do it when the
236 scrutinee is a PrimOp which can't fail.
238 We do it *here*, looking at un-simplified alternatives, because we
239 have to check that r doesn't mention the variables bound by the
240 pattern in each alternative, so the binder-info is rather useful.
242 So the case-elimination algorithm is:
244 1. Eliminate alternatives which can't match
246 2. Check whether all the remaining alternatives
247 (a) do not mention in their rhs any of the variables bound in their pattern
248 and (b) have equal rhss
250 3. Check we can safely ditch the case:
251 * PedanticBottoms is off,
252 or * the scrutinee is an already-evaluated variable
253 or * the scrutinee is a primop which is ok for speculation
254 -- ie we want to preserve divide-by-zero errors, and
255 -- calls to error itself!
257 or * [Prim cases] the scrutinee is a primitive variable
259 or * [Alg cases] the scrutinee is a variable and
260 either * the rhs is the same variable
261 (eg case x of C a b -> x ===> x)
262 or * there is only one alternative, the default alternative,
263 and the binder is used strictly in its scope.
264 [NB this is helped by the "use default binder where
265 possible" transformation; see below.]
268 If so, then we can replace the case with one of the rhss.
271 completeCase env scrut alts rhs_c
272 | switchIsSet env SimplDoCaseElim &&
278 (not (switchIsSet env SimplPedanticBottoms) ||
280 scrut_is_eliminable_primitive ||
282 scrut_is_var_and_single_strict_default
285 = tick CaseElim `thenSmpl_`
288 -- Find the non-excluded rhss of the case; always at least one
289 (rhs1:rhss) = possible_rhss
290 all_rhss_same = all (cheap_eq rhs1) rhss
292 -- Find the reduced set of possible rhss, along with an indication of
293 -- whether none of their binders are used
294 (binders_unused, possible_rhss, new_env)
296 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
300 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
302 -- Eliminate unused rhss if poss
303 rhss = case scrut_form of
304 OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
305 not (alt_lit `is_elem` not_these)
307 other -> [rhs | (_,rhs) <- alts]
309 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
310 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
313 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
315 -- Eliminate unused alts if poss
316 possible_alts = case scrut_form of
317 OtherCon not_these ->
318 -- Remove alts which can't match
319 [alt | alt@(alt_con,_,_) <- alts,
320 not (alt_con `is_elem` not_these)]
324 alt_binders_unused (con, args, rhs) = all is_dead args
325 is_dead (_, DeadCode) = True
326 is_dead other_arg = False
328 -- If the scrutinee is a variable, look it up to see what we know about it
329 scrut_form = case scrut of
330 Var v -> lookupRhsInfo env v
333 -- If the scrut is already eval'd then there's no worry about
334 -- eliminating the case
335 scrut_is_evald = isEvaluated scrut_form
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 (runEager $ lookupId env rhs_var) of
369 VarArg rhs_var' -> rhs_var' == scrut_var
373 is_elem x ys = isIn "completeCase" x ys
376 Scrutinising anything else. If it's a variable, it can't be bound to a
377 constructor or literal, because that would have been inlined
380 completeCase env scrut alts rhs_c
381 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
382 mkCoCase env scrut alts'
389 bindLargeAlts :: SimplEnv
391 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
392 -> OutType -- Result type
393 -> SmplM ([OutBinding], -- Extra bindings
394 InAlts) -- Modified alts
396 bindLargeAlts env the_lot@(AlgAlts 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, AlgAlts alts' deflt')
401 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
402 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
403 returnSmpl (bind, (con,args,rhs'))
405 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
406 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
407 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
408 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
410 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
411 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
412 returnSmpl (bind, (lit,rhs'))
414 bindLargeDefault env NoDefault rhs_ty rhs_c
415 = returnSmpl ([], NoDefault)
416 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
417 = bindLargeRhs env [binder] rhs_ty
418 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
419 returnSmpl ([bind], BindDefault binder rhs')
422 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
423 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
427 bindLargeRhs :: SimplEnv
428 -> [InBinder] -- The args wrt which the rhs should be abstracted
430 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
431 -> SmplM (OutBinding, -- New bindings (singleton or empty)
432 InExpr) -- Modified rhs
434 bindLargeRhs env args rhs_ty rhs_c
435 | null used_args && isPrimType rhs_ty
436 -- If we try to lift a primitive-typed something out
437 -- for let-binding-purposes, we will *caseify* it (!),
438 -- with potentially-disastrous strictness results. So
439 -- instead we turn it into a function: \v -> e
440 -- where v::Void. Since arguments of type
441 -- VoidPrim don't generate any code, this gives the
444 -- The general structure is just the same as for the common "otherwise~ case
445 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
446 newId voidTy `thenSmpl` \ void_arg_id ->
447 rhs_c env `thenSmpl` \ prim_new_body ->
449 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
450 App (Var prim_rhs_fun_id) (VarArg voidId))
453 = -- Generate the rhs
454 cloneIds env used_args `thenSmpl` \ used_args' ->
456 new_env = extendIdEnvWithClones env used_args used_args'
457 rhs_fun_ty :: OutType
458 rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
461 -- Make the new binding Id. NB: it's an OutId
462 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
463 rhs_c new_env `thenSmpl` \ rhs' ->
465 final_rhs = mkValLam used_args' rhs'
467 returnSmpl (NonRec rhs_fun_id final_rhs,
468 foldl App (Var rhs_fun_id) used_arg_atoms)
469 -- This is slightly wierd. We're retuning an OutId as part of the
470 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
471 -- it's processed the OutId won't be found in the environment, so it
472 -- will be left unmodified.
475 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
476 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
480 prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
483 Case alternatives when we don't know the scrutinee
484 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
486 A special case for case default. If we have
492 it is best to make sure that \tr{default_e} mentions \tr{x} in
493 preference to \tr{y}. The code generator can do a cheaper job if it
494 doesn't have to come up with a binding for \tr{y}.
497 simplAlts :: SimplEnv
498 -> OutExpr -- Simplified scrutinee;
499 -- only of interest if its a var,
500 -- in which case we record its form
502 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
505 simplAlts env scrut (AlgAlts alts deflt) rhs_c
506 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
507 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
508 returnSmpl (AlgAlts alts' deflt')
510 deflt_form = OtherCon [con | (con,_,_) <- alts]
511 do_alt (con, con_args, rhs)
512 = cloneIds env con_args `thenSmpl` \ con_args' ->
514 env1 = extendIdEnvWithClones env con_args con_args'
515 new_env = case scrut of
516 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
518 (_, ty_args, _) = getAppDataTyConExpandingDicts (idType v)
519 args = map TyArg ty_args ++ map VarArg 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 = OtherLit [lit | (lit,_) <- alts]
534 new_env = case scrut of
535 Var v -> extendEnvGivenNewRhs env v (Lit 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 -> RhsInfo -- 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@(_,occ_info) rhs)
582 info_from_this_case rhs_c
583 = cloneId env binder `thenSmpl` \ binder' ->
585 env1 = extendIdEnvWithClone env binder binder'
586 env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
588 -- Add form details for the default binder
589 scrut_info = lookupRhsInfo env scrut_var
590 env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
591 new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
593 rhs_c new_env rhs `thenSmpl` \ rhs' ->
594 returnSmpl (BindDefault binder' rhs')
596 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
597 info_from_this_case rhs_c
598 = cloneId env binder `thenSmpl` \ binder' ->
600 env1 = extendIdEnvWithClone env binder binder'
601 new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
603 rhs_c new_env rhs `thenSmpl` \ rhs' ->
604 returnSmpl (BindDefault binder' rhs')
607 Case alternatives when we know what the scrutinee is
608 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
611 completePrimCaseWithKnownLit
615 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
618 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
621 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
623 search_alts ((alt_lit, rhs) : _)
625 = -- Matching alternative!
628 search_alts (_ : other_alts)
629 = -- This alternative doesn't match; keep looking
630 search_alts other_alts
634 NoDefault -> -- Blargh!
635 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
637 BindDefault binder rhs -> -- OK, there's a default case
638 -- Just bind the Id to the atom and continue
640 new_env = extendIdEnvWithAtom env binder (LitArg lit)
645 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
646 select one case alternative (or default). If we choose the default:
647 we do different things depending on whether the constructor was
648 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
649 [let-bind it] or we just know the \tr{y} is now the same as some other
650 var [substitute \tr{y} out of existence].
653 completeAlgCaseWithKnownCon
655 -> DataCon -> [InArg]
656 -- Scrutinee is (con, type, value arguments)
658 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
661 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
662 = ASSERT(isDataCon con)
665 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
667 search_alts ((alt_con, alt_args, rhs) : _)
669 = -- Matching alternative!
671 new_env = extendIdEnvWithAtoms env
672 (zipEqual "SimplCase" alt_args (filter isValArg con_args))
676 search_alts (_ : other_alts)
677 = -- This alternative doesn't match; keep looking
678 search_alts other_alts
681 = -- No matching alternative
683 NoDefault -> -- Blargh!
684 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
686 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
687 -- let-bind the binder to the constructor
688 cloneId env binder `thenSmpl` \ id' ->
690 env1 = extendIdEnvWithClone env binder id'
691 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
693 rhs_c new_env rhs `thenSmpl` \ rhs' ->
694 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
697 Case absorption and identity-case elimination
698 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
701 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
704 @mkCoCase@ tries the following transformation (if possible):
706 case v of ==> case v of
707 p1 -> rhs1 p1 -> rhs1
709 pm -> rhsm pm -> rhsm
710 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
711 {or (prim) case v of d -> rhsn}
714 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
717 which merges two cases in one case when -- the default alternative of
718 the outer case scrutises the same variable as the outer case This
719 transformation is called Case Merging. It avoids that the same
720 variable is scrutinised multiple times.
722 There's a closely-related transformation:
724 case e of ==> case e of
725 p1 -> rhs1 p1 -> rhs1
727 pm -> rhsm pm -> rhsm
728 d -> case d of pn -> let d = pn in rhsn
730 ... po -> let d = po in rhso
731 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
734 Here, the let's are essential, because d isn't in scope any more.
735 Sigh. Of course, they may be unused, in which case they'll be
736 eliminated on the next round. Unfortunately, we can't figure out
737 whether or not they are used at this juncture.
739 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
740 scrutinee is a variable, because it'll be mapped to the scrutinised
741 variable. Hence the [v/d] substitions can be omitted.
743 ALAS, now the default binder is used by preference, so we have to
744 generate trivial lets to express the substitutions, which will be
745 eliminated on the next pass.
747 The following code handles *both* these transformations (one
748 equation for AlgAlts, one for PrimAlts):
751 mkCoCase env scrut (AlgAlts outer_alts
752 (BindDefault deflt_var
753 (Case (Var scrut_var')
754 (AlgAlts inner_alts inner_deflt))))
755 | switchIsSet env SimplCaseMerge &&
756 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
757 deflt_var == scrut_var') -- Second transformation
758 = -- Aha! The default-absorption rule applies
759 tick CaseMerge `thenSmpl_`
760 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
761 (munge_alg_deflt deflt_var inner_deflt)))
762 -- NB: see comment in this location for the PrimAlts case
765 scrut_is_var = case scrut of {Var v -> True; other -> False}
766 scrut_var = case scrut of Var v -> v
768 -- Eliminate any inner alts which are shadowed by the outer ones
769 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
770 not (con `is_elem` outer_cons)]
771 outer_cons = [con | (con,_,_) <- outer_alts]
772 is_elem = isIn "mkAlgAlts"
774 -- Add the lets if necessary
775 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
777 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
779 v | scrut_is_var = Var scrut_var
780 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
782 arg_tys = --trace "SimplCase:getAppData...:2" $
783 case (getAppDataTyConExpandingDicts (idType deflt_var)) of
784 (_, arg_tys, _) -> arg_tys
786 mkCoCase env scrut (PrimAlts
788 (BindDefault deflt_var (Case
790 (PrimAlts inner_alts inner_deflt))))
791 | switchIsSet env SimplCaseMerge &&
792 ((scrut_is_var && scrut_var == scrut_var') ||
793 deflt_var == scrut_var')
794 = -- Aha! The default-absorption rule applies
795 tick CaseMerge `thenSmpl_`
796 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
797 (munge_prim_deflt deflt_var inner_deflt)))
799 -- Nota Bene: we don't recurse to mkCoCase again, because the
800 -- default will now have a binding in it that prevents
801 -- mkCoCase doing anything useful. Much worse, in this
802 -- PrimAlts case the binding in the default branch is another
803 -- Case, so if we recurse to mkCoCase we will get into an
806 -- ToDo: think of a better way to do this. At the moment
807 -- there is at most one case merge per round. That's probably
808 -- plenty but it seems unclean somehow.
811 scrut_is_var = case scrut of {Var v -> True; other -> False}
812 scrut_var = case scrut of Var v -> v
814 -- Eliminate any inner alts which are shadowed by the outer ones
815 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
816 not (lit `is_elem` outer_lits)]
817 outer_lits = [lit | (lit,_) <- outer_alts]
818 is_elem = isIn "mkPrimAlts"
820 -- Add the lets (well cases actually) if necessary
821 -- The munged alternative looks like
822 -- lit -> case lit of d -> rhs
823 -- The next pass will certainly eliminate the inner case, but
824 -- it isn't easy to do so right away.
825 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
828 | scrut_is_var = (lit, Case (Var scrut_var)
829 (PrimAlts [] (BindDefault deflt_var rhs)))
830 | otherwise = (lit, Case (Lit lit)
831 (PrimAlts [] (BindDefault deflt_var rhs)))
834 Now the identity-case transformation:
843 mkCoCase env scrut alts
845 = tick CaseIdentity `thenSmpl_`
848 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
849 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
851 identity_alg_alt (con, args, Con con' args')
853 && and (zipWith eq_arg args args')
854 && length args == length args'
855 identity_alg_alt other
858 identity_prim_alt (lit, Lit lit') = lit == lit'
859 identity_prim_alt other = False
861 -- For the default case we want to spot both
864 -- case y of { ... ; x -> y }
865 -- as "identity" defaults
866 identity_deflt NoDefault = True
867 identity_deflt (BindDefault binder (Var x)) = x == binder ||
871 identity_deflt _ = False
873 eq_arg binder (VarArg x) = binder == x
880 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
883 Boring local functions used above. They simply introduce a trivial binding
884 for the binder, d', in an inner default; either
885 let d' = deflt_var in rhs
887 case deflt_var of d' -> rhs
888 depending on whether it's an algebraic or primitive case.
891 munge_prim_deflt _ NoDefault = NoDefault
893 munge_prim_deflt deflt_var (BindDefault d' rhs)
894 = BindDefault deflt_var (Case (Var deflt_var)
895 (PrimAlts [] (BindDefault d' rhs)))
897 munge_alg_deflt _ NoDefault = NoDefault
899 munge_alg_deflt deflt_var (BindDefault d' rhs)
900 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
902 -- This line caused a generic version of munge_deflt (ie one used for
903 -- both alg and prim) to space leak massively. No idea why.
904 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
908 cheap_eq :: InExpr -> InExpr -> Bool
909 -- A cheap equality test which bales out fast!
911 cheap_eq (Var v1) (Var v2) = v1==v2
912 cheap_eq (Lit l1) (Lit l2) = l1==l2
913 cheap_eq (Con con1 args1) (Con con2 args2)
914 = con1 == con2 && args1 `eq_args` args2
916 cheap_eq (Prim op1 args1) (Prim op2 args2)
917 = op1 ==op2 && args1 `eq_args` args2
919 cheap_eq (App f1 a1) (App f2 a2)
920 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
924 -- ToDo: make CoreArg an instance of Eq
925 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
929 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
930 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
931 eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2
932 eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2