From e55df039ad34fa0fef6c2a746643a43c9b0515cd Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Thu, 11 Oct 2001 14:31:45 +0000
Subject: [PATCH] [project @ 2001-10-11 14:31:45 by sewardj] Correctly handle
 unboxed tuples when converting DEFAULT alts to   unboxed
 tuple constructors in case args.  (I'm sure this could   be
 worded better).  Branch and HEAD have drifted too far apart
   for easy common commit for this, so is committed
 seperately for   ghc-5-02-branch.

---
 ghc/compiler/codeGen/CgCase.lhs       |   27 ++++++++++++++++-----------
 ghc/compiler/simplCore/SimplUtils.lhs |    8 +++++---
 2 files changed, 21 insertions(+), 14 deletions(-)

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 43147e5..379c397 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.53 2001/09/26 15:11:50 simonpj Exp $
+% $Id: CgCase.lhs,v 1.54 2001/10/11 14:31:45 sewardj Exp $
 %
 %********************************************************
 %*							*
@@ -396,17 +396,22 @@ cgEvalAlts cc_slot bndr srt alts
 		Just spec_tycon = maybe_tycon
     	in
 
-    	-- deal with the unboxed tuple case
+    	-- Deal with the unboxed tuple case
     	if is_alg && isUnboxedTupleTyCon spec_tycon then
-	    case alts of 
-         	[alt] -> let lbl = mkReturnInfoLabel uniq in
-			 cgUnboxedTupleAlt uniq cc_slot True alt
-				`thenFC` \ abs_c ->
-		  	 getSRTInfo srt		 `thenFC` \ srt_info -> 
-		  	 absC (CRetDirect uniq abs_c srt_info
-					liveness_mask) `thenC`
-		  	returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
-	 	_ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
+		-- By now, the simplifier should have have turned it
+		-- into 	case e of (# a,b #) -> e
+		-- There shouldn't be a 
+		--		case e of DEFAULT -> e
+	    ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
+		     text "cgEvalAlts: dodgy case of unboxed tuple type" )
+	    let
+		alt = head alts
+         	lbl = mkReturnInfoLabel uniq
+ 	    in
+	    cgUnboxedTupleAlt uniq cc_slot True alt		`thenFC` \ abs_c ->
+	    getSRTInfo srt				 	`thenFC` \ srt_info -> 
+	    absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC`
+	    returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
 
     	-- normal algebraic (or polymorphic) case alternatives
     	else let
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index fb70278..e53bc04 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -41,7 +41,7 @@ import Type		( Type, seqType,
 			  splitRepFunTys, isStrictType
 			)
 import OccName		( UserFS )
-import TyCon		( tyConDataConsIfAvailable, isDataTyCon )
+import TyCon		( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
 import DataCon		( dataConRepArity, dataConSig, dataConArgTys )
 import Var		( mkSysTyVar, tyVarKind )
 import Util		( lengthExceeds, mapAccumL )
@@ -886,12 +886,14 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 
 mkAlts scrut case_bndr alts
   | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
-    isDataTyCon tycon,			-- It's a data type
+    isAlgTyCon tycon,	-- It's a data type, tuple, or unboxed tuples.  
+			-- We aren't expecting any newtypes at this point.
     (alts_no_deflt, Just rhs) <- findDefault alts,
 		-- There is a DEFAULT case
     [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
 		-- There is just one missing constructor!
-  = tick (FillInCaseDefault case_bndr)	`thenSmpl_`
+  = ASSERT( not (isNewTyCon tycon) )
+    tick (FillInCaseDefault case_bndr)	`thenSmpl_`
     getUniquesSmpl 			`thenSmpl` \ tv_uniqs ->
     getUniquesSmpl 			`thenSmpl` \ id_uniqs ->
     let
-- 
1.7.10.4