[project @ 1998-12-22 12:55:54 by simonm]

splitAlgTyConAppThroughNewTypes becomes splitTyConAppThroughNewTypes
(i.e. it handles primitive types in addition to other TyCons).  This
enables case-of-case-of-primop to compile correctly.

2 files changed, 24 insertions, 17 deletions

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 474059d93b..4f54e34790 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.19 1998/12/18 17:40:48 simonpj Exp $
+% $Id: CgCase.lhs,v 1.20 1998/12/22 12:55:54 simonm Exp $
 %
 %********************************************************
 %*							*
@@ -11,7 +11,7 @@
 
 \begin{code}
 module CgCase (	cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre,
-		splitAlgTyConAppThroughNewTypes ) where
+		splitTyConAppThroughNewTypes ) where
 
 #include "HsVersions.h"
 
@@ -61,7 +61,7 @@ import PrimRep		( getPrimRepSize, retPrimRepSize, PrimRep(..)
 import TyCon		( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
 			  isNewTyCon, isAlgTyCon,
 			  tyConDataCons, tyConFamilySize )
-import Type		( Type, typePrimRep, splitAlgTyConApp, splitAlgTyConApp_maybe,
+import Type		( Type, typePrimRep, splitAlgTyConApp, splitTyConApp_maybe,
 			  splitFunTys, applyTys )
 import Unique           ( Unique, Uniquable(..) )
 import Maybes		( maybeToBool )
@@ -155,6 +155,11 @@ cgCase (StgCon (PrimOp op) args res_ty) live_in_whole_case live_in_alts bndr srt
     cgInlineAlts bndr alts
 \end{code}
 
+TODO: Case-of-case of primop can probably be done inline too (but
+maybe better to translate it out beforehand).  See
+ghc/lib/misc/PackedString.lhs for examples where this crops up (with
+4.02).
+
 Another special case: scrutinising a primitive-typed variable.	No
 evaluation required.  We don't save volatile variables, nor do we do a
 heap-check in the alternatives.	 Instead, the heap usage of the
@@ -993,7 +998,7 @@ possibleHeapCheck NoGC	_ _ tags lbl code
   = code
 \end{code}
 
-splitTyConAppThroughNewTypes is like splitAlgTyConApp_maybe except
+splitTyConAppThroughNewTypes is like splitTyConApp_maybe except
 that it looks through newtypes in addition to synonyms.  It's
 useful in the back end where we're not interested in newtypes
 anymore.
@@ -1005,10 +1010,11 @@ SEQ_FRAME to evaluate the case scrutinee.
 \begin{code}
 getScrutineeTyCon :: Type -> Maybe TyCon
 getScrutineeTyCon ty =
-   case (splitAlgTyConAppThroughNewTypes ty) of
+   case (splitTyConAppThroughNewTypes ty) of
 	Nothing -> Nothing
 	Just (tc,_) -> 
 		if not (isAlgTyCon tc) then Just tc else
+			-- works for primitive TyCons too
 		case (tyConFamilySize tc) of
 			0 -> pprTrace "Warning" (hcat [
 				text "constructors for ",
@@ -1017,14 +1023,15 @@ getScrutineeTyCon ty =
 				]) Nothing
 			_ -> Just tc
 
-splitAlgTyConAppThroughNewTypes  :: Type -> Maybe (TyCon, [Type])
-splitAlgTyConAppThroughNewTypes ty
-  = case splitAlgTyConApp_maybe ty of
-	Just (tc, tys, cons)
-	  | isNewTyCon tc ->  splitAlgTyConAppThroughNewTypes ty
-	  | otherwise     ->  Just (tc, tys)
-	  where
-	    ([ty], _) = splitFunTys (applyTys (dataConType (head cons)) tys)
+splitTyConAppThroughNewTypes  :: Type -> Maybe (TyCon, [Type])
+splitTyConAppThroughNewTypes ty
+  = case splitTyConApp_maybe ty of
+      Just (tc, tys)
+	| isNewTyCon tc ->  splitTyConAppThroughNewTypes ty
+	| otherwise     ->  Just (tc, tys)
+	where
+	  ([ty], _) = splitFunTys (applyTys (dataConType (head (tyConDataCons tc))) tys)
+
+      other  -> Nothing
 
-	other  -> Nothing
 \end{code}
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 01a7003173..3cc58a675d 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgExpr.lhs,v 1.17 1998/12/18 17:40:50 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.18 1998/12/22 12:55:55 simonm Exp $
 %
 %********************************************************
 %*							*
@@ -24,7 +24,7 @@ import SMRep		( fixedHdrSize )
 import CgBindery	( getArgAmodes, CgIdInfo, nukeDeadBindings )
 import CgCase		( cgCase, saveVolatileVarsAndRegs, 
 			  restoreCurrentCostCentre,
-			  splitAlgTyConAppThroughNewTypes )
+			  splitTyConAppThroughNewTypes )
 import CgClosure	( cgRhsClosure, cgStdRhsClosure )
 import CgCon		( buildDynCon, cgReturnDataCon )
 import CgLetNoEscape	( cgLetNoEscapeClosure )
@@ -423,7 +423,7 @@ Little helper for primitives that return unboxed tuples.
 \begin{code}
 primRetUnboxedTuple :: PrimOp -> [StgArg] -> Type -> Code
 primRetUnboxedTuple op args res_ty
-  = let (tc,ty_args) = case splitAlgTyConAppThroughNewTypes res_ty of
+  = let (tc,ty_args) = case splitTyConAppThroughNewTypes res_ty of
 			  Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
 			  Just pr -> pr