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 SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun )
16 import BinderInfo -- too boring to try to select things...
17 import CmdLineOpts ( SimplifierSwitch(..) )
19 import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..),
22 import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
25 import Id ( idType, isDataCon, getIdDemandInfo,
26 DataCon(..), GenId{-instance Eq-}
28 import IdInfo ( willBeDemanded, DemandInfo )
29 import Literal ( isNoRepLit, Literal{-instance Eq-} )
30 import Maybes ( maybeToBool )
31 import PrelInfo ( voidPrimTy, voidPrimId )
32 import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
35 import SimplUtils ( mkValLamTryingEta )
36 import Type ( isPrimType, maybeAppDataTyCon, mkFunTys, eqTy )
37 import Unique ( Unique{-instance Eq-} )
38 import Usage ( GenUsage{-instance Eq-} )
39 import Util ( isIn, isSingleton, 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 []
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 rhs_c env retyped_error_app
136 alts_ty = coreAltsType (unTagBindersAlts alts)
137 maybe_error_app = maybeErrorApp scrut (Just alts_ty)
138 Just retyped_error_app = maybe_error_app
141 Finally the default case
144 simplCase env other_scrut alts rhs_c result_ty
145 = -- Float the let outside the case scrutinee
146 simplExpr env other_scrut [] `thenSmpl` \ scrut' ->
147 completeCase env scrut' alts rhs_c
151 %************************************************************************
153 \subsection[Simplify-case]{Completing case-expression simplification}
155 %************************************************************************
160 -> OutExpr -- The already-simplified scrutinee
161 -> InAlts -- The un-simplified alternatives
162 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
163 -> SmplM OutExpr -- The whole case expression
166 Scrutinising a literal or constructor.
167 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
168 It's an obvious win to do:
170 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
172 and the similar thing for primitive case. If we have
176 and x is known to be of constructor form, then we'll already have
177 inlined the constructor to give (case (C a b) of ...), so we don't
178 need to check for the variable case separately.
180 Sanity check: we don't have a good
181 story to tell about case analysis on NoRep things. ToDo.
184 completeCase env (Lit lit) alts rhs_c
185 | not (isNoRepLit lit)
186 = -- Ha! Select the appropriate alternative
187 tick KnownBranch `thenSmpl_`
188 completePrimCaseWithKnownLit env lit alts rhs_c
190 completeCase env expr@(Con con con_args) alts rhs_c
191 = -- Ha! Staring us in the face -- select the appropriate alternative
192 tick KnownBranch `thenSmpl_`
193 completeAlgCaseWithKnownCon env con con_args alts rhs_c
198 Start with a simple situation:
200 case x# of ===> e[x#/y#]
203 (when x#, y# are of primitive type, of course).
204 We can't (in general) do this for algebraic cases, because we might
205 turn bottom into non-bottom!
207 Actually, we generalise this idea to look for a case where we're
208 scrutinising a variable, and we know that only the default case can
213 other -> ...(case x of
217 Here the inner case can be eliminated. This really only shows up in
218 eliminating error-checking code.
220 Lastly, we generalise the transformation to handle this:
226 We only do this for very cheaply compared r's (constructors, literals
227 and variables). If pedantic bottoms is on, we only do it when the
228 scrutinee is a PrimOp which can't fail.
230 We do it *here*, looking at un-simplified alternatives, because we
231 have to check that r doesn't mention the variables bound by the
232 pattern in each alternative, so the binder-info is rather useful.
234 So the case-elimination algorithm is:
236 1. Eliminate alternatives which can't match
238 2. Check whether all the remaining alternatives
239 (a) do not mention in their rhs any of the variables bound in their pattern
240 and (b) have equal rhss
242 3. Check we can safely ditch the case:
243 * PedanticBottoms is off,
244 or * the scrutinee is an already-evaluated variable
245 or * the scrutinee is a primop which is ok for speculation
246 -- ie we want to preserve divide-by-zero errors, and
247 -- calls to error itself!
249 or * [Prim cases] the scrutinee is a primitive variable
251 or * [Alg cases] the scrutinee is a variable and
252 either * the rhs is the same variable
253 (eg case x of C a b -> x ===> x)
254 or * there is only one alternative, the default alternative,
255 and the binder is used strictly in its scope.
256 [NB this is helped by the "use default binder where
257 possible" transformation; see below.]
260 If so, then we can replace the case with one of the rhss.
263 completeCase env scrut alts rhs_c
264 | switchIsSet env SimplDoCaseElim &&
270 (not (switchIsSet env SimplPedanticBottoms) ||
272 scrut_is_eliminable_primitive ||
274 scrut_is_var_and_single_strict_default
277 = tick CaseElim `thenSmpl_`
280 -- Find the non-excluded rhss of the case; always at least one
281 (rhs1:rhss) = possible_rhss
282 all_rhss_same = all (cheap_eq rhs1) rhss
284 -- Find the reduced set of possible rhss, along with an indication of
285 -- whether none of their binders are used
286 (binders_unused, possible_rhss, new_env)
288 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
292 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
294 -- Eliminate unused rhss if poss
295 rhss = case scrut_form of
296 OtherLitForm not_these -> [rhs | (alt_lit,rhs) <- alts,
297 not (alt_lit `is_elem` not_these)
299 other -> [rhs | (_,rhs) <- alts]
301 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
302 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
305 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
307 -- Eliminate unused alts if poss
308 possible_alts = case scrut_form of
309 OtherConForm not_these ->
310 -- Remove alts which can't match
311 [alt | alt@(alt_con,_,_) <- alts,
312 not (alt_con `is_elem` not_these)]
315 -- ConForm c v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppStr "<args>"]) (ppr PprDebug alts))
316 -- ConForm can't happen, since we'd have
317 -- inlined it, and be in completeCaseWithKnownCon by now
321 alt_binders_unused (con, args, rhs) = all is_dead args
322 is_dead (_, DeadCode) = True
323 is_dead other_arg = False
325 -- If the scrutinee is a variable, look it up to see what we know about it
326 scrut_form = case scrut of
327 Var v -> lookupUnfolding env v
328 other -> NoUnfoldingDetails
330 -- If the scrut is already eval'd then there's no worry about
331 -- eliminating the case
332 scrut_is_evald = case scrut_form of
333 OtherLitForm _ -> True
335 OtherConForm _ -> True
339 scrut_is_eliminable_primitive
341 Prim op _ -> primOpOkForSpeculation op
342 Var _ -> case alts of
343 PrimAlts _ _ -> True -- Primitive, hence non-bottom
344 AlgAlts _ _ -> False -- Not primitive
347 -- case v of w -> e{strict in w} ===> e[v/w]
348 scrut_is_var_and_single_strict_default
350 Var _ -> case alts of
351 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
355 elim_deflt_binder NoDefault -- No Binder
357 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
359 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
361 Var v -> -- Binder used, but can be eliminated in favour of scrut
362 (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
363 non_var -> -- Binder used, and can't be elimd
366 -- Check whether the chosen unique rhs (ie rhs1) is the same as
367 -- the scrutinee. Remember that the rhs is as yet unsimplified.
368 rhs1_is_scrutinee = case (scrut, rhs1) of
369 (Var scrut_var, Var rhs_var)
370 -> case lookupId env rhs_var of
371 Just (ItsAnAtom (VarArg rhs_var'))
372 -> rhs_var' == scrut_var
376 is_elem x ys = isIn "completeCase" x ys
379 Scrutinising anything else. If it's a variable, it can't be bound to a
380 constructor or literal, because that would have been inlined
383 completeCase env scrut alts rhs_c
384 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
392 bindLargeAlts :: SimplEnv
394 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
395 -> OutType -- Result type
396 -> SmplM ([OutBinding], -- Extra bindings
397 InAlts) -- Modified alts
399 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
400 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
401 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
402 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
404 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
405 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
406 returnSmpl (bind, (con,args,rhs'))
408 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
409 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
410 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
411 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
413 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
414 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
415 returnSmpl (bind, (lit,rhs'))
417 bindLargeDefault env NoDefault rhs_ty rhs_c
418 = returnSmpl ([], NoDefault)
419 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
420 = bindLargeRhs env [binder] rhs_ty
421 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
422 returnSmpl ([bind], BindDefault binder rhs')
425 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
426 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
430 bindLargeRhs :: SimplEnv
431 -> [InBinder] -- The args wrt which the rhs should be abstracted
433 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
434 -> SmplM (OutBinding, -- New bindings (singleton or empty)
435 InExpr) -- Modified rhs
437 bindLargeRhs env args rhs_ty rhs_c
438 | null used_args && isPrimType rhs_ty
439 -- If we try to lift a primitive-typed something out
440 -- for let-binding-purposes, we will *caseify* it (!),
441 -- with potentially-disastrous strictness results. So
442 -- instead we turn it into a function: \v -> e
443 -- where v::VoidPrim. Since arguments of type
444 -- VoidPrim don't generate any code, this gives the
447 -- The general structure is just the same as for the common "otherwise~ case
448 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
449 newId voidPrimTy `thenSmpl` \ void_arg_id ->
450 rhs_c env `thenSmpl` \ prim_new_body ->
452 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
453 App (Var prim_rhs_fun_id) (VarArg voidPrimId))
456 = -- Make the new binding Id. NB: it's an OutId
457 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
460 cloneIds env used_args `thenSmpl` \ used_args' ->
462 new_env = extendIdEnvWithClones env used_args used_args'
464 rhs_c new_env `thenSmpl` \ rhs' ->
467 = (if switchIsSet new_env SimplDoEtaReduction
468 then mkValLamTryingEta
469 else mkValLam) used_args' rhs'
471 returnSmpl (NonRec rhs_fun_id final_rhs,
472 foldl App (Var rhs_fun_id) used_arg_atoms)
473 -- This is slightly wierd. We're retuning an OutId as part of the
474 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
475 -- it's processed the OutId won't be found in the environment, so it
476 -- will be left unmodified.
478 rhs_fun_ty :: OutType
479 rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
481 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
482 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
486 prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty
489 Case alternatives when we don't know the scrutinee
490 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
492 A special case for case default. If we have
498 it is best to make sure that \tr{default_e} mentions \tr{x} in
499 preference to \tr{y}. The code generator can do a cheaper job if it
500 doesn't have to come up with a binding for \tr{y}.
503 simplAlts :: SimplEnv
504 -> OutExpr -- Simplified scrutinee;
505 -- only of interest if its a var,
506 -- in which case we record its form
508 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
511 simplAlts env scrut (AlgAlts alts deflt) rhs_c
512 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
513 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
514 returnSmpl (AlgAlts alts' deflt')
516 deflt_form = OtherConForm [con | (con,_,_) <- alts]
517 do_alt (con, con_args, rhs)
518 = cloneIds env con_args `thenSmpl` \ con_args' ->
520 env1 = extendIdEnvWithClones env con_args con_args'
521 new_env = case scrut of
522 Var v -> extendUnfoldEnvGivenConstructor env1 v con con_args'
525 rhs_c new_env rhs `thenSmpl` \ rhs' ->
526 returnSmpl (con, con_args', rhs')
528 simplAlts env scrut (PrimAlts alts deflt) rhs_c
529 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
530 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
531 returnSmpl (PrimAlts alts' deflt')
533 deflt_form = OtherLitForm [lit | (lit,_) <- alts]
536 new_env = case scrut of
537 Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit)
540 rhs_c new_env rhs `thenSmpl` \ rhs' ->
541 returnSmpl (lit, rhs')
544 Use default binder where possible
545 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
546 There's one complication when simplifying the default clause of
547 a case expression. If we see
552 we'd like to convert it to
557 Reason 1: then there might be just one occurrence of x, and it can be
558 inlined as the case scrutinee. So we spot this case when dealing with
559 the default clause, and add a binding to the environment mapping x to
562 Reason 2: if the body is strict in x' then we can eliminate the
563 case altogether. By using x' in preference to x we give the max chance
564 of the strictness analyser finding that the body is strict in x'.
566 On the other hand, if x does *not* get inlined, then we'll actually
567 get somewhat better code from the former expression. So when
568 doing Core -> STG we convert back!
573 -> OutExpr -- Simplified scrutinee
574 -> InDefault -- Default alternative to be completed
575 -> UnfoldingDetails -- Gives form of scrutinee
576 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
579 simplDefault env scrut NoDefault form rhs_c
580 = returnSmpl NoDefault
582 -- Special case for variable scrutinee; see notes above.
583 simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rhs_c
584 = cloneId env binder `thenSmpl` \ binder' ->
586 env1 = extendIdEnvWithAtom env binder (VarArg binder')
588 -- Add form details for the default binder
589 scrut_form = lookupUnfolding env scrut_var
591 = case (form_from_this_case, scrut_form) of
592 (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds)
593 (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds)
594 -- ConForm, LitForm impossible
595 -- (ASSERT? ASSERT? Hello? WDP 95/05)
596 other -> form_from_this_case
598 env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form
600 -- Change unfold details for scrut var. We now want to unfold it
602 new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm
603 (Var binder') UnfoldAlways
604 new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form
607 rhs_c new_env rhs `thenSmpl` \ rhs' ->
608 returnSmpl (BindDefault binder' rhs')
610 simplDefault env scrut (BindDefault binder rhs) form rhs_c
611 = cloneId env binder `thenSmpl` \ binder' ->
613 env1 = extendIdEnvWithAtom env binder (VarArg binder')
614 new_env = extendUnfoldEnvGivenFormDetails env1 binder' form
616 rhs_c new_env rhs `thenSmpl` \ rhs' ->
617 returnSmpl (BindDefault binder' rhs')
620 Case alternatives when we know what the scrutinee is
621 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
624 completePrimCaseWithKnownLit
628 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
631 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
634 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
636 search_alts ((alt_lit, rhs) : _)
638 = -- Matching alternative!
641 search_alts (_ : other_alts)
642 = -- This alternative doesn't match; keep looking
643 search_alts other_alts
647 NoDefault -> -- Blargh!
648 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
650 BindDefault binder rhs -> -- OK, there's a default case
651 -- Just bind the Id to the atom and continue
653 new_env = extendIdEnvWithAtom env binder (LitArg lit)
658 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
659 select one case alternative (or default). If we choose the default:
660 we do different things depending on whether the constructor was
661 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
662 [let-bind it] or we just know the \tr{y} is now the same as some other
663 var [substitute \tr{y} out of existence].
666 completeAlgCaseWithKnownCon
668 -> DataCon -> [InArg]
669 -- Scrutinee is (con, type, value arguments)
671 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
674 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
675 = ASSERT(isDataCon con)
678 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
680 search_alts ((alt_con, alt_args, rhs) : _)
682 = -- Matching alternative!
684 new_env = extendIdEnvWithAtomList env (zip alt_args con_args)
688 search_alts (_ : other_alts)
689 = -- This alternative doesn't match; keep looking
690 search_alts other_alts
693 = -- No matching alternative
695 NoDefault -> -- Blargh!
696 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
698 BindDefault binder rhs -> -- OK, there's a default case
699 -- let-bind the binder to the constructor
700 cloneId env binder `thenSmpl` \ id' ->
702 env1 = extendIdEnvWithClone env binder id'
703 new_env = extendUnfoldEnvGivenFormDetails env1 id'
704 (ConForm con con_args)
706 rhs_c new_env rhs `thenSmpl` \ rhs' ->
707 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
710 Case absorption and identity-case elimination
711 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
714 mkCoCase :: OutExpr -> OutAlts -> SmplM OutExpr
717 @mkCoCase@ tries the following transformation (if possible):
719 case v of ==> case v of
720 p1 -> rhs1 p1 -> rhs1
722 pm -> rhsm pm -> rhsm
723 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
724 {or (prim) case v of d -> rhsn}
727 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
730 which merges two cases in one case when -- the default alternative of
731 the outer case scrutises the same variable as the outer case This
732 transformation is called Case Merging. It avoids that the same
733 variable is scrutinised multiple times.
735 There's a closely-related transformation:
737 case e of ==> case e of
738 p1 -> rhs1 p1 -> rhs1
740 pm -> rhsm pm -> rhsm
741 d -> case d of pn -> let d = pn in rhsn
743 ... po -> let d = po in rhso
744 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
747 Here, the let's are essential, because d isn't in scope any more.
748 Sigh. Of course, they may be unused, in which case they'll be
749 eliminated on the next round. Unfortunately, we can't figure out
750 whether or not they are used at this juncture.
752 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
753 scrutinee is a variable, because it'll be mapped to the scrutinised
754 variable. Hence the [v/d] substitions can be omitted.
756 ALAS, now the default binder is used by preference, so we have to
757 generate trivial lets to express the substitutions, which will be
758 eliminated on the next pass.
760 The following code handles *both* these transformations (one
761 equation for AlgAlts, one for PrimAlts):
764 mkCoCase scrut (AlgAlts outer_alts
765 (BindDefault deflt_var
766 (Case (Var scrut_var')
767 (AlgAlts inner_alts inner_deflt))))
768 | (scrut_is_var && scrut_var == scrut_var') -- First transformation
769 || deflt_var == scrut_var' -- Second transformation
770 = -- Aha! The default-absorption rule applies
771 tick CaseMerge `thenSmpl_`
772 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
773 (munge_alg_deflt deflt_var inner_deflt)))
774 -- NB: see comment in this location for the PrimAlts case
777 scrut_is_var = case scrut of {Var v -> True; other -> False}
778 scrut_var = case scrut of Var v -> v
780 -- Eliminate any inner alts which are shadowed by the outer ones
781 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
782 not (con `is_elem` outer_cons)]
783 outer_cons = [con | (con,_,_) <- outer_alts]
784 is_elem = isIn "mkAlgAlts"
786 -- Add the lets if necessary
787 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
789 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
791 v | scrut_is_var = Var scrut_var
792 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
794 arg_tys = case maybeAppDataTyCon (idType deflt_var) of
795 Just (_, arg_tys, _) -> arg_tys
797 mkCoCase scrut (PrimAlts
799 (BindDefault deflt_var (Case
801 (PrimAlts inner_alts inner_deflt))))
802 | (scrut_is_var && scrut_var == scrut_var') ||
803 deflt_var == scrut_var'
804 = -- Aha! The default-absorption rule applies
805 tick CaseMerge `thenSmpl_`
806 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
807 (munge_prim_deflt deflt_var inner_deflt)))
809 -- Nota Bene: we don't recurse to mkCoCase again, because the
810 -- default will now have a binding in it that prevents
811 -- mkCoCase doing anything useful. Much worse, in this
812 -- PrimAlts case the binding in the default branch is another
813 -- Case, so if we recurse to mkCoCase we will get into an
816 -- ToDo: think of a better way to do this. At the moment
817 -- there is at most one case merge per round. That's probably
818 -- plenty but it seems unclean somehow.
821 scrut_is_var = case scrut of {Var v -> True; other -> False}
822 scrut_var = case scrut of Var v -> v
824 -- Eliminate any inner alts which are shadowed by the outer ones
825 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
826 not (lit `is_elem` outer_lits)]
827 outer_lits = [lit | (lit,_) <- outer_alts]
828 is_elem = isIn "mkPrimAlts"
830 -- Add the lets (well cases actually) if necessary
831 -- The munged alternative looks like
832 -- lit -> case lit of d -> rhs
833 -- The next pass will certainly eliminate the inner case, but
834 -- it isn't easy to do so right away.
835 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
838 | scrut_is_var = (lit, Case (Var scrut_var)
839 (PrimAlts [] (BindDefault deflt_var rhs)))
840 | otherwise = (lit, Case (Lit lit)
841 (PrimAlts [] (BindDefault deflt_var rhs)))
844 Now the identity-case transformation:
855 = tick CaseIdentity `thenSmpl_`
858 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
859 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
861 identity_alg_alt (con, args, Con con' args')
863 && and (zipWith eq_arg args args')
864 && length args == length args'
865 identity_alg_alt other
868 identity_prim_alt (lit, Lit lit') = lit == lit'
869 identity_prim_alt other = False
871 -- For the default case we want to spot both
874 -- case y of { ... ; x -> y }
875 -- as "identity" defaults
876 identity_deflt NoDefault = True
877 identity_deflt (BindDefault binder (Var x)) = x == binder ||
881 identity_deflt _ = False
883 eq_arg binder (VarArg x) = binder == x
890 mkCoCase other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
893 Boring local functions used above. They simply introduce a trivial binding
894 for the binder, d', in an inner default; either
895 let d' = deflt_var in rhs
897 case deflt_var of d' -> rhs
898 depending on whether it's an algebraic or primitive case.
901 munge_prim_deflt _ NoDefault = NoDefault
903 munge_prim_deflt deflt_var (BindDefault d' rhs)
904 = BindDefault deflt_var (Case (Var deflt_var)
905 (PrimAlts [] (BindDefault d' rhs)))
907 munge_alg_deflt _ NoDefault = NoDefault
909 munge_alg_deflt deflt_var (BindDefault d' rhs)
910 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
912 -- This line caused a generic version of munge_deflt (ie one used for
913 -- both alg and prim) to space leak massively. No idea why.
914 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
918 cheap_eq :: InExpr -> InExpr -> Bool
919 -- A cheap equality test which bales out fast!
921 cheap_eq (Var v1) (Var v2) = v1==v2
922 cheap_eq (Lit l1) (Lit l2) = l1==l2
923 cheap_eq (Con con1 args1) (Con con2 args2)
924 = con1 == con2 && args1 `eq_args` args2
926 cheap_eq (Prim op1 args1) (Prim op2 args2)
927 = op1 ==op2 && args1 `eq_args` args2
929 cheap_eq (App f1 a1) (App f2 a2)
930 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
934 -- ToDo: make CoreArg an instance of Eq
935 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
939 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
940 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
941 eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2
942 eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2