X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=e38da87182e0c11fd570065b93bd1008915956ec;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=d40619627a2185374231223d0f56075c1e4ccdb8;hpb=5cf27e8f1731c52fe63a5b9615f927484164c61b;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index d406196..e38da87 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -9,10 +9,10 @@ module TyCon( TyCon(..), -- NB: some pals need to see representation - Arity(..), NewOrData(..), + SYN_IE(Arity), NewOrData(..), isFunTyCon, isPrimTyCon, isBoxedTyCon, - isDataTyCon, isSynTyCon, isNewTyCon, + isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon, mkDataTyCon, mkFunTyCon, @@ -28,7 +28,9 @@ module TyCon( tyConDataCons, tyConFamilySize, tyConDerivings, - tyConArity, synTyConArity, + tyConTheta, + tyConPrimRep, + synTyConArity, getSynTyConDefn, maybeTyConSingleCon, @@ -38,15 +40,16 @@ module TyCon( CHK_Ubiq() -- debugging consistency check -import TyLoop ( Type(..), GenType, - Class(..), GenClass, - Id(..), GenId, - mkTupleCon, dataConSig, - specMaybeTysSuffix +IMPORT_DELOOPER(TyLoop) ( SYN_IE(Type), GenType, + SYN_IE(Class), GenClass, + SYN_IE(Id), GenId, + splitSigmaTy, splitFunTy, + mkTupleCon, isNullaryDataCon, idType + --LATER: specMaybeTysSuffix ) -import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar ) -import Usage ( GenUsage, Usage(..) ) +import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, SYN_IE(TyVar) ) +import Usage ( GenUsage, SYN_IE(Usage) ) import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind ) import Maybes @@ -54,12 +57,14 @@ import Name ( Name, RdrName(..), appendRdr, nameUnique, mkTupleTyConName, mkFunTyConName ) import Unique ( Unique, funTyConKey, mkTupleTyConUnique ) -import PrelInfo ( intDataCon, charDataCon ) -import Pretty ( Pretty(..), PrettyRep ) -import PprStyle ( PprStyle ) +import Pretty ( SYN_IE(Pretty), PrettyRep ) +import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) -import Unique ( intDataConKey, charDataConKey ) -import Util ( panic, panic#, nOfThem, isIn, Ord3(..) ) +import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic ) +--import {-hide me-} +-- PprType (pprTyCon) +--import {-hide me-} +-- PprStyle--ToDo:rm \end{code} \begin{code} @@ -90,6 +95,7 @@ data TyCon Unique -- Always unboxed; hence never represented by a closure Name -- Often represented by a bit-pattern for the thing Kind -- itself (eg Int#), but sometimes by a pointer to + PrimRep | SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#) TyCon @@ -127,17 +133,14 @@ mkTupleTyCon arity n = mkTupleTyConName arity u = uniqueOf n -mkDataTyCon name - = DataTyCon (nameUnique name) name -mkPrimTyCon name - = PrimTyCon (nameUnique name) name -mkSynTyCon name - = SynTyCon (nameUnique name) name +mkDataTyCon name = DataTyCon (nameUnique name) name +mkPrimTyCon name = PrimTyCon (nameUnique name) name +mkSynTyCon name = SynTyCon (nameUnique name) name isFunTyCon FunTyCon = True isFunTyCon _ = False -isPrimTyCon (PrimTyCon _ _ _) = True +isPrimTyCon (PrimTyCon _ _ _ _) = True isPrimTyCon _ = False -- At present there are no unboxed non-primitive types, so @@ -150,6 +153,16 @@ isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True isDataTyCon (TupleTyCon _ _ _) = True isDataTyCon other = False +maybeNewTyCon :: TyCon -> Maybe ([TyVar], Type) -- Returns representation type info +maybeNewTyCon (DataTyCon _ _ _ _ _ (con:null_cons) _ NewType) + = ASSERT( null null_cons && null null_tys) + Just (tyvars, rep_ty) + where + (tyvars, theta, tau) = splitSigmaTy (idType con) + (rep_ty:null_tys, res_ty) = splitFunTy tau + +maybeNewTyCon other = Nothing + isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True isNewTyCon other = False @@ -165,7 +178,7 @@ kind2 = mkBoxedTypeKind `mkArrowKind` kind1 tyConKind :: TyCon -> Kind tyConKind FunTyCon = kind2 tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind -tyConKind (PrimTyCon _ _ kind) = kind +tyConKind (PrimTyCon _ _ kind _) = kind tyConKind (SynTyCon _ _ k _ _ _) = k tyConKind (TupleTyCon _ _ n) @@ -190,18 +203,10 @@ tyConUnique :: TyCon -> Unique tyConUnique FunTyCon = funTyConKey tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq tyConUnique (TupleTyCon uniq _ _) = uniq -tyConUnique (PrimTyCon uniq _ _) = uniq +tyConUnique (PrimTyCon uniq _ _ _) = uniq tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" -tyConArity :: TyCon -> Arity -tyConArity FunTyCon = 2 -tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs -tyConArity (TupleTyCon _ _ arity) = arity -tyConArity (PrimTyCon _ _ _) = 0 -- ?? -tyConArity (SpecTyCon _ _) = 0 -tyConArity (SynTyCon _ _ _ arity _ _) = arity - synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity synTyConArity _ = Nothing @@ -213,8 +218,10 @@ tyConTyVars FunTyCon = [alphaTyVar,betaTyVar] tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs -tyConTyVars (PrimTyCon _ _ _) = panic "tyConTyVars:PrimTyCon" +#ifdef DEBUG +tyConTyVars (PrimTyCon _ _ _ _) = panic "tyConTyVars:PrimTyCon" tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon" +#endif \end{code} \begin{code} @@ -230,6 +237,13 @@ tyConDataCons other = [] tyConFamilySize (DataTyCon _ _ _ _ _ data_cons _ _) = length data_cons tyConFamilySize (TupleTyCon _ _ _) = 1 +#ifdef DEBUG +--tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other) +#endif + +tyConPrimRep :: TyCon -> PrimRep +tyConPrimRep (PrimTyCon _ _ _ rep) = rep +tyConPrimRep _ = PtrRep \end{code} \begin{code} @@ -239,6 +253,13 @@ tyConDerivings other = [] \end{code} \begin{code} +tyConTheta :: TyCon -> [(Class,Type)] +tyConTheta (DataTyCon _ _ _ _ theta _ _ _) = theta +tyConTheta (TupleTyCon _ _ _) = [] +-- should ask about anything else +\end{code} + +\begin{code} getSynTyConDefn :: TyCon -> ([TyVar], Type) getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty) \end{code} @@ -249,17 +270,14 @@ maybeTyConSingleCon :: TyCon -> Maybe Id maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon arity) maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing -maybeTyConSingleCon (PrimTyCon _ _ _) = Nothing +maybeTyConSingleCon (PrimTyCon _ _ _ _) = Nothing maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon" -- requires DataCons of TyCon isEnumerationTyCon (TupleTyCon _ _ arity) = arity == 0 isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) - = not (null data_cons) && all is_nullary data_cons - where - is_nullary con = case (dataConSig con) of { (_,_, arg_tys, _) -> - null arg_tys } + = not (null data_cons) && all isNullaryDataCon data_cons \end{code} @derivedFor@ reports if we have an {\em obviously}-derived instance @@ -288,28 +306,7 @@ the property @(a<=b) || (b<=a)@. \begin{code} instance Ord3 TyCon where - cmp FunTyCon FunTyCon = EQ_ - cmp (DataTyCon a _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _) = a `cmp` b - cmp (SynTyCon a _ _ _ _ _) (SynTyCon b _ _ _ _ _) = a `cmp` b - cmp (TupleTyCon _ _ a) (TupleTyCon _ _ b) = a `cmp` b - cmp (PrimTyCon a _ _) (PrimTyCon b _ _) = a `cmp` b - cmp (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2) - = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx } - - -- now we *know* the tags are different, so... - cmp other_1 other_2 - | tag1 _LT_ tag2 = LT_ - | otherwise = GT_ - where - tag1 = tag_TyCon other_1 - tag2 = tag_TyCon other_2 - - tag_TyCon FunTyCon = ILIT(1) - tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2) - tag_TyCon (TupleTyCon _ _ _) = ILIT(3) - tag_TyCon (PrimTyCon _ _ _) = ILIT(4) - tag_TyCon (SpecTyCon _ _) = ILIT(5) - tag_TyCon (SynTyCon _ _ _ _ _ _) = ILIT(6) + cmp tc1 tc2 = uniqueOf tc1 `cmp` uniqueOf tc2 instance Eq TyCon where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } @@ -325,7 +322,7 @@ instance Ord TyCon where instance Uniquable TyCon where uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u uniqueOf (TupleTyCon u _ _) = u - uniqueOf (PrimTyCon u _ _) = u + uniqueOf (PrimTyCon u _ _ _) = u uniqueOf (SynTyCon u _ _ _ _ _) = u uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon" uniqueOf tc = uniqueOf (getName tc) @@ -334,7 +331,7 @@ instance Uniquable TyCon where \begin{code} instance NamedThing TyCon where getName (DataTyCon _ n _ _ _ _ _ _) = n - getName (PrimTyCon _ n _) = n + getName (PrimTyCon _ n _ _) = n getName (SpecTyCon tc _) = getName tc getName (SynTyCon _ n _ _ _ _) = n getName FunTyCon = mkFunTyConName @@ -342,7 +339,7 @@ instance NamedThing TyCon where getName tc = panic "TyCon.getName" {- LATER: - getName (SpecTyCon tc tys) = let (m,n) = moduleNamePair tc in + getName (SpecTyCon tc tys) = let (OrigName m n) = origName "????" tc in (m, n _APPEND_ specMaybeTysSuffix tys) getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc)) getName other = Nothing