Make impossible-alternative-finding code more reusable

Makes the following changes:
 1. Generalises the type signatures of some functions relating to alternatives
    so that the type of "variables" and "expression" is not specified
 2. Puts the bulk of the alternative-filtering code into a new function filterAlts
    (in CoreUtils) that can be used outside of the SimplM monad
 3. Allows prepareAlts to return a null alternatives list if none are applicable -
    it turns out that this case was already handled by the caller (in the simplifier).
    This should result in a modest optimisation improvement in some cases.

Conflicts:

	compiler/coreSyn/CoreUtils.lhs
	compiler/simplCore/SimplUtils.lhs

4 files changed, 98 insertions, 98 deletions

diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index d7296e3e25..4faad7fc25 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -917,10 +917,10 @@ instance Outputable AltCon where
 instance Show AltCon where
   showsPrec p con = showsPrecSDoc p (ppr con)
 
-cmpAlt :: Alt b -> Alt b -> Ordering
+cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering
 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 
-ltAlt :: Alt b -> Alt b -> Bool
+ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool
 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 
 cmpAltCon :: AltCon -> AltCon -> Ordering
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 198ac7e610..44aebb8169 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -15,7 +15,8 @@ module CoreUtils (
         mkAltExpr,
 
         -- * Taking expressions apart
-        findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
+        findDefault, findAlt, isDefaultAlt,
+        mergeAlts, trimConArgs, filterAlts,
 
         -- * Properties of expressions
         exprType, coreAltType, coreAltsType,
@@ -69,7 +70,7 @@ import Util
 import Pair
 import Data.Word
 import Data.Bits
-import Data.List ( mapAccumL )
+import Data.List
 \end{code}
 
 
@@ -342,18 +343,18 @@ This makes it easy to find, though it makes matching marginally harder.
 
 \begin{code}
 -- | Extract the default case alternative
-findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
+findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 findDefault alts                        =                     (alts, Nothing)
 
-isDefaultAlt :: CoreAlt -> Bool
+isDefaultAlt :: (AltCon, a, b) -> Bool
 isDefaultAlt (DEFAULT, _, _) = True
 isDefaultAlt _               = False
 
 
 -- | Find the case alternative corresponding to a particular
 -- constructor: panics if no such constructor exists
-findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
+findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
     -- A "Nothing" result *is* legitmiate
     -- See Note [Unreachable code]
 findAlt con alts
@@ -369,7 +370,7 @@ findAlt con alts
           GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
 
 ---------------------------------
-mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
+mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
 -- ^ Merge alternatives preserving order; alternatives in
 -- the first argument shadow ones in the second
 mergeAlts [] as2 = as2
@@ -396,6 +397,83 @@ trimConArgs (LitAlt _)   args = ASSERT( null args ) []
 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 \end{code}
 
+\begin{code}
+filterAlts :: [Unique]             -- ^ Supply of uniques used in case we have to manufacture a new AltCon
+           -> Type                 -- ^ Type of scrutinee (used to prune possibilities)
+           -> [AltCon]             -- ^ Constructors known to be impossible due to the form of the scrutinee
+           -> [(AltCon, [Var], a)] -- ^ Alternatives
+           -> ([AltCon], Bool, [(AltCon, [Var], a)])
+             -- Returns:
+             --  1. Constructors that will never be encountered by the *default* case (if any)
+             --  2. Whether we managed to refine the default alternative into a specific constructor (for statistcs only)
+             --  3. The new alternatives
+             --
+             -- NB: the final list of alternatives may be empty:
+             -- This is a tricky corner case.  If the data type has no constructors,
+             -- which GHC allows, then the case expression will have at most a default
+             -- alternative.
+             --
+             -- If callers need to preserve the invariant that there is always at least one branch
+             -- in a "case" statement then they will need to manually add a dummy case branch that just
+             -- calls "error" or similar.
+filterAlts us ty imposs_cons alts = (imposs_deflt_cons, refined_deflt, merged_alts)
+  where
+    (alts_wo_default, maybe_deflt) = findDefault alts
+    alt_cons = [con | (con,_,_) <- alts_wo_default]
+    imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
+      -- "imposs_deflt_cons" are handled 
+      --   EITHER by the context, 
+      --   OR by a non-DEFAULT branch in this case expression.
+
+    trimmed_alts = filterOut impossible_alt alts_wo_default
+    merged_alts  = mergeAlts trimmed_alts (maybeToList maybe_deflt')
+      -- We need the mergeAlts in case the new default_alt 
+      -- has turned into a constructor alternative.
+      -- The merge keeps the inner DEFAULT at the front, if there is one
+      -- and interleaves the alternatives in the right order
+
+    (refined_deflt, maybe_deflt') = case maybe_deflt of
+      Just deflt_rhs -> case mb_tc_app of
+        Just (tycon, inst_tys)
+          |     -- This branch handles the case where we are 
+                -- scrutinisng an algebraic data type
+            isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.  
+          , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:
+                                        --      case x of { DEFAULT -> e }
+                                        -- and we don't want to fill in a default for them!
+          , Just all_cons <- tyConDataCons_maybe tycon
+          , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type 
+                impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
+          -> case filterOut impossible all_cons of
+               -- Eliminate the default alternative
+               -- altogether if it can't match:
+               []    -> (False, Nothing)
+               -- It matches exactly one constructor, so fill it in:
+               [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs))
+                 where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
+               _     -> (False, Just (DEFAULT, [], deflt_rhs))
+
+          | debugIsOn, isAlgTyCon tycon
+          , null (tyConDataCons tycon)
+          , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
+                -- Check for no data constructors
+                -- This can legitimately happen for abstract types and type families,
+                -- so don't report that
+          -> pprTrace "prepareDefault" (ppr tycon)
+             (False, Just (DEFAULT, [], deflt_rhs))
+
+        _ -> (False, Just (DEFAULT, [], deflt_rhs))
+      Nothing -> (False, Nothing)
+  
+    mb_tc_app = splitTyConApp_maybe ty
+    Just (_, inst_tys) = mb_tc_app
+
+    impossible_alt :: (AltCon, a, b) -> Bool
+    impossible_alt (con, _, _) | con `elem` imposs_cons = True
+    impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
+    impossible_alt _                   = False
+\end{code}
+
 Note [Unreachable code]
 ~~~~~~~~~~~~~~~~~~~~~~~
 It is possible (although unusual) for GHC to find a case expression
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7da185a1ae..59ebeea1bc 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -44,7 +44,6 @@ import StaticFlags
 import CoreSyn
 import qualified CoreSubst
 import PprCore
-import DataCon	( dataConCannotMatch, dataConWorkId )
 import CoreFVs
 import CoreUtils
 import CoreArity
@@ -56,7 +55,7 @@ import Demand
 import SimplMonad
 import Type	hiding( substTy )
 import Coercion hiding( substCo )
-import TyCon
+import DataCon          ( dataConWorkId )
 import VarSet
 import BasicTypes
 import Util
@@ -65,7 +64,7 @@ import Outputable
 import FastString
 import Pair
 
-import Data.List
+import Control.Monad    ( when )
 \end{code}
 
 
@@ -1495,97 +1494,18 @@ of the inner case y, which give us nowhere to go!
 
 \begin{code}
 prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])
