X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplCase.lhs;h=7e47bd45422b12bf9623971ac282cc77004eef0f;hb=967cc47f37cb93a5e2b6df7822c9a646f0428247;hp=0e80f1ea1b6a5053fb9bc080dae00aa8e9544581;hpb=23c8ca46f1b871eff2ecd65d71806ec03684ce2e;p=ghc-hetmet.git

diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 0e80f1e..7e47bd4 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -1,4 +1,4 @@
-`%
+%
 % (c) The AQUA Project, Glasgow University, 1994-1996
 %
 \section[SimplCase]{Simplification of `case' expression}
@@ -37,6 +37,7 @@ import TyCon		( isDataTyCon )
 import TysPrim		( voidTy )
 import Util		( Eager, runEager, appEager,
 			  isIn, isSingleton, zipEqual, panic, assertPanic )
+import Outputable
 \end{code}
 
 Float let out of case.
@@ -115,7 +116,13 @@ simplCase env (Case inner_scrut inner_alts) (subst_envs, outer_alts) rhs_c resul
 	   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)
@@ -685,7 +692,7 @@ completeAlgCaseWithKnownCon
 	-> (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
@@ -709,7 +716,8 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
       = 	-- 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