From 354ce4040a514f3016323f2e330c7eac527ce3b2 Mon Sep 17 00:00:00 2001 From: simonpj 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 c4afa17..f6771a6 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 e12979d..e762898 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 1a31975..cf9623f 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 0a1887b..a7b6572 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 -- 1.7.10.4