[project @ 2001-10-17 16:08:35 by simonpj]

Tidy up case-simplification a little bit

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 906568b..4d68228 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -791,10 +791,10 @@ tryRhsTyLam env tyvars body               -- Only does something if there's a let
 mkCase puts a case expression back together, trying various transformations first.
 
 \begin{code}
-mkCase :: OutExpr -> OutId -> [OutAlt] -> SimplM OutExpr
+mkCase :: OutExpr -> [AltCon] -> OutId -> [OutAlt] -> SimplM OutExpr
 
-mkCase scrut case_bndr alts
-  = mkAlts scrut case_bndr alts        `thenSmpl` \ better_alts ->
+mkCase scrut handled_cons case_bndr alts
+  = mkAlts scrut handled_cons case_bndr alts   `thenSmpl` \ better_alts ->
     mkCase1 scrut case_bndr better_alts
 \end{code}
 
@@ -869,7 +869,7 @@ and similarly in cascade for all the join points!
 --------------------------------------------------
 --     1. Merge identical branches
 --------------------------------------------------
-mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
+mkAlts scrut handled_cons case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
   | all isDeadBinder bndrs1,                   -- Remember the default 
     length filtered_alts < length con_alts     -- alternative comes first
   = tick (AltMerge case_bndr)                  `thenSmpl_`
@@ -884,7 +884,7 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 --     2. Fill in missing constructor
 --------------------------------------------------
 
-mkAlts scrut case_bndr alts
+mkAlts scrut handled_cons case_bndr alts
   | (alts_no_deflt, Just rhs) <- findDefault alts,
                        -- There is a DEFAULT case
 
@@ -894,7 +894,8 @@ mkAlts scrut case_bndr alts
                                --      case x of { DEFAULT -> e }
                                -- and we don't want to fill in a default for them!
 
-    [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
+    [missing_con] <- [con | con <- tyConDataConsIfAvailable tycon,
+                           not (con `elem` handled_data_cons)]
                        -- There is just one missing constructor!
 
   = tick (FillInCaseDefault case_bndr) `thenSmpl_`
@@ -910,18 +911,13 @@ mkAlts scrut case_bndr alts
     in
     returnSmpl better_alts
   where
-    impossible_cons   = case scrut of
-                           Var v -> otherCons (idUnfolding v)
-                           other -> []
-    handled_data_cons = [data_con | DataAlt data_con         <- impossible_cons] ++
-                       [data_con | (DataAlt data_con, _, _) <- alts]
-    is_missing con    = not (con `elem` handled_data_cons)
+    handled_data_cons = [data_con | DataAlt data_con <- handled_cons]
 
 --------------------------------------------------
 --     3.  Merge nested cases
 --------------------------------------------------
 
-mkAlts scrut outer_bndr outer_alts
+mkAlts scrut handled_cons outer_bndr outer_alts
   | opt_SimplCaseMerge,
     (outer_alts_without_deflt, maybe_outer_deflt)   <- findDefault outer_alts,
     Just (Case (Var scrut_var) inner_bndr inner_alts) <- maybe_outer_deflt,
@@ -965,7 +961,7 @@ mkAlts scrut outer_bndr outer_alts
 --     Catch-all
 --------------------------------------------------
 
-mkAlts scrut case_bndr other_alts = returnSmpl other_alts
+mkAlts scrut handled_cons case_bndr other_alts = returnSmpl other_alts
 \end{code}
 
 

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 13918ad..ee35251 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -1238,6 +1238,10 @@ rebuildCase env scrut case_bndr alts cont
                        []    -> alts
                        other -> [alt | alt@(con,_,_) <- alts, 
                                        not (con `elem` impossible_cons)]
+
+       -- handled_cons are handled either by the context, 
+       -- or by an alternative in this case
+       handled_cons = impossible_cons ++ [con | (con,_,_) <- better_alts]
     in
 
        -- Deal with the case binder, and prepare the continuation;
@@ -1249,11 +1253,11 @@ rebuildCase env scrut case_bndr alts cont
     simplCaseBinder env scrut case_bndr                `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) ->
 
        -- Deal with the case alternatives
-    simplAlts alt_env zap_occ_info impossible_cons
+    simplAlts alt_env zap_occ_info handled_cons
              case_bndr' better_alts cont'              `thenSmpl` \ alts' ->
 
        -- Put the case back together
-    mkCase scrut case_bndr' alts'                      `thenSmpl` \ case_expr ->
+    mkCase scrut handled_cons case_bndr' alts'         `thenSmpl` \ case_expr ->
 
        -- Notice that rebuildDone returns the in-scope set from env, not alt_env
        -- The case binder *not* scope over the whole returned case-expression
@@ -1358,20 +1362,16 @@ simplCaseBinder env other_scrut case_bndr
 simplAlts :: SimplEnv 
          -> (InId -> InId)             -- Occ-info zapper
          -> [AltCon]                   -- Alternatives the scrutinee can't be
+                                       -- in the default case
          -> OutId                      -- Case binder
          -> [InAlt] -> SimplCont
          -> SimplM [OutAlt]            -- Includes the continuation
 
-simplAlts env zap_occ_info impossible_cons case_bndr' alts cont'
+simplAlts env zap_occ_info handled_cons case_bndr' alts cont'
   = mapSmpl simpl_alt alts
   where
     inst_tys' = tyConAppArgs (idType case_bndr')
 
-       -- handled_cons is all the constructors that are dealt
-       -- with, either by being impossible, or by there being an alternative
-    (con_alts,_) = findDefault alts
-    handled_cons = impossible_cons ++ [con | (con,_,_) <- con_alts]
-
     simpl_alt (DEFAULT, _, rhs)
        = let
                -- In the default case we record the constructors that the