[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
 %
 %
 % (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,
 
 \begin{code}
 module CgCase (        cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre,

-               splitAlgTyConAppThroughNewTypes ) where
+               splitTyConAppThroughNewTypes ) where

 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

@@ -61,7 +61,7 @@ import PrimRep                ( getPrimRepSize, retPrimRepSize, PrimRep(..)
 import TyCon           ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
                          isNewTyCon, isAlgTyCon,
                          tyConDataCons, tyConFamilySize )
 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 )
                          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}
 
     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
 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}
 
   = 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.
 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 =
 \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
        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 ",
                case (tyConFamilySize tc) of
                        0 -> pprTrace "Warning" (hcat [
                                text "constructors for ",

@@ -1017,14 +1023,15 @@ getScrutineeTyCon ty =
                                ]) Nothing
                        _ -> Just tc
 
                                ]) 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}
 \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
 %
 %
 % (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,
 import CgBindery       ( getArgAmodes, CgIdInfo, nukeDeadBindings )
 import CgCase          ( cgCase, saveVolatileVarsAndRegs, 
                          restoreCurrentCostCentre,

-                         splitAlgTyConAppThroughNewTypes )
+                         splitTyConAppThroughNewTypes )

 import CgClosure       ( cgRhsClosure, cgStdRhsClosure )
 import CgCon           ( buildDynCon, cgReturnDataCon )
 import CgLetNoEscape   ( cgLetNoEscapeClosure )
 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
 \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
 
                          Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
                          Just pr -> pr