-prepareAlts scrut case_bndr' alts
-  = do	{ let (alts_wo_default, maybe_deflt) = findDefault alts
-	      alt_cons = [con | (con,_,_) <- alts_wo_default]
-	      imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
-		-- "imposs_deflt_cons" are handled 
-		--   EITHER by the context, 
-		--   OR by a non-DEFAULT branch in this case expression.
-
-	; default_alts <- prepareDefault case_bndr' mb_tc_app 
-					 imposs_deflt_cons maybe_deflt
-
-	; let trimmed_alts = filterOut impossible_alt alts_wo_default
-	      merged_alts  = mergeAlts trimmed_alts default_alts
-		-- We need the mergeAlts in case the new default_alt 
-		-- has turned into a constructor alternative.
-		-- The merge keeps the inner DEFAULT at the front, if there is one
-		-- and interleaves the alternatives in the right order
-
-	; return (imposs_deflt_cons, merged_alts) }
+prepareAlts scrut case_bndr' alts = do
+    us <- getUniquesM
+    -- Case binder is needed just for its type. Note that as an
+    --   OutId, it has maximum information; this is important.
+    --   Test simpl013 is an example
+    let (imposs_deflt_cons, refined_deflt, alts') = filterAlts us (varType case_bndr') imposs_cons alts
+    when refined_deflt $ tick (FillInCaseDefault case_bndr')
+    return (imposs_deflt_cons, alts')
   where
-    mb_tc_app = splitTyConApp_maybe (idType case_bndr')
-    Just (_, inst_tys) = mb_tc_app 
-
     imposs_cons = case scrut of
 		    Var v -> otherCons (idUnfolding v)
 		    _     -> []
-
-    impossible_alt :: CoreAlt -> Bool
-    impossible_alt (con, _, _) | con `elem` imposs_cons = True
-    impossible_alt (DataAlt con, _, _) = dataConCannotMatch inst_tys con
-    impossible_alt _                   = False
-
-
-prepareDefault :: OutId		-- Case binder; need just for its type. Note that as an
-				--   OutId, it has maximum information; this is important.
-				--   Test simpl013 is an example
-	       -> Maybe (TyCon, [Type])	-- Type of scrutinee, decomposed
-	       -> [AltCon]	-- These cons can't happen when matching the default
-	       -> Maybe InExpr	-- Rhs
-	       -> SimplM [InAlt]	-- Still unsimplified
-					-- We use a list because it's what mergeAlts expects,
-
---------- Fill in known constructor -----------
-prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
-  | 	-- This branch handles the case where we are 
-	-- scrutinisng an algebraic data type
-    isAlgTyCon tycon		-- It's a data type, tuple, or unboxed tuples.  
-  , not (isNewTyCon tycon)	-- We can have a newtype, if we are just doing an eval:
-				-- 	case x of { DEFAULT -> e }
-				-- and we don't want to fill in a default for them!
-  , Just all_cons <- tyConDataCons_maybe tycon
-  , not (null all_cons)	
-	-- This is a tricky corner case.  If the data type has no constructors,
-	-- which GHC allows, then the case expression will have at most a default
-	-- alternative.  We don't want to eliminate that alternative, because the
-	-- invariant is that there's always one alternative.  It's more convenient
-	-- to leave	
-	--	case x of { DEFAULT -> e }     
-	-- as it is, rather than transform it to
-	--	error "case cant match"
-	-- which would be quite legitmate.  But it's a really obscure corner, and
-	-- not worth wasting code on.
-  , let imposs_data_cons = [con | DataAlt con <- imposs_cons]	-- We now know it's a data type 
-	impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
-  = case filterOut impossible all_cons of
-	[]    -> return []	-- Eliminate the default alternative
-				-- altogether if it can't match
-
-	[con] -> 	-- It matches exactly one constructor, so fill it in
-		 do { tick (FillInCaseDefault case_bndr)
-                    ; us <- getUniquesM
-                    ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
-                    ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] }
-
-	_ -> return [(DEFAULT, [], deflt_rhs)]
-
-  | debugIsOn, isAlgTyCon tycon
-  , null (tyConDataCons tycon)
-  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
-	-- Check for no data constructors
-        -- This can legitimately happen for abstract types and type families,
-        -- so don't report that
-  = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
-        $ return [(DEFAULT, [], deflt_rhs)]
-
---------- Catch-all cases -----------
-prepareDefault _case_bndr _bndr_ty _imposs_cons (Just deflt_rhs)
-  = return [(DEFAULT, [], deflt_rhs)]
-
-prepareDefault _case_bndr _bndr_ty _imposs_cons Nothing
-  = return []	-- No default branch
 \end{code}
 
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index b8c8160972..ab195e87b1 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1958,6 +1958,8 @@ simplAlts env scrut case_bndr alts cont'
 						       case_bndr case_bndr1 alts
 
         ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts
+          -- NB: it's possible that the returned in_alts is empty: this is handled
+          -- by the caller (rebuildCase) in the missingAlt function
 
 	; let mb_var_scrut = case scrut' of { Var v -> Just v; _ -> Nothing }
         ; alts' <- mapM (simplAlt alt_env' mb_var_scrut