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-} )
33 import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys )
34 import TyCon ( isDataTyCon )
35 import TysPrim ( voidTy )
36 import Unique ( Unique{-instance Eq-} )
37 import Util ( Eager, runEager, appEager,
38 isIn, isSingleton, zipEqual, panic, assertPanic )
41 Float let out of case.
45 -> InExpr -- Scrutinee
46 -> InAlts -- Alternatives
47 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
48 -> OutType -- Type of result expression
51 simplCase env (Let bind body) alts rhs_c result_ty
52 | not (switchIsSet env SimplNoLetFromCase)
53 = -- Float the let outside the case scrutinee (if not disabled by flag)
54 tick LetFloatFromCase `thenSmpl_`
55 simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
58 OK to do case-of-case if
60 * we allow arbitrary code duplication
64 * the inner case has one alternative
65 case (case e of (a,b) -> rhs) of
76 IF neither of these two things are the case, we avoid code-duplication
77 by abstracting the outer rhss wrt the pattern variables. For example
79 case (case e of { p1->rhs1; ...; pn -> rhsn }) of
85 p1 -> case rhs1 of (x,y) -> b x y
87 pn -> case rhsn of (x,y) -> b x y
90 OK, so outer case expression gets duplicated, but that's all. Furthermore,
91 (a) the binding for "b" will be let-no-escaped, so no heap allocation
92 will take place; the "call" to b will simply be a stack adjustment
94 (b) very commonly, at least some of the rhsi's will be constructors, which
95 makes life even simpler.
97 All of this works equally well if the outer case has multiple rhss.
101 simplCase env (Case inner_scrut inner_alts) outer_alts rhs_c result_ty
102 | switchIsSet env SimplCaseOfCase
103 = -- Ha! Do case-of-case
104 tick CaseOfCase `thenSmpl_`
106 if no_need_to_bind_large_alts
108 simplCase env inner_scrut inner_alts
109 (\env rhs -> simplCase env rhs outer_alts rhs_c result_ty) result_ty
111 bindLargeAlts env outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
113 rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
115 simplCase env inner_scrut inner_alts
116 (\env rhs -> simplCase env rhs outer_alts' rhs_c' result_ty)
118 `thenSmpl` \ case_expr ->
119 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
122 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
123 isSingleton (nonErrorRHSs inner_alts)
126 Case of an application of error.
129 simplCase env scrut alts rhs_c result_ty
130 | maybeToBool maybe_error_app
131 = -- Look for an application of an error id
132 tick CaseOfError `thenSmpl_`
133 simplExpr env retyped_error_app [] result_ty
135 -- We must apply simplExpr because "rhs" isn't yet simplified.
136 -- The ice is a little thin because body_ty is an OutType; but it's ok really
138 maybe_error_app = maybeErrorApp scrut (Just result_ty)
139 Just retyped_error_app = maybe_error_app
142 Finally the default case
145 simplCase env other_scrut alts rhs_c result_ty
146 = simplTy env scrut_ty `appEager` \ scrut_ty' ->
147 simplExpr env' other_scrut [] scrut_ty `thenSmpl` \ scrut' ->
148 completeCase env scrut' alts rhs_c
150 -- When simplifying the scrutinee of a complete case that
151 -- has no default alternative
153 AlgAlts _ NoDefault -> setCaseScrutinee env
154 PrimAlts _ NoDefault -> setCaseScrutinee env
157 scrut_ty = coreExprType (unTagBinders other_scrut)
161 %************************************************************************
163 \subsection[Simplify-case]{Completing case-expression simplification}
165 %************************************************************************
170 -> OutExpr -- The already-simplified scrutinee
171 -> InAlts -- The un-simplified alternatives
172 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
173 -> SmplM OutExpr -- The whole case expression
176 Scrutinising a literal or constructor.
177 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
178 It's an obvious win to do:
180 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
182 and the similar thing for primitive case. If we have
186 and x is known to be of constructor form, then we'll already have
187 inlined the constructor to give (case (C a b) of ...), so we don't
188 need to check for the variable case separately.
190 Sanity check: we don't have a good
191 story to tell about case analysis on NoRep things. ToDo.
194 completeCase env (Lit lit) alts rhs_c
195 | not (isNoRepLit lit)
196 = -- Ha! Select the appropriate alternative
197 tick KnownBranch `thenSmpl_`
198 completePrimCaseWithKnownLit env lit alts rhs_c
200 completeCase env expr@(Con con con_args) alts rhs_c
201 = -- Ha! Staring us in the face -- select the appropriate alternative
202 tick KnownBranch `thenSmpl_`
203 completeAlgCaseWithKnownCon env con con_args alts rhs_c
208 Start with a simple situation:
210 case x# of ===> e[x#/y#]
213 (when x#, y# are of primitive type, of course).
214 We can't (in general) do this for algebraic cases, because we might
215 turn bottom into non-bottom!
217 Actually, we generalise this idea to look for a case where we're
218 scrutinising a variable, and we know that only the default case can
223 other -> ...(case x of
227 Here the inner case can be eliminated. This really only shows up in
228 eliminating error-checking code.
230 Lastly, we generalise the transformation to handle this:
236 We only do this for very cheaply compared r's (constructors, literals
237 and variables). If pedantic bottoms is on, we only do it when the
238 scrutinee is a PrimOp which can't fail.
240 We do it *here*, looking at un-simplified alternatives, because we
241 have to check that r doesn't mention the variables bound by the
242 pattern in each alternative, so the binder-info is rather useful.
244 So the case-elimination algorithm is:
246 1. Eliminate alternatives which can't match
248 2. Check whether all the remaining alternatives
249 (a) do not mention in their rhs any of the variables bound in their pattern
250 and (b) have equal rhss
252 3. Check we can safely ditch the case:
253 * PedanticBottoms is off,
254 or * the scrutinee is an already-evaluated variable
255 or * the scrutinee is a primop which is ok for speculation
256 -- ie we want to preserve divide-by-zero errors, and
257 -- calls to error itself!
259 or * [Prim cases] the scrutinee is a primitive variable
261 or * [Alg cases] the scrutinee is a variable and
262 either * the rhs is the same variable
263 (eg case x of C a b -> x ===> x)
264 or * there is only one alternative, the default alternative,
265 and the binder is used strictly in its scope.
266 [NB this is helped by the "use default binder where
267 possible" transformation; see below.]
270 If so, then we can replace the case with one of the rhss.
273 completeCase env scrut alts rhs_c
274 | switchIsSet env SimplDoCaseElim &&
280 (not (switchIsSet env SimplPedanticBottoms) ||
282 scrut_is_eliminable_primitive ||
284 scrut_is_var_and_single_strict_default
287 = tick CaseElim `thenSmpl_`
290 -- Find the non-excluded rhss of the case; always at least one
291 (rhs1:rhss) = possible_rhss
292 all_rhss_same = all (cheap_eq rhs1) rhss
294 -- Find the reduced set of possible rhss, along with an indication of
295 -- whether none of their binders are used
296 (binders_unused, possible_rhss, new_env)
298 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
302 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
304 -- Eliminate unused rhss if poss
305 rhss = case scrut_form of
306 OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
307 not (alt_lit `is_elem` not_these)
309 other -> [rhs | (_,rhs) <- alts]
311 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
312 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
315 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
317 -- Eliminate unused alts if poss
318 possible_alts = case scrut_form of
319 OtherCon not_these ->
320 -- Remove alts which can't match
321 [alt | alt@(alt_con,_,_) <- alts,
322 not (alt_con `is_elem` not_these)]
326 alt_binders_unused (con, args, rhs) = all is_dead args
327 is_dead (_, DeadCode) = True
328 is_dead other_arg = False
330 -- If the scrutinee is a variable, look it up to see what we know about it
331 scrut_form = case scrut of
332 Var v -> lookupRhsInfo env v
335 -- If the scrut is already eval'd then there's no worry about
336 -- eliminating the case
337 scrut_is_evald = isEvaluated scrut_form
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 (runEager $ lookupId env rhs_var) of
371 VarArg rhs_var' -> rhs_var' == scrut_var
375 is_elem x ys = isIn "completeCase" x ys
378 Scrutinising anything else. If it's a variable, it can't be bound to a
379 constructor or literal, because that would have been inlined
382 completeCase env scrut alts rhs_c
383 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
384 mkCoCase env scrut alts'
391 bindLargeAlts :: SimplEnv
393 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
394 -> OutType -- Result type
395 -> SmplM ([OutBinding], -- Extra bindings
396 InAlts) -- Modified alts
398 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
399 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
400 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
401 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
403 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
404 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
405 returnSmpl (bind, (con,args,rhs'))
407 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
408 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
409 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
410 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
412 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
413 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
414 returnSmpl (bind, (lit,rhs'))
416 bindLargeDefault env NoDefault rhs_ty rhs_c
417 = returnSmpl ([], NoDefault)
418 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
419 = bindLargeRhs env [binder] rhs_ty
420 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
421 returnSmpl ([bind], BindDefault binder rhs')
424 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
425 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
429 bindLargeRhs :: SimplEnv
430 -> [InBinder] -- The args wrt which the rhs should be abstracted
432 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
433 -> SmplM (OutBinding, -- New bindings (singleton or empty)
434 InExpr) -- Modified rhs
436 bindLargeRhs env args rhs_ty rhs_c
437 | null used_args && isUnpointedType rhs_ty
438 -- If we try to lift a primitive-typed something out
439 -- for let-binding-purposes, we will *caseify* it (!),
440 -- with potentially-disastrous strictness results. So
441 -- instead we turn it into a function: \v -> e
442 -- where v::Void. Since arguments of type
443 -- VoidPrim don't generate any code, this gives the
446 -- The general structure is just the same as for the common "otherwise~ case
447 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
448 newId voidTy `thenSmpl` \ void_arg_id ->
449 rhs_c env `thenSmpl` \ prim_new_body ->
451 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
452 App (Var prim_rhs_fun_id) (VarArg voidId))
455 = -- Generate the rhs
456 cloneIds env used_args `thenSmpl` \ used_args' ->
458 new_env = extendIdEnvWithClones env used_args 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 = ASSERT( isDataTyCon tycon )
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 = cloneIds env con_args `thenSmpl` \ con_args' ->
537 env1 = extendIdEnvWithClones env con_args con_args'
538 new_env = case scrut of
539 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
541 (_, ty_args, _) = splitAlgTyConApp (idType v)
542 args = map TyArg ty_args ++ map VarArg con_args'
546 rhs_c new_env rhs `thenSmpl` \ rhs' ->
547 returnSmpl (con, con_args', rhs')
549 simplAlts env scrut (PrimAlts alts deflt) rhs_c
550 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
551 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
552 returnSmpl (PrimAlts alts' deflt')
554 deflt_form = OtherLit [lit | (lit,_) <- alts]
557 new_env = case scrut of
558 Var v -> extendEnvGivenNewRhs env v (Lit lit)
561 rhs_c new_env rhs `thenSmpl` \ rhs' ->
562 returnSmpl (lit, rhs')
565 Use default binder where possible
566 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
567 There's one complication when simplifying the default clause of
568 a case expression. If we see
573 we'd like to convert it to
578 Reason 1: then there might be just one occurrence of x, and it can be
579 inlined as the case scrutinee. So we spot this case when dealing with
580 the default clause, and add a binding to the environment mapping x to
583 Reason 2: if the body is strict in x' then we can eliminate the
584 case altogether. By using x' in preference to x we give the max chance
585 of the strictness analyser finding that the body is strict in x'.
587 On the other hand, if x does *not* get inlined, then we'll actually
588 get somewhat better code from the former expression. So when
589 doing Core -> STG we convert back!
594 -> OutExpr -- Simplified scrutinee
595 -> InDefault -- Default alternative to be completed
596 -> RhsInfo -- Gives form of scrutinee
597 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
600 simplDefault env scrut NoDefault form rhs_c
601 = returnSmpl NoDefault
603 -- Special case for variable scrutinee; see notes above.
604 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
605 info_from_this_case rhs_c
606 = cloneId env binder `thenSmpl` \ binder' ->
608 env1 = extendIdEnvWithClone env binder binder'
609 env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
611 -- Add form details for the default binder
612 scrut_info = lookupRhsInfo env scrut_var
613 env3 = extendEnvGivenRhsInfo env2 binder' occ_info scrut_info
614 new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
616 rhs_c new_env rhs `thenSmpl` \ rhs' ->
617 returnSmpl (BindDefault binder' rhs')
619 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
620 info_from_this_case rhs_c
621 = cloneId env binder `thenSmpl` \ binder' ->
623 env1 = extendIdEnvWithClone env binder binder'
624 new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case
626 rhs_c new_env rhs `thenSmpl` \ rhs' ->
627 returnSmpl (BindDefault binder' rhs')
630 Case alternatives when we know what the scrutinee is
631 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
634 completePrimCaseWithKnownLit
638 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
641 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
644 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
646 search_alts ((alt_lit, rhs) : _)
648 = -- Matching alternative!
651 search_alts (_ : other_alts)
652 = -- This alternative doesn't match; keep looking
653 search_alts other_alts
657 NoDefault -> -- Blargh!
658 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
660 BindDefault binder rhs -> -- OK, there's a default case
661 -- Just bind the Id to the atom and continue
663 new_env = extendIdEnvWithAtom env binder (LitArg lit)
668 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
669 select one case alternative (or default). If we choose the default:
670 we do different things depending on whether the constructor was
671 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
672 [let-bind it] or we just know the \tr{y} is now the same as some other
673 var [substitute \tr{y} out of existence].
676 completeAlgCaseWithKnownCon
678 -> DataCon -> [InArg]
679 -- Scrutinee is (con, type, value arguments)
681 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
684 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
685 = ASSERT(isDataCon con)
688 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
690 search_alts ((alt_con, alt_args, rhs) : _)
692 = -- Matching alternative!
694 new_env = extendIdEnvWithAtoms env
695 (zipEqual "SimplCase" alt_args (filter isValArg con_args))
699 search_alts (_ : other_alts)
700 = -- This alternative doesn't match; keep looking
701 search_alts other_alts
704 = -- No matching alternative
706 NoDefault -> -- Blargh!
707 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
709 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
710 -- let-bind the binder to the constructor
711 cloneId env binder `thenSmpl` \ id' ->
713 env1 = extendIdEnvWithClone env binder id'
714 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
716 rhs_c new_env rhs `thenSmpl` \ rhs' ->
717 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
720 Case absorption and identity-case elimination
721 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
724 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
727 @mkCoCase@ tries the following transformation (if possible):
729 case v of ==> case v of
730 p1 -> rhs1 p1 -> rhs1
732 pm -> rhsm pm -> rhsm
733 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
734 {or (prim) case v of d -> rhsn}
737 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
740 which merges two cases in one case when -- the default alternative of
741 the outer case scrutises the same variable as the outer case This
742 transformation is called Case Merging. It avoids that the same
743 variable is scrutinised multiple times.
745 There's a closely-related transformation:
747 case e of ==> case e of
748 p1 -> rhs1 p1 -> rhs1
750 pm -> rhsm pm -> rhsm
751 d -> case d of pn -> let d = pn in rhsn
753 ... po -> let d = po in rhso
754 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
757 Here, the let's are essential, because d isn't in scope any more.
758 Sigh. Of course, they may be unused, in which case they'll be
759 eliminated on the next round. Unfortunately, we can't figure out
760 whether or not they are used at this juncture.
762 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
763 scrutinee is a variable, because it'll be mapped to the scrutinised
764 variable. Hence the [v/d] substitions can be omitted.
766 ALAS, now the default binder is used by preference, so we have to
767 generate trivial lets to express the substitutions, which will be
768 eliminated on the next pass.
770 The following code handles *both* these transformations (one
771 equation for AlgAlts, one for PrimAlts):
774 mkCoCase env scrut (AlgAlts outer_alts
775 (BindDefault deflt_var
776 (Case (Var scrut_var')
777 (AlgAlts inner_alts inner_deflt))))
778 | switchIsSet env SimplCaseMerge &&
779 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
780 deflt_var == scrut_var') -- Second transformation
781 = -- Aha! The default-absorption rule applies
782 tick CaseMerge `thenSmpl_`
783 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
784 (munge_alg_deflt deflt_var inner_deflt)))
785 -- NB: see comment in this location for the PrimAlts case
788 scrut_is_var = case scrut of {Var v -> True; other -> False}
789 scrut_var = case scrut of Var v -> v
791 -- Eliminate any inner alts which are shadowed by the outer ones
792 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
793 not (con `is_elem` outer_cons)]
794 outer_cons = [con | (con,_,_) <- outer_alts]
795 is_elem = isIn "mkAlgAlts"
797 -- Add the lets if necessary
798 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
800 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
802 v | scrut_is_var = Var scrut_var
803 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
805 arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
806 (_, arg_tys, _) -> arg_tys
808 mkCoCase env scrut (PrimAlts
810 (BindDefault deflt_var (Case
812 (PrimAlts inner_alts inner_deflt))))
813 | switchIsSet env SimplCaseMerge &&
814 ((scrut_is_var && scrut_var == scrut_var') ||
815 deflt_var == scrut_var')
816 = -- Aha! The default-absorption rule applies
817 tick CaseMerge `thenSmpl_`
818 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
819 (munge_prim_deflt deflt_var inner_deflt)))
821 -- Nota Bene: we don't recurse to mkCoCase again, because the
822 -- default will now have a binding in it that prevents
823 -- mkCoCase doing anything useful. Much worse, in this
824 -- PrimAlts case the binding in the default branch is another
825 -- Case, so if we recurse to mkCoCase we will get into an
828 -- ToDo: think of a better way to do this. At the moment
829 -- there is at most one case merge per round. That's probably
830 -- plenty but it seems unclean somehow.
833 scrut_is_var = case scrut of {Var v -> True; other -> False}
834 scrut_var = case scrut of Var v -> v
836 -- Eliminate any inner alts which are shadowed by the outer ones
837 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
838 not (lit `is_elem` outer_lits)]
839 outer_lits = [lit | (lit,_) <- outer_alts]
840 is_elem = isIn "mkPrimAlts"
842 -- Add the lets (well cases actually) if necessary
843 -- The munged alternative looks like
844 -- lit -> case lit of d -> rhs
845 -- The next pass will certainly eliminate the inner case, but
846 -- it isn't easy to do so right away.
847 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
850 | scrut_is_var = (lit, Case (Var scrut_var)
851 (PrimAlts [] (BindDefault deflt_var rhs)))
852 | otherwise = (lit, Case (Lit lit)
853 (PrimAlts [] (BindDefault deflt_var rhs)))
856 Now the identity-case transformation:
865 mkCoCase env scrut alts
867 = tick CaseIdentity `thenSmpl_`
870 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
871 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
873 identity_alg_alt (con, args, Con con' args')
875 && and (zipWith eq_arg args args')
876 && length args == length args'
877 identity_alg_alt other
880 identity_prim_alt (lit, Lit lit') = lit == lit'
881 identity_prim_alt other = False
883 -- For the default case we want to spot both
886 -- case y of { ... ; x -> y }
887 -- as "identity" defaults
888 identity_deflt NoDefault = True
889 identity_deflt (BindDefault binder (Var x)) = x == binder ||
893 identity_deflt _ = False
895 eq_arg binder (VarArg x) = binder == x
902 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
905 Boring local functions used above. They simply introduce a trivial binding
906 for the binder, d', in an inner default; either
907 let d' = deflt_var in rhs
909 case deflt_var of d' -> rhs
910 depending on whether it's an algebraic or primitive case.
913 munge_prim_deflt _ NoDefault = NoDefault
915 munge_prim_deflt deflt_var (BindDefault d' rhs)
916 = BindDefault deflt_var (Case (Var deflt_var)
917 (PrimAlts [] (BindDefault d' rhs)))
919 munge_alg_deflt _ NoDefault = NoDefault
921 munge_alg_deflt deflt_var (BindDefault d' rhs)
922 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
924 -- This line caused a generic version of munge_deflt (ie one used for
925 -- both alg and prim) to space leak massively. No idea why.
926 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
930 cheap_eq :: InExpr -> InExpr -> Bool
931 -- A cheap equality test which bales out fast!
933 cheap_eq (Var v1) (Var v2) = v1==v2
934 cheap_eq (Lit l1) (Lit l2) = l1==l2
935 cheap_eq (Con con1 args1) (Con con2 args2)
936 = con1 == con2 && args1 `eq_args` args2
938 cheap_eq (Prim op1 args1) (Prim op2 args2)
939 = op1 ==op2 && args1 `eq_args` args2
941 cheap_eq (App f1 a1) (App f2 a2)
942 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
946 -- ToDo: make CoreArg an instance of Eq
947 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
951 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
952 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
953 eq_arg (TyArg t1) (TyArg t2) = t1 == t2