2 % (c) The AQUA Project, Glasgow University, 1994-1996
4 \section[SimplCase]{Simplification of `case' expression}
6 Support code for @Simplify@.
9 #include "HsVersions.h"
11 module SimplCase ( simplCase, bindLargeRhs ) where
14 IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun )
16 import BinderInfo -- too boring to try to select things...
17 import CmdLineOpts ( SimplifierSwitch(..) )
19 import CoreUnfold ( Unfolding, SimpleUnfolding )
20 import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
23 import Id ( idType, isDataCon, getIdDemandInfo,
24 SYN_IE(DataCon), GenId{-instance Eq-}
26 import IdInfo ( willBeDemanded, DemandInfo )
27 import Literal ( isNoRepLit, Literal{-instance Eq-} )
28 import Maybes ( maybeToBool )
29 import PrelVals ( voidId )
30 import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} )
33 import Type ( isPrimType, getAppDataTyConExpandingDicts, mkFunTy, mkFunTys, eqTy )
34 import TysPrim ( voidTy )
35 import Unique ( Unique{-instance Eq-} )
36 import Usage ( GenUsage{-instance Eq-} )
37 import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
40 Float let out of case.
44 -> InExpr -- Scrutinee
45 -> InAlts -- Alternatives
46 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
47 -> OutType -- Type of result expression
50 simplCase env (Let bind body) alts rhs_c result_ty
51 | not (switchIsSet env SimplNoLetFromCase)
52 = -- Float the let outside the case scrutinee (if not disabled by flag)
53 tick LetFloatFromCase `thenSmpl_`
54 simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
57 OK to do case-of-case if
59 * we allow arbitrary code duplication
63 * the inner case has one alternative
64 case (case e of (a,b) -> rhs) of
75 IF neither of these two things are the case, we avoid code-duplication
76 by abstracting the outer rhss wrt the pattern variables. For example
78 case (case e of { p1->rhs1; ...; pn -> rhsn }) of
84 p1 -> case rhs1 of (x,y) -> b x y
86 pn -> case rhsn of (x,y) -> b x y
89 OK, so outer case expression gets duplicated, but that's all. Furthermore,
90 (a) the binding for "b" will be let-no-escaped, so no heap allocation
91 will take place; the "call" to b will simply be a stack adjustment
93 (b) very commonly, at least some of the rhsi's will be constructors, which
94 makes life even simpler.
96 All of this works equally well if the outer case has multiple rhss.
100 simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
101 | switchIsSet env SimplCaseOfCase
102 = -- Ha! Do case-of-case
103 tick CaseOfCase `thenSmpl_`
105 if no_need_to_bind_large_alts
107 simplCase env inner_scrut inner_alts
108 (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
110 bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
112 rhs_c' = \env rhs -> simplExpr env rhs []
114 simplCase env inner_scrut inner_alts
115 (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
117 `thenSmpl` \ case_expr ->
118 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
121 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
122 isSingleton (nonErrorRHSs inner_alts)
125 Case of an application of error.
128 simplCase env scrut alts rhs_c result_ty
129 | maybeToBool maybe_error_app
130 = -- Look for an application of an error id
131 tick CaseOfError `thenSmpl_`
132 rhs_c env retyped_error_app
134 alts_ty = coreAltsType (unTagBindersAlts alts)
135 maybe_error_app = maybeErrorApp scrut (Just alts_ty)
136 Just retyped_error_app = maybe_error_app
139 Finally the default case
142 simplCase env other_scrut alts rhs_c result_ty
143 = -- Float the let outside the case scrutinee
144 simplExpr env other_scrut [] `thenSmpl` \ scrut' ->
145 completeCase env scrut' alts rhs_c
149 %************************************************************************
151 \subsection[Simplify-case]{Completing case-expression simplification}
153 %************************************************************************
158 -> OutExpr -- The already-simplified scrutinee
159 -> InAlts -- The un-simplified alternatives
160 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
161 -> SmplM OutExpr -- The whole case expression
164 Scrutinising a literal or constructor.
165 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
166 It's an obvious win to do:
168 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
170 and the similar thing for primitive case. If we have
174 and x is known to be of constructor form, then we'll already have
175 inlined the constructor to give (case (C a b) of ...), so we don't
176 need to check for the variable case separately.
178 Sanity check: we don't have a good
179 story to tell about case analysis on NoRep things. ToDo.
182 completeCase env (Lit lit) alts rhs_c
183 | not (isNoRepLit lit)
184 = -- Ha! Select the appropriate alternative
185 tick KnownBranch `thenSmpl_`
186 completePrimCaseWithKnownLit env lit alts rhs_c
188 completeCase env expr@(Con con con_args) alts rhs_c
189 = -- Ha! Staring us in the face -- select the appropriate alternative
190 tick KnownBranch `thenSmpl_`
191 completeAlgCaseWithKnownCon env con con_args alts rhs_c
196 Start with a simple situation:
198 case x# of ===> e[x#/y#]
201 (when x#, y# are of primitive type, of course).
202 We can't (in general) do this for algebraic cases, because we might
203 turn bottom into non-bottom!
205 Actually, we generalise this idea to look for a case where we're
206 scrutinising a variable, and we know that only the default case can
211 other -> ...(case x of
215 Here the inner case can be eliminated. This really only shows up in
216 eliminating error-checking code.
218 Lastly, we generalise the transformation to handle this:
224 We only do this for very cheaply compared r's (constructors, literals
225 and variables). If pedantic bottoms is on, we only do it when the
226 scrutinee is a PrimOp which can't fail.
228 We do it *here*, looking at un-simplified alternatives, because we
229 have to check that r doesn't mention the variables bound by the
230 pattern in each alternative, so the binder-info is rather useful.
232 So the case-elimination algorithm is:
234 1. Eliminate alternatives which can't match
236 2. Check whether all the remaining alternatives
237 (a) do not mention in their rhs any of the variables bound in their pattern
238 and (b) have equal rhss
240 3. Check we can safely ditch the case:
241 * PedanticBottoms is off,
242 or * the scrutinee is an already-evaluated variable
243 or * the scrutinee is a primop which is ok for speculation
244 -- ie we want to preserve divide-by-zero errors, and
245 -- calls to error itself!
247 or * [Prim cases] the scrutinee is a primitive variable
249 or * [Alg cases] the scrutinee is a variable and
250 either * the rhs is the same variable
251 (eg case x of C a b -> x ===> x)
252 or * there is only one alternative, the default alternative,
253 and the binder is used strictly in its scope.
254 [NB this is helped by the "use default binder where
255 possible" transformation; see below.]
258 If so, then we can replace the case with one of the rhss.
261 completeCase env scrut alts rhs_c
262 | switchIsSet env SimplDoCaseElim &&
268 (not (switchIsSet env SimplPedanticBottoms) ||
270 scrut_is_eliminable_primitive ||
272 scrut_is_var_and_single_strict_default
275 = tick CaseElim `thenSmpl_`
278 -- Find the non-excluded rhss of the case; always at least one
279 (rhs1:rhss) = possible_rhss
280 all_rhss_same = all (cheap_eq rhs1) rhss
282 -- Find the reduced set of possible rhss, along with an indication of
283 -- whether none of their binders are used
284 (binders_unused, possible_rhss, new_env)
286 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
290 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
292 -- Eliminate unused rhss if poss
293 rhss = case scrut_form of
294 OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
295 not (alt_lit `is_elem` not_these)
297 other -> [rhs | (_,rhs) <- alts]
299 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
300 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
303 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
305 -- Eliminate unused alts if poss
306 possible_alts = case scrut_form of
307 OtherCon not_these ->
308 -- Remove alts which can't match
309 [alt | alt@(alt_con,_,_) <- alts,
310 not (alt_con `is_elem` not_these)]
314 alt_binders_unused (con, args, rhs) = all is_dead args
315 is_dead (_, DeadCode) = True
316 is_dead other_arg = False
318 -- If the scrutinee is a variable, look it up to see what we know about it
319 scrut_form = case scrut of
320 Var v -> lookupRhsInfo env v
323 -- If the scrut is already eval'd then there's no worry about
324 -- eliminating the case
325 scrut_is_evald = isEvaluated scrut_form
327 scrut_is_eliminable_primitive
329 Prim op _ -> primOpOkForSpeculation op
330 Var _ -> case alts of
331 PrimAlts _ _ -> True -- Primitive, hence non-bottom
332 AlgAlts _ _ -> False -- Not primitive
335 -- case v of w -> e{strict in w} ===> e[v/w]
336 scrut_is_var_and_single_strict_default
338 Var _ -> case alts of
339 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
343 elim_deflt_binder NoDefault -- No Binder
345 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
347 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
349 Var v -> -- Binder used, but can be eliminated in favour of scrut
350 (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v))
351 non_var -> -- Binder used, and can't be elimd
354 -- Check whether the chosen unique rhs (ie rhs1) is the same as
355 -- the scrutinee. Remember that the rhs is as yet unsimplified.
356 rhs1_is_scrutinee = case (scrut, rhs1) of
357 (Var scrut_var, Var rhs_var)
358 -> case lookupId env rhs_var of
359 VarArg rhs_var' -> rhs_var' == scrut_var
363 is_elem x ys = isIn "completeCase" x ys
366 Scrutinising anything else. If it's a variable, it can't be bound to a
367 constructor or literal, because that would have been inlined
370 completeCase env scrut alts rhs_c
371 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
372 mkCoCase env scrut alts'
379 bindLargeAlts :: SimplEnv
381 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
382 -> OutType -- Result type
383 -> SmplM ([OutBinding], -- Extra bindings
384 InAlts) -- Modified alts
386 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
387 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
388 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
389 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
391 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
392 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
393 returnSmpl (bind, (con,args,rhs'))
395 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
396 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
397 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
398 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
400 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
401 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
402 returnSmpl (bind, (lit,rhs'))
404 bindLargeDefault env NoDefault rhs_ty rhs_c
405 = returnSmpl ([], NoDefault)
406 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
407 = bindLargeRhs env [binder] rhs_ty
408 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
409 returnSmpl ([bind], BindDefault binder rhs')
412 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
413 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
417 bindLargeRhs :: SimplEnv
418 -> [InBinder] -- The args wrt which the rhs should be abstracted
420 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
421 -> SmplM (OutBinding, -- New bindings (singleton or empty)
422 InExpr) -- Modified rhs
424 bindLargeRhs env args rhs_ty rhs_c
425 | null used_args && isPrimType rhs_ty
426 -- If we try to lift a primitive-typed something out
427 -- for let-binding-purposes, we will *caseify* it (!),
428 -- with potentially-disastrous strictness results. So
429 -- instead we turn it into a function: \v -> e
430 -- where v::Void. Since arguments of type
431 -- VoidPrim don't generate any code, this gives the
434 -- The general structure is just the same as for the common "otherwise~ case
435 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
436 newId voidTy `thenSmpl` \ void_arg_id ->
437 rhs_c env `thenSmpl` \ prim_new_body ->
439 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
440 App (Var prim_rhs_fun_id) (VarArg voidId))
443 = -- Make the new binding Id. NB: it's an OutId
444 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
447 cloneIds env used_args `thenSmpl` \ used_args' ->
449 new_env = extendIdEnvWithClones env used_args used_args'
451 rhs_c new_env `thenSmpl` \ rhs' ->
453 final_rhs = mkValLam used_args' rhs'
455 returnSmpl (NonRec rhs_fun_id final_rhs,
456 foldl App (Var rhs_fun_id) used_arg_atoms)
457 -- This is slightly wierd. We're retuning an OutId as part of the
458 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
459 -- it's processed the OutId won't be found in the environment, so it
460 -- will be left unmodified.
462 rhs_fun_ty :: OutType
463 rhs_fun_ty = mkFunTys [simplTy env (idType id) | (id,_) <- used_args] rhs_ty
465 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
466 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
470 prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
473 Case alternatives when we don't know the scrutinee
474 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
476 A special case for case default. If we have
482 it is best to make sure that \tr{default_e} mentions \tr{x} in
483 preference to \tr{y}. The code generator can do a cheaper job if it
484 doesn't have to come up with a binding for \tr{y}.
487 simplAlts :: SimplEnv
488 -> OutExpr -- Simplified scrutinee;
489 -- only of interest if its a var,
490 -- in which case we record its form
492 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
495 simplAlts env scrut (AlgAlts alts deflt) rhs_c
496 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
497 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
498 returnSmpl (AlgAlts alts' deflt')
500 deflt_form = OtherCon [con | (con,_,_) <- alts]
501 do_alt (con, con_args, rhs)
502 = cloneIds env con_args `thenSmpl` \ con_args' ->
504 env1 = extendIdEnvWithClones env con_args con_args'
505 new_env = case scrut of
506 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
508 (_, ty_args, _) = --trace "SimplCase.getAppData..." $
509 getAppDataTyConExpandingDicts (idType v)
510 args = map TyArg ty_args ++ map VarArg con_args'
514 rhs_c new_env rhs `thenSmpl` \ rhs' ->
515 returnSmpl (con, con_args', rhs')
517 simplAlts env scrut (PrimAlts alts deflt) rhs_c
518 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
519 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
520 returnSmpl (PrimAlts alts' deflt')
522 deflt_form = OtherLit [lit | (lit,_) <- alts]
525 new_env = case scrut of
526 Var v -> extendEnvGivenNewRhs env v (Lit lit)
529 rhs_c new_env rhs `thenSmpl` \ rhs' ->
530 returnSmpl (lit, rhs')
533 Use default binder where possible
534 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
535 There's one complication when simplifying the default clause of
536 a case expression. If we see
541 we'd like to convert it to
546 Reason 1: then there might be just one occurrence of x, and it can be
547 inlined as the case scrutinee. So we spot this case when dealing with
548 the default clause, and add a binding to the environment mapping x to
551 Reason 2: if the body is strict in x' then we can eliminate the
552 case altogether. By using x' in preference to x we give the max chance
553 of the strictness analyser finding that the body is strict in x'.
555 On the other hand, if x does *not* get inlined, then we'll actually
556 get somewhat better code from the former expression. So when
557 doing Core -> STG we convert back!
562 -> OutExpr -- Simplified scrutinee
563 -> InDefault -- Default alternative to be completed
564 -> RhsInfo -- Gives form of scrutinee
565 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
568 simplDefault env scrut NoDefault form rhs_c
569 = returnSmpl NoDefault
571 -- Special case for variable scrutinee; see notes above.
572 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
573 info_from_this_case rhs_c
574 = cloneId env binder `thenSmpl` \ binder' ->
576 env1 = extendIdEnvWithClone env binder binder'
577 env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
579 -- Add form details for the default binder
580 scrut_info = lookupRhsInfo env scrut_var
581 env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
582 new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
584 rhs_c new_env rhs `thenSmpl` \ rhs' ->
585 returnSmpl (BindDefault binder' rhs')
587 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
588 info_from_this_case rhs_c
589 = cloneId env binder `thenSmpl` \ binder' ->
591 env1 = extendIdEnvWithClone env binder binder'
592 new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
594 rhs_c new_env rhs `thenSmpl` \ rhs' ->
595 returnSmpl (BindDefault binder' rhs')
598 Case alternatives when we know what the scrutinee is
599 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
602 completePrimCaseWithKnownLit
606 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
609 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
612 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
614 search_alts ((alt_lit, rhs) : _)
616 = -- Matching alternative!
619 search_alts (_ : other_alts)
620 = -- This alternative doesn't match; keep looking
621 search_alts other_alts
625 NoDefault -> -- Blargh!
626 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
628 BindDefault binder rhs -> -- OK, there's a default case
629 -- Just bind the Id to the atom and continue
631 new_env = extendIdEnvWithAtom env binder (LitArg lit)
636 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
637 select one case alternative (or default). If we choose the default:
638 we do different things depending on whether the constructor was
639 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
640 [let-bind it] or we just know the \tr{y} is now the same as some other
641 var [substitute \tr{y} out of existence].
644 completeAlgCaseWithKnownCon
646 -> DataCon -> [InArg]
647 -- Scrutinee is (con, type, value arguments)
649 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
652 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
653 = ASSERT(isDataCon con)
656 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
658 search_alts ((alt_con, alt_args, rhs) : _)
660 = -- Matching alternative!
662 new_env = extendIdEnvWithAtoms env
663 (zipEqual "SimplCase" alt_args (filter isValArg con_args))
667 search_alts (_ : other_alts)
668 = -- This alternative doesn't match; keep looking
669 search_alts other_alts
672 = -- No matching alternative
674 NoDefault -> -- Blargh!
675 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
677 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
678 -- let-bind the binder to the constructor
679 cloneId env binder `thenSmpl` \ id' ->
681 env1 = extendIdEnvWithClone env binder id'
682 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
684 rhs_c new_env rhs `thenSmpl` \ rhs' ->
685 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
688 Case absorption and identity-case elimination
689 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
692 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
695 @mkCoCase@ tries the following transformation (if possible):
697 case v of ==> case v of
698 p1 -> rhs1 p1 -> rhs1
700 pm -> rhsm pm -> rhsm
701 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
702 {or (prim) case v of d -> rhsn}
705 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
708 which merges two cases in one case when -- the default alternative of
709 the outer case scrutises the same variable as the outer case This
710 transformation is called Case Merging. It avoids that the same
711 variable is scrutinised multiple times.
713 There's a closely-related transformation:
715 case e of ==> case e of
716 p1 -> rhs1 p1 -> rhs1
718 pm -> rhsm pm -> rhsm
719 d -> case d of pn -> let d = pn in rhsn
721 ... po -> let d = po in rhso
722 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
725 Here, the let's are essential, because d isn't in scope any more.
726 Sigh. Of course, they may be unused, in which case they'll be
727 eliminated on the next round. Unfortunately, we can't figure out
728 whether or not they are used at this juncture.
730 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
731 scrutinee is a variable, because it'll be mapped to the scrutinised
732 variable. Hence the [v/d] substitions can be omitted.
734 ALAS, now the default binder is used by preference, so we have to
735 generate trivial lets to express the substitutions, which will be
736 eliminated on the next pass.
738 The following code handles *both* these transformations (one
739 equation for AlgAlts, one for PrimAlts):
742 mkCoCase env scrut (AlgAlts outer_alts
743 (BindDefault deflt_var
744 (Case (Var scrut_var')
745 (AlgAlts inner_alts inner_deflt))))
746 | switchIsSet env SimplCaseMerge &&
747 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
748 deflt_var == scrut_var') -- Second transformation
749 = -- Aha! The default-absorption rule applies
750 tick CaseMerge `thenSmpl_`
751 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
752 (munge_alg_deflt deflt_var inner_deflt)))
753 -- NB: see comment in this location for the PrimAlts case
756 scrut_is_var = case scrut of {Var v -> True; other -> False}
757 scrut_var = case scrut of Var v -> v
759 -- Eliminate any inner alts which are shadowed by the outer ones
760 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
761 not (con `is_elem` outer_cons)]
762 outer_cons = [con | (con,_,_) <- outer_alts]
763 is_elem = isIn "mkAlgAlts"
765 -- Add the lets if necessary
766 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
768 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
770 v | scrut_is_var = Var scrut_var
771 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
773 arg_tys = --trace "SimplCase:getAppData...:2" $
774 case (getAppDataTyConExpandingDicts (idType deflt_var)) of
775 (_, arg_tys, _) -> arg_tys
777 mkCoCase env scrut (PrimAlts
779 (BindDefault deflt_var (Case
781 (PrimAlts inner_alts inner_deflt))))
782 | switchIsSet env SimplCaseMerge &&
783 ((scrut_is_var && scrut_var == scrut_var') ||
784 deflt_var == scrut_var')
785 = -- Aha! The default-absorption rule applies
786 tick CaseMerge `thenSmpl_`
787 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
788 (munge_prim_deflt deflt_var inner_deflt)))
790 -- Nota Bene: we don't recurse to mkCoCase again, because the
791 -- default will now have a binding in it that prevents
792 -- mkCoCase doing anything useful. Much worse, in this
793 -- PrimAlts case the binding in the default branch is another
794 -- Case, so if we recurse to mkCoCase we will get into an
797 -- ToDo: think of a better way to do this. At the moment
798 -- there is at most one case merge per round. That's probably
799 -- plenty but it seems unclean somehow.
802 scrut_is_var = case scrut of {Var v -> True; other -> False}
803 scrut_var = case scrut of Var v -> v
805 -- Eliminate any inner alts which are shadowed by the outer ones
806 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
807 not (lit `is_elem` outer_lits)]
808 outer_lits = [lit | (lit,_) <- outer_alts]
809 is_elem = isIn "mkPrimAlts"
811 -- Add the lets (well cases actually) if necessary
812 -- The munged alternative looks like
813 -- lit -> case lit of d -> rhs
814 -- The next pass will certainly eliminate the inner case, but
815 -- it isn't easy to do so right away.
816 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
819 | scrut_is_var = (lit, Case (Var scrut_var)
820 (PrimAlts [] (BindDefault deflt_var rhs)))
821 | otherwise = (lit, Case (Lit lit)
822 (PrimAlts [] (BindDefault deflt_var rhs)))
825 Now the identity-case transformation:
834 mkCoCase env scrut alts
836 = tick CaseIdentity `thenSmpl_`
839 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
840 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
842 identity_alg_alt (con, args, Con con' args')
844 && and (zipWith eq_arg args args')
845 && length args == length args'
846 identity_alg_alt other
849 identity_prim_alt (lit, Lit lit') = lit == lit'
850 identity_prim_alt other = False
852 -- For the default case we want to spot both
855 -- case y of { ... ; x -> y }
856 -- as "identity" defaults
857 identity_deflt NoDefault = True
858 identity_deflt (BindDefault binder (Var x)) = x == binder ||
862 identity_deflt _ = False
864 eq_arg binder (VarArg x) = binder == x
871 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
874 Boring local functions used above. They simply introduce a trivial binding
875 for the binder, d', in an inner default; either
876 let d' = deflt_var in rhs
878 case deflt_var of d' -> rhs
879 depending on whether it's an algebraic or primitive case.
882 munge_prim_deflt _ NoDefault = NoDefault
884 munge_prim_deflt deflt_var (BindDefault d' rhs)
885 = BindDefault deflt_var (Case (Var deflt_var)
886 (PrimAlts [] (BindDefault d' rhs)))
888 munge_alg_deflt _ NoDefault = NoDefault
890 munge_alg_deflt deflt_var (BindDefault d' rhs)
891 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
893 -- This line caused a generic version of munge_deflt (ie one used for
894 -- both alg and prim) to space leak massively. No idea why.
895 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
899 cheap_eq :: InExpr -> InExpr -> Bool
900 -- A cheap equality test which bales out fast!
902 cheap_eq (Var v1) (Var v2) = v1==v2
903 cheap_eq (Lit l1) (Lit l2) = l1==l2
904 cheap_eq (Con con1 args1) (Con con2 args2)
905 = con1 == con2 && args1 `eq_args` args2
907 cheap_eq (Prim op1 args1) (Prim op2 args2)
908 = op1 ==op2 && args1 `eq_args` args2
910 cheap_eq (App f1 a1) (App f2 a2)
911 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
915 -- ToDo: make CoreArg an instance of Eq
916 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
920 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
921 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
922 eq_arg (TyArg t1) (TyArg t2) = t1 `eqTy` t2
923 eq_arg (UsageArg u1) (UsageArg u2) = u1 == u2