From 354ce4040a514f3016323f2e330c7eac527ce3b2 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 28 Jun 1999 16:29:49 +0000
Subject: [PATCH] [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
---
ghc/compiler/codeGen/CgCase.lhs | 6 ++---
ghc/compiler/codeGen/CgExpr.lhs | 6 ++---
ghc/compiler/stgSyn/CoreToStg.lhs | 22 ++++++++--------
ghc/compiler/types/Type.lhs | 42 ++++++++++++++-----------------
4 files changed, 36 insertions(+), 40 deletions(-)
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index c4afa179a9cf..f6771a63200d 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.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 e12979d9c2f6..e76289892aa0 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.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 1a319759265b..cf9623f2f6cf 100644
--- 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 0a1887be1626..a7b6572e4d1d 100644
--- 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
--
GitLab