[project @ 1999-06-28 16:29:45 by simonpj]

* Add Type.repType

* Re-express splitRepTyConApp_maybe using repType

* Use the new repType in Core2Stg

	The bug was that we ended up with a binding like
		let x = /\a -> 3# +# y
		in ...
	and this should turn into an STG case, but the big lambda
	fooled the core-to-STG pass

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index c4afa17..f6771a6 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.33 1999/06/24 13:04:16 simonmar Exp $
+% $Id: CgCase.lhs,v 1.34 1999/06/28 16:29:45 simonpj Exp $
 %
 %********************************************************
 %*                                                     *
@@ -62,7 +62,7 @@ import TyCon          ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
                          isNewTyCon, isAlgTyCon, isFunTyCon, isPrimTyCon,
                          tyConDataCons, tyConFamilySize )
 import Type            ( Type, typePrimRep, splitAlgTyConApp, 
-                         splitTyConApp_maybe, splitRepTyConApp_maybe )
+                         splitTyConApp_maybe, repType )
 import Unique           ( Unique, Uniquable(..), mkBuiltinUnique )
 import Maybes          ( maybeToBool )
 import Util
@@ -981,7 +981,7 @@ possibleHeapCheck NoGC      _ _ tags lbl code
 \begin{code}
 getScrutineeTyCon :: Type -> Maybe TyCon
 getScrutineeTyCon ty =
-   case splitRepTyConApp_maybe ty of
+   case splitTyConApp_maybe (repType ty) of
        Nothing -> Nothing
        Just (tc,_) -> 
                if isFunTyCon tc  then Nothing else     -- not interested in funs

diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index e12979d..e762898 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.28 1999/06/24 13:04:18 simonmar Exp $
+% $Id: CgExpr.lhs,v 1.29 1999/06/28 16:29:45 simonpj Exp $
 %
 %********************************************************
 %*                                                     *
