-`%
+%
% (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.
rhs_c' = \env rhs -> simplExpr env rhs [] result_ty
in
simplCase env inner_scrut (getSubstEnvs env, inner_alts)
- (\env rhs -> simplCase env rhs (emptySubstEnvs, outer_alts') rhs_c' result_ty)
+ (\env rhs -> simplCase env rhs (subst_envs, outer_alts') rhs_c' result_ty)
+ -- We used to have "emptySubstEnvs" instead of subst_envs here,
+ -- but that is *wrong*. The outer_alts' still have the old
+ -- binders from outer_alts, with un-substituted types,
+ -- so we must keep their subst_envs with them. It does
+ -- no harm to the freshly-manufactured part of outer_alts',
+ -- because it'll have nothing in the domain of subst_envs anyway
result_ty
`thenSmpl` \ case_expr ->
returnSmpl (mkCoLetsNoUnboxed extra_bindings case_expr)
-> (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