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, SimpleUnfolding )
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 -> lookupRhsInfo 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 (runEager $ lookupId env rhs_var) of
372 VarArg rhs_var' -> 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' ->
385 mkCoCase env scrut 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 && isUnpointedType 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::Void. 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 voidTy `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 voidId))
456 = -- Generate the rhs
457 simplBinders env used_args `thenSmpl` \ (new_env, used_args') ->
459 rhs_fun_ty :: OutType
460 rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
463 -- Make the new binding Id. NB: it's an OutId
464 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
465 rhs_c new_env `thenSmpl` \ rhs' ->
467 final_rhs = mkValLam used_args' rhs'
469 returnSmpl (NonRec rhs_fun_id final_rhs,
470 foldl App (Var rhs_fun_id) used_arg_atoms)
471 -- This is slightly wierd. We're retuning an OutId as part of the
472 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
473 -- it's processed the OutId won't be found in the environment, so it
474 -- will be left unmodified.
477 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
478 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
482 prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
485 Case alternatives when we don't know the scrutinee
486 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
488 A special case for case default. If we have
494 it is best to make sure that \tr{default_e} mentions \tr{x} in
495 preference to \tr{y}. The code generator can do a cheaper job if it
496 doesn't have to come up with a binding for \tr{y}.
499 simplAlts :: SimplEnv
500 -> OutExpr -- Simplified scrutinee;
501 -- only of interest if its a var,
502 -- in which case we record its form
504 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
506 -- For single-constructor types
507 -- case e of y -> b ===> case e of (a,b) -> let y = (a,b) in b
509 simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
510 | maybeToBool maybe_data_ty &&
511 not (null cons) && -- Not an abstract type (can arise if we're pruning tydecl imports)
513 isDataTyCon tycon -- doesn't apply to (constructor-less) newtypes
514 = newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
516 new_args = [ (b, bad_occ_info) | b <- new_bindees ]
517 con_app = mkCon con ty_args (map VarArg new_bindees)
518 new_rhs = Let (NonRec bndr con_app) rhs
520 simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
522 maybe_data_ty = splitAlgTyConApp_maybe (idType id)
523 Just (tycon, ty_args, cons) = maybe_data_ty
524 (con:other_cons) = cons
525 inst_con_arg_tys = dataConArgTys con ty_args
526 bad_occ_info = ManyOcc 0 -- Non-committal!
528 simplAlts env scrut (AlgAlts alts deflt) rhs_c
529 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
530 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
531 returnSmpl (AlgAlts alts' deflt')
533 deflt_form = OtherCon [con | (con,_,_) <- alts]
534 do_alt (con, con_args, rhs)
535 = simplBinders env con_args `thenSmpl` \ (env1, con_args') ->
537 new_env = case scrut of
538 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
540 (_, ty_args, _) = splitAlgTyConApp (idType v)
541 args = map TyArg ty_args ++ map VarArg con_args'
545 rhs_c new_env rhs `thenSmpl` \ rhs' ->
546 returnSmpl (con, con_args', rhs')
548 simplAlts env scrut (PrimAlts alts deflt) rhs_c
549 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
550 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
551 returnSmpl (PrimAlts alts' deflt')
553 deflt_form = OtherLit [lit | (lit,_) <- alts]
556 new_env = case scrut of
557 Var v -> extendEnvGivenNewRhs env v (Lit lit)
560 rhs_c new_env rhs `thenSmpl` \ rhs' ->
561 returnSmpl (lit, rhs')
564 Use default binder where possible
565 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
566 There's one complication when simplifying the default clause of
567 a case expression. If we see
572 we'd like to convert it to
577 Reason 1: then there might be just one occurrence of x, and it can be
578 inlined as the case scrutinee. So we spot this case when dealing with
579 the default clause, and add a binding to the environment mapping x to
582 Reason 2: if the body is strict in x' then we can eliminate the
583 case altogether. By using x' in preference to x we give the max chance
584 of the strictness analyser finding that the body is strict in x'.
586 On the other hand, if x does *not* get inlined, then we'll actually
587 get somewhat better code from the former expression. So when
588 doing Core -> STG we convert back!
593 -> OutExpr -- Simplified scrutinee
594 -> InDefault -- Default alternative to be completed
595 -> RhsInfo -- Gives form of scrutinee
596 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
599 simplDefault env scrut NoDefault form rhs_c
600 = returnSmpl NoDefault
602 -- Special case for variable scrutinee; see notes above.
603 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
604 info_from_this_case rhs_c
605 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
607 env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
609 -- Add form details for the default binder
610 scrut_info = lookupRhsInfo env scrut_var
611 env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
612 new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
614 rhs_c new_env rhs `thenSmpl` \ rhs' ->
615 returnSmpl (BindDefault binder' rhs')
617 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
618 info_from_this_case rhs_c
619 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
621 new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
623 rhs_c new_env rhs `thenSmpl` \ rhs' ->
624 returnSmpl (BindDefault binder' rhs')
627 Case alternatives when we know what the scrutinee is
628 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
631 completePrimCaseWithKnownLit
635 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
638 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
641 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
643 search_alts ((alt_lit, rhs) : _)
645 = -- Matching alternative!
648 search_alts (_ : other_alts)
649 = -- This alternative doesn't match; keep looking
650 search_alts other_alts
654 NoDefault -> -- Blargh!
655 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
657 BindDefault binder rhs -> -- OK, there's a default case
658 -- Just bind the Id to the atom and continue
660 new_env = bindIdToAtom env binder (LitArg lit)
665 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
666 select one case alternative (or default). If we choose the default:
667 we do different things depending on whether the constructor was
668 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
669 [let-bind it] or we just know the \tr{y} is now the same as some other
670 var [substitute \tr{y} out of existence].
673 completeAlgCaseWithKnownCon
675 -> DataCon -> [InArg]
676 -- Scrutinee is (con, type, value arguments)
678 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
681 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
682 = ASSERT(isDataCon con)
685 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
687 search_alts ((alt_con, alt_args, rhs) : _)
689 = -- Matching alternative!
691 val_args = filter isValArg con_args
692 new_env = foldr bind env (zipEqual "SimplCase" alt_args val_args)
693 bind (bndr, atom) env = bindIdToAtom env bndr atom
697 search_alts (_ : other_alts)
698 = -- This alternative doesn't match; keep looking
699 search_alts other_alts
702 = -- No matching alternative
704 NoDefault -> -- Blargh!
705 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
707 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
708 -- let-bind the binder to the constructor
709 simplBinder env binder `thenSmpl` \ (env1, id') ->
711 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
713 rhs_c new_env rhs `thenSmpl` \ rhs' ->
714 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
717 Case absorption and identity-case elimination
718 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
721 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
724 @mkCoCase@ tries the following transformation (if possible):
726 case v of ==> case v of
727 p1 -> rhs1 p1 -> rhs1
729 pm -> rhsm pm -> rhsm
730 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
731 {or (prim) case v of d -> rhsn}
734 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
737 which merges two cases in one case when -- the default alternative of
738 the outer case scrutises the same variable as the outer case This
739 transformation is called Case Merging. It avoids that the same
740 variable is scrutinised multiple times.
742 There's a closely-related transformation:
744 case e of ==> case e of
745 p1 -> rhs1 p1 -> rhs1
747 pm -> rhsm pm -> rhsm
748 d -> case d of pn -> let d = pn in rhsn
750 ... po -> let d = po in rhso
751 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
754 Here, the let's are essential, because d isn't in scope any more.
755 Sigh. Of course, they may be unused, in which case they'll be
756 eliminated on the next round. Unfortunately, we can't figure out
757 whether or not they are used at this juncture.
759 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
760 scrutinee is a variable, because it'll be mapped to the scrutinised
761 variable. Hence the [v/d] substitions can be omitted.
763 ALAS, now the default binder is used by preference, so we have to
764 generate trivial lets to express the substitutions, which will be
765 eliminated on the next pass.
767 The following code handles *both* these transformations (one
768 equation for AlgAlts, one for PrimAlts):
771 mkCoCase env scrut (AlgAlts outer_alts
772 (BindDefault deflt_var
773 (Case (Var scrut_var')
774 (AlgAlts inner_alts inner_deflt))))
775 | switchIsSet env SimplCaseMerge &&
776 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
777 deflt_var == scrut_var') -- Second transformation
778 = -- Aha! The default-absorption rule applies
779 tick CaseMerge `thenSmpl_`
780 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
781 (munge_alg_deflt deflt_var inner_deflt)))
782 -- NB: see comment in this location for the PrimAlts case
785 scrut_is_var = case scrut of {Var v -> True; other -> False}
786 scrut_var = case scrut of Var v -> v
788 -- Eliminate any inner alts which are shadowed by the outer ones
789 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
790 not (con `is_elem` outer_cons)]
791 outer_cons = [con | (con,_,_) <- outer_alts]
792 is_elem = isIn "mkAlgAlts"
794 -- Add the lets if necessary
795 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
797 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
799 v | scrut_is_var = Var scrut_var
800 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
802 arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
803 (_, arg_tys, _) -> arg_tys
805 mkCoCase env scrut (PrimAlts
807 (BindDefault deflt_var (Case
809 (PrimAlts inner_alts inner_deflt))))
810 | switchIsSet env SimplCaseMerge &&
811 ((scrut_is_var && scrut_var == scrut_var') ||
812 deflt_var == scrut_var')
813 = -- Aha! The default-absorption rule applies
814 tick CaseMerge `thenSmpl_`
815 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
816 (munge_prim_deflt deflt_var inner_deflt)))
818 -- Nota Bene: we don't recurse to mkCoCase again, because the
819 -- default will now have a binding in it that prevents
820 -- mkCoCase doing anything useful. Much worse, in this
821 -- PrimAlts case the binding in the default branch is another
822 -- Case, so if we recurse to mkCoCase we will get into an
825 -- ToDo: think of a better way to do this. At the moment
826 -- there is at most one case merge per round. That's probably
827 -- plenty but it seems unclean somehow.
830 scrut_is_var = case scrut of {Var v -> True; other -> False}
831 scrut_var = case scrut of Var v -> v
833 -- Eliminate any inner alts which are shadowed by the outer ones
834 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
835 not (lit `is_elem` outer_lits)]
836 outer_lits = [lit | (lit,_) <- outer_alts]
837 is_elem = isIn "mkPrimAlts"
839 -- Add the lets (well cases actually) if necessary
840 -- The munged alternative looks like
841 -- lit -> case lit of d -> rhs
842 -- The next pass will certainly eliminate the inner case, but
843 -- it isn't easy to do so right away.
844 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
847 | scrut_is_var = (lit, Case (Var scrut_var)
848 (PrimAlts [] (BindDefault deflt_var rhs)))
849 | otherwise = (lit, Case (Lit lit)
850 (PrimAlts [] (BindDefault deflt_var rhs)))
853 Now the identity-case transformation:
862 mkCoCase env scrut alts
864 = tick CaseIdentity `thenSmpl_`
867 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
868 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
870 identity_alg_alt (con, args, Con con' args')
872 && and (zipWith eq_arg args args')
873 && length args == length args'
874 identity_alg_alt other
877 identity_prim_alt (lit, Lit lit') = lit == lit'
878 identity_prim_alt other = False
880 -- For the default case we want to spot both
883 -- case y of { ... ; x -> y }
884 -- as "identity" defaults
885 identity_deflt NoDefault = True
886 identity_deflt (BindDefault binder (Var x)) = x == binder ||
890 identity_deflt _ = False
892 eq_arg binder (VarArg x) = binder == x
899 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
902 Boring local functions used above. They simply introduce a trivial binding
903 for the binder, d', in an inner default; either
904 let d' = deflt_var in rhs
906 case deflt_var of d' -> rhs
907 depending on whether it's an algebraic or primitive case.
910 munge_prim_deflt _ NoDefault = NoDefault
912 munge_prim_deflt deflt_var (BindDefault d' rhs)
913 = BindDefault deflt_var (Case (Var deflt_var)
914 (PrimAlts [] (BindDefault d' rhs)))
916 munge_alg_deflt _ NoDefault = NoDefault
918 munge_alg_deflt deflt_var (BindDefault d' rhs)
919 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
921 -- This line caused a generic version of munge_deflt (ie one used for
922 -- both alg and prim) to space leak massively. No idea why.
923 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
927 cheap_eq :: InExpr -> InExpr -> Bool
928 -- A cheap equality test which bales out fast!
930 cheap_eq (Var v1) (Var v2) = v1==v2
931 cheap_eq (Lit l1) (Lit l2) = l1==l2
932 cheap_eq (Con con1 args1) (Con con2 args2)
933 = con1 == con2 && args1 `eq_args` args2
935 cheap_eq (Prim op1 args1) (Prim op2 args2)
936 = op1 ==op2 && args1 `eq_args` args2
938 cheap_eq (App f1 a1) (App f2 a2)
939 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
943 -- ToDo: make CoreArg an instance of Eq
944 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
948 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
949 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
950 eq_arg (TyArg t1) (TyArg t2) = t1 == t2