2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[SimplCase]{Simplification of `case' expression}
6 Support code for @Simplify@.
9 module SimplCase ( simplCase, bindLargeRhs ) where
11 #include "HsVersions.h"
13 import {-# SOURCE #-} Simplify ( simplBind, simplExpr )
15 import BinderInfo -- too boring to try to select things...
16 import CmdLineOpts ( SimplifierSwitch(..) )
18 import CoreUnfold ( Unfolding(..) )
19 import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
20 unTagBindersAlts, unTagBinders, coreExprType
22 import Id ( idType, isDataCon, getIdDemandInfo, dataConArgTys,
23 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-} )
31 import SimplVar ( simplBinder, simplBinders )
32 import SimplUtils ( newId, newIds )
35 import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys )
36 import TyCon ( isDataTyCon )
37 import TysPrim ( voidTy )
38 import Util ( 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 simplExpr env retyped_error_app [] result_ty
136 -- We must apply simplExpr because "rhs" isn't yet simplified.
137 -- The ice is a little thin because body_ty is an OutType; but it's ok really
139 maybe_error_app = maybeErrorApp scrut (Just result_ty)
140 Just retyped_error_app = maybe_error_app
143 Finally the default case
146 simplCase env other_scrut alts rhs_c result_ty
147 = simplTy env scrut_ty `appEager` \ scrut_ty' ->
148 simplExpr env' other_scrut [] scrut_ty `thenSmpl` \ scrut' ->
149 completeCase env scrut' alts rhs_c
151 -- When simplifying the scrutinee of a complete case that
152 -- has no default alternative
154 AlgAlts _ NoDefault -> setCaseScrutinee env
155 PrimAlts _ NoDefault -> setCaseScrutinee env
158 scrut_ty = coreExprType (unTagBinders other_scrut)
162 %************************************************************************
164 \subsection[Simplify-case]{Completing case-expression simplification}
166 %************************************************************************
171 -> OutExpr -- The already-simplified scrutinee
172 -> InAlts -- The un-simplified alternatives
173 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
174 -> SmplM OutExpr -- The whole case expression
177 Scrutinising a literal or constructor.
178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
179 It's an obvious win to do:
181 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
183 and the similar thing for primitive case. If we have
187 and x is known to be of constructor form, then we'll already have
188 inlined the constructor to give (case (C a b) of ...), so we don't
189 need to check for the variable case separately.
191 Sanity check: we don't have a good
192 story to tell about case analysis on NoRep things. ToDo.
195 completeCase env (Lit lit) alts rhs_c
196 | not (isNoRepLit lit)
197 = -- Ha! Select the appropriate alternative
198 tick KnownBranch `thenSmpl_`
199 completePrimCaseWithKnownLit env lit alts rhs_c
201 completeCase env expr@(Con con con_args) alts rhs_c
202 = -- Ha! Staring us in the face -- select the appropriate alternative
203 tick KnownBranch `thenSmpl_`
204 completeAlgCaseWithKnownCon env con con_args alts rhs_c
209 Start with a simple situation:
211 case x# of ===> e[x#/y#]
214 (when x#, y# are of primitive type, of course).
215 We can't (in general) do this for algebraic cases, because we might
216 turn bottom into non-bottom!
218 Actually, we generalise this idea to look for a case where we're
219 scrutinising a variable, and we know that only the default case can
224 other -> ...(case x of
228 Here the inner case can be eliminated. This really only shows up in
229 eliminating error-checking code.
231 Lastly, we generalise the transformation to handle this:
237 We only do this for very cheaply compared r's (constructors, literals
238 and variables). If pedantic bottoms is on, we only do it when the
239 scrutinee is a PrimOp which can't fail.
241 We do it *here*, looking at un-simplified alternatives, because we
242 have to check that r doesn't mention the variables bound by the
243 pattern in each alternative, so the binder-info is rather useful.
245 So the case-elimination algorithm is:
247 1. Eliminate alternatives which can't match
249 2. Check whether all the remaining alternatives
250 (a) do not mention in their rhs any of the variables bound in their pattern
251 and (b) have equal rhss
253 3. Check we can safely ditch the case:
254 * PedanticBottoms is off,
255 or * the scrutinee is an already-evaluated variable
256 or * the scrutinee is a primop which is ok for speculation
257 -- ie we want to preserve divide-by-zero errors, and
258 -- calls to error itself!
260 or * [Prim cases] the scrutinee is a primitive variable
262 or * [Alg cases] the scrutinee is a variable and
263 either * the rhs is the same variable
264 (eg case x of C a b -> x ===> x)
265 or * there is only one alternative, the default alternative,
266 and the binder is used strictly in its scope.
267 [NB this is helped by the "use default binder where
268 possible" transformation; see below.]
271 If so, then we can replace the case with one of the rhss.
274 completeCase env scrut alts rhs_c
275 | switchIsSet env SimplDoCaseElim &&
281 (not (switchIsSet env SimplPedanticBottoms) ||
283 scrut_is_eliminable_primitive ||
285 scrut_is_var_and_single_strict_default
288 = tick CaseElim `thenSmpl_`
291 -- Find the non-excluded rhss of the case; always at least one
292 (rhs1:rhss) = possible_rhss
293 all_rhss_same = all (cheap_eq rhs1) rhss
295 -- Find the reduced set of possible rhss, along with an indication of
296 -- whether none of their binders are used
297 (binders_unused, possible_rhss, new_env)
299 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
303 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
305 -- Eliminate unused rhss if poss
306 rhss = case scrut_form of
307 OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
308 not (alt_lit `is_elem` not_these)
310 other -> [rhs | (_,rhs) <- alts]
312 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
313 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
316 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
318 -- Eliminate unused alts if poss
319 possible_alts = case scrut_form of
320 OtherCon not_these ->
321 -- Remove alts which can't match
322 [alt | alt@(alt_con,_,_) <- alts,
323 not (alt_con `is_elem` not_these)]
327 alt_binders_unused (con, args, rhs) = all is_dead args
328 is_dead (_, DeadCode) = True
329 is_dead other_arg = False
331 -- If the scrutinee is a variable, look it up to see what we know about it
332 scrut_form = case scrut of
333 Var v -> lookupUnfolding env v
336 -- If the scrut is already eval'd then there's no worry about
337 -- eliminating the case
338 scrut_is_evald = isEvaluated scrut_form
340 scrut_is_eliminable_primitive
342 Prim op _ -> primOpOkForSpeculation op
343 Var _ -> case alts of
344 PrimAlts _ _ -> True -- Primitive, hence non-bottom
345 AlgAlts _ _ -> False -- Not primitive
348 -- case v of w -> e{strict in w} ===> e[v/w]
349 scrut_is_var_and_single_strict_default
351 Var _ -> case alts of
352 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
356 elim_deflt_binder NoDefault -- No Binder
358 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
360 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
362 Var v -> -- Binder used, but can be eliminated in favour of scrut
363 (True, [rhs], bindIdToAtom env used_binder (VarArg v))
364 non_var -> -- Binder used, and can't be elimd
367 -- Check whether the chosen unique rhs (ie rhs1) is the same as
368 -- the scrutinee. Remember that the rhs is as yet unsimplified.
369 rhs1_is_scrutinee = case (scrut, rhs1) of
370 (Var scrut_var, Var rhs_var)
371 -> case (lookupIdSubst env rhs_var) of
372 Nothing -> rhs_var == scrut_var
373 Just (SubstVar rhs_var') -> rhs_var' == scrut_var
377 is_elem x ys = isIn "completeCase" x ys
380 Scrutinising anything else. If it's a variable, it can't be bound to a
381 constructor or literal, because that would have been inlined
384 completeCase env scrut alts rhs_c
385 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
386 mkCoCase env scrut alts'
393 bindLargeAlts :: SimplEnv
395 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
396 -> OutType -- Result type
397 -> SmplM ([OutBinding], -- Extra bindings
398 InAlts) -- Modified alts
400 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
401 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
402 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
403 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
405 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
406 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
407 returnSmpl (bind, (con,args,rhs'))
409 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
410 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
411 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
412 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
414 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
415 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
416 returnSmpl (bind, (lit,rhs'))
418 bindLargeDefault env NoDefault rhs_ty rhs_c
419 = returnSmpl ([], NoDefault)
420 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
421 = bindLargeRhs env [binder] rhs_ty
422 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
423 returnSmpl ([bind], BindDefault binder rhs')
426 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
427 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
431 bindLargeRhs :: SimplEnv
432 -> [InBinder] -- The args wrt which the rhs should be abstracted
434 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
435 -> SmplM (OutBinding, -- New bindings (singleton or empty)
436 InExpr) -- Modified rhs
438 bindLargeRhs env args rhs_ty rhs_c
439 | null used_args && isUnpointedType rhs_ty
440 -- If we try to lift a primitive-typed something out
441 -- for let-binding-purposes, we will *caseify* it (!),
442 -- with potentially-disastrous strictness results. So
443 -- instead we turn it into a function: \v -> e
444 -- where v::Void. Since arguments of type
445 -- VoidPrim don't generate any code, this gives the
448 -- The general structure is just the same as for the common "otherwise~ case
449 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
450 newId voidTy `thenSmpl` \ void_arg_id ->
451 rhs_c env `thenSmpl` \ prim_new_body ->
453 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
454 App (Var prim_rhs_fun_id) (VarArg voidId))
457 = -- Generate the rhs
458 simplBinders env used_args `thenSmpl` \ (new_env, used_args') ->
460 rhs_fun_ty :: OutType
461 rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
464 -- Make the new binding Id. NB: it's an OutId
465 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
466 rhs_c new_env `thenSmpl` \ rhs' ->
468 final_rhs = mkValLam used_args' rhs'
470 returnSmpl (NonRec rhs_fun_id final_rhs,
471 foldl App (Var rhs_fun_id) used_arg_atoms)
472 -- This is slightly wierd. We're retuning an OutId as part of the
473 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
474 -- it's processed the OutId won't be found in the environment, so it
475 -- will be left unmodified.
478 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
479 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
483 prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
486 Case alternatives when we don't know the scrutinee
487 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
489 A special case for case default. If we have
495 it is best to make sure that \tr{default_e} mentions \tr{x} in
496 preference to \tr{y}. The code generator can do a cheaper job if it
497 doesn't have to come up with a binding for \tr{y}.
500 simplAlts :: SimplEnv
501 -> OutExpr -- Simplified scrutinee;
502 -- only of interest if its a var,
503 -- in which case we record its form
505 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
507 -- For single-constructor types
508 -- case e of y -> b ===> case e of (a,b) -> let y = (a,b) in b
510 simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
511 | maybeToBool maybe_data_ty &&
512 not (null cons) && -- Not an abstract type (can arise if we're pruning tydecl imports)
514 isDataTyCon tycon -- doesn't apply to (constructor-less) newtypes
515 = newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
517 new_args = [ (b, bad_occ_info) | b <- new_bindees ]
518 con_app = mkCon con ty_args (map VarArg new_bindees)
519 new_rhs = Let (NonRec bndr con_app) rhs
521 simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
523 maybe_data_ty = splitAlgTyConApp_maybe (idType id)
524 Just (tycon, ty_args, cons) = maybe_data_ty
525 (con:other_cons) = cons
526 inst_con_arg_tys = dataConArgTys con ty_args
527 bad_occ_info = ManyOcc 0 -- Non-committal!
529 simplAlts env scrut (AlgAlts alts deflt) rhs_c
530 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
531 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
532 returnSmpl (AlgAlts alts' deflt')
534 deflt_form = OtherCon [con | (con,_,_) <- alts]
535 do_alt (con, con_args, rhs)
536 = simplBinders env con_args `thenSmpl` \ (env1, con_args') ->
538 new_env = case scrut of
539 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
541 (_, ty_args, _) = splitAlgTyConApp (idType v)
542 args = map TyArg ty_args ++ map VarArg con_args'
546 rhs_c new_env rhs `thenSmpl` \ rhs' ->
547 returnSmpl (con, con_args', rhs')
549 simplAlts env scrut (PrimAlts alts deflt) rhs_c
550 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
551 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
552 returnSmpl (PrimAlts alts' deflt')
554 deflt_form = OtherLit [lit | (lit,_) <- alts]
557 new_env = case scrut of
558 Var v -> extendEnvGivenNewRhs env v (Lit lit)
561 rhs_c new_env rhs `thenSmpl` \ rhs' ->
562 returnSmpl (lit, rhs')
565 Use default binder where possible
566 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
567 There's one complication when simplifying the default clause of
568 a case expression. If we see
573 we'd like to convert it to
578 Reason 1: then there might be just one occurrence of x, and it can be
579 inlined as the case scrutinee. So we spot this case when dealing with
580 the default clause, and add a binding to the environment mapping x to
583 Reason 2: if the body is strict in x' then we can eliminate the
584 case altogether. By using x' in preference to x we give the max chance
585 of the strictness analyser finding that the body is strict in x'.
587 On the other hand, if x does *not* get inlined, then we'll actually
588 get somewhat better code from the former expression. So when
589 doing Core -> STG we convert back!
594 -> OutExpr -- Simplified scrutinee
595 -> InDefault -- Default alternative to be completed
596 -> Unfolding -- Gives form of scrutinee
597 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
600 simplDefault env scrut NoDefault form rhs_c
601 = returnSmpl NoDefault
603 -- Special case for variable scrutinee; see notes above.
604 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
605 info_from_this_case rhs_c
606 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
608 env2 = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
610 -- Add form details for the default binder
611 scrut_info = lookupUnfolding env scrut_var
612 env3 = extendEnvGivenUnfolding env2 binder' occ_info scrut_info
613 new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
615 rhs_c new_env rhs `thenSmpl` \ rhs' ->
616 returnSmpl (BindDefault binder' rhs')
618 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
619 info_from_this_case rhs_c
620 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
622 new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
624 rhs_c new_env rhs `thenSmpl` \ rhs' ->
625 returnSmpl (BindDefault binder' rhs')
628 Case alternatives when we know what the scrutinee is
629 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
632 completePrimCaseWithKnownLit
636 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
639 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
642 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
644 search_alts ((alt_lit, rhs) : _)
646 = -- Matching alternative!
649 search_alts (_ : other_alts)
650 = -- This alternative doesn't match; keep looking
651 search_alts other_alts
655 NoDefault -> -- Blargh!
656 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
658 BindDefault binder rhs -> -- OK, there's a default case
659 -- Just bind the Id to the atom and continue
661 new_env = bindIdToAtom env binder (LitArg lit)
666 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
667 select one case alternative (or default). If we choose the default:
668 we do different things depending on whether the constructor was
669 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
670 [let-bind it] or we just know the \tr{y} is now the same as some other
671 var [substitute \tr{y} out of existence].
674 completeAlgCaseWithKnownCon
676 -> DataCon -> [InArg]
677 -- Scrutinee is (con, type, value arguments)
679 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
682 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
683 = ASSERT(isDataCon con)
686 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
688 search_alts ((alt_con, alt_args, rhs) : _)
690 = -- Matching alternative!
692 val_args = filter isValArg con_args
693 new_env = foldr bind env (zipEqual "SimplCase" alt_args val_args)
694 bind (bndr, atom) env = bindIdToAtom env bndr atom
698 search_alts (_ : other_alts)
699 = -- This alternative doesn't match; keep looking
700 search_alts other_alts
703 = -- No matching alternative
705 NoDefault -> -- Blargh!
706 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
708 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
709 -- let-bind the binder to the constructor
710 simplBinder env binder `thenSmpl` \ (env1, id') ->
712 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
714 rhs_c new_env rhs `thenSmpl` \ rhs' ->
715 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
718 Case absorption and identity-case elimination
719 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
722 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
725 @mkCoCase@ tries the following transformation (if possible):
727 case v of ==> case v of
728 p1 -> rhs1 p1 -> rhs1
730 pm -> rhsm pm -> rhsm
731 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
732 {or (prim) case v of d -> rhsn}
735 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
738 which merges two cases in one case when -- the default alternative of
739 the outer case scrutises the same variable as the outer case This
740 transformation is called Case Merging. It avoids that the same
741 variable is scrutinised multiple times.
743 There's a closely-related transformation:
745 case e of ==> case e of
746 p1 -> rhs1 p1 -> rhs1
748 pm -> rhsm pm -> rhsm
749 d -> case d of pn -> let d = pn in rhsn
751 ... po -> let d = po in rhso
752 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
755 Here, the let's are essential, because d isn't in scope any more.
756 Sigh. Of course, they may be unused, in which case they'll be
757 eliminated on the next round. Unfortunately, we can't figure out
758 whether or not they are used at this juncture.
760 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
761 scrutinee is a variable, because it'll be mapped to the scrutinised
762 variable. Hence the [v/d] substitions can be omitted.
764 ALAS, now the default binder is used by preference, so we have to
765 generate trivial lets to express the substitutions, which will be
766 eliminated on the next pass.
768 The following code handles *both* these transformations (one
769 equation for AlgAlts, one for PrimAlts):
772 mkCoCase env scrut (AlgAlts outer_alts
773 (BindDefault deflt_var
774 (Case (Var scrut_var')
775 (AlgAlts inner_alts inner_deflt))))
776 | switchIsSet env SimplCaseMerge &&
777 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
778 deflt_var == scrut_var') -- Second transformation
779 = -- Aha! The default-absorption rule applies
780 tick CaseMerge `thenSmpl_`
781 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
782 (munge_alg_deflt deflt_var inner_deflt)))
783 -- NB: see comment in this location for the PrimAlts case
786 scrut_is_var = case scrut of {Var v -> True; other -> False}
787 scrut_var = case scrut of Var v -> v
789 -- Eliminate any inner alts which are shadowed by the outer ones
790 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
791 not (con `is_elem` outer_cons)]
792 outer_cons = [con | (con,_,_) <- outer_alts]
793 is_elem = isIn "mkAlgAlts"
795 -- Add the lets if necessary
796 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
798 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
800 v | scrut_is_var = Var scrut_var
801 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
803 arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
804 (_, arg_tys, _) -> arg_tys
806 mkCoCase env scrut (PrimAlts
808 (BindDefault deflt_var (Case
810 (PrimAlts inner_alts inner_deflt))))
811 | switchIsSet env SimplCaseMerge &&
812 ((scrut_is_var && scrut_var == scrut_var') ||
813 deflt_var == scrut_var')
814 = -- Aha! The default-absorption rule applies
815 tick CaseMerge `thenSmpl_`
816 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
817 (munge_prim_deflt deflt_var inner_deflt)))
819 -- Nota Bene: we don't recurse to mkCoCase again, because the
820 -- default will now have a binding in it that prevents
821 -- mkCoCase doing anything useful. Much worse, in this
822 -- PrimAlts case the binding in the default branch is another
823 -- Case, so if we recurse to mkCoCase we will get into an
826 -- ToDo: think of a better way to do this. At the moment
827 -- there is at most one case merge per round. That's probably
828 -- plenty but it seems unclean somehow.
831 scrut_is_var = case scrut of {Var v -> True; other -> False}
832 scrut_var = case scrut of Var v -> v
834 -- Eliminate any inner alts which are shadowed by the outer ones
835 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
836 not (lit `is_elem` outer_lits)]
837 outer_lits = [lit | (lit,_) <- outer_alts]
838 is_elem = isIn "mkPrimAlts"
840 -- Add the lets (well cases actually) if necessary
841 -- The munged alternative looks like
842 -- lit -> case lit of d -> rhs
843 -- The next pass will certainly eliminate the inner case, but
844 -- it isn't easy to do so right away.
845 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
848 | scrut_is_var = (lit, Case (Var scrut_var)
849 (PrimAlts [] (BindDefault deflt_var rhs)))
850 | otherwise = (lit, Case (Lit lit)
851 (PrimAlts [] (BindDefault deflt_var rhs)))
854 Now the identity-case transformation:
863 mkCoCase env scrut alts
865 = tick CaseIdentity `thenSmpl_`
868 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
869 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
871 identity_alg_alt (con, args, Con con' args')
873 && and (zipWith eq_arg args args')
874 && length args == length args'
875 identity_alg_alt other
878 identity_prim_alt (lit, Lit lit') = lit == lit'
879 identity_prim_alt other = False
881 -- For the default case we want to spot both
884 -- case y of { ... ; x -> y }
885 -- as "identity" defaults
886 identity_deflt NoDefault = True
887 identity_deflt (BindDefault binder (Var x)) = x == binder ||
891 identity_deflt _ = False
893 eq_arg binder (VarArg x) = binder == x
900 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
903 Boring local functions used above. They simply introduce a trivial binding
904 for the binder, d', in an inner default; either
905 let d' = deflt_var in rhs
907 case deflt_var of d' -> rhs
908 depending on whether it's an algebraic or primitive case.
911 munge_prim_deflt _ NoDefault = NoDefault
913 munge_prim_deflt deflt_var (BindDefault d' rhs)
914 = BindDefault deflt_var (Case (Var deflt_var)
915 (PrimAlts [] (BindDefault d' rhs)))
917 munge_alg_deflt _ NoDefault = NoDefault
919 munge_alg_deflt deflt_var (BindDefault d' rhs)
920 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
922 -- This line caused a generic version of munge_deflt (ie one used for
923 -- both alg and prim) to space leak massively. No idea why.
924 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
928 cheap_eq :: InExpr -> InExpr -> Bool
929 -- A cheap equality test which bales out fast!
931 cheap_eq (Var v1) (Var v2) = v1==v2
932 cheap_eq (Lit l1) (Lit l2) = l1==l2
933 cheap_eq (Con con1 args1) (Con con2 args2)
934 = con1 == con2 && args1 `eq_args` args2
936 cheap_eq (Prim op1 args1) (Prim op2 args2)
937 = op1 ==op2 && args1 `eq_args` args2
939 cheap_eq (App f1 a1) (App f2 a2)
940 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
944 -- ToDo: make CoreArg an instance of Eq
945 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
949 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
950 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
951 eq_arg (TyArg t1) (TyArg t2) = t1 == t2