[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.

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 474059d..4f54e34 100644 (file)
--- 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 01a7003..3cc58a6 100644 (file)
--- 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