From cf8adb9e5e64e2bbe24e50e3c57b0cfe39ec41e5 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 17 Oct 2001 16:08:35 +0000
Subject: [PATCH] [project @ 2001-10-17 16:08:35 by simonpj] Tidy up
 case-simplification a little bit

---
 ghc/compiler/simplCore/SimplUtils.lhs |   24 ++++++++++--------------
 ghc/compiler/simplCore/Simplify.lhs   |   16 ++++++++--------
 2 files changed, 18 insertions(+), 22 deletions(-)

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 906568b..4d68228 100644
--- 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
--- 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
-- 
1.7.10.4