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 )
43 Float let out of case.
47 -> InExpr -- Scrutinee
48 -> (SubstEnvs, InAlts) -- Alternatives, and their static environment
49 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
50 -> OutType -- Type of result expression
53 simplCase env (Let bind body) alts rhs_c result_ty
54 | not (switchIsSet env SimplNoLetFromCase)
55 = -- Float the let outside the case scrutinee (if not disabled by flag)
56 tick LetFloatFromCase `thenSmpl_`
57 simplBind env bind (\env -> simplCase env body alts rhs_c result_ty) result_ty
60 OK to do case-of-case if
62 * we allow arbitrary code duplication
66 * the inner case has one alternative
67 case (case e of (a,b) -> rhs) of
78 IF neither of these two things are the case, we avoid code-duplication
79 by abstracting the outer rhss wrt the pattern variables. For example
81 case (case e of { p1->rhs1; ...; pn -> rhsn }) of
87 p1 -> case rhs1 of (x,y) -> b x y
89 pn -> case rhsn of (x,y) -> b x y
92 OK, so outer case expression gets duplicated, but that's all. Furthermore,
93 (a) the binding for "b" will be let-no-escaped, so no heap allocation
94 will take place; the "call" to b will simply be a stack adjustment
96 (b) very commonly, at least some of the rhsi's will be constructors, which
97 makes life even simpler.
99 All of this works equally well if the outer case has multiple rhss.
103 simplCase env (Case inner_scrut inner_alts) (subst_envs, outer_alts) rhs_c result_ty
104 | switchIsSet env SimplCaseOfCase
105 = -- Ha! Do case-of-case
106 tick CaseOfCase `thenSmpl_`
108 if no_need_to_bind_large_alts
110 simplCase env inner_scrut (getSubstEnvs env, inner_alts)
111 (\env' rhs -> simplCase env' rhs (subst_envs, outer_alts) rhs_c result_ty)
114 bindLargeAlts env_alts outer_alts rhs_c result_ty `thenSmpl` \ (extra_bindings, outer_alts') ->
116 rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
118 simplCase env inner_scrut (getSubstEnvs env, inner_alts)
119 (\env rhs -> simplCase env rhs (subst_envs, outer_alts') rhs_c' result_ty)
120 -- We used to have "emptySubstEnvs" instead of subst_envs here,
121 -- but that is *wrong*. The outer_alts' still have the old
122 -- binders from outer_alts, with un-substituted types,
123 -- so we must keep their subst_envs with them. It does
124 -- no harm to the freshly-manufactured part of outer_alts',
125 -- because it'll have nothing in the domain of subst_envs anyway
127 `thenSmpl` \ case_expr ->
128 returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
131 env_alts = setSubstEnvs env subst_envs
133 no_need_to_bind_large_alts = switchIsSet env SimplOkToDupCode ||
134 isSingleton (nonErrorRHSs inner_alts)
137 Case of an application of error.
140 simplCase env scrut alts rhs_c result_ty
141 | maybeToBool maybe_error_app
142 = -- Look for an application of an error id
143 tick CaseOfError `thenSmpl_`
144 simplExpr env retyped_error_app [] result_ty
146 -- We must apply simplExpr because "rhs" isn't yet simplified.
147 -- The ice is a little thin because body_ty is an OutType; but it's ok really
149 maybe_error_app = maybeErrorApp scrut (Just result_ty)
150 Just retyped_error_app = maybe_error_app
153 Finally the default case
156 simplCase env other_scrut (subst_envs, alts) rhs_c result_ty
157 = simplTy env scrut_ty `appEager` \ scrut_ty' ->
158 simplExpr env_scrut other_scrut [] scrut_ty' `thenSmpl` \ scrut' ->
159 completeCase env_alts scrut' alts rhs_c
161 -- When simplifying the scrutinee of a complete case that
162 -- has no default alternative
163 env_scrut = case alts of
164 AlgAlts _ NoDefault -> setCaseScrutinee env
165 PrimAlts _ NoDefault -> setCaseScrutinee env
168 env_alts = setSubstEnvs env subst_envs
170 scrut_ty = coreExprType (unTagBinders other_scrut)
174 %************************************************************************
176 \subsection[Simplify-case]{Completing case-expression simplification}
178 %************************************************************************
183 -> OutExpr -- The already-simplified scrutinee
184 -> InAlts -- The un-simplified alternatives
185 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
186 -> SmplM OutExpr -- The whole case expression
189 Scrutinising a literal or constructor.
190 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
191 It's an obvious win to do:
193 case (C a b) of {...; C p q -> rhs; ...} ===> rhs[a/p,b/q]
195 and the similar thing for primitive case. If we have
199 and x is known to be of constructor form, then we'll already have
200 inlined the constructor to give (case (C a b) of ...), so we don't
201 need to check for the variable case separately.
203 Sanity check: we don't have a good
204 story to tell about case analysis on NoRep things. ToDo.
207 completeCase env (Lit lit) alts rhs_c
208 | not (isNoRepLit lit)
209 = -- Ha! Select the appropriate alternative
210 tick KnownBranch `thenSmpl_`
211 completePrimCaseWithKnownLit env lit alts rhs_c
213 completeCase env expr@(Con con con_args) alts rhs_c
214 = -- Ha! Staring us in the face -- select the appropriate alternative
215 tick KnownBranch `thenSmpl_`
216 completeAlgCaseWithKnownCon env con con_args alts rhs_c
221 Start with a simple situation:
223 case x# of ===> e[x#/y#]
226 (when x#, y# are of primitive type, of course).
227 We can't (in general) do this for algebraic cases, because we might
228 turn bottom into non-bottom!
230 Actually, we generalise this idea to look for a case where we're
231 scrutinising a variable, and we know that only the default case can
236 other -> ...(case x of
240 Here the inner case can be eliminated. This really only shows up in
241 eliminating error-checking code.
243 Lastly, we generalise the transformation to handle this:
249 We only do this for very cheaply compared r's (constructors, literals
250 and variables). If pedantic bottoms is on, we only do it when the
251 scrutinee is a PrimOp which can't fail.
253 We do it *here*, looking at un-simplified alternatives, because we
254 have to check that r doesn't mention the variables bound by the
255 pattern in each alternative, so the binder-info is rather useful.
257 So the case-elimination algorithm is:
259 1. Eliminate alternatives which can't match
261 2. Check whether all the remaining alternatives
262 (a) do not mention in their rhs any of the variables bound in their pattern
263 and (b) have equal rhss
265 3. Check we can safely ditch the case:
266 * PedanticBottoms is off,
267 or * the scrutinee is an already-evaluated variable
268 or * the scrutinee is a primop which is ok for speculation
269 -- ie we want to preserve divide-by-zero errors, and
270 -- calls to error itself!
272 or * [Prim cases] the scrutinee is a primitive variable
274 or * [Alg cases] the scrutinee is a variable and
275 either * the rhs is the same variable
276 (eg case x of C a b -> x ===> x)
277 or * there is only one alternative, the default alternative,
278 and the binder is used strictly in its scope.
279 [NB this is helped by the "use default binder where
280 possible" transformation; see below.]
283 If so, then we can replace the case with one of the rhss.
286 completeCase env scrut alts rhs_c
287 | switchIsSet env SimplDoCaseElim &&
293 (not (switchIsSet env SimplPedanticBottoms) ||
295 scrut_is_eliminable_primitive ||
297 scrut_is_var_and_single_strict_default
300 = tick CaseElim `thenSmpl_`
303 -- Find the non-excluded rhss of the case; always at least one
304 (rhs1:rhss) = possible_rhss
305 all_rhss_same = all (cheap_eq rhs1) rhss
307 -- Find the reduced set of possible rhss, along with an indication of
308 -- whether none of their binders are used
309 (binders_unused, possible_rhss, new_env)
311 PrimAlts alts deflt -> (deflt_binder_unused, -- No binders other than deflt
315 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
317 -- Eliminate unused rhss if poss
318 rhss = case scrut_form of
319 OtherLit not_these -> [rhs | (alt_lit,rhs) <- alts,
320 not (alt_lit `is_elem` not_these)
322 other -> [rhs | (_,rhs) <- alts]
324 AlgAlts alts deflt -> (deflt_binder_unused && all alt_binders_unused possible_alts,
325 deflt_rhs ++ [rhs | (_,_,rhs) <- possible_alts],
328 (deflt_binder_unused, deflt_rhs, new_env) = elim_deflt_binder deflt
330 -- Eliminate unused alts if poss
331 possible_alts = case scrut_form of
332 OtherCon not_these ->
333 -- Remove alts which can't match
334 [alt | alt@(alt_con,_,_) <- alts,
335 not (alt_con `is_elem` not_these)]
339 alt_binders_unused (con, args, rhs) = all is_dead args
340 is_dead (_, DeadCode) = True
341 is_dead other_arg = False
343 -- If the scrutinee is a variable, look it up to see what we know about it
344 scrut_form = case scrut of
345 Var v -> lookupUnfolding env v
348 -- If the scrut is already eval'd then there's no worry about
349 -- eliminating the case
350 scrut_is_evald = isEvaluated scrut_form
352 scrut_is_eliminable_primitive
354 Prim op _ -> primOpOkForSpeculation op
355 Var _ -> case alts of
356 PrimAlts _ _ -> True -- Primitive, hence non-bottom
357 AlgAlts _ _ -> False -- Not primitive
360 -- case v of w -> e{strict in w} ===> e[v/w]
361 scrut_is_var_and_single_strict_default
363 Var _ -> case alts of
364 AlgAlts [] (BindDefault (v,_) _) -> willBeDemanded (getIdDemandInfo v)
368 elim_deflt_binder NoDefault -- No Binder
370 elim_deflt_binder (BindDefault (id, DeadCode) rhs) -- Binder unused
372 elim_deflt_binder (BindDefault used_binder rhs) -- Binder used
374 Var v -> -- Binder used, but can be eliminated in favour of scrut
375 (True, [rhs], bindIdToAtom env used_binder (VarArg v))
376 non_var -> -- Binder used, and can't be elimd
379 -- Check whether the chosen unique rhs (ie rhs1) is the same as
380 -- the scrutinee. Remember that the rhs is as yet unsimplified.
381 rhs1_is_scrutinee = case (scrut, rhs1) of
382 (Var scrut_var, Var rhs_var)
383 -> case (lookupIdSubst env rhs_var) of
384 Nothing -> rhs_var == scrut_var
385 Just (SubstVar rhs_var') -> rhs_var' == scrut_var
389 is_elem x ys = isIn "completeCase" x ys
392 Scrutinising anything else. If it's a variable, it can't be bound to a
393 constructor or literal, because that would have been inlined
396 completeCase env scrut alts rhs_c
397 = simplAlts env scrut alts rhs_c `thenSmpl` \ alts' ->
398 mkCoCase env scrut alts'
405 bindLargeAlts :: SimplEnv
407 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
408 -> OutType -- Result type
409 -> SmplM ([OutBinding], -- Extra bindings
410 InAlts) -- Modified alts
412 bindLargeAlts env the_lot@(AlgAlts alts deflt) rhs_c rhs_ty
413 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
414 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
415 returnSmpl (deflt_bindings ++ alt_bindings, AlgAlts alts' deflt')
417 do_alt (con,args,rhs) = bindLargeRhs env args rhs_ty
418 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
419 returnSmpl (bind, (con,args,rhs'))
421 bindLargeAlts env the_lot@(PrimAlts alts deflt) rhs_c rhs_ty
422 = mapAndUnzipSmpl do_alt alts `thenSmpl` \ (alt_bindings, alts') ->
423 bindLargeDefault env deflt rhs_ty rhs_c `thenSmpl` \ (deflt_bindings, deflt') ->
424 returnSmpl (deflt_bindings ++ alt_bindings, PrimAlts alts' deflt')
426 do_alt (lit,rhs) = bindLargeRhs env [] rhs_ty
427 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
428 returnSmpl (bind, (lit,rhs'))
430 bindLargeDefault env NoDefault rhs_ty rhs_c
431 = returnSmpl ([], NoDefault)
432 bindLargeDefault env (BindDefault binder rhs) rhs_ty rhs_c
433 = bindLargeRhs env [binder] rhs_ty
434 (\env -> rhs_c env rhs) `thenSmpl` \ (bind,rhs') ->
435 returnSmpl ([bind], BindDefault binder rhs')
438 bindLargeRhs env [x1,..,xn] rhs rhs_ty rhs_c
439 | otherwise = (rhs_id = \x1..xn -> rhs_c rhs,
443 bindLargeRhs :: SimplEnv
444 -> [InBinder] -- The args wrt which the rhs should be abstracted
446 -> (SimplEnv -> SmplM OutExpr) -- Rhs handler
447 -> SmplM (OutBinding, -- New bindings (singleton or empty)
448 InExpr) -- Modified rhs
450 bindLargeRhs env args rhs_ty rhs_c
451 | null used_args && isUnpointedType rhs_ty
452 -- If we try to lift a primitive-typed something out
453 -- for let-binding-purposes, we will *caseify* it (!),
454 -- with potentially-disastrous strictness results. So
455 -- instead we turn it into a function: \v -> e
456 -- where v::Void. Since arguments of type
457 -- VoidPrim don't generate any code, this gives the
460 -- The general structure is just the same as for the common "otherwise~ case
461 = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id ->
462 newId voidTy `thenSmpl` \ void_arg_id ->
463 rhs_c env `thenSmpl` \ prim_new_body ->
465 returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body),
466 App (Var prim_rhs_fun_id) (VarArg voidId))
469 = -- Generate the rhs
470 simplBinders env used_args `thenSmpl` \ (new_env, used_args') ->
472 rhs_fun_ty :: OutType
473 rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty
476 -- Make the new binding Id. NB: it's an OutId
477 newId rhs_fun_ty `thenSmpl` \ rhs_fun_id ->
478 rhs_c new_env `thenSmpl` \ rhs' ->
480 final_rhs = mkValLam used_args' rhs'
482 returnSmpl (NonRec rhs_fun_id final_rhs,
483 foldl App (Var rhs_fun_id) used_arg_atoms)
484 -- This is slightly wierd. We're retuning an OutId as part of the
485 -- modified rhs, which is meant to be an InExpr. However, that's ok, because when
486 -- it's processed the OutId won't be found in the environment, so it
487 -- will be left unmodified.
490 used_args = [arg | arg@(_,usage) <- args, not (dead usage)]
491 used_arg_atoms = [VarArg arg_id | (arg_id,_) <- used_args]
495 prim_rhs_fun_ty = mkFunTy voidTy rhs_ty
498 Case alternatives when we don't know the scrutinee
499 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
501 A special case for case default. If we have
507 it is best to make sure that \tr{default_e} mentions \tr{x} in
508 preference to \tr{y}. The code generator can do a cheaper job if it
509 doesn't have to come up with a binding for \tr{y}.
512 simplAlts :: SimplEnv
513 -> OutExpr -- Simplified scrutinee;
514 -- only of interest if its a var,
515 -- in which case we record its form
517 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
519 -- For single-constructor types
520 -- case e of y -> b ===> case e of (a,b) -> let y = (a,b) in b
522 simplAlts env scrut (AlgAlts [] (BindDefault bndr@(id,occ_info) rhs)) rhs_c
523 | maybeToBool maybe_data_ty &&
524 not (null cons) && -- Not an abstract type (can arise if we're pruning tydecl imports)
526 isDataTyCon tycon -- doesn't apply to (constructor-less) newtypes
527 = newIds inst_con_arg_tys `thenSmpl` \ new_bindees ->
529 new_args = [ (b, bad_occ_info) | b <- new_bindees ]
530 con_app = mkCon con ty_args (map VarArg new_bindees)
531 new_rhs = Let (NonRec bndr con_app) rhs
533 simplAlts env scrut (AlgAlts [(con,new_args,new_rhs)] NoDefault) rhs_c
535 maybe_data_ty = splitAlgTyConApp_maybe (idType id)
536 Just (tycon, ty_args, cons) = maybe_data_ty
537 (con:other_cons) = cons
538 inst_con_arg_tys = dataConArgTys con ty_args
539 bad_occ_info = ManyOcc 0 -- Non-committal!
541 simplAlts env scrut (AlgAlts alts deflt) rhs_c
542 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
543 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
544 returnSmpl (AlgAlts alts' deflt')
546 deflt_form = OtherCon [con | (con,_,_) <- alts]
547 do_alt (con, con_args, rhs)
548 = simplBinders env con_args `thenSmpl` \ (env1, con_args') ->
550 new_env = case scrut of
551 Var v -> extendEnvGivenNewRhs env1 v (Con con args)
553 (_, ty_args, _) = splitAlgTyConApp (idType v)
554 args = map TyArg ty_args ++ map VarArg con_args'
558 rhs_c new_env rhs `thenSmpl` \ rhs' ->
559 returnSmpl (con, con_args', rhs')
561 simplAlts env scrut (PrimAlts alts deflt) rhs_c
562 = mapSmpl do_alt alts `thenSmpl` \ alts' ->
563 simplDefault env scrut deflt deflt_form rhs_c `thenSmpl` \ deflt' ->
564 returnSmpl (PrimAlts alts' deflt')
566 deflt_form = OtherLit [lit | (lit,_) <- alts]
569 new_env = case scrut of
570 Var v -> extendEnvGivenNewRhs env v (Lit lit)
573 rhs_c new_env rhs `thenSmpl` \ rhs' ->
574 returnSmpl (lit, rhs')
577 Use default binder where possible
578 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
579 There's one complication when simplifying the default clause of
580 a case expression. If we see
585 we'd like to convert it to
590 Reason 1: then there might be just one occurrence of x, and it can be
591 inlined as the case scrutinee. So we spot this case when dealing with
592 the default clause, and add a binding to the environment mapping x to
595 Reason 2: if the body is strict in x' then we can eliminate the
596 case altogether. By using x' in preference to x we give the max chance
597 of the strictness analyser finding that the body is strict in x'.
599 On the other hand, if x does *not* get inlined, then we'll actually
600 get somewhat better code from the former expression. So when
601 doing Core -> STG we convert back!
606 -> OutExpr -- Simplified scrutinee
607 -> InDefault -- Default alternative to be completed
608 -> Unfolding -- Gives form of scrutinee
609 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Old rhs handler
612 simplDefault env scrut NoDefault form rhs_c
613 = returnSmpl NoDefault
615 -- Special case for variable scrutinee; see notes above.
616 simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
617 info_from_this_case rhs_c
618 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
620 env2 = extendEnvGivenNewRhs env1 scrut_var (Var binder')
622 -- Add form details for the default binder
623 scrut_unf = lookupUnfolding env scrut_var
624 new_env = extendEnvGivenUnfolding env2 binder' noBinderInfo scrut_unf
625 -- Use noBinderInfo rather than occ_info because we've
626 -- added more occurrences by binding the scrut_var to it
628 rhs_c new_env rhs `thenSmpl` \ rhs' ->
629 returnSmpl (BindDefault binder' rhs')
631 simplDefault env scrut (BindDefault binder@(_,occ_info) rhs)
632 info_from_this_case rhs_c
633 = simplBinder env binder `thenSmpl` \ (env1, binder') ->
635 new_env = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
637 rhs_c new_env rhs `thenSmpl` \ rhs' ->
638 returnSmpl (BindDefault binder' rhs')
641 Case alternatives when we know what the scrutinee is
642 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
645 completePrimCaseWithKnownLit
649 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
652 completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c
655 search_alts :: [(Literal, InExpr)] -> SmplM OutExpr
657 search_alts ((alt_lit, rhs) : _)
659 = -- Matching alternative!
662 search_alts (_ : other_alts)
663 = -- This alternative doesn't match; keep looking
664 search_alts other_alts
668 NoDefault -> -- Blargh!
669 panic "completePrimCaseWithKnownLit: No matching alternative and no default"
671 BindDefault binder rhs -> -- OK, there's a default case
672 -- Just bind the Id to the atom and continue
674 new_env = bindIdToAtom env binder (LitArg lit)
679 @completeAlgCaseWithKnownCon@: We know the constructor, so we can
680 select one case alternative (or default). If we choose the default:
681 we do different things depending on whether the constructor was
682 staring us in the face (e.g., \tr{case (p:ps) of {y -> ...}})
683 [let-bind it] or we just know the \tr{y} is now the same as some other
684 var [substitute \tr{y} out of existence].
687 completeAlgCaseWithKnownCon
689 -> DataCon -> [InArg]
690 -- Scrutinee is (con, type, value arguments)
692 -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
695 completeAlgCaseWithKnownCon env con con_args a@(AlgAlts alts deflt) rhs_c
696 = ASSERT(isDataCon con)
699 search_alts :: [(Id, [InBinder], InExpr)] -> SmplM OutExpr
701 search_alts ((alt_con, alt_args, rhs) : _)
703 = -- Matching alternative!
705 val_args = filter isValArg con_args
706 new_env = foldr bind env (zipEqual "SimplCase" alt_args val_args)
707 bind (bndr, atom) env = bindIdToAtom env bndr atom
711 search_alts (_ : other_alts)
712 = -- This alternative doesn't match; keep looking
713 search_alts other_alts
716 = -- No matching alternative
718 NoDefault -> -- Blargh!
719 pprPanic "completeAlgCaseWithKnownCon: No matching alternative and no default"
720 (ppr con <+> ppr con_args $$ ppr a)
722 BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
723 -- let-bind the binder to the constructor
724 simplBinder env binder `thenSmpl` \ (env1, id') ->
726 new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args)
728 rhs_c new_env rhs `thenSmpl` \ rhs' ->
729 returnSmpl (Let (NonRec id' (Con con con_args)) rhs')
732 Case absorption and identity-case elimination
733 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
736 mkCoCase :: SimplEnv -> OutExpr -> OutAlts -> SmplM OutExpr
739 @mkCoCase@ tries the following transformation (if possible):
741 case v of ==> case v of
742 p1 -> rhs1 p1 -> rhs1
744 pm -> rhsm pm -> rhsm
745 d -> case v of pn -> rhsn[v/d] {or (alg) let d=v in rhsn}
746 {or (prim) case v of d -> rhsn}
749 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
752 which merges two cases in one case when -- the default alternative of
753 the outer case scrutises the same variable as the outer case This
754 transformation is called Case Merging. It avoids that the same
755 variable is scrutinised multiple times.
757 There's a closely-related transformation:
759 case e of ==> case e of
760 p1 -> rhs1 p1 -> rhs1
762 pm -> rhsm pm -> rhsm
763 d -> case d of pn -> let d = pn in rhsn
765 ... po -> let d = po in rhso
766 po -> rhso d -> rhsd[d/d'] {or let d'=d in rhsd}
769 Here, the let's are essential, because d isn't in scope any more.
770 Sigh. Of course, they may be unused, in which case they'll be
771 eliminated on the next round. Unfortunately, we can't figure out
772 whether or not they are used at this juncture.
774 NB: The binder in a BindDefault USED TO BE guaranteed unused if the
775 scrutinee is a variable, because it'll be mapped to the scrutinised
776 variable. Hence the [v/d] substitions can be omitted.
778 ALAS, now the default binder is used by preference, so we have to
779 generate trivial lets to express the substitutions, which will be
780 eliminated on the next pass.
782 The following code handles *both* these transformations (one
783 equation for AlgAlts, one for PrimAlts):
786 mkCoCase env scrut (AlgAlts outer_alts
787 (BindDefault deflt_var
788 (Case (Var scrut_var')
789 (AlgAlts inner_alts inner_deflt))))
790 | switchIsSet env SimplCaseMerge &&
791 ((scrut_is_var && scrut_var == scrut_var') || -- First transformation
792 deflt_var == scrut_var') -- Second transformation
793 = -- Aha! The default-absorption rule applies
794 tick CaseMerge `thenSmpl_`
795 returnSmpl (Case scrut (AlgAlts (outer_alts ++ munged_reduced_inner_alts)
796 (munge_alg_deflt deflt_var inner_deflt)))
797 -- NB: see comment in this location for the PrimAlts case
800 scrut_is_var = case scrut of {Var v -> True; other -> False}
801 scrut_var = case scrut of Var v -> v
803 -- Eliminate any inner alts which are shadowed by the outer ones
804 reduced_inner_alts = [alt | alt@(con,_,_) <- inner_alts,
805 not (con `is_elem` outer_cons)]
806 outer_cons = [con | (con,_,_) <- outer_alts]
807 is_elem = isIn "mkAlgAlts"
809 -- Add the lets if necessary
810 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
812 munge_alt (con, args, rhs) = (con, args, Let (NonRec deflt_var v) rhs)
814 v | scrut_is_var = Var scrut_var
815 | otherwise = Con con (map TyArg arg_tys ++ map VarArg args)
817 arg_tys = case (splitAlgTyConApp (idType deflt_var)) of
818 (_, arg_tys, _) -> arg_tys
820 mkCoCase env scrut (PrimAlts
822 (BindDefault deflt_var (Case
824 (PrimAlts inner_alts inner_deflt))))
825 | switchIsSet env SimplCaseMerge &&
826 ((scrut_is_var && scrut_var == scrut_var') ||
827 deflt_var == scrut_var')
828 = -- Aha! The default-absorption rule applies
829 tick CaseMerge `thenSmpl_`
830 returnSmpl (Case scrut (PrimAlts (outer_alts ++ munged_reduced_inner_alts)
831 (munge_prim_deflt deflt_var inner_deflt)))
833 -- Nota Bene: we don't recurse to mkCoCase again, because the
834 -- default will now have a binding in it that prevents
835 -- mkCoCase doing anything useful. Much worse, in this
836 -- PrimAlts case the binding in the default branch is another
837 -- Case, so if we recurse to mkCoCase we will get into an
840 -- ToDo: think of a better way to do this. At the moment
841 -- there is at most one case merge per round. That's probably
842 -- plenty but it seems unclean somehow.
845 scrut_is_var = case scrut of {Var v -> True; other -> False}
846 scrut_var = case scrut of Var v -> v
848 -- Eliminate any inner alts which are shadowed by the outer ones
849 reduced_inner_alts = [alt | alt@(lit,_) <- inner_alts,
850 not (lit `is_elem` outer_lits)]
851 outer_lits = [lit | (lit,_) <- outer_alts]
852 is_elem = isIn "mkPrimAlts"
854 -- Add the lets (well cases actually) if necessary
855 -- The munged alternative looks like
856 -- lit -> case lit of d -> rhs
857 -- The next pass will certainly eliminate the inner case, but
858 -- it isn't easy to do so right away.
859 munged_reduced_inner_alts = map munge_alt reduced_inner_alts
862 | scrut_is_var = (lit, Case (Var scrut_var)
863 (PrimAlts [] (BindDefault deflt_var rhs)))
864 | otherwise = (lit, Case (Lit lit)
865 (PrimAlts [] (BindDefault deflt_var rhs)))
868 Now the identity-case transformation:
877 mkCoCase env scrut alts
879 = tick CaseIdentity `thenSmpl_`
882 identity_alts (AlgAlts alts deflt) = all identity_alg_alt alts && identity_deflt deflt
883 identity_alts (PrimAlts alts deflt) = all identity_prim_alt alts && identity_deflt deflt
885 identity_alg_alt (con, args, Con con' args')
887 && and (zipWith eq_arg args args')
888 && length args == length args'
889 identity_alg_alt other
892 identity_prim_alt (lit, Lit lit') = lit == lit'
893 identity_prim_alt other = False
895 -- For the default case we want to spot both
898 -- case y of { ... ; x -> y }
899 -- as "identity" defaults
900 identity_deflt NoDefault = True
901 identity_deflt (BindDefault binder (Var x)) = x == binder ||
905 identity_deflt _ = False
907 eq_arg binder (VarArg x) = binder == x
914 mkCoCase env other_scrut other_alts = returnSmpl (Case other_scrut other_alts)
917 Boring local functions used above. They simply introduce a trivial binding
918 for the binder, d', in an inner default; either
919 let d' = deflt_var in rhs
921 case deflt_var of d' -> rhs
922 depending on whether it's an algebraic or primitive case.
925 munge_prim_deflt _ NoDefault = NoDefault
927 munge_prim_deflt deflt_var (BindDefault d' rhs)
928 = BindDefault deflt_var (Case (Var deflt_var)
929 (PrimAlts [] (BindDefault d' rhs)))
931 munge_alg_deflt _ NoDefault = NoDefault
933 munge_alg_deflt deflt_var (BindDefault d' rhs)
934 = BindDefault deflt_var (Let (NonRec d' (Var deflt_var)) rhs)
936 -- This line caused a generic version of munge_deflt (ie one used for
937 -- both alg and prim) to space leak massively. No idea why.
938 -- = BindDefault deflt_var (mkCoLetUnboxedToCase (NonRec d' (Var deflt_var)) rhs)
942 cheap_eq :: InExpr -> InExpr -> Bool
943 -- A cheap equality test which bales out fast!
945 cheap_eq (Var v1) (Var v2) = v1==v2
946 cheap_eq (Lit l1) (Lit l2) = l1==l2
947 cheap_eq (Con con1 args1) (Con con2 args2)
948 = con1 == con2 && args1 `eq_args` args2
950 cheap_eq (Prim op1 args1) (Prim op2 args2)
951 = op1 ==op2 && args1 `eq_args` args2
953 cheap_eq (App f1 a1) (App f2 a2)
954 = f1 `cheap_eq` f2 && a1 `eq_arg` a2
958 -- ToDo: make CoreArg an instance of Eq
959 eq_args (a1:as1) (a2:as2) = a1 `eq_arg` a2 && as1 `eq_args` as2
963 eq_arg (LitArg l1) (LitArg l2) = l1 == l2
964 eq_arg (VarArg v1) (VarArg v2) = v1 == v2
965 eq_arg (TyArg t1) (TyArg t2) = t1 == t2