From 979947f545d70c63edb7ca96f6e47008ac90e3bf Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 6 Feb 2002 15:54:26 +0000 Subject: [PATCH] [project @ 2002-02-06 15:54:23 by simonpj] Eliminate all vestiages of UsageTy, in preparation for Keith's new version. Hurrah! Keith: LBVarInfo and usOnce,usMany are still there, because I know you have eliminated LBVarInfo, and I didn't want to cause unnecessary conflicts. --- ghc/compiler/coreSyn/CorePrep.lhs | 22 +--- ghc/compiler/coreSyn/CoreUtils.lhs | 8 +- ghc/compiler/coreSyn/MkExternalCore.lhs | 1 - ghc/compiler/coreSyn/Subst.lhs | 10 +- ghc/compiler/hsSyn/HsTypes.lhs | 16 --- ghc/compiler/prelude/PrimOp.lhs | 48 +------- ghc/compiler/rename/ParseIface.y | 2 - ghc/compiler/typecheck/TcMType.lhs | 8 -- ghc/compiler/typecheck/TcType.lhs | 48 ++------ ghc/compiler/typecheck/TcUnify.lhs | 4 - ghc/compiler/types/PprType.lhs | 16 +-- ghc/compiler/types/Type.lhs | 194 +++---------------------------- ghc/compiler/types/TypeRep.lhs | 9 -- ghc/compiler/types/Variance.lhs | 2 - 14 files changed, 40 insertions(+), 348 deletions(-) diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index da19ebd..63c1d95 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -15,8 +15,7 @@ import CoreFVs ( exprFreeVars ) import CoreLint ( endPass ) import CoreSyn import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy, - isUnLiftedType, isUnboxedTupleType, repType, - uaUTy, usOnce, usMany, eqUsage, seqType ) + isUnLiftedType, isUnboxedTupleType, repType, seqType ) import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) import PrimOp ( PrimOp(..) ) import Var ( Var, Id, setVarUnique ) @@ -702,23 +701,12 @@ mkDem :: Demand -> Bool -> RhsDemand mkDem strict once = RhsDemand (isStrictDmd strict) once mkDemTy :: Demand -> Type -> RhsDemand -mkDemTy strict ty = RhsDemand (isStrictDmd strict) (isOnceTy ty) - -isOnceTy :: Type -> Bool -isOnceTy ty - = -#ifdef USMANY - opt_UsageSPOn && -- can't expect annotations if -fusagesp is off -#endif - once - where - u = uaUTy ty - once | u `eqUsage` usOnce = True - | u `eqUsage` usMany = False - | isTyVarTy u = False -- if unknown at compile-time, is Top ie usMany +mkDemTy strict ty = RhsDemand (isStrictDmd strict) + False {- For now -} bdrDem :: Id -> RhsDemand -bdrDem id = mkDem (idNewDemandInfo id) (isOnceTy (idType id)) +bdrDem id = mkDem (idNewDemandInfo id) + False {- For now -} safeDem, onceDem :: RhsDemand safeDem = RhsDemand False False -- always safe to use this diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 6fafd53..d7a91a0 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -57,7 +57,7 @@ import IdInfo ( LBVarInfo(..), megaSeqIdInfo ) import NewDemand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy, - applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, + applyTys, isUnLiftedType, seqType, mkTyVarTy, splitForAllTy_maybe, isForAllTy, splitNewType_maybe, splitTyConApp_maybe, eqType, funResultTy, applyTy, funResultTy, applyTy @@ -111,12 +111,8 @@ mkPiTypes :: [Var] -> Type -> Type -- doesn't work... mkPiTypes vs ty = foldr mkPiType ty vs mkPiType v ty - | isId v = add_usage (mkFunTy (idType v) ty) + | isId v = mkFunTy (idType v) ty | otherwise = mkForAllTy v ty - where - add_usage ty = case idLBVarInfo v of - LBVarInfo u -> mkUTy u ty - otherwise -> ty \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index f3622eb..7e7f808 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -142,7 +142,6 @@ make_ty (TyConApp tc ts) = foldl C.Tapp (C.Tcon (make_con_qid (tyConName tc))) ( make_ty (FunTy t1 t2) = make_ty (TyConApp funTyCon [t1,t2]) make_ty (ForAllTy tv t) = C.Tforall (make_tbind tv) (make_ty t) make_ty (SourceTy p) = make_ty (sourceTypeRep p) -make_ty (UsageTy _ t) = make_ty t make_ty (NoteTy _ t) = make_ty t diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs index 745f0a1..ce5d8bc 100644 --- a/ghc/compiler/coreSyn/Subst.lhs +++ b/ghc/compiler/coreSyn/Subst.lhs @@ -45,7 +45,7 @@ import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, import CoreFVs ( exprFreeVars ) import TypeRep ( Type(..), TyNote(..) ) -- friend import Type ( ThetaType, SourceType(..), PredType, - tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy + tyVarsOfType, tyVarsOfTypes, mkAppTy, ) import VarSet import VarEnv @@ -249,12 +249,10 @@ zapSubstEnv :: Subst -> Subst zapSubstEnv (Subst in_scope env) = Subst in_scope emptySubstEnv extendSubst :: Subst -> Var -> SubstResult -> Subst -extendSubst (Subst in_scope env) v r = UASSERT( case r of { DoneTy ty -> not (isUTy ty) ; _ -> True } ) - Subst in_scope (extendSubstEnv env v r) +extendSubst (Subst in_scope env) v r = Subst in_scope (extendSubstEnv env v r) extendSubstList :: Subst -> [Var] -> [SubstResult] -> Subst -extendSubstList (Subst in_scope env) v r = UASSERT( all (\ r1 -> case r1 of { DoneTy ty -> not (isUTy ty) ; _ -> True }) r ) - Subst in_scope (extendSubstEnvList env v r) +extendSubstList (Subst in_scope env) v r = Subst in_scope (extendSubstEnvList env v r) lookupSubst :: Subst -> Var -> Maybe SubstResult lookupSubst (Subst _ env) v = lookupSubstEnv env v @@ -440,8 +438,6 @@ subst_ty subst ty go (ForAllTy tv ty) = case substTyVar subst tv of (subst', tv') -> ForAllTy tv' $! (subst_ty subst' ty) - - go (UsageTy u ty) = mkUTy (go u) $! (go ty) \end{code} Here is where we invent a new binder if necessary. diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 15bc03f..5e9b874 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -106,9 +106,6 @@ data HsType name -- these next two are only used in interfaces | HsPredTy (HsPred name) - - | HsUsageTy (HsType name) -- Usage annotation - (HsType name) -- Annotated type ----------------------- @@ -286,12 +283,6 @@ ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred) -ppr_mono_ty ctxt_prec (HsUsageTy u ty) - = maybeParen (ctxt_prec >= pREC_CON) - (sep [ptext SLIT("__u") <+> ppr_mono_ty pREC_CON u, - ppr_mono_ty pREC_CON ty]) - -- pREC_FUN would be logical for u, but it yields a reduce/reduce conflict with AppTy - -- Generics ppr_mono_ty ctxt_prec (HsNumTy n) = integer n ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2 @@ -366,10 +357,6 @@ toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of (map toHsPred preds) (toHsType tau) -toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty) - -- **! consider dropping usMany annotations ToDo KSW 2000-10 - - toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys) toHsPred (IParam n ty) = HsIParam n (toHsType ty) @@ -471,9 +458,6 @@ eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) eq_hsType env (HsPredTy p1) (HsPredTy p2) = eq_hsPred env p1 p2 -eq_hsType env (HsUsageTy u1 ty1) (HsUsageTy u2 ty2) - = eq_hsType env u1 u2 && eq_hsType env ty1 ty2 - eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2) = eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2 diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 5259fc1..99323ce 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -6,7 +6,7 @@ \begin{code} module PrimOp ( PrimOp(..), allThePrimOps, - primOpType, primOpSig, primOpUsg, primOpArity, + primOpType, primOpSig, primOpArity, mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc, commutableOp, @@ -31,8 +31,7 @@ import RdrName ( RdrName, mkRdrOrig ) import OccName ( OccName, pprOccName, mkVarOcc ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, - splitFunTy_maybe, tyConAppTyCon, splitTyConApp, - mkUTy, usOnce, usMany + splitFunTy_maybe, tyConAppTyCon, splitTyConApp ) import PprType () -- get at Outputable Type instance. import Unique ( mkPrimOpIdUnique ) @@ -427,49 +426,6 @@ primOpSig op Compare occ ty -> ([], [ty,ty], boolTy) GenPrimOp occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty) - --- primOpUsg is like primOpSig but the types it yields are the --- appropriate sigma (i.e., usage-annotated) types, --- as required by the UsageSP inference. - -primOpUsg :: PrimOp -> ([TyVar],[Type],Type) -#include "primop-usage.hs-incl" - --- Things with no Haskell pointers inside: in actuality, usages are --- irrelevant here (hence it doesn't matter that some of these --- apparently permit duplication; since such arguments are never --- ENTERed anyway, the usage annotation they get is entirely irrelevant --- except insofar as it propagates to infect other values that *are* --- pointed. - - --- Helper bits & pieces for usage info. - -mkZ = mkUTy usOnce -- pointed argument used zero -mkO = mkUTy usOnce -- pointed argument used once -mkM = mkUTy usMany -- pointed argument used multiply -mkP = mkUTy usOnce -- unpointed argument -mkR = mkUTy usMany -- unpointed result - -nomangle op - = case primOpSig op of - (tyvars, arg_tys, res_ty, _, _) - -> (tyvars, map mkP arg_tys, mkR res_ty) - -mangle op fs g - = case primOpSig op of - (tyvars, arg_tys, res_ty, _, _) - -> (tyvars, zipWithEqual "primOpUsg" ($) fs arg_tys, g res_ty) - -inFun op f g ty - = case splitFunTy_maybe ty of - Just (a,b) -> mkFunTy (f a) (g b) - Nothing -> pprPanic "primOpUsg:inFun" (ppr op <+> ppr ty) - -inUB op fs ty - = case splitTyConApp ty of - (tc,tys) -> ASSERT( tc == tupleTyCon Unboxed (length fs) ) - mkTupleTy Unboxed (length fs) (zipWithEqual "primOpUsg" ($) fs tys) \end{code} \begin{code} diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 99f84ff..b71b71f 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -547,7 +547,6 @@ types2 : type ',' type { [$1,$3] } btype :: { RdrNameHsType } btype : atype { $1 } | btype atype { HsAppTy $1 $2 } - | '__u' atype atype { HsUsageTy $2 $3 } atype :: { RdrNameHsType } atype : qtc_name { HsTyVar $1 } @@ -579,7 +578,6 @@ ttype : '__forall' tv_bndrs tbtype :: { RdrNameHsType } tbtype : tatype { $1 } | tbtype atype { HsAppTy $1 $2 } - | '__u' atype atype { HsUsageTy $2 $3 } tatype :: { RdrNameHsType } tatype : qtc_name { HsTyVar $1 } diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 29721d3..aa1a2ce 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -157,7 +157,6 @@ tcSplitRhoTyM t case maybe_ty of Just ty | not (tcIsTyVarTy ty) -> go syn_t ty ts other -> returnNF_Tc (reverse ts, syn_t) - go syn_t (UsageTy _ t) ts = go syn_t t ts go syn_t t ts = returnNF_Tc (reverse ts, syn_t) \end{code} @@ -274,7 +273,6 @@ putTcTyVar tyvar ty | otherwise = ASSERT( isMutTyVar tyvar ) - UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty ) tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` returnNF_Tc ty \end{code} @@ -498,10 +496,6 @@ zonkType unbound_var_fn ty go arg `thenNF_Tc` \ arg' -> returnNF_Tc (mkAppTy fun' arg') - go (UsageTy u ty) = go u `thenNF_Tc` \ u' -> - go ty `thenNF_Tc` \ ty' -> - returnNF_Tc (UsageTy u' ty') - -- The two interesting cases! go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar @@ -725,7 +719,6 @@ check_tau_type :: Rank -> UbxTupFlag -> Type -> TcM () -- Rank is allowed rank for function args -- No foralls otherwise -check_tau_type rank ubx_tup ty@(UsageTy _ _) = failWithTc (usageTyErr ty) check_tau_type rank ubx_tup ty@(ForAllTy _ _) = failWithTc (forAllTyErr ty) check_tau_type rank ubx_tup (SourceTy sty) = getDOptsTc `thenNF_Tc` \ dflags -> check_source_ty dflags TypeCtxt sty @@ -778,7 +771,6 @@ check_tau_type rank ubx_tup ty@(TyConApp tc tys) ---------------------------------------- forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr_ty ty -usageTyErr ty = ptext SLIT("Illegal usage type:") <+> ppr_ty ty unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr_ty ty ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr_ty ty kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index f6ce0b4..5db0ad7 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -108,7 +108,6 @@ import {-# SOURCE #-} PprType( pprType ) -- friends: import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend -import Type ( mkUTyM, unUTy ) -- Used locally import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, @@ -289,9 +288,7 @@ tyVarBindingInfo tv mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau) mkRhoTy :: [SourceType] -> Type -> Type -mkRhoTy theta ty = UASSERT2( not (isUTy ty), pprType ty ) - foldr (\p r -> FunTy (mkUTyM (mkPredTy p)) (mkUTyM r)) ty theta - +mkRhoTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta \end{code} @@ -305,7 +302,6 @@ isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b isTauTy (SourceTy p) = True -- Don't look through source types isTauTy (NoteTy _ ty) = isTauTy ty -isTauTy (UsageTy _ ty) = isTauTy ty isTauTy other = False \end{code} @@ -318,7 +314,6 @@ getDFunTyKey (AppTy fun _) = getDFunTyKey fun getDFunTyKey (NoteTy _ t) = getDFunTyKey t getDFunTyKey (FunTy arg _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t -getDFunTyKey (UsageTy _ t) = getDFunTyKey t getDFunTyKey (SourceTy (NType tc _)) = getOccName tc -- Newtypes are quite reasonable getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) -- SourceTy shouldn't happen @@ -345,12 +340,10 @@ tcSplitForAllTys ty = split ty ty [] where split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs - split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs split orig_ty t tvs = (reverse tvs, orig_ty) tcIsForAllTy (ForAllTy tv ty) = True tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty -tcIsForAllTy (UsageTy n ty) = tcIsForAllTy ty tcIsForAllTy t = False tcSplitRhoTy :: Type -> ([PredType], Type) @@ -360,7 +353,6 @@ tcSplitRhoTy ty = split ty ty [] Just p -> split res res (p:ts) Nothing -> (reverse ts, orig_ty) split orig_ty (NoteTy n ty) ts = split orig_ty ty ts - split orig_ty (UsageTy _ ty) ts = split orig_ty ty ts split orig_ty ty ts = (reverse ts, orig_ty) tcSplitSigmaTy ty = case tcSplitForAllTys ty of @@ -381,9 +373,8 @@ tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) -- Newtypes are opaque, so they may be split tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) +tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty -tcSplitTyConApp_maybe (UsageTy _ ty) = tcSplitTyConApp_maybe ty tcSplitTyConApp_maybe (SourceTy (NType tc tys)) = Just (tc,tys) -- However, predicates are not treated -- as tycon applications by the type checker @@ -399,7 +390,6 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res) tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty -tcSplitFunTy_maybe (UsageTy _ ty) = tcSplitFunTy_maybe ty tcSplitFunTy_maybe other = Nothing tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg } @@ -407,10 +397,9 @@ tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res } tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) -tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2) +tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty -tcSplitAppTy_maybe (UsageTy _ ty) = tcSplitAppTy_maybe ty tcSplitAppTy_maybe (SourceTy (NType tc tys)) = tc_split_app tc tys --- Don't forget that newtype! tcSplitAppTy_maybe (TyConApp tc tys) = tc_split_app tc tys @@ -429,7 +418,6 @@ tcSplitAppTy ty = case tcSplitAppTy_maybe ty of tcGetTyVar_maybe :: Type -> Maybe TyVar tcGetTyVar_maybe (TyVarTy tv) = Just tv tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t -tcGetTyVar_maybe ty@(UsageTy _ _) = pprPanic "tcGetTyVar_maybe: UTy:" (pprType ty) tcGetTyVar_maybe other = Nothing tcGetTyVar :: String -> Type -> TyVar @@ -455,7 +443,6 @@ tcSplitMethodTy ty = split ty Just p -> (p, res) Nothing -> panic "splitMethodTy" split (NoteTy n ty) = split ty - split (UsageTy _ ty) = split ty split _ = panic "splitMethodTy" tcSplitDFunTy :: Type -> ([TyVar], [SourceType], Class, [Type]) @@ -483,14 +470,12 @@ isPred (NType _ _) = False isPredTy :: Type -> Bool isPredTy (NoteTy _ ty) = isPredTy ty -isPredTy (UsageTy _ ty) = isPredTy ty isPredTy (SourceTy sty) = isPred sty isPredTy _ = False tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty -tcSplitPredTy_maybe (UsageTy _ ty) = tcSplitPredTy_maybe ty tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p tcSplitPredTy_maybe other = Nothing @@ -513,8 +498,7 @@ mkPredName uniq loc (IParam ip ty) = mkLocalName uniq (getOccName (ipNameName --------------------- Dictionary types --------------------------------- \begin{code} -mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - ClassP clas tys +mkClassPred clas tys = ClassP clas tys isClassPred :: SourceType -> Bool isClassPred (ClassP clas tys) = True @@ -531,13 +515,11 @@ getClassPredTys :: PredType -> (Class, [Type]) getClassPredTys (ClassP clas tys) = (clas, tys) mkDictTy :: Class -> [Type] -> Type -mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) ) - mkPredTy (ClassP clas tys) +mkDictTy clas tys = mkPredTy (ClassP clas tys) isDictTy :: Type -> Bool isDictTy (SourceTy p) = isClassPred p isDictTy (NoteTy _ ty) = isDictTy ty -isDictTy (UsageTy _ ty) = isDictTy ty isDictTy other = False \end{code} @@ -597,11 +579,9 @@ cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2) -- we in effect substitute tv2 for tv1 in t1 before continuing - -- Look through NoteTy and UsageTy + -- Look through NoteTy cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2 -cmpTy env (UsageTy _ ty1) ty2 = cmpTy env ty1 ty2 -cmpTy env ty1 (UsageTy _ ty2) = cmpTy env ty1 ty2 -- Deal with equal constructors cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of @@ -674,14 +654,12 @@ isSigmaTy :: Type -> Bool isSigmaTy (ForAllTy tyvar ty) = True isSigmaTy (FunTy a b) = isPredTy a isSigmaTy (NoteTy n ty) = isSigmaTy ty -isSigmaTy (UsageTy _ ty) = isSigmaTy ty isSigmaTy _ = False isOverloadedTy :: Type -> Bool isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty isOverloadedTy (FunTy a b) = isPredTy a isOverloadedTy (NoteTy n ty) = isOverloadedTy ty -isOverloadedTy (UsageTy _ ty) = isOverloadedTy ty isOverloadedTy _ = False \end{code} @@ -732,7 +710,6 @@ hoistForAllTys ty (tvs,theta,tau) -> (tvs,theta,mkFunTy arg tau) hoist orig_ty (NoteTy _ ty) = hoist orig_ty ty - hoist orig_ty (UsageTy _ ty) = hoist orig_ty ty hoist orig_ty ty = ([], [], orig_ty) \end{code} @@ -747,7 +724,6 @@ deNoteType (NoteTy _ ty) = deNoteType ty deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) -deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty) deNoteSourceType :: SourceType -> SourceType deNoteSourceType (ClassP c tys) = ClassP c (map deNoteType tys) @@ -770,7 +746,6 @@ namesOfType (SourceTy (NType tc tys)) = unitNameSet (getName tc) `unionNameSets` namesOfType (FunTy arg res) = namesOfType arg `unionNameSets` namesOfType res namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg namesOfType (ForAllTy tyvar ty) = namesOfType ty `delFromNameSet` getName tyvar -namesOfType (UsageTy u ty) = namesOfType u `unionNameSets` namesOfType ty namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys @@ -1025,10 +1000,6 @@ uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)" uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)" #endif - -- Ignore usages -uTysX (UsageTy _ t1) t2 k subst = uTysX t1 t2 k subst -uTysX t1 (UsageTy _ t2) k subst = uTysX t1 t2 k subst - -- Anything else fails uTysX ty1 ty2 k subst = Nothing @@ -1049,7 +1020,6 @@ uVarX tv1 ty2 k subst@(tmpls, env) | typeKind ty2 `eqKind` tyVarKind tv1 && occur_check_ok ty2 -> -- No kind mismatch nor occur check - UASSERT( not (isUTy ty2) ) k (tmpls, extendSubstEnv env tv1 (DoneTy ty2)) | otherwise -> Nothing -- Fail if kind mis-match or occur check @@ -1117,8 +1087,7 @@ match (TyVarTy v) ty tmpls k senv | v `elemVarSet` tmpls = -- v is a template variable case lookupSubstEnv senv v of - Nothing -> UASSERT( not (isUTy ty) ) - k (extendSubstEnv senv v (DoneTy ty)) + Nothing -> k (extendSubstEnv senv v (DoneTy ty)) Just (DoneTy ty') | ty' `tcEqType` ty -> k senv -- Succeeds | otherwise -> Nothing -- Fails @@ -1159,9 +1128,6 @@ match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv match (SourceTy (NType tc1 tys1)) (SourceTy (NType tc2 tys2)) tmpls k senv | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv -match (UsageTy _ ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv -match ty1 (UsageTy _ ty2) tmpls k senv = match ty1 ty2 tmpls k senv - -- With type synonyms, we have to be careful for the exact -- same reasons as in the unifier. Please see the -- considerable commentary there before changing anything diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index e9d36c4..6b74930 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -420,10 +420,6 @@ uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 - -- Ignore usage annotations inside typechecker -uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 - -- Variables; go for uVar uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2 uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index dab39da..0412c04 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -20,7 +20,7 @@ module PprType( -- (PprType can see all the representations it's trying to print) import TypeRep ( Type(..), TyNote(..), Kind, liftedTypeKind ) -- friend -import Type ( SourceType(..), isUTyVar, eqKind ) +import Type ( SourceType(..), eqKind ) import TcType ( ThetaType, PredType, tcSplitSigmaTy, isPredTy, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe @@ -165,13 +165,7 @@ ppr_ty ctxt_prec ty@(ForAllTy _ _) ] where (tyvars, theta, tau) = tcSplitSigmaTy ty - - pp_tyvars sty = sep (map pprTyVarBndr some_tyvars) - where - some_tyvars | userStyle sty && not opt_PprStyle_RawTypes - = filter (not . isUTyVar) tyvars -- hide uvars from user - | otherwise - = tyvars + pp_tyvars sty = sep (map pprTyVarBndr tyvars) ppr_theta [] = empty ppr_theta theta = pprTheta theta <+> ptext SLIT("=>") @@ -191,12 +185,6 @@ ppr_ty ctxt_prec (AppTy ty1 ty2) = maybeParen ctxt_prec tYCON_PREC $ ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2 -ppr_ty ctxt_prec (UsageTy u ty) - = maybeParen ctxt_prec tYCON_PREC $ - ptext SLIT("__u") <+> ppr_ty tYCON_PREC u - <+> ppr_ty tYCON_PREC ty - -- fUN_PREC would be logical for u, but it yields a reduce/reduce conflict with AppTy - ppr_ty ctxt_prec (NoteTy (SynNote ty) expansion) = ppr_ty ctxt_prec ty -- = ppr_ty ctxt_prec expansion -- if we don't want to see syntys diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index c561acb..f901d91 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -37,10 +37,6 @@ module Type ( tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, - mkUTy, splitUTy, splitUTy_maybe, - isUTy, uaUTy, unUTy, liftUTy, mkUTyM, - isUsageKind, isUsage, isUTyVar, - mkSynTy, repType, splitRepFunTys, typePrimRep, @@ -59,7 +55,7 @@ module Type ( -- Free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - usageAnnOfType, typeKind, addFreeTyVars, + typeKind, addFreeTyVars, -- Tidying up for printing tidyType, tidyTypes, @@ -161,21 +157,18 @@ getTyVar :: String -> Type -> TyVar getTyVar msg (TyVarTy tv) = tv getTyVar msg (SourceTy p) = getTyVar msg (sourceTypeRep p) getTyVar msg (NoteTy _ t) = getTyVar msg t -getTyVar msg ty@(UsageTy _ _) = pprPanic "getTyVar: UTy:" (text msg $$ pprType ty) getTyVar msg other = panic ("getTyVar: " ++ msg) getTyVar_maybe :: Type -> Maybe TyVar getTyVar_maybe (TyVarTy tv) = Just tv getTyVar_maybe (NoteTy _ t) = getTyVar_maybe t getTyVar_maybe (SourceTy p) = getTyVar_maybe (sourceTypeRep p) -getTyVar_maybe ty@(UsageTy _ _) = pprPanic "getTyVar_maybe: UTy:" (pprType ty) getTyVar_maybe other = Nothing isTyVarTy :: Type -> Bool isTyVarTy (TyVarTy tv) = True isTyVarTy (NoteTy _ ty) = isTyVarTy ty isTyVarTy (SourceTy p) = isTyVarTy (sourceTypeRep p) -isTyVarTy ty@(UsageTy _ _) = pprPanic "isTyVarTy: UTy:" (pprType ty) isTyVarTy other = False \end{code} @@ -190,13 +183,10 @@ invariant: use it. \begin{code} mkAppTy orig_ty1 orig_ty2 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * - UASSERT2( not (isUTy orig_ty2), pprType orig_ty1 <+> pprType orig_ty2 ) - -- argument must be unannotated mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2]) - mk_app ty@(UsageTy _ _) = pprPanic "mkAppTy: UTy:" (pprType ty) mk_app ty1 = AppTy orig_ty1 orig_ty2 mkAppTys :: Type -> [Type] -> Type @@ -208,17 +198,14 @@ mkAppTys orig_ty1 [] = orig_ty1 -- the Rational part. mkAppTys orig_ty1 orig_tys2 = ASSERT( not (isSourceTy orig_ty1) ) -- Source types are of kind * - UASSERT2( not (any isUTy orig_tys2), pprType orig_ty1 <+> fsep (map pprType orig_tys2) ) - -- arguments must be unannotated mk_app orig_ty1 where mk_app (NoteTy _ ty1) = mk_app ty1 mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2) - mk_app ty@(UsageTy _ _) = pprPanic "mkAppTys: UTy:" (pprType ty) mk_app ty1 = foldl AppTy orig_ty1 orig_tys2 splitAppTy_maybe :: Type -> Maybe (Type, Type) -splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [unUTy ty1], unUTy ty2) +splitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) splitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) splitAppTy_maybe (NoteTy _ ty) = splitAppTy_maybe ty splitAppTy_maybe (SourceTy p) = splitAppTy_maybe (sourceTypeRep p) @@ -228,7 +215,6 @@ splitAppTy_maybe (TyConApp tc tys) = split tys [] split [ty2] acc = Just (TyConApp tc (reverse acc), ty2) split (ty:tys) acc = split tys (ty:acc) -splitAppTy_maybe ty@(UsageTy _ _) = pprPanic "splitAppTy_maybe: UTy:" (pprType ty) splitAppTy_maybe other = Nothing splitAppTy :: Type -> (Type, Type) @@ -243,9 +229,8 @@ splitAppTys ty = split ty ty [] split orig_ty (NoteTy _ ty) args = split orig_ty ty args split orig_ty (SourceTy p) args = split orig_ty (sourceTypeRep p) args split orig_ty (FunTy ty1 ty2) args = ASSERT( null args ) - (TyConApp funTyCon [], [unUTy ty1,unUTy ty2]) + (TyConApp funTyCon [], [ty1,ty2]) split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args) - split orig_ty (UsageTy _ _) args = pprPanic "splitAppTys: UTy:" (pprType orig_ty) split orig_ty ty args = (orig_ty, args) \end{code} @@ -256,24 +241,20 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -mkFunTy arg res = UASSERT2( isUTy arg && isUTy res, pprType arg <+> pprType res ) - FunTy arg res +mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type -mkFunTys tys ty = UASSERT2( all isUTy (ty:tys), fsep (map pprType (tys++[ty])) ) - foldr FunTy ty tys +mkFunTys tys ty = foldr FunTy ty tys splitFunTy :: Type -> (Type, Type) splitFunTy (FunTy arg res) = (arg, res) splitFunTy (NoteTy _ ty) = splitFunTy ty -splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) -splitFunTy ty@(UsageTy _ _) = pprPanic "splitFunTy: UTy:" (pprType ty) +splitFunTy (SourceTy p) = splitFunTy (sourceTypeRep p) splitFunTy_maybe :: Type -> Maybe (Type, Type) splitFunTy_maybe (FunTy arg res) = Just (arg, res) splitFunTy_maybe (NoteTy _ ty) = splitFunTy_maybe ty -splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p) -splitFunTy_maybe ty@(UsageTy _ _) = pprPanic "splitFunTy_maybe: UTy:" (pprType ty) +splitFunTy_maybe (SourceTy p) = splitFunTy_maybe (sourceTypeRep p) splitFunTy_maybe other = Nothing splitFunTys :: Type -> ([Type], Type) @@ -281,8 +262,7 @@ splitFunTys ty = split [] ty ty where split args orig_ty (FunTy arg res) = split (arg:args) res res split args orig_ty (NoteTy _ ty) = split args orig_ty ty - split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) - split args orig_ty (UsageTy _ _) = pprPanic "splitFunTys: UTy:" (pprType orig_ty) + split args orig_ty (SourceTy p) = split args orig_ty (sourceTypeRep p) split args orig_ty ty = (reverse args, orig_ty) zipFunTys :: Outputable a => [a] -> Type -> ([(a,Type)], Type) @@ -291,22 +271,19 @@ zipFunTys orig_xs orig_ty = split [] orig_xs orig_ty orig_ty split acc [] nty ty = (reverse acc, nty) split acc (x:xs) nty (FunTy arg res) = split ((x,arg):acc) xs res res split acc xs nty (NoteTy _ ty) = split acc xs nty ty - split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p) - split acc xs nty (UsageTy _ _) = pprPanic "zipFunTys: UTy:" (ppr orig_xs <+> pprType orig_ty) + split acc xs nty (SourceTy p) = split acc xs nty (sourceTypeRep p) split acc (x:xs) nty ty = pprPanic "zipFunTys" (ppr orig_xs <+> pprType orig_ty) funResultTy :: Type -> Type funResultTy (FunTy arg res) = res funResultTy (NoteTy _ ty) = funResultTy ty -funResultTy (SourceTy p) = funResultTy (sourceTypeRep p) -funResultTy (UsageTy _ ty) = funResultTy ty +funResultTy (SourceTy p) = funResultTy (sourceTypeRep p) funResultTy ty = pprPanic "funResultTy" (pprType ty) funArgTy :: Type -> Type funArgTy (FunTy arg res) = arg funArgTy (NoteTy _ ty) = funArgTy ty -funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) -funArgTy (UsageTy _ ty) = funArgTy ty +funArgTy (SourceTy p) = funArgTy (sourceTypeRep p) funArgTy ty = pprPanic "funArgTy" (pprType ty) \end{code} @@ -322,7 +299,7 @@ mkTyConApp :: TyCon -> [Type] -> Type -- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those mkTyConApp tycon tys | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy (mkUTyM ty1) (mkUTyM ty2) + = FunTy ty1 ty2 | isNewTyCon tycon, -- A saturated newtype application; not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them) @@ -331,7 +308,6 @@ mkTyConApp tycon tys | otherwise = ASSERT(not (isSynTyCon tycon)) - UASSERT2( not (any isUTy tys), ppr tycon <+> fsep (map pprType tys) ) TyConApp tycon tys mkTyConTy :: TyCon -> Type @@ -355,10 +331,9 @@ splitTyConApp ty = case splitTyConApp_maybe ty of splitTyConApp_maybe :: Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) -splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [unUTy arg,unUTy res]) +splitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) splitTyConApp_maybe (NoteTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe (SourceTy p) = splitTyConApp_maybe (sourceTypeRep p) -splitTyConApp_maybe (UsageTy _ ty) = splitTyConApp_maybe ty splitTyConApp_maybe other = Nothing \end{code} @@ -425,7 +400,6 @@ repType :: Type -> Type repType (ForAllTy _ ty) = repType ty repType (NoteTy _ ty) = repType ty repType (SourceTy p) = repType (sourceTypeRep p) -repType (UsageTy _ ty) = repType ty repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc = repType (newTypeRep tc tys) repType ty = ty @@ -457,18 +431,11 @@ mkForAllTy tyvar ty = mkForAllTys [tyvar] ty mkForAllTys :: [TyVar] -> Type -> Type -mkForAllTys tyvars ty - = case splitUTy_maybe ty of - Just (u,ty1) -> UASSERT2( not (mkVarSet tyvars `intersectsVarSet` tyVarsOfType u), - ptext SLIT("mkForAllTys: usage scope") - <+> ppr tyvars <+> pprType ty ) - mkUTy u (foldr ForAllTy ty1 tyvars) -- we lift usage annotations over foralls - Nothing -> foldr ForAllTy ty tyvars +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars isForAllTy :: Type -> Bool isForAllTy (NoteTy _ ty) = isForAllTy ty isForAllTy (ForAllTy _ _) = True -isForAllTy (UsageTy _ ty) = isForAllTy ty isForAllTy other_ty = False splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) @@ -477,7 +444,6 @@ splitForAllTy_maybe ty = splitFAT_m ty splitFAT_m (NoteTy _ ty) = splitFAT_m ty splitFAT_m (SourceTy p) = splitFAT_m (sourceTypeRep p) splitFAT_m (ForAllTy tyvar ty) = Just(tyvar, ty) - splitFAT_m (UsageTy _ ty) = splitFAT_m ty splitFAT_m _ = Nothing splitForAllTys :: Type -> ([TyVar], Type) @@ -486,7 +452,6 @@ splitForAllTys ty = split ty ty [] split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs) split orig_ty (NoteTy _ ty) tvs = split orig_ty ty tvs split orig_ty (SourceTy p) tvs = split orig_ty (sourceTypeRep p) tvs - split orig_ty (UsageTy _ ty) tvs = split orig_ty ty tvs split orig_ty t tvs = (reverse tvs, orig_ty) \end{code} @@ -496,22 +461,14 @@ Applying a for-all to its arguments. Lift usage annotation as required. \begin{code} applyTy :: Type -> Type -> Type -applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg -applyTy (NoteTy _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = UASSERT2( not (isUTy arg), - ptext SLIT("applyTy") - <+> pprType ty <+> pprType arg ) - substTyWith [tv] [arg] ty -applyTy (UsageTy u ty) arg = UsageTy u (applyTy ty arg) -applyTy other arg = panic "applyTy" +applyTy (SourceTy p) arg = applyTy (sourceTypeRep p) arg +applyTy (NoteTy _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = substTyWith [tv] [arg] ty +applyTy other arg = panic "applyTy" applyTys :: Type -> [Type] -> Type applyTys fun_ty arg_tys - = UASSERT2( not (any isUTy arg_tys), ptext SLIT("applyTys") <+> pprType fun_ty ) - (case mu of - Just u -> UsageTy u - Nothing -> id) $ - substTyWith tvs arg_tys ty + = substTyWith tvs arg_tys ty where (mu, tvs, ty) = split fun_ty arg_tys @@ -520,93 +477,10 @@ applyTys fun_ty arg_tys split (SourceTy p) args = split (sourceTypeRep p) args split (ForAllTy tv fun_ty) (arg:args) = case split fun_ty args of (mu, tvs, ty) -> (mu, tv:tvs, ty) - split (UsageTy u ty) args = case split ty args of - (Nothing, tvs, ty) -> (Just u, tvs, ty) - (Just _ , _ , _ ) -> pprPanic "applyTys:" - (pprType fun_ty) split other_ty args = panic "applyTys" \end{code} ---------------------------------------------------------------------- - UsageTy - ~~~~~~~ - -Constructing and taking apart usage types. - -\begin{code} -mkUTy :: Type -> Type -> Type -mkUTy u ty - = ASSERT2( typeKind u `eqKind` usageTypeKind, - ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) - UASSERT2( not (isUTy ty), ptext SLIT("mkUTy:") <+> pprType u <+> pprType ty ) - -- if u == usMany then ty else : ToDo? KSW 2000-10 -#ifdef DO_USAGES - UsageTy u ty -#else - ty -#endif - -splitUTy :: Type -> (Type {- :: $ -}, Type) -splitUTy orig_ty - = case splitUTy_maybe orig_ty of - Just (u,ty) -> (u,ty) -#ifdef DO_USAGES - Nothing -> pprPanic "splitUTy:" (pprType orig_ty) -#else - Nothing -> (usMany,orig_ty) -- default annotation ToDo KSW 2000-10 -#endif - -splitUTy_maybe :: Type -> Maybe (Type {- :: $ -}, Type) -splitUTy_maybe (UsageTy u ty) = Just (u,ty) -splitUTy_maybe (NoteTy _ ty) = splitUTy_maybe ty -splitUTy_maybe other_ty = Nothing - -isUTy :: Type -> Bool - -- has usage annotation -isUTy = maybeToBool . splitUTy_maybe - -uaUTy :: Type -> Type - -- extract annotation -uaUTy = fst . splitUTy - -unUTy :: Type -> Type - -- extract unannotated type -unUTy = snd . splitUTy -\end{code} - -\begin{code} -liftUTy :: (Type -> Type) -> Type -> Type - -- lift outer usage annot over operation on unannotated types -liftUTy f ty - = let - (u,ty') = splitUTy ty - in - mkUTy u (f ty') -\end{code} - -\begin{code} -mkUTyM :: Type -> Type - -- put TOP (no info) annotation on unannotated type -mkUTyM ty = mkUTy usMany ty -\end{code} - -\begin{code} -isUsageKind :: Kind -> Bool -isUsageKind k - = ASSERT( typeKind k `eqKind` superKind ) - k `eqKind` usageTypeKind - -isUsage :: Type -> Bool -isUsage ty - = isUsageKind (typeKind ty) - -isUTyVar :: Var -> Bool -isUTyVar v - = isUsageKind (tyVarKind v) -\end{code} - - %************************************************************************ %* * \subsection{Source types} @@ -638,7 +512,6 @@ sourceTypeRep (NType tc tys) = newTypeRep tc tys isSourceTy :: Type -> Bool isSourceTy (NoteTy _ ty) = isSourceTy ty -isSourceTy (UsageTy _ ty) = isSourceTy ty isSourceTy (SourceTy sty) = True isSourceTy _ = False @@ -695,7 +568,6 @@ typeKind (FunTy arg res) = fix_up (typeKind res) -- a strange kind like (*->*). typeKind (ForAllTy tv ty) = typeKind ty -typeKind (UsageTy _ ty) = typeKind ty -- we don't have separate kinds for ann/unann \end{code} @@ -712,7 +584,6 @@ tyVarsOfType (SourceTy sty) = tyVarsOfSourceType sty tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg tyVarsOfType (ForAllTy tyvar ty) = tyVarsOfType ty `minusVarSet` unitVarSet tyvar -tyVarsOfType (UsageTy u ty) = tyVarsOfType u `unionVarSet` tyVarsOfType ty tyVarsOfTypes :: [Type] -> TyVarSet tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys @@ -734,28 +605,6 @@ addFreeTyVars ty@(NoteTy (FTVNote _) _) = ty addFreeTyVars ty = NoteTy (FTVNote (tyVarsOfType ty)) ty \end{code} -Usage annotations of a type -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Get a list of usage annotations of a type, *in left-to-right pre-order*. - -\begin{code} -usageAnnOfType :: Type -> [Type] -usageAnnOfType ty - = goS ty - where - goT (TyVarTy _) = [] - goT (AppTy ty1 ty2) = goT ty1 ++ goT ty2 - goT (TyConApp tc tys) = concatMap goT tys - goT (FunTy sty1 sty2) = goS sty1 ++ goS sty2 - goT (ForAllTy mv ty) = goT ty - goT (SourceTy p) = goT (sourceTypeRep p) - goT ty@(UsageTy _ _) = pprPanic "usageAnnOfType: unexpected usage:" (pprType ty) - goT (NoteTy note ty) = goT ty - - goS sty = case splitUTy sty of - (u,tty) -> u : goT tty -\end{code} %************************************************************************ @@ -815,7 +664,6 @@ tidyType env@(tidy_env, subst) ty go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty) where (envp, tvp) = tidyTyVarBndr env tv - go (UsageTy u ty) = (UsageTy $! (go u)) $! (go ty) go_note (SynNote ty) = SynNote $! (go ty) go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars @@ -868,7 +716,6 @@ isUnLiftedType :: Type -> Bool isUnLiftedType (ForAllTy tv ty) = isUnLiftedType ty isUnLiftedType (NoteTy _ ty) = isUnLiftedType ty isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc -isUnLiftedType (UsageTy _ ty) = isUnLiftedType ty isUnLiftedType (SourceTy _) = False -- All source types are lifted isUnLiftedType other = False @@ -896,7 +743,6 @@ which is below TcType in the hierarchy, so it's convenient to put it here. isStrictType (ForAllTy tv ty) = isStrictType ty isStrictType (NoteTy _ ty) = isStrictType ty isStrictType (TyConApp tc _) = isUnLiftedTyCon tc -isStrictType (UsageTy _ ty) = isStrictType ty isStrictType (SourceTy (ClassP clas _)) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) -- We may be strict in dictionary types, but only if it -- has more than one component. @@ -932,7 +778,6 @@ seqType (NoteTy note t2) = seqNote note `seq` seqType t2 seqType (SourceTy p) = seqPred p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty -seqType (UsageTy u ty) = seqType u `seq` seqType ty seqTypes :: [Type] -> () seqTypes [] = () @@ -990,7 +835,6 @@ eq_ty env (ForAllTy tv1 t1) (ForAllTy tv2 t2) | otherwise = eq_ty (extendVarEnv env tv1 tv2) t1 t2 eq_ty env (AppTy s1 t1) (AppTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) eq_ty env (FunTy s1 t1) (FunTy s2 t2) = (eq_ty env s1 s2) && (eq_ty env t1 t2) -eq_ty env (UsageTy _ t1) (UsageTy _ t2) = eq_ty env t1 t2 eq_ty env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 == tc2) && (eq_tys env tys1 tys2) eq_ty env t1 t2 = False diff --git a/ghc/compiler/types/TypeRep.lhs b/ghc/compiler/types/TypeRep.lhs index bb0a7f0..cf1d440 100644 --- a/ghc/compiler/types/TypeRep.lhs +++ b/ghc/compiler/types/TypeRep.lhs @@ -162,10 +162,6 @@ data Type | SourceTy -- A high level source type SourceType -- ...can be expanded to a representation type... - | UsageTy -- A usage-annotated type - Type -- - Annotation of kind $ (i.e., usage annotation) - Type -- - Annotated type - | NoteTy -- A type with a note attached TyNote Type -- The expanded version @@ -178,11 +174,6 @@ data TyNote -- The type to which the note is attached is the expanded form. \end{code} -INVARIANT: UsageTys are optional, but may *only* appear immediately -under a FunTy (either argument), or at top-level of a Type permitted -to be annotated (such as the type of an Id). NoteTys are transparent -for the purposes of this rule. - ------------------------------------- Source types diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs index 420f8f1..ffc96d5 100644 --- a/ghc/compiler/types/Variance.lhs +++ b/ghc/compiler/types/Variance.lhs @@ -158,8 +158,6 @@ vrcInTy fao v (ForAllTy v' ty) = if v==v' vrcInTy fao v (TyConApp tc tys) = let pms1 = map (vrcInTy fao v) tys pms2 = fao tc in orVrcs (zipWith timesVrc pms1 pms2) - -vrcInTy fao v (UsageTy u ty) = vrcInTy fao v u `orVrc` vrcInTy fao v ty \end{code} -- 1.7.10.4