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 ( whnfDetails, mkConForm, mkLitForm,
20 UnfoldingDetails(..), UnfoldingGuidance(..),
23 import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
26 import Id ( idType, isDataCon, getIdDemandInfo,
27 SYN_IE(DataCon), GenId{-instance Eq-}
29 import IdInfo ( willBeDemanded, DemandInfo )
30 import Literal ( isNoRepLit, Literal{-instance Eq-} )
31 import Maybes ( maybeToBool )
32 import PrelVals ( voidId )
33 import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
36 import SimplUtils ( mkValLamTryingEta )
37 import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy )
38 import TysPrim ( voidTy )
39 import Unique ( Unique{-instance Eq-} )
40 import Usage ( GenUsage{-instance Eq-} )
41 import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
44 Float let out of case.
48 -> InExpr -- Scrutinee
49 -> InAlts -- Alternatives
50 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
51 -> OutType -- Type of result expression
54 simplCase env (Let bind body) alts rhs_c result_ty
55 | not (switchIsSet env SimplNoLetFromCase)
56 = -- Float the let outside the case scrutinee (if not disabled by flag)
57 tick LetFloatFromCase `thenSmpl_`
58 simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
61 OK to do case-of-case if
63 * we allow arbitrary code duplication
67 * the inner case has one alternative
68 case (case e of (a,b) -> rhs) of
79 IF neither of these two things are the case, we avoid code-duplication
80 by abstracting the outer rhss wrt the pattern variables. For example
82 case (case e of { p1->rhs1; ...; pn -> rhsn }) of
88 p1 -> case rhs1 of (x,y) -> b x y
90 pn -> case rhsn of (x,y) -> b x y
93 OK, so outer case expression gets duplicated, but that's all. Furthermore,
94 (a) the binding for "b" will be let-no-escaped, so no heap allocation
95 will take place; the "call" to b will simply be a stack adjustment
97 (b) very commonly, at least some of the rhsi's will be constructors, which
98 makes life even simpler.
100 All of this works equally well if the outer case has multiple rhss.
104 simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
105 | switchIsSet env SimplCaseOfCase
106 = -- Ha! Do case-of-case
107 tick CaseOfCase `thenSmpl_`
109 if no_need_to_bind_large_alts
111 simplCase env inner_scrut inner_alts
112 (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
114 bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
116 rhs_c' = \env rhs -> simplExpr env rhs []
118 simplCase env inner_scrut inner_alts
119 (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
121 `thenSmpl` \ case_expr ->
122 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
125 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
126 isSingleton (nonErrorRHSs inner_alts)
129 Case of an application of error.
132 simplCase env scrut alts rhs_c result_ty
133 | maybeToBool maybe_error_app
134 = -- Look for an application of an error id
135 tick CaseOfError `thenSmpl_`
136 rhs_c env retyped_error_app
138 alts_ty = coreAltsType (unTagBindersAlts alts)
139 maybe_error_app = maybeErrorApp scrut (Just alts_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 = -- Float the let outside the case scrutinee
148 simplExpr env other_scrut [] `thenSmpl` \ scrut' ->
149 completeCase env scrut' alts rhs_c
153 %************************************************************************
155 \subsection[Simplify-case]{Completing case-expression simplification}
157 %************************************************************************
162 -> OutExpr -- The already-simplified scrutinee
163 -> InAlts -- The un-simplified alternatives
164 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
165 -> SmplM OutExpr -- The whole case expression
168 Scrutinising a literal or constructor.
169 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
170 It's an obvious win to do:
172 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
174 and the similar thing for primitive case. If we have
178 and x is known to be of constructor form, then we'll already have
179 inlined the constructor to give (case (C a b) of ...), so we don't
180 need to check for the variable case separately.
182 Sanity check: we don't have a good
183 story to tell about case analysis on NoRep things. ToDo.
186 completeCase env (Lit lit) alts rhs_c
187 | not (isNoRepLit lit)
188 = -- Ha! Select the appropriate alternative
189 tick KnownBranch `thenSmpl_`
190 completePrimCaseWithKnownLit env lit alts rhs_c
192 completeCase env expr@(Con con con_args) alts rhs_c
193 = -- Ha! Staring us in the face -- select the appropriate alternative
194 tick KnownBranch `thenSmpl_`
195 completeAlgCaseWithKnownCon env con con_args alts rhs_c
200 Start with a simple situation:
202 case x# of ===> e[x#/y#]
205 (when x#, y# are of primitive type, of course).
206 We can't (in general) do this for algebraic cases, because we might
207 turn bottom into non-bottom!
209 Actually, we generalise this idea to look for a case where we're
210 scrutinising a variable, and we know that only the default case can
215 other -> ...(case x of
219 Here the inner case can be eliminated. This really only shows up in
220 eliminating error-checking code.
222 Lastly, we generalise the transformation to handle this:
228 We only do this for very cheaply compared r's (constructors, literals
229 and variables). If pedantic bottoms is on, we only do it when the
230 scrutinee is a PrimOp which can't fail.
232 We do it *here*, looking at un-simplified alternatives, because we
233 have to check that r doesn't mention the variables bound by the
234 pattern in each alternative, so the binder-info is rather useful.
236 So the case-elimination algorithm is:
238 1. Eliminate alternatives which can't match
240 2. Check whether all the remaining alternatives
241 (a) do not mention in their rhs any of the variables bound in their pattern
242 and (b) have equal rhss
244 3. Check we can safely ditch the case:
245 * PedanticBottoms is off,
246 or * the scrutinee is an already-evaluated variable
247 or * the scrutinee is a primop which is ok for speculation
248 -- ie we want to preserve divide-by-zero errors, and
249 -- calls to error itself!
251 or * [Prim cases] the scrutinee is a primitive variable
253 or * [Alg cases] the scrutinee is a variable and
254 either * the rhs is the same variable
255 (eg case x of C a b -> x ===> x)
256 or * there is only one alternative, the default alternative,
257 and the binder is used strictly in its scope.
258 [NB this is helped by the "use default binder where
259 possible" transformation; see below.]
262 If so, then we can replace the case with one of the rhss.
265 completeCase env scrut alts rhs_c
266 | switchIsSet env SimplDoCaseElim &&
272 (not (switchIsSet env SimplPedanticBottoms) ||
274 scrut_is_eliminable_primitive ||
276 scrut_is_var_and_single_strict_default
279 = tick CaseElim `thenSmpl_`
282 -- Find the non-excluded rhss of the case; always at least one
283 (rhs1:rhss) = possible_rhss
284 all_rhss_same = all (cheap_eq rhs1) rhss
286 -- Find the reduced set of possible rhss, along with an indication of
287 -- whether none of their binders are used
288 (binders_unused, possible_rhss, new_env)
290 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
294 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
296 -- Eliminate unused rhss if poss
297 rhss = case scrut_form of
298 OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
299 not (alt_lit `is_elem` not_these)
301 other -> [rhs | (_,rhs) <- alts]
303 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
304 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
307 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
309 -- Eliminate unused alts if poss
310 possible_alts = case scrut_form of
311 OtherConForm not_these ->
312 -- Remove alts which can't match
313 [alt | alt@(alt_con,_,_) <- alts,
314 not (alt_con `is_elem` not_these)]
318 alt_binders_unused (con, args, rhs) = all is_dead args
319 is_dead (_, DeadCode) = True
320 is_dead other_arg = False
322 -- If the scrutinee is a variable, look it up to see what we know about it
323 scrut_form = case scrut of
324 Var v -> lookupUnfolding env v
325 other -> NoUnfoldingDetails
327 -- If the scrut is already eval'd then there's no worry about
328 -- eliminating the case
329 scrut_is_evald = whnfDetails scrut_form
331 scrut_is_eliminable_primitive
333 Prim op _ -> primOpOkForSpeculation op
334 Var _ -> case alts of
335 PrimAlts _ _ -> True -- Primitive, hence non-bottom
336 AlgAlts _ _ -> False -- Not primitive
339 -- case v of w -> e{strict in w} ===> e[v/w]
340 scrut_is_var_and_single_strict_default
342 Var _ -> case alts of
343 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
347 elim_deflt_binder NoDefault -- No Binder
349 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
351 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
353 Var v -> -- Binder used, but can be eliminated in favour of scrut
354 (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
355 non_var -> -- Binder used, and can't be elimd
358 -- Check whether the chosen unique rhs (ie rhs1) is the same as
359 -- the scrutinee. Remember that the rhs is as yet unsimplified.
360 rhs1_is_scrutinee = case (scrut, rhs1) of
361 (Var scrut_var, Var rhs_var)
362 -> case lookupId env rhs_var of
363 Just (ItsAnAtom (VarArg rhs_var'))
364 -> rhs_var' == scrut_var
368 is_elem x ys = isIn "completeCase" x ys
371 Scrutinising anything else. If it's a variable, it can't be bound to a
372 constructor or literal, because that would have been inlined
375 completeCase env scrut alts rhs_c
376 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
384 bindLargeAlts :: SimplEnv
386 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
387 -> OutType -- Result type
388 -> SmplM ([OutBinding], -- Extra bindings
389 InAlts) -- Modified alts
391 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
392 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
393 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
394 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
396 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
397 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
398 returnSmpl (bind, (con,args,rhs'))
400 bindLargeAlts env the_lot@(PrimAlts 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, PrimAlts alts' deflt')
405 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
406 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
407 returnSmpl (bind, (lit,rhs'))
409 bindLargeDefault env NoDefault rhs_ty rhs_c
410 = returnSmpl ([], NoDefault)
411 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
412 = bindLargeRhs env [binder] rhs_ty
413 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
414 returnSmpl ([bind], BindDefault binder rhs')
417 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
418 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
422 bindLargeRhs :: SimplEnv
423 -> [InBinder] -- The args wrt which the rhs should be abstracted
425 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
426 -> SmplM (OutBinding, -- New bindings (singleton or empty)
427 InExpr) -- Modified rhs
429 bindLargeRhs env args rhs_ty rhs_c
430 | null used_args && isPrimType rhs_ty
431 -- If we try to lift a primitive-typed something out
432 -- for let-binding-purposes, we will *caseify* it (!),
433 -- with potentially-disastrous strictness results. So
434 -- instead we turn it into a function: \v -> e
435 -- where v::Void. Since arguments of type
436 -- VoidPrim don't generate any code, this gives the
439 -- The general structure is just the same as for the common "otherwise~ case
440 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
441 newId voidTy `thenSmpl` \ void_arg_id ->
442 rhs_c env `thenSmpl` \ prim_new_body ->
444 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
445 App (Var prim_rhs_fun_id) (VarArg voidId))
448 = -- Make the new binding Id. NB: it's an OutId
449 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
452 cloneIds env used_args `thenSmpl` \ used_args' ->
454 new_env = extendIdEnvWithClones env used_args used_args'
456 rhs_c new_env `thenSmpl` \ rhs' ->
459 = (if switchIsSet new_env SimplDoEtaReduction
460 then mkValLamTryingEta
461 else mkValLam) used_args' rhs'
463 returnSmpl (NonRec rhs_fun_id final_rhs,
464 foldl App (Var rhs_fun_id) used_arg_atoms)
465 -- This is slightly wierd. We're retuning an OutId as part of the
466 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
467 -- it's processed the OutId won't be found in the environment, so it
468 -- will be left unmodified.
470 rhs_fun_ty :: OutType
471 rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
473 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
474 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
478 prim_rhs_fun_ty = mkFunTys [voidTy] rhs_ty
481 Case alternatives when we don't know the scrutinee
482 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
484 A special case for case default. If we have
490 it is best to make sure that \tr{default_e} mentions \tr{x} in
491 preference to \tr{y}. The code generator can do a cheaper job if it
492 doesn't have to come up with a binding for \tr{y}.
495 simplAlts :: SimplEnv
496 -> OutExpr -- Simplified scrutinee;
497 -- only of interest if its a var,
498 -- in which case we record its form
500 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
503 simplAlts env scrut (AlgAlts alts deflt) rhs_c
504 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
505 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
506 returnSmpl (AlgAlts alts' deflt')
508 deflt_form = OtherConForm [con | (con,_,_) <- alts]
509 do_alt (con, con_args, rhs)
510 = cloneIds env con_args `thenSmpl` \ con_args' ->
512 env1 = extendIdEnvWithClones env con_args con_args'
513 new_env = case scrut of
514 Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args'
517 rhs_c new_env rhs `thenSmpl` \ rhs' ->
518 returnSmpl (con, con_args', rhs')
520 simplAlts env scrut (PrimAlts alts deflt) rhs_c
521 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
522 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
523 returnSmpl (PrimAlts alts' deflt')
525 deflt_form = OtherLitForm [lit | (lit,_) <- alts]
528 new_env = case scrut of
529 Var v -> extendUnfoldEnvGivenFormDetails env v (mkLitForm lit)
532 rhs_c new_env rhs `thenSmpl` \ rhs' ->
533 returnSmpl (lit, rhs')
536 Use default binder where possible
537 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
538 There's one complication when simplifying the default clause of
539 a case expression. If we see
544 we'd like to convert it to
549 Reason 1: then there might be just one occurrence of x, and it can be
550 inlined as the case scrutinee. So we spot this case when dealing with
551 the default clause, and add a binding to the environment mapping x to
554 Reason 2: if the body is strict in x' then we can eliminate the
555 case altogether. By using x' in preference to x we give the max chance
556 of the strictness analyser finding that the body is strict in x'.
558 On the other hand, if x does *not* get inlined, then we'll actually
559 get somewhat better code from the former expression. So when
560 doing Core -> STG we convert back!
565 -> OutExpr -- Simplified scrutinee
566 -> InDefault -- Default alternative to be completed
567 -> UnfoldingDetails -- Gives form of scrutinee
568 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
571 simplDefault env scrut NoDefault form rhs_c
572 = returnSmpl NoDefault
574 -- Special case for variable scrutinee; see notes above.
575 simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
576 = cloneId env binder `thenSmpl` \ binder' ->
578 env1 = extendIdEnvWithAtom env binder (VarArg binder')
580 -- Add form details for the default binder
581 scrut_form = lookupUnfolding env scrut_var
583 = case (form_from_this_case, scrut_form) of
584 (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
585 (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
586 other -> form_from_this_case
588 env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
590 -- Change unfold details for scrut var. We now want to unfold it
592 new_scrut_var_form = GenForm WhnfForm (Var binder') UnfoldAlways
594 new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
597 rhs_c new_env rhs `thenSmpl` \ rhs' ->
598 returnSmpl (BindDefault binder' rhs')
600 simplDefault env scrut (BindDefault binder rhs) form rhs_c
601 = cloneId env binder `thenSmpl` \ binder' ->
603 env1 = extendIdEnvWithAtom env binder (VarArg binder')
604 new_env = extendUnfoldEnvGivenFormDetails env1 binder' form
606 rhs_c new_env rhs `thenSmpl` \ rhs' ->
607 returnSmpl (BindDefault binder' rhs')
610 Case alternatives when we know what the scrutinee is
611 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
614 completePrimCaseWithKnownLit
618 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
621 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
624 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
626 search_alts ((alt_lit, rhs) : _)
628 = -- Matching alternative!
631 search_alts (_ : other_alts)
632 = -- This alternative doesn't match; keep looking
633 search_alts other_alts
637 NoDefault -> -- Blargh!
638 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
640 BindDefault binder rhs -> -- OK, there's a default case
641 -- Just bind the Id to the atom and continue
643 new_env = extendIdEnvWithAtom env binder (LitArg lit)
648 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
649 select one case alternative (or default). If we choose the default:
650 we do different things depending on whether the constructor was
651 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
652 [let-bind it] or we just know the \tr{y} is now the same as some other
653 var [substitute \tr{y} out of existence].
656 completeAlgCaseWithKnownCon
658 -> DataCon -> [InArg]
659 -- Scrutinee is (con, type, value arguments)
661 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
664 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
665 = ASSERT(isDataCon con)
668 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
670 search_alts ((alt_con, alt_args, rhs) : _)
672 = -- Matching alternative!
674 new_env = extendIdEnvWithAtomList env (zipEqual "SimplCase" alt_args (filter isValArg con_args))
678 search_alts (_ : other_alts)
679 = -- This alternative doesn't match; keep looking
680 search_alts other_alts
683 = -- No matching alternative
685 NoDefault -> -- Blargh!
686 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
688 BindDefault binder rhs -> -- OK, there's a default case
689 -- let-bind the binder to the constructor
690 cloneId env binder `thenSmpl` \ id' ->
692 env1 = extendIdEnvWithClone env binder id'
693 new_env = extendUnfoldEnvGivenFormDetails env1 id'
694 (mkConForm con con_args)
696 rhs_c new_env rhs `thenSmpl` \ rhs' ->
697 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
700 Case absorption and identity-case elimination
701 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
704 mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
707 @mkCoCase@ tries the following transformation (if possible):
709 case v of ==> case v of
710 p1 -> rhs1 p1 -> rhs1
712 pm -> rhsm pm -> rhsm
713 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
714 {or (prim) case v of d -> rhsn}
717 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
720 which merges two cases in one case when -- the default alternative of
721 the outer case scrutises the same variable as the outer case This
722 transformation is called Case Merging. It avoids that the same
723 variable is scrutinised multiple times.
725 There's a closely-related transformation:
727 case e of ==> case e of
728 p1 -> rhs1 p1 -> rhs1
730 pm -> rhsm pm -> rhsm
731 d -> case d of pn -> let d = pn in rhsn
733 ... po -> let d = po in rhso
734 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
737 Here, the let's are essential, because d isn't in scope any more.
738 Sigh. Of course, they may be unused, in which case they'll be
739 eliminated on the next round. Unfortunately, we can't figure out
740 whether or not they are used at this juncture.
742 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
743 scrutinee is a variable, because it'll be mapped to the scrutinised
744 variable. Hence the [v/d] substitions can be omitted.
746 ALAS, now the default binder is used by preference, so we have to
747 generate trivial lets to express the substitutions, which will be
748 eliminated on the next pass.
750 The following code handles *both* these transformations (one
751 equation for AlgAlts, one for PrimAlts):
754 mkCoCase scrut (AlgAlts outer_alts
755 (BindDefault deflt_var
756 (Case (Var scrut_var')
757 (AlgAlts inner_alts inner_deflt))))
758 | (scrut_is_var && scrut_var == scrut_var') -- First transformation
759 || deflt_var == scrut_var' -- Second transformation
760 = -- Aha! The default-absorption rule applies
761 tick CaseMerge `thenSmpl_`
762 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
763 (munge_alg_deflt deflt_var inner_deflt)))
764 -- NB: see comment in this location for the PrimAlts case
767 scrut_is_var = case scrut of {Var v -> True; other -> False}
768 scrut_var = case scrut of Var v -> v
770 -- Eliminate any inner alts which are shadowed by the outer ones
771 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
772 not (con `is_elem` outer_cons)]
773 outer_cons = [con | (con,_,_) <- outer_alts]
774 is_elem = isIn "mkAlgAlts"
776 -- Add the lets if necessary
777 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
779 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
781 v | scrut_is_var = Var scrut_var
782 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
784 arg_tys = case (maybeAppDataTyConExpandingDicts (idType deflt_var)) of
785 Just (_, arg_tys, _) -> arg_tys
787 mkCoCase scrut (PrimAlts
789 (BindDefault deflt_var (Case
791 (PrimAlts inner_alts inner_deflt))))
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:
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 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