From b16992d66aa5f610de586eb8a720214b8065bd65 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 17 Oct 2005 11:10:36 +0000
Subject: [PATCH] [project @ 2005-10-17 11:10:36 by simonpj] Small simplifier
 bug in case optimisation 
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

The simplifier eliminates redundant case branches, and panics if there
are no case alternatives.  But due to a slightly delayed instantiation
of a type constructor variable 'p' by a type constructor 'P', it turned
out that an inner case had no alternatives at all, becuase an outer case
had not pruned a branch as quickly as it should have.

This commit fixes both problems:

a) SimplUtils.mkCase1 now returns a call to 'error' (instead of panicing)
   when it gets an empty list of alternatives.   Somewhat analogous to
   the inaccessible GADT case in Simplify.simplifyAlt

b) In SimplUtils.prepareDefault, use the up-to-date scrutinee, rather than
   the less up-to-date case_bndr, to get the case type constructor.  That
   leads to slightly earlier pruning of inaccessible branches.

Fixes a bug reported by Ian Lynagh.

Test is simplCore/should_compile/simpl013
---
 ghc/compiler/simplCore/SimplUtils.lhs |   28 ++++++++++++++++++----------
 1 file changed, 18 insertions(+), 10 deletions(-)

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 4785039..0d9be52 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -34,8 +34,10 @@ import CoreUtils	( cheapEqExpr, exprType, exprIsTrivial, exprIsCheap,
 			  etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2,
 			  findDefault, exprOkForSpeculation, exprIsHNF
 			)
+import Literal		( mkStringLit )
 import CoreUnfold	( smallEnoughToInline )
-import Id		( idType, isDataConWorkId, idOccInfo, isDictId, idArity,
+import MkId		( eRROR_ID )
+import Id		( idType, isDataConWorkId, idOccInfo, isDictId, 
 			  mkSysLocal, isDeadBinder, idNewDemandInfo, isExportedId,
 			  idUnfolding, idNewStrictness, idInlinePragma,
 			)
@@ -49,7 +51,7 @@ import TyCon		( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
 import DataCon		( dataConRepArity, dataConTyVars, dataConInstArgTys, isVanillaDataCon )
 import Var		( tyVarKind, mkTyVar )
 import VarSet
-import BasicTypes	( TopLevelFlag(..), isTopLevel, isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
+import BasicTypes	( TopLevelFlag(..), isNotTopLevel, OccInfo(..), isLoopBreaker, isOneOcc,
 			  Activation, isAlwaysActive, isActive )
 import Util		( lengthExceeds )
 import Outputable
@@ -1116,7 +1118,7 @@ of the inner case y, which give us nowhere to go!
 
 \begin{code}
 prepareAlts :: OutExpr 		-- Scrutinee
-	    -> InId		-- Case binder
+	    -> InId		-- Case binder (passed only to use in statistics)
 	    -> [InAlt]		-- Increasing order
 	    -> SimplM ([InAlt], 	-- Better alternatives, still incresaing order
 			[AltCon])	-- These cases are handled
@@ -1142,14 +1144,17 @@ prepareAlts scrut case_bndr alts
 	-- Filter out the default, if it can't happen,
 	-- or replace it with "proper" alternative if there
 	-- is only one constructor left
-    prepareDefault case_bndr handled_cons maybe_deflt	`thenSmpl` \ deflt_alt ->
+    prepareDefault scrut case_bndr handled_cons maybe_deflt	`thenSmpl` \ deflt_alt ->
 
     returnSmpl (mergeAlts better_alts deflt_alt, handled_cons)
 	-- We need the mergeAlts in case the new default_alt 
 	-- has turned into a constructor alternative.
 
-prepareDefault case_bndr handled_cons (Just rhs)
-  | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
+prepareDefault scrut case_bndr handled_cons (Just rhs)
+  | Just (tycon, inst_tys) <- splitTyConApp_maybe (exprType scrut),
+	-- Use exprType scrut here, rather than idType case_bndr, because
+	-- case_bndr is an InId, so exprType scrut may have more information
+	-- Test simpl013 is an example
     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 }
@@ -1182,7 +1187,7 @@ prepareDefault case_bndr handled_cons (Just rhs)
   | otherwise
   = returnSmpl [(DEFAULT, [], rhs)]
 
-prepareDefault case_bndr handled_cons Nothing
+prepareDefault scrut case_bndr handled_cons Nothing
   = returnSmpl []
 
 mk_args missing_con inst_tys
@@ -1488,11 +1493,14 @@ I don't really know how to improve this situation.
 --	0. Check for empty alternatives
 --------------------------------------------------
 
-#ifdef DEBUG
+-- This isn't strictly an error.  It's possible that the simplifer might "see"
+-- that an inner case has no accessible alternatives before it "sees" that the
+-- entire branch of an outer case is inaccessible.  So we simply
+-- put an error case here insteadd
 mkCase1 scrut case_bndr ty []
   = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $
-    returnSmpl scrut
-#endif
+    return (mkApps (Var eRROR_ID)
+		   [Type ty, Lit (mkStringLit "Impossible alternative")])
 
 --------------------------------------------------
 --	1. Eliminate the case altogether if poss
-- 
1.7.10.4