@@ -48,7 +48,7 @@ import PrimOp         ( primOpOutOfLine,
 import PrimRep         ( getPrimRepSize, PrimRep(..), isFollowableRep )
 import TyCon           ( maybeTyConSingleCon,
                          isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type            ( Type, typePrimRep, splitTyConApp_maybe, splitRepTyConApp_maybe )
+import Type            ( Type, typePrimRep, splitTyConApp_maybe, repType )
 import Maybes          ( assocMaybe, maybeToBool )
 import Unique          ( mkBuiltinUnique )
 import BasicTypes      ( TopLevelFlag(..), RecFlag(..) )
@@ -462,7 +462,7 @@ primRetUnboxedTuple op args res_ty
       allocate some temporaries for the return values.
     -}
     let
-      (tc,ty_args)      = case splitRepTyConApp_maybe res_ty of
+      (tc,ty_args)      = case splitTyConApp_maybe (repType res_ty) of
                            Nothing -> pprPanic "primRetUnboxedTuple" (ppr res_ty)
                            Just pr -> pr
       prim_reps          = map typePrimRep ty_args

diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index 1a31975..cf9623f 100644 (file)
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -34,7 +34,7 @@ import Const          ( Con(..), Literal(..), isLitLitLit, conStrictness, isWHNFC
 import VarEnv
 import PrimOp          ( PrimOp(..), primOpUsg, primOpSig )
 import Type            ( isUnLiftedType, isUnboxedTupleType, Type, splitFunTy_maybe,
-                          UsageAnn(..), tyUsg, applyTy, mkUsgTy )
+                          UsageAnn(..), tyUsg, applyTy, mkUsgTy, repType )
 import TysPrim         ( intPrimTy )
 import UniqSupply      -- all of it, really
 import Util            ( lengthExceeds )
@@ -813,10 +813,10 @@ mkStgBind (NonRecF bndr rhs dem floats) body
 
 mk_stg_let bndr rhs dem floats body
 #endif
-  | isUnLiftedType bndr_ty                     -- Use a case/PrimAlts
-  = ASSERT( not (isUnboxedTupleType bndr_ty) )
+  | isUnLiftedType bndr_rep_ty                 -- Use a case/PrimAlts
+  = ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
     mkStgBinds floats $
-    mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
+    mkStgCase rhs bndr (StgPrimAlts bndr_rep_ty [] (StgBindDefault body))
 
   | is_whnf
   = if is_strict then
@@ -836,19 +836,19 @@ mk_stg_let bndr rhs dem floats body
   = if is_strict then
        -- Strict let with non-WHNF rhs
        mkStgBinds floats $
-       mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
+       mkStgCase rhs bndr (StgAlgAlts bndr_rep_ty [] (StgBindDefault body))
     else
        -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
        mkStgBinds floats rhs           `thenUs` \ new_rhs ->
        returnUs (StgLet (StgNonRec bndr (exprToRhs dem NotTopLevel new_rhs)) body)
        
   where
-    bndr_ty   = idType bndr
-    is_strict = isStrictDem dem
-    is_whnf   = case rhs of
-                 StgCon _ _ _ -> True
-                 StgLam _ _ _ -> True
-                 other        -> False
+    bndr_rep_ty = repType (idType bndr)
+    is_strict   = isStrictDem dem
+    is_whnf     = case rhs of
+                   StgCon _ _ _ -> True
+                   StgLam _ _ _ -> True
+                   other        -> False
 
 -- Split at the first strict binding
 splitFloats fs@(NonRecF _ _ dem _ : _) 

diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index 0a1887b..a7b6572 100644 (file)
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -29,10 +29,10 @@ module Type (
        zipFunTys,
 
        mkTyConApp, mkTyConTy, splitTyConApp_maybe,
-       splitAlgTyConApp_maybe, splitAlgTyConApp, splitRepTyConApp_maybe,
+       splitAlgTyConApp_maybe, splitAlgTyConApp, 
        mkDictTy, splitDictTy_maybe, isDictTy,
 
-       mkSynTy, isSynTy, deNoteType,
+       mkSynTy, isSynTy, deNoteType, repType,
 
         mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
 
@@ -529,27 +529,6 @@ isDictTy (NoteTy _ ty)     = isDictTy ty
 isDictTy other         = False
 \end{code}
 
-splitRepTyConApp_maybe is like splitTyConApp_maybe except
-that it looks through 
-       (a) for-alls, and
-       (b) newtypes
-in addition to synonyms.  It's useful in the back end where we're not
-interested in newtypes anymore.
-
-\begin{code}
-splitRepTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
-splitRepTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
-splitRepTyConApp_maybe (NoteTy _ ty)     = splitRepTyConApp_maybe ty
-splitRepTyConApp_maybe (ForAllTy _ ty)   = splitRepTyConApp_maybe ty
-splitRepTyConApp_maybe (TyConApp tc tys) 
-       | isNewTyCon tc 
-       = case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
-               Just (rep_ty, _) -> splitRepTyConApp_maybe rep_ty
-       | otherwise
-       = Just (tc,tys)
-splitRepTyConApp_maybe other            = Nothing
-\end{code}
-
 ---------------------------------------------------------------------
                                SynTy
                                ~~~~~
@@ -592,6 +571,23 @@ interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 
 
 
+repType looks through 
+       (a) for-alls, and
+       (b) newtypes
+in addition to synonyms.  It's useful in the back end where we're not
+interested in newtypes anymore.
+
+\begin{code}
+repType :: Type -> Type
+repType (NoteTy _ ty)     = repType ty
+repType (ForAllTy _ ty)   = repType ty
+repType (TyConApp tc tys) | isNewTyCon tc      
+                         = case splitFunTy_maybe (applyTys (dataConType (head (tyConDataCons tc))) tys) of
+                               Just (rep_ty, _) -> repType rep_ty
+repType other_ty         = other_ty
+\end{code}
+
+
 
 ---------------------------------------------------------------------
                                UsgNote