-`%
+%
% (c) The AQUA Project, Glasgow University, 1994-1996
%
\section[SimplCase]{Simplification of `case' expression}
import TysPrim ( voidTy )
import Util ( Eager, runEager, appEager,
isIn, isSingleton, zipEqual, panic, assertPanic )
+import Outputable
\end{code}
Float let out of case.
info_from_this_case rhs_c
= simplBinder env binder `thenSmpl` \ (env1, binder') ->
let
- env2 = extendEnvGivenUnfolding env1 binder' occ_info info_from_this_case
+ env2 = extendEnvGivenNewRhs env1 scrut_var (Var binder')
-- Add form details for the default binder
- scrut_info = lookupUnfolding env scrut_var
- env3 = extendEnvGivenUnfolding env2 binder' occ_info scrut_info
- new_env = extendEnvGivenNewRhs env3 scrut_var (Var binder')
+ scrut_unf = lookupUnfolding env scrut_var
+ new_env = extendEnvGivenUnfolding env2 binder' noBinderInfo scrut_unf
+ -- Use noBinderInfo rather than occ_info because we've
+ -- added more occurrences by binding the scrut_var to it
in
rhs_c new_env rhs `thenSmpl` \ rhs' ->
returnSmpl (BindDefault binder' rhs')
-> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler
-> SmplM OutExpr
-completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
+completeAlgCaseWithKnownCon env con con_args a@(AlgAlts alts deflt) rhs_c
= ASSERT(isDataCon con)
search_alts alts
where
= -- No matching alternative
case deflt of
NoDefault -> -- Blargh!
- panic "completeAlgCaseWithKnownCon: No matching alternative and no default"
+ pprPanic "completeAlgCaseWithKnownCon: No matching alternative and no default"
+ (ppr con <+> ppr con_args $$ ppr a)
BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case
-- let-bind the binder to the constructor