X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FType.lhs;h=294f4235cd6ecb2805e5daea288f21666a78deb7;hb=3cbb4112ec0d75f517fb07ccb6ae42039686b757;hp=d63cecc64d288e1a56de2b26ca825a2e5b1d4758;hpb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;p=ghc-hetmet.git diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d63cecc..294f423 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -5,13 +5,13 @@ module Type ( GenType(..), SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, - mkAppTy, mkAppTys, splitAppTy, + mkAppTy, mkAppTys, splitAppTy, splitAppTys, mkFunTy, mkFunTys, splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking, getFunTy_maybe, getFunTyExpandingDicts_maybe, mkTyConTy, getTyCon_maybe, applyTyCon, mkSynTy, - mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy, + mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy, splitForAllTyExpandingDicts, mkForAllUsageTy, getForAllUsageTy, applyTy, #ifdef DEBUG @@ -37,19 +37,26 @@ module Type ( isTauTy, - tyVarsOfType, tyVarsOfTypes, typeKind + tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, + showTypeCategory ) where IMP_Ubiq() ---IMPORT_DELOOPER(IdLoop) -- for paranoia checking +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 +IMPORT_DELOOPER(IdLoop) -- for paranoia checking IMPORT_DELOOPER(TyLoop) --IMPORT_DELOOPER(PrelLoop) -- for paranoia checking +#else +import {-# SOURCE #-} Id ( Id, dataConArgTys ) +import {-# SOURCE #-} TysPrim ( voidTy ) +import {-# SOURCE #-} TysWiredIn ( tupleTyCon ) +#endif -- friends: -import Class ( classSig, classOpLocalType, GenClass{-instances-} ) +import Class ( classSig, classOpLocalType, GenClass{-instances-}, SYN_IE(Class) ) import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, - isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, +import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon, + isPrimTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), emptyTyVarSet, unionTyVarSets, minusTyVarSet, @@ -59,10 +66,15 @@ import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, eqUsage ) +import Name ( NamedThing(..), + NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet + ) + -- others import Maybes ( maybeToBool, assocMaybe ) import PrimRep ( PrimRep(..) ) import Unique -- quite a few *Keys +import UniqFM ( Uniquable(..) ) import Util ( thenCmp, zipEqual, assoc, panic, panic#, assertPanic, pprPanic, Ord3(..){-instances-} @@ -74,10 +86,6 @@ import Util ( thenCmp, zipEqual, assoc, -- PprStyle --import {-mumble-} -- PprType --(pprType ) ---import {-mumble-} --- UniqFM (ufmToList ) ---import {-mumble-} --- Outputable --import PprEnv \end{code} @@ -137,6 +145,21 @@ type SigmaType = Type \end{code} +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms whereever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs. + + Expand abbreviations ~~~~~~~~~~~~~~~~~~~~ Removes just the top level of any abbreviations. @@ -159,7 +182,7 @@ expandTy (DictTy clas ty u) -- no methods! other -> ASSERT(not (null all_arg_tys)) - foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys + foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys -- A tuple of 'em -- Note: length of all_arg_tys can be 0 if the class is @@ -206,8 +229,13 @@ mkAppTy = AppTy mkAppTys :: GenType t u -> [GenType t u] -> GenType t u mkAppTys t ts = foldl AppTy t ts -splitAppTy :: GenType t u -> (GenType t u, [GenType t u]) -splitAppTy t = go t [] +splitAppTy :: GenType t u -> (GenType t u, GenType t u) +splitAppTy (AppTy t arg) = (t,arg) +splitAppTy (SynTy _ _ t) = splitAppTy t +splitAppTy other = panic "splitAppTy" + +splitAppTys :: GenType t u -> (GenType t u, [GenType t u]) +splitAppTys t = go t [] where go (AppTy t arg) ts = go t (arg:ts) go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts) @@ -230,11 +258,15 @@ mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts -- ToDo: NUKE when we do dicts via newtype getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u) -getFunTy_maybe (FunTy arg result _) = Just (arg,result) -getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res) +getFunTy_maybe t + = go t t + where + -- See notes on type synonyms above + go syn_t (FunTy arg result _) = Just (arg,result) + go syn_t (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) -getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t -getFunTy_maybe other = Nothing + go syn_t (SynTy _ _ t) = go syn_t t + go syn_t other = Nothing getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons -> Type @@ -245,19 +277,32 @@ getFunTyExpandingDicts_maybe peek (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty) + +getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty + -- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking + + +{- This is a truly disgusting bit of code. + It's used by the code generator to look at the rep of a newtype. + The code gen will have thrown away coercions involving that newtype, so + this is the other side of the coin. + Gruesome in the extreme. +-} + getFunTyExpandingDicts_maybe peek other | not peek = Nothing -- that was easy | otherwise = case (maybeAppTyCon other) of - Nothing -> Nothing Just (tc, arg_tys) - | not (isNewTyCon tc) -> Nothing - | otherwise -> - let - [newtype_con] = tyConDataCons tc -- there must be exactly one... - [inside_ty] = dataConArgTys newtype_con arg_tys - in - getFunTyExpandingDicts_maybe peek inside_ty + | isNewTyCon tc && not (null data_cons) + -> getFunTyExpandingDicts_maybe peek inside_ty + where + data_cons = tyConDataCons tc + [the_con] = data_cons + [inside_ty] = dataConArgTys the_con arg_tys + + other -> Nothing + splitFunTy :: GenType t u -> ([GenType t u], GenType t u) splitFunTyExpandingDicts :: Type -> ([Type], Type) @@ -266,6 +311,13 @@ splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type) splitFunTy t = split_fun_ty getFunTy_maybe t splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t + -- This "peeking" stuff is used only by the code generator. + -- It's interested in the representation type of things, ignoring: + -- newtype Why??? Nuked SLPJ May 97. We may not know the + -- rep of an abstractly imported newtype + -- foralls + -- expanding dictionary reps + -- synonyms, of course split_fun_ty get t = go t [] where @@ -333,14 +385,15 @@ mkRhoTy theta ty = splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u) splitRhoTy t = - go t [] + go t t [] where - go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts) - go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts + -- See notes on type synonyms above + go syn_t (FunTy (DictTy c t _) r _) ts = go r r ((c,t):ts) + go syn_t (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts | isFunTyCon tycon - = go r ((c,t):ts) - go (SynTy _ _ t) ts = go t ts - go t ts = (reverse ts, t) + = go r r ((c,t):ts) + go syn_t (SynTy _ _ t) ts = go syn_t t ts + go syn_t t ts = (reverse ts, syn_t) mkTheta :: [Type] -> ThetaType @@ -376,12 +429,21 @@ getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t) getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty) getForAllTyExpandingDicts_maybe _ = Nothing -splitForAllTy :: GenType t u-> ([t], GenType t u) -splitForAllTy t = go t [] +splitForAllTy :: GenType t u -> ([t], GenType t u) +splitForAllTy t = go t t [] where - go (ForAllTy tv t) tvs = go t (tv:tvs) - go (SynTy _ _ t) tvs = go t tvs - go t tvs = (reverse tvs, t) + -- See notes on type synonyms above + go syn_t (ForAllTy tv t) tvs = go t t (tv:tvs) + go syn_t (SynTy _ _ t) tvs = go syn_t t tvs + go syn_t t tvs = (reverse tvs, syn_t) + +splitForAllTyExpandingDicts :: Type -> ([TyVar], Type) +splitForAllTyExpandingDicts ty + = go [] ty + where + go tvs ty = case getForAllTyExpandingDicts_maybe ty of + Just (tv, ty') -> go (tv:tvs) ty' + Nothing -> (reverse tvs, ty) \end{code} \begin{code} @@ -407,7 +469,7 @@ maybeAppTyCon ty Nothing -> Nothing Just tycon -> Just (tycon, arg_tys) where - (app_ty, arg_tys) = splitAppTy ty + (app_ty, arg_tys) = splitAppTys ty getAppTyCon @@ -425,6 +487,8 @@ getAppTyCon ty Applied data tycons (give back constrs) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nota Bene: all these functions suceed for @newtype@ applications too! + \begin{code} maybeAppDataTyCon :: GenType (GenTyVar any) uvar @@ -442,11 +506,10 @@ maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty maybe_app_data_tycon expand ty = let expanded_ty = expand ty - (app_ty, arg_tys) = splitAppTy expanded_ty + (app_ty, arg_tys) = splitAppTys expanded_ty in case (getTyCon_maybe app_ty) of - Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $ - isDataTyCon tycon && + Just tycon | isAlgTyCon tycon && -- NB "Alg"; succeeds for newtype too notArrowKind (typeKind expanded_ty) -- Must be saturated for ty to be a data type -> Just (tycon, arg_tys, tyConDataCons tycon) @@ -480,8 +543,8 @@ get_app_data_tycon maybe ty maybeBoxedPrimType :: Type -> Maybe (Id, Type) maybeBoxedPrimType ty - = case (maybeAppDataTyCon ty) of -- Data type, - Just (tycon, tys_applied, [data_con]) -- with exactly one constructor + = case (maybeAppDataTyCon ty) of -- Data type, + Just (tycon, tys_applied, [data_con]) | isDataTyCon tycon -- with exactly one constructor -> case (dataConArgTys data_con tys_applied) of [data_con_arg_ty] -- Applied to exactly one type, | isPrimType data_con_arg_ty -- which is primitive @@ -534,19 +597,35 @@ tyVarsOfType (ForAllUsageTy _ _ ty) = tyVarsOfType ty tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys + +-- Find the free names of a type, including the type constructors and classes it mentions +namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet +namesOfType (TyVarTy tv) = unitNameSet (getName tv) +namesOfType (TyConTy tycon usage) = unitNameSet (getName tycon) +namesOfType (SynTy tycon tys ty) = unitNameSet (getName tycon) `unionNameSets` + namesOfType ty +namesOfType (FunTy arg res _) = namesOfType arg `unionNameSets` namesOfType res +namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg +namesOfType (DictTy clas ty _) = unitNameSet (getName clas) `unionNameSets` + namesOfType ty +namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar) +namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage" \end{code} Instantiating a type ~~~~~~~~~~~~~~~~~~~~ \begin{code} -applyTy :: GenType (GenTyVar flexi) uvar - -> GenType (GenTyVar flexi) uvar - -> GenType (GenTyVar flexi) uvar +-- applyTy :: GenType (GenTyVar flexi) uvar +-- -> GenType (GenTyVar flexi) uvar +-- -> GenType (GenTyVar flexi) uvar + +applyTy :: Type -> Type -> Type -applyTy (SynTy _ _ fun) arg = applyTy fun arg -applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty -applyTy other arg = panic "applyTy" +applyTy (SynTy _ _ fun) arg = applyTy fun arg +applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty +applyTy ty@(DictTy _ _ _) arg = applyTy (expandTy ty) arg +applyTy other arg = panic "applyTy" \end{code} \begin{code} @@ -585,6 +664,8 @@ instant_help ty lookup_tv deflt_tv choose_tycon else \x->x) ForAllTy (deflt_forall_tv tv) (go ty) +instantiateTy [] ty = ty + instantiateTy tenv ty = instant_help ty lookup_tv deflt_tv choose_tycon if_usage if_forall bound_forall_tv_BAD deflt_forall_tv @@ -713,7 +794,9 @@ tc_primrep_list ,(stablePtrPrimTyConKey, StablePtrRep) ,(statePrimTyConKey, VoidRep) ,(synchVarPrimTyConKey, PtrRep) - ,(voidTyConKey, VoidRep) + ,(voidTyConKey, PtrRep) -- Not VoidRep! That's just for Void# + -- The type Void is represented by a pointer to + -- a bottom closure. ,(wordPrimTyConKey, WordRep) ] \end{code} @@ -900,3 +983,53 @@ eqTy t1 t2 = eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2 eqBounds uve _ _ = False \end{code} + +\begin{code} +showTypeCategory :: Type -> Char + {- + {C,I,F,D} char, int, float, double + T tuple + S other single-constructor type + {c,i,f,d} unboxed ditto + t *unpacked* tuple + s *unpacked" single-cons... + + v void# + a primitive array + + E enumeration type + + dictionary, unless it's a ... + L List + > function + M other (multi-constructor) data-con type + . other type + - reserved for others to mark as "uninteresting" + -} +showTypeCategory ty + = if isDictTy ty + then '+' + else + case getTyCon_maybe ty of + Nothing -> if maybeToBool (getFunTy_maybe ty) + then '>' + else '.' + + Just tycon -> + let utc = uniqueOf tycon in + if utc == charDataConKey then 'C' + else if utc == intDataConKey then 'I' + else if utc == floatDataConKey then 'F' + else if utc == doubleDataConKey then 'D' + else if utc == integerDataConKey then 'J' + else if utc == charPrimTyConKey then 'c' + else if (utc == intPrimTyConKey || utc == wordPrimTyConKey + || utc == addrPrimTyConKey) then 'i' + else if utc == floatPrimTyConKey then 'f' + else if utc == doublePrimTyConKey then 'd' + else if isPrimTyCon tycon {- array, we hope -} then 'A' + else if isEnumerationTyCon tycon then 'E' + else if isTupleTyCon tycon then 'T' + else if maybeToBool (maybeTyConSingleCon tycon) then 'S' + else if utc == listTyConKey then 'L' + else 'M' -- oh, well... +\end{code}