X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=8a03de11aa8549ae0fec702f7ce0ac3810e2018e;hb=711e4d7a4d65472a3a1fb35bcad8e1c9a109c728;hp=5592d0014114ef904440cf13840e21cd28f444a2;hpb=c271b64780a6504e7ccd4cc422dfc90678ea966f;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 5592d00..8a03de1 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,7 +5,10 @@ \begin{code} module TyCon( - TyCon, KindCon, SuperKindCon, ArgVrcs, AlgTyConFlavour(..), + TyCon, KindCon, SuperKindCon, ArgVrcs, + + AlgTyConFlavour(..), + DataConDetails(..), visibleDataCons, isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, @@ -13,10 +16,13 @@ module TyCon( isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, - mkAlgTyCon, --mkAlgTyCon, + mkForeignTyCon, isForeignTyCon, + + mkAlgTyCon, mkClassTyCon, mkFunTyCon, mkPrimTyCon, + mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, mkKindCon, @@ -29,12 +35,12 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs_maybe, - tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize, + tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, tyConTheta, tyConPrimRep, tyConArity, - isClassTyCon, + isClassTyCon, tyConClass_maybe, getSynTyConDefn, maybeTyConSingleCon, @@ -47,21 +53,24 @@ module TyCon( #include "HsVersions.h" -import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind ) +import {-# SOURCE #-} TypeRep ( Type, PredType, Kind, SuperKind ) -- Should just be Type(Type), but this fails due to bug present up to -- and including 4.02 involving slurping of hi-boot files. Bug is now fixed. import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon ) -import Class ( ClassContext ) import Var ( TyVar, Id ) +import Class ( Class ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, EP(..) ) import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) import PrimRep ( PrimRep(..), isFollowableRep ) +import Util ( lengthIs ) +import Maybes ( expectJust ) import Outputable +import FastString \end{code} %************************************************************************ @@ -92,45 +101,38 @@ data TyCon tyConTyVars :: [TyVar], tyConArgVrcs :: ArgVrcs, - algTyConTheta :: ClassContext, + algTyConTheta :: [PredType], - dataCons :: [DataCon], - -- Its data constructors, with fully polymorphic types - -- This list can be empty, when we import a data type abstractly, - -- either (a) the interface is hand-written and doesn't give - -- the constructors, or - -- (b) in a quest for fast compilation we don't import - -- the constructors + dataCons :: DataConDetails DataCon, selIds :: [Id], -- Its record selectors (if any) - noOfDataCons :: Int, -- Number of data constructors - -- Usually this is the same as the length of the - -- dataCons field, but the latter may be empty if - -- we imported the type abstractly. But even if we import - -- abstractly we still need to know the number of constructors - -- so we can get the return convention right. Tiresome! - algTyConFlavour :: AlgTyConFlavour, - algTyConRec :: RecFlag, -- Tells whether the data type is part of - -- a mutually-recursive group or not + algTyConRec :: RecFlag, -- Tells whether the data type is part of + -- a mutually-recursive group or not genInfo :: Maybe (EP Id), -- Convert T <-> Tring -- Some TyCons don't have it; -- e.g. the TyCon for a Class dictionary, -- and TyCons with unboxed arguments - algTyConClass :: Bool -- True if this tycon comes from a class declaration + algTyConClass :: Maybe Class + -- Just cl if this tycon came from a class declaration } - | PrimTyCon { -- Primitive types; cannot be defined in Haskell - -- NB: All of these guys are *unlifted*, but not all are *unboxed* + | PrimTyCon { -- Primitive types; cannot be defined in Haskell + -- Now includes foreign-imported types tyConUnique :: Unique, tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, tyConArgVrcs :: ArgVrcs, - primTyConRep :: PrimRep + primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are + -- boxed (represented by pointers). The PrimRep tells. + + isUnLifted :: Bool, -- Most primitive tycons are unlifted, + -- but foreign-imported ones may not be + tyConExtName :: Maybe FastString } | TupleTyCon { @@ -174,21 +176,38 @@ type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] data AlgTyConFlavour = DataTyCon -- Data type + | EnumTyCon -- Special sort of enumeration type + | NewTyCon Type -- Newtype, with its *ultimate* representation type -- By 'ultimate' I mean that the rep type is not itself -- a newtype or type synonym. - -- The rep type has explicit for-alls for the tyvars of - -- the TyCon. Thus: + -- The rep type has free type variables the tyConTyVars + -- Thus: -- newtype T a = MkT [(a,Int)] - -- The rep type is forall a. [(a,Int)] + -- The rep type is [(a,Int)] -- -- The rep type isn't entirely simple: -- for a recursive newtype we pick () as the rep type -- newtype T = MkT T + +data DataConDetails datacon + = DataCons [datacon] -- Its data constructors, with fully polymorphic types + -- A type can have zero constructors + + | Unknown -- We're importing this data type from an hi-boot file + -- and we don't know what its constructors are + + | HasCons Int -- In a quest for compilation speed we have imported + -- only the number of constructors (to get return + -- conventions right) but not the constructors themselves + +visibleDataCons (DataCons cs) = cs +visibleDataCons other = [] \end{code} + %************************************************************************ %* * \subsection{TyCon Construction} @@ -240,7 +259,7 @@ tyConGenIds tycon = case tyConGenInfo tycon of -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour rec gen_info = AlgTyCon { tyConName = name, @@ -252,14 +271,13 @@ mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec algTyConTheta = theta, dataCons = cons, selIds = sels, - noOfDataCons = ncons, - algTyConClass = False, + algTyConClass = Nothing, algTyConFlavour = flavour, algTyConRec = rec, genInfo = gen_info } -mkClassTyCon name kind tyvars argvrcs con clas flavour +mkClassTyCon name kind tyvars argvrcs con clas flavour rec = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -268,12 +286,11 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour tyConTyVars = tyvars, tyConArgVrcs = argvrcs, algTyConTheta = [], - dataCons = [con], + dataCons = DataCons [con], selIds = [], - noOfDataCons = 1, - algTyConClass = True, + algTyConClass = Just clas, algTyConFlavour = flavour, - algTyConRec = NonRecursive, + algTyConRec = rec, genInfo = Nothing } @@ -290,14 +307,42 @@ mkTupleTyCon name kind arity tyvars con boxed gen_info genInfo = gen_info } -mkPrimTyCon name kind arity arg_vrcs rep +-- Foreign-imported (.NET) type constructors are represented +-- as primitive, but *lifted*, TyCons for now. They are lifted +-- because the Haskell type T representing the (foreign) .NET +-- type T is actually implemented (in ILX) as a thunk +-- They have PtrRep +mkForeignTyCon name ext_name kind arity arg_vrcs = PrimTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = arity, + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = arity, tyConArgVrcs = arg_vrcs, - primTyConRep = rep + primTyConRep = PtrRep, + isUnLifted = False, + tyConExtName = ext_name + } + + +-- most Prim tycons are lifted +mkPrimTyCon name kind arity arg_vrcs rep + = mkPrimTyCon' name kind arity arg_vrcs rep True + +-- but RealWorld is lifted +mkLiftedPrimTyCon name kind arity arg_vrcs rep + = mkPrimTyCon' name kind arity arg_vrcs rep False + +mkPrimTyCon' name kind arity arg_vrcs rep is_unlifted + = PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = arity, + tyConArgVrcs = arg_vrcs, + primTyConRep = rep, + isUnLifted = is_unlifted, + tyConExtName = Nothing } mkSynTyCon name kind arity tyvars rhs argvrcs @@ -322,9 +367,9 @@ isFunTyCon _ = False isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False -isUnLiftedTyCon (PrimTyCon {}) = True -isUnLiftedTyCon (TupleTyCon { tyConBoxed = boxity}) = not (isBoxed boxity) -isUnLiftedTyCon _ = False +isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted +isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) +isUnLiftedTyCon _ = False -- isBoxedTyCon should not be applied to SynTyCon, nor KindCon isBoxedTyCon (AlgTyCon {}) = True @@ -337,18 +382,26 @@ isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = False --- isDataTyCon returns False for @newtype@ and for unboxed tuples -isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of - NewTyCon _ -> False - other -> True +-- isDataTyCon returns True for data types that are represented by +-- heap-allocated constructors. +-- These are srcutinised by Core-level @case@ expressions, and they +-- get info tables allocated for them. +-- True for all @data@ types +-- False for newtypes +-- unboxed tuples +isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data, algTyConRec = is_rec}) + = case new_or_data of + NewTyCon _ -> False + other -> True + isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True isNewTyCon other = False -newTyConRep (AlgTyCon {algTyConFlavour = NewTyCon rep}) = Just rep -newTyConRep other = Nothing +newTyConRep :: TyCon -> ([TyVar], Type) +newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep) -- A "product" tycon -- has *one* constructor, @@ -357,9 +410,9 @@ newTyConRep other = Nothing -- may be DataType or NewType, -- may be unboxed or not, -- may be recursive or not -isProductTyCon (AlgTyCon {dataCons = [data_con]}) = not (isExistentialDataCon data_con) -isProductTyCon (TupleTyCon {}) = True -isProductTyCon other = False +isProductTyCon (AlgTyCon {dataCons = DataCons [data_con]}) = not (isExistentialDataCon data_con) +isProductTyCon (TupleTyCon {}) = True +isProductTyCon other = False isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False @@ -383,24 +436,31 @@ tupleTyConBoxity tc = tyConBoxed tc isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True isRecursiveTyCon other = False + +-- isForeignTyCon identifies foreign-imported type constructors +-- For the moment, they are primitive but lifted, but that may change +isForeignTyCon (PrimTyCon {isUnLifted = is_unlifted}) = not is_unlifted +isForeignTyCon other = False \end{code} \begin{code} +tyConDataConDetails :: TyCon -> DataConDetails DataCon +tyConDataConDetails (AlgTyCon {dataCons = cons}) = cons +tyConDataConDetails (TupleTyCon {dataCon = con}) = DataCons [con] +tyConDataConDetails other = Unknown + tyConDataCons :: TyCon -> [DataCon] -tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) cons - where - cons = tyConDataConsIfAvailable tycon +tyConDataCons tycon = expectJust "tyConDataCons" (tyConDataCons_maybe tycon) -tyConDataConsIfAvailable (AlgTyCon {dataCons = cons}) = cons -- Empty for abstract types -tyConDataConsIfAvailable (TupleTyCon {dataCon = con}) = [con] -tyConDataConsIfAvailable other = [] - -- You may think this last equation should fail, - -- but it's quite convenient to return no constructors for - -- a synonym; see for example the call in TcTyClsDecls. +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (AlgTyCon {dataCons = DataCons cons}) = Just cons +tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] +tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {noOfDataCons = n}) = n -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {dataCons = DataCons cs}) = length cs +tyConFamilySize (AlgTyCon {dataCons = HasCons n}) = n +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -413,13 +473,17 @@ tyConSelIds other_tycon = [] \begin{code} tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep -tyConPrimRep _ = PtrRep +tyConPrimRep tc = ASSERT( not (isUnboxedTupleTyCon tc) ) + PtrRep + -- We should not be asking what the representation of an + -- unboxed tuple is, because it isn't a first class value. \end{code} \begin{code} -tyConTheta :: TyCon -> ClassContext +tyConTheta :: TyCon -> [PredType] tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta --- should ask about anything else +tyConTheta (TupleTyCon {}) = [] +-- shouldn't ask about anything else \end{code} @tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for @@ -444,19 +508,22 @@ getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,t \begin{code} maybeTyConSingleCon :: TyCon -> Maybe DataCon -maybeTyConSingleCon (AlgTyCon {dataCons = [c]}) = Just c -maybeTyConSingleCon (AlgTyCon {}) = Nothing -maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con -maybeTyConSingleCon (PrimTyCon {}) = Nothing -maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty -maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ - ppr tc +maybeTyConSingleCon (AlgTyCon {dataCons = DataCons [c]}) = Just c +maybeTyConSingleCon (AlgTyCon {}) = Nothing +maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con +maybeTyConSingleCon (PrimTyCon {}) = Nothing +maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty +maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc \end{code} \begin{code} isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTyConClass = is_class_tycon}) = is_class_tycon -isClassTyCon other_tycon = False +isClassTyCon (AlgTyCon {algTyConClass = Just _}) = True +isClassTyCon other_tycon = False + +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (AlgTyCon {algTyConClass = maybe_clas}) = maybe_clas +tyConClass_maybe ther_tycon = Nothing \end{code}