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(..) )
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 -> (SubstEnvs, InAlts) -- Alternatives, and their static environment
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) (subst_envs, 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 (getSubstEnvs env, inner_alts)
110 (\env' rhs -> simplCase env' rhs (subst_envs, outer_alts) rhs_c result_ty)
113 bindLargeAlts env_alts outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
115 rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
117 simplCase env inner_scrut (getSubstEnvs env, inner_alts)
118 (\env rhs -> simplCase env rhs (emptySubstEnvs, outer_alts') rhs_c' result_ty)
120 `thenSmpl` \ case_expr ->
121 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
124 env_alts = setSubstEnvs env subst_envs
126 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
127 isSingleton (nonErrorRHSs inner_alts)
130 Case of an application of error.
133 simplCase env scrut alts rhs_c result_ty
134 | maybeToBool maybe_error_app
135 = -- Look for an application of an error id
136 tick CaseOfError `thenSmpl_`
137 simplExpr env retyped_error_app [] result_ty
139 -- We must apply simplExpr because "rhs" isn't yet simplified.
140 -- The ice is a little thin because body_ty is an OutType; but it's ok really
142 maybe_error_app = maybeErrorApp scrut (Just result_ty)
143 Just retyped_error_app = maybe_error_app
146 Finally the default case
149 simplCase env other_scrut (subst_envs, alts) rhs_c result_ty
150 = simplTy env scrut_ty `appEager` \ scrut_ty' ->
151 simplExpr env_scrut other_scrut [] scrut_ty' `thenSmpl` \ scrut' ->
152 completeCase env_alts scrut' alts rhs_c
154 -- When simplifying the scrutinee of a complete case that
155 -- has no default alternative
156 env_scrut = case alts of
157 AlgAlts _ NoDefault -> setCaseScrutinee env
158 PrimAlts _ NoDefault -> setCaseScrutinee env
161 env_alts = setSubstEnvs env subst_envs
163 scrut_ty = coreExprType (unTagBinders other_scrut)
167 %************************************************************************
169 \subsection[Simplify-case]{Completing case-expression simplification}
171 %************************************************************************
176 -> OutExpr -- The already-simplified scrutinee
177 -> InAlts -- The un-simplified alternatives
178 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
179 -> SmplM OutExpr -- The whole case expression
182 Scrutinising a literal or constructor.
183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
184 It's an obvious win to do:
186 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
188 and the similar thing for primitive case. If we have
192 and x is known to be of constructor form, then we'll already have
193 inlined the constructor to give (case (C a b) of ...), so we don't
194 need to check for the variable case separately.
196 Sanity check: we don't have a good
197 story to tell about case analysis on NoRep things. ToDo.
200 completeCase env (Lit lit) alts rhs_c
201 | not (isNoRepLit lit)
202 = -- Ha! Select the appropriate alternative
203 tick KnownBranch `thenSmpl_`
204 completePrimCaseWithKnownLit env lit alts rhs_c
206 completeCase env expr@(Con con con_args) alts rhs_c
207 = -- Ha! Staring us in the face -- select the appropriate alternative
208 tick KnownBranch `thenSmpl_`
209 completeAlgCaseWithKnownCon env con con_args alts rhs_c
214 Start with a simple situation:
216 case x# of ===> e[x#/y#]
219 (when x#, y# are of primitive type, of course).
220 We can't (in general) do this for algebraic cases, because we might
221 turn bottom into non-bottom!
223 Actually, we generalise this idea to look for a case where we're
224 scrutinising a variable, and we know that only the default case can
229 other -> ...(case x of
233 Here the inner case can be eliminated. This really only shows up in
234 eliminating error-checking code.
236 Lastly, we generalise the transformation to handle this:
242 We only do this for very cheaply compared r's (constructors, literals
243 and variables). If pedantic bottoms is on, we only do it when the
244 scrutinee is a PrimOp which can't fail.
246 We do it *here*, looking at un-simplified alternatives, because we
247 have to check that r doesn't mention the variables bound by the
248 pattern in each alternative, so the binder-info is rather useful.
250 So the case-elimination algorithm is:
252 1. Eliminate alternatives which can't match
254 2. Check whether all the remaining alternatives
255 (a) do not mention in their rhs any of the variables bound in their pattern
256 and (b) have equal rhss
258 3. Check we can safely ditch the case:
259 * PedanticBottoms is off,
260 or * the scrutinee is an already-evaluated variable
261 or * the scrutinee is a primop which is ok for speculation
262 -- ie we want to preserve divide-by-zero errors, and
263 -- calls to error itself!
265 or * [Prim cases] the scrutinee is a primitive variable
267 or * [Alg cases] the scrutinee is a variable and
268 either * the rhs is the same variable
269 (eg case x of C a b -> x ===> x)
270 or * there is only one alternative, the default alternative,
271 and the binder is used strictly in its scope.
272 [NB this is helped by the "use default binder where
273 possible" transformation; see below.]
276 If so, then we can replace the case with one of the rhss.
279 completeCase env scrut alts rhs_c
280 | switchIsSet env SimplDoCaseElim &&
286 (not (switchIsSet env SimplPedanticBottoms) ||
288 scrut_is_eliminable_primitive ||
290 scrut_is_var_and_single_strict_default
293 = tick CaseElim `thenSmpl_`
296 -- Find the non-excluded rhss of the case; always at least one
297 (rhs1:rhss) = possible_rhss
298 all_rhss_same = all (cheap_eq rhs1) rhss
300 -- Find the reduced set of possible rhss, along with an indication of
301 -- whether none of their binders are used
302 (binders_unused, possible_rhss, new_env)
304 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
308 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
310 -- Eliminate unused rhss if poss
311 rhss = case scrut_form of
312 OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
313 not (alt_lit `is_elem` not_these)
315 other -> [rhs | (_,rhs) <- alts]
317 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
318 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
321 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
323 -- Eliminate unused alts if poss
324 possible_alts = case scrut_form of
325 OtherCon not_these ->
326 -- Remove alts which can't match
327 [alt | alt@(alt_con,_,_) <- alts,
328 not (alt_con `is_elem` not_these)]
332 alt_binders_unused (con, args, rhs) = all is_dead args
333 is_dead (_, DeadCode) = True
334 is_dead other_arg = False
336 -- If the scrutinee is a variable, look it up to see what we know about it
337 scrut_form = case scrut of
338 Var v -> lookupUnfolding env v
341 -- If the scrut is already eval'd then there's no worry about
342 -- eliminating the case
343 scrut_is_evald = isEvaluated scrut_form
345 scrut_is_eliminable_primitive
347 Prim op _ -> primOpOkForSpeculation op
348 Var _ -> case alts of
349 PrimAlts _ _ -> True -- Primitive, hence non-bottom
350 AlgAlts _ _ -> False -- Not primitive
353 -- case v of w -> e{strict in w} ===> e[v/w]
354 scrut_is_var_and_single_strict_default
356 Var _ -> case alts of
357 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
361 elim_deflt_binder NoDefault -- No Binder
363 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
365 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
367 Var v -> -- Binder used, but can be eliminated in favour of scrut
368 (True, [rhs], bindIdToAtom env used_binder (VarArg v))
369 non_var -> -- Binder used, and can't be elimd
372 -- Check whether the chosen unique rhs (ie rhs1) is the same as
373 -- the scrutinee. Remember that the rhs is as yet unsimplified.
374 rhs1_is_scrutinee = case (scrut, rhs1) of
375 (Var scrut_var, Var rhs_var)
376 -> case (lookupIdSubst env rhs_var) of
377 Nothing -> rhs_var == scrut_var
378 Just (SubstVar rhs_var') -> rhs_var' == scrut_var
382 is_elem x ys = isIn "completeCase" x ys
385 Scrutinising anything else. If it's a variable, it can't be bound to a
386 constructor or literal, because that would have been inlined
389 completeCase env scrut alts rhs_c
390 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
391 mkCoCase env scrut alts'
398 bindLargeAlts :: SimplEnv
400 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
401 -> OutType -- Result type
402 -> SmplM ([OutBinding], -- Extra bindings
403 InAlts) -- Modified alts
405 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
406 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
407 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
408 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
410 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
411 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
412 returnSmpl (bind, (con,args,rhs'))
414 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
415 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
416 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
417 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
419 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
420 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
421 returnSmpl (bind, (lit,rhs'))
423 bindLargeDefault env NoDefault rhs_ty rhs_c
424 = returnSmpl ([], NoDefault)
425 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
426 = bindLargeRhs env [binder] rhs_ty
427 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
428 returnSmpl ([bind], BindDefault binder rhs')
431 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
432 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
436 bindLargeRhs :: SimplEnv
437 -> [InBinder] -- The args wrt which the rhs should be abstracted
439 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
440 -> SmplM (OutBinding, -- New bindings (singleton or empty)
441 InExpr) -- Modified rhs
443 bindLargeRhs env args rhs_ty rhs_c
444 | null used_args && isUnpointedType rhs_ty
445 -- If we try to lift a primitive-typed something out
446 -- for let-binding-purposes, we will *caseify* it (!),
447 -- with potentially-disastrous strictness results. So
448 -- instead we turn it into a function: \v -> e
449 -- where v::Void. Since arguments of type
450 -- VoidPrim don't generate any code, this gives the
453 -- The general structure is just the same as for the common "otherwise~ case
454 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
455 newId voidTy `thenSmpl` \ void_arg_id ->
456 rhs_c env `thenSmpl` \ prim_new_body ->
458 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
459 App (Var prim_rhs_fun_id) (VarArg voidId))
462 = -- Generate the rhs
463 simplBinders env used_args `thenSmpl` \ (new_env, used_args') ->
465 rhs_fun_ty :: OutType
466 rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
469 -- Make the new binding Id. NB: it's an OutId
470 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
471 rhs_c new_env `thenSmpl` \ rhs' ->
473 final_rhs = mkValLam used_args' rhs'
475 returnSmpl (NonRec rhs_fun_id final_rhs,
476 foldl App (Var rhs_fun_id) used_arg_atoms)
477 -- This is slightly wierd. We're retuning an OutId as part of the
478 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
479 -- it's processed the OutId won't be found in the environment, so it
480 -- will be left unmodified.
483 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
484 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
488 prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
491 Case alternatives when we don't know the scrutinee
492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
494 A special case for case default. If we have
500 it is best to make sure that \tr{default_e} mentions \tr{x} in
501 preference to \tr{y}. The code generator can do a cheaper job if it
502 doesn't have to come up with a binding for \tr{y}.
505 simplAlts :: SimplEnv
506 -> OutExpr -- Simplified scrutinee;
507 -- only of interest if its a var,
508 -- in which case we record its form
510 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
512 -- For single-constructor types
513 -- case e of y -> b ===> case e of (a,b) -> let y = (a,b) in b
515 simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
516 | maybeToBool maybe_data_ty &&
517 not (null cons) && -- Not an abstract type (can arise if we're pruning tydecl imports)
519 isDataTyCon tycon -- doesn't apply to (constructor-less) newtypes
520 = newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
522 new_args = [ (b, bad_occ_info) | b <- new_bindees ]
523 con_app = mkCon con ty_args (map VarArg new_bindees)
524 new_rhs = Let (NonRec bndr con_app) rhs
526 simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
528 maybe_data_ty = splitAlgTyConApp_maybe (idType id)
529 Just (tycon, ty_args, cons) = maybe_data_ty
530 (con:other_cons) = cons
531 inst_con_arg_tys = dataConArgTys con ty_args
532 bad_occ_info = ManyOcc 0 -- Non-committal!
534 simplAlts env scrut (AlgAlts alts deflt) rhs_c
535 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
536 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
537 returnSmpl (AlgAlts alts' deflt')
539 deflt_form = OtherCon [con | (con,_,_) <- alts]
540 do_alt (con, con_args, rhs)
541 = simplBinders env con_args `thenSmpl` \ (env1, con_args') ->
543 new_env = case scrut of
544 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
546 (_, ty_args, _) = splitAlgTyConApp (idType v)
547 args = map TyArg ty_args ++ map VarArg con_args'
551 rhs_c new_env rhs `thenSmpl` \ rhs' ->
552 returnSmpl (con, con_args', rhs')
554 simplAlts env scrut (PrimAlts alts deflt) rhs_c
555 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
556 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
557 returnSmpl (PrimAlts alts' deflt')
559 deflt_form = OtherLit [lit | (lit,_) <- alts]
562 new_env = case scrut of
563 Var v -> extendEnvGivenNewRhs env v (Lit lit)
566 rhs_c new_env rhs `thenSmpl` \ rhs' ->
567 returnSmpl (lit, rhs')
570 Use default binder where possible
571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
572 There's one complication when simplifying the default clause of
573 a case expression. If we see
578 we'd like to convert it to
583 Reason 1: then there might be just one occurrence of x, and it can be
584 inlined as the case scrutinee. So we spot this case when dealing with
585 the default clause, and add a binding to the environment mapping x to
588 Reason 2: if the body is strict in x' then we can eliminate the
589 case altogether. By using x' in preference to x we give the max chance
590 of the strictness analyser finding that the body is strict in x'.
592 On the other hand, if x does *not* get inlined, then we'll actually
593 get somewhat better code from the former expression. So when
594 doing Core -> STG we convert back!
599 -> OutExpr -- Simplified scrutinee
600 -> InDefault -- Default alternative to be completed
601 -> Unfolding -- Gives form of scrutinee
602 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
605 simplDefault env scrut NoDefault form rhs_c
606 = returnSmpl NoDefault
608 -- Special case for variable scrutinee; see notes above.
609 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
610 info_from_this_case rhs_c
611 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
613 env2 = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
615 -- Add form details for the default binder
616 scrut_info = lookupUnfolding env scrut_var
617 env3 = extendEnvGivenUnfolding env2 binder' occ_info scrut_info
618 new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
620 rhs_c new_env rhs `thenSmpl` \ rhs' ->
621 returnSmpl (BindDefault binder' rhs')
623 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
624 info_from_this_case rhs_c
625 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
627 new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
629 rhs_c new_env rhs `thenSmpl` \ rhs' ->
630 returnSmpl (BindDefault binder' rhs')
633 Case alternatives when we know what the scrutinee is
634 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
637 completePrimCaseWithKnownLit
641 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
644 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
647 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
649 search_alts ((alt_lit, rhs) : _)
651 = -- Matching alternative!
654 search_alts (_ : other_alts)
655 = -- This alternative doesn't match; keep looking
656 search_alts other_alts
660 NoDefault -> -- Blargh!
661 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
663 BindDefault binder rhs -> -- OK, there's a default case
664 -- Just bind the Id to the atom and continue
666 new_env = bindIdToAtom env binder (LitArg lit)
671 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
672 select one case alternative (or default). If we choose the default:
673 we do different things depending on whether the constructor was
674 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
675 [let-bind it] or we just know the \tr{y} is now the same as some other
676 var [substitute \tr{y} out of existence].
679 completeAlgCaseWithKnownCon
681 -> DataCon -> [InArg]
682 -- Scrutinee is (con, type, value arguments)
684 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
687 completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
688 = ASSERT(isDataCon con)
691 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
693 search_alts ((alt_con, alt_args, rhs) : _)
695 = -- Matching alternative!
697 val_args = filter isValArg con_args
698 new_env = foldr bind env (zipEqual "SimplCase" alt_args val_args)
699 bind (bndr, atom) env = bindIdToAtom env bndr atom
703 search_alts (_ : other_alts)
704 = -- This alternative doesn't match; keep looking
705 search_alts other_alts
708 = -- No matching alternative
710 NoDefault -> -- Blargh!
711 panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
713 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
714 -- let-bind the binder to the constructor
715 simplBinder env binder `thenSmpl` \ (env1, id') ->
717 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
719 rhs_c new_env rhs `thenSmpl` \ rhs' ->
720 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
723 Case absorption and identity-case elimination
724 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
727 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
730 @mkCoCase@ tries the following transformation (if possible):
732 case v of ==> case v of
733 p1 -> rhs1 p1 -> rhs1
735 pm -> rhsm pm -> rhsm
736 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
737 {or (prim) case v of d -> rhsn}
740 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
743 which merges two cases in one case when -- the default alternative of
744 the outer case scrutises the same variable as the outer case This
745 transformation is called Case Merging. It avoids that the same
746 variable is scrutinised multiple times.
748 There's a closely-related transformation:
750 case e of ==> case e of
751 p1 -> rhs1 p1 -> rhs1
753 pm -> rhsm pm -> rhsm
754 d -> case d of pn -> let d = pn in rhsn
756 ... po -> let d = po in rhso
757 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
760 Here, the let's are essential, because d isn't in scope any more.
761 Sigh. Of course, they may be unused, in which case they'll be
762 eliminated on the next round. Unfortunately, we can't figure out
763 whether or not they are used at this juncture.
765 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
766 scrutinee is a variable, because it'll be mapped to the scrutinised
767 variable. Hence the [v/d] substitions can be omitted.
769 ALAS, now the default binder is used by preference, so we have to
770 generate trivial lets to express the substitutions, which will be
771 eliminated on the next pass.
773 The following code handles *both* these transformations (one
774 equation for AlgAlts, one for PrimAlts):
777 mkCoCase env scrut (AlgAlts outer_alts
778 (BindDefault deflt_var
779 (Case (Var scrut_var')
780 (AlgAlts inner_alts inner_deflt))))
781 | switchIsSet env SimplCaseMerge &&
782 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
783 deflt_var == scrut_var') -- Second transformation
784 = -- Aha! The default-absorption rule applies
785 tick CaseMerge `thenSmpl_`
786 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
787 (munge_alg_deflt deflt_var inner_deflt)))
788 -- NB: see comment in this location for the PrimAlts case
791 scrut_is_var = case scrut of {Var v -> True; other -> False}
792 scrut_var = case scrut of Var v -> v
794 -- Eliminate any inner alts which are shadowed by the outer ones
795 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
796 not (con `is_elem` outer_cons)]
797 outer_cons = [con | (con,_,_) <- outer_alts]
798 is_elem = isIn "mkAlgAlts"
800 -- Add the lets if necessary
801 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
803 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
805 v | scrut_is_var = Var scrut_var
806 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
808 arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
809 (_, arg_tys, _) -> arg_tys
811 mkCoCase env scrut (PrimAlts
813 (BindDefault deflt_var (Case
815 (PrimAlts inner_alts inner_deflt))))
816 | switchIsSet env SimplCaseMerge &&
817 ((scrut_is_var && scrut_var == scrut_var') ||
818 deflt_var == scrut_var')
819 = -- Aha! The default-absorption rule applies
820 tick CaseMerge `thenSmpl_`
821 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
822 (munge_prim_deflt deflt_var inner_deflt)))
824 -- Nota Bene: we don't recurse to mkCoCase again, because the
825 -- default will now have a binding in it that prevents
826 -- mkCoCase doing anything useful. Much worse, in this
827 -- PrimAlts case the binding in the default branch is another
828 -- Case, so if we recurse to mkCoCase we will get into an
831 -- ToDo: think of a better way to do this. At the moment
832 -- there is at most one case merge per round. That's probably
833 -- plenty but it seems unclean somehow.
836 scrut_is_var = case scrut of {Var v -> True; other -> False}
837 scrut_var = case scrut of Var v -> v
839 -- Eliminate any inner alts which are shadowed by the outer ones
840 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
841 not (lit `is_elem` outer_lits)]
842 outer_lits = [lit | (lit,_) <- outer_alts]
843 is_elem = isIn "mkPrimAlts"
845 -- Add the lets (well cases actually) if necessary
846 -- The munged alternative looks like
847 -- lit -> case lit of d -> rhs
848 -- The next pass will certainly eliminate the inner case, but
849 -- it isn't easy to do so right away.
850 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
853 | scrut_is_var = (lit, Case (Var scrut_var)
854 (PrimAlts [] (BindDefault deflt_var rhs)))
855 | otherwise = (lit, Case (Lit lit)
856 (PrimAlts [] (BindDefault deflt_var rhs)))
859 Now the identity-case transformation:
868 mkCoCase env scrut alts
870 = tick CaseIdentity `thenSmpl_`
873 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
874 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
876 identity_alg_alt (con, args, Con con' args')
878 && and (zipWith eq_arg args args')
879 && length args == length args'
880 identity_alg_alt other
883 identity_prim_alt (lit, Lit lit') = lit == lit'
884 identity_prim_alt other = False
886 -- For the default case we want to spot both
889 -- case y of { ... ; x -> y }
890 -- as "identity" defaults
891 identity_deflt NoDefault = True
892 identity_deflt (BindDefault binder (Var x)) = x == binder ||
896 identity_deflt _ = False
898 eq_arg binder (VarArg x) = binder == x
905 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
908 Boring local functions used above. They simply introduce a trivial binding
909 for the binder, d', in an inner default; either
910 let d' = deflt_var in rhs
912 case deflt_var of d' -> rhs
913 depending on whether it's an algebraic or primitive case.
916 munge_prim_deflt _ NoDefault = NoDefault
918 munge_prim_deflt deflt_var (BindDefault d' rhs)
919 = BindDefault deflt_var (Case (Var deflt_var)
920 (PrimAlts [] (BindDefault d' rhs)))
922 munge_alg_deflt _ NoDefault = NoDefault
924 munge_alg_deflt deflt_var (BindDefault d' rhs)
925 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
927 -- This line caused a generic version of munge_deflt (ie one used for
928 -- both alg and prim) to space leak massively. No idea why.
929 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
933 cheap_eq :: InExpr -> InExpr -> Bool
934 -- A cheap equality test which bales out fast!
936 cheap_eq (Var v1) (Var v2) = v1==v2
937 cheap_eq (Lit l1) (Lit l2) = l1==l2
938 cheap_eq (Con con1 args1) (Con con2 args2)
939 = con1 == con2 && args1 `eq_args` args2
941 cheap_eq (Prim op1 args1) (Prim op2 args2)
942 = op1 ==op2 && args1 `eq_args` args2
944 cheap_eq (App f1 a1) (App f2 a2)
945 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
949 -- ToDo: make CoreArg an instance of Eq
950 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
954 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
955 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
956 eq_arg (TyArg t1) (TyArg t2) = t1 == t2