[project @ 1998-09-29 15:50:13 by sof]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplCase.lhs

diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index c7d3313..7e47bd4 100644 (file)
--- 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)
@@ -610,12 +617,13 @@ simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs)
             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')
@@ -684,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
@@ -708,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