X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypes%2FTyCon.lhs;h=6f1ac543aab7dfc6b6dc3cb08e451bf3fd37646b;hb=fa6b1e4523a9d8a1fe85a95e5c69e767746cbe7d;hp=14180b22036bcecf6d4cf106d7eb6646a55c65b2;hpb=30b5ebe424ebae69b162ac3fc547eb14d898535f;p=ghc-hetmet.git diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 14180b2..6f1ac54 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,15 +5,24 @@ \begin{code} module TyCon( - TyCon, KindCon, SuperKindCon, ArgVrcs, + TyCon, KindCon, SuperKindCon, ArgVrcs, + + AlgTyConFlavour(..), + DataConDetails(..), visibleDataCons, isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, + isEnumerationTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, + isRecursiveTyCon, newTyConRep, + + mkForeignTyCon, isForeignTyCon, mkAlgTyCon, + mkClassTyCon, mkFunTyCon, mkPrimTyCon, + mkLiftedPrimTyCon, mkTupleTyCon, mkSynTyCon, mkKindCon, @@ -21,40 +30,46 @@ module TyCon( setTyConName, + tyConName, tyConKind, tyConUnique, tyConTyVars, tyConArgVrcs_maybe, - tyConDataCons, - tyConFamilySize, - tyConDerivings, + tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, + tyConSelIds, tyConTheta, tyConPrimRep, tyConArity, - tyConClass_maybe, + isClassTyCon, tyConClass_maybe, getSynTyConDefn, maybeTyConSingleCon, - matchesTyCon + matchesTyCon, + + -- Generics + tyConGenIds, tyConGenInfo ) where #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 ( Class ) -import Var ( TyVar ) -import BasicTypes ( Arity, NewOrData(..), RecFlag(..) ) -import Maybes + +import Var ( TyVar, Id ) +import Class ( Class ) +import BasicTypes ( Arity, RecFlag(..), Boxity(..), + isBoxed, EP(..) ) import Name ( Name, nameUnique, NamedThing(getName) ) -import Unique ( Unique, Uniquable(..), anyBoxConKey ) +import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) import PrimRep ( PrimRep(..), isFollowableRep ) +import Maybes ( orElse ) import Outputable +import FastString \end{code} %************************************************************************ @@ -83,36 +98,40 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], - dataTyConTheta :: [(Class,[Type])], - dataTyConArgVrcs :: ArgVrcs, - - 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 - - dataTyConDerivings :: [Class], -- Classes which have derived instances - - dataTyConClass_maybe :: (Maybe Class), -- Nothing for ordinary types; - -- Just c for the type constructor - -- for dictionaries of class c. - algTyConFlavour :: NewOrData, - algTyConRec :: RecFlag -- Tells whether the data type is part of - -- a mutually-recursive group or not + tyConTyVars :: [TyVar], + tyConArgVrcs :: ArgVrcs, + algTyConTheta :: [PredType], + + dataCons :: DataConDetails DataCon, + + selIds :: [Id], -- Its record selectors (if any) + + algTyConFlavour :: AlgTyConFlavour, + 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 :: 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, - primTyConArgVrcs :: ArgVrcs, - primTyConRep :: PrimRep + tyConArgVrcs :: ArgVrcs, + 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 { @@ -121,9 +140,10 @@ data TyCon tyConName :: Name, tyConKind :: Kind, tyConArity :: Arity, - tyConBoxed :: Bool, -- True for boxed; False for unboxed + tyConBoxed :: Boxity, tyConTyVars :: [TyVar], - dataCon :: DataCon + dataCon :: DataCon, + genInfo :: Maybe (EP Id) -- Generic type and conv funs } | SynTyCon { @@ -136,7 +156,7 @@ data TyCon synTyConDefn :: Type, -- Right-hand side, mentioning these type vars. -- Acts as a template for the expansion when -- the tycon is applied to some types. - synTyConArgVrcs :: ArgVrcs + tyConArgVrcs :: ArgVrcs } | KindCon { -- Type constructor at the kind level @@ -152,10 +172,44 @@ data TyCon } type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] - -- *NB*: this is tyvar variance info, *not* - -- termvar usage info. + +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 isn't entirely simple: + -- for a recursive newtype we pick () as the rep type + -- newtype T = MkT T + -- + -- The rep type has free type variables the tyConTyVars + -- Thus: + -- newtype T a = MkT [(a,Int)] + -- The rep type is [(a,Int)] + -- NB: the rep type isn't necessarily the original RHS of the + -- newtype decl, because the rep type looks through other + -- newtypes. If you want hte original RHS, look at the + -- argument type of the data constructor. + +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} @@ -192,24 +246,58 @@ mkFunTyCon name kind tyConKind = kind, tyConArity = 2 } - -mkAlgTyCon name kind tyvars theta argvrcs cons derivs maybe_clas flavour rec + +tyConGenInfo :: TyCon -> Maybe (EP Id) +tyConGenInfo (AlgTyCon { genInfo = info }) = info +tyConGenInfo (TupleTyCon { genInfo = info }) = info +tyConGenInfo other = Nothing + +tyConGenIds :: TyCon -> [Id] +-- Returns the generic-programming Ids; these Ids need bindings +tyConGenIds tycon = case tyConGenInfo tycon of + Nothing -> [] + Just (EP from to) -> [from,to] + +-- 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 sels flavour is_rec + gen_info = AlgTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConKind = kind, - tyConArity = length tyvars, - tyConTyVars = tyvars, - dataTyConTheta = theta, - dataTyConArgVrcs = argvrcs, - dataCons = cons, - dataTyConDerivings = derivs, - dataTyConClass_maybe = maybe_clas, - algTyConFlavour = flavour, - algTyConRec = rec + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConArgVrcs = argvrcs, + algTyConTheta = theta, + dataCons = cons, + selIds = sels, + algTyConClass = Nothing, + algTyConFlavour = flavour, + algTyConRec = is_rec, + genInfo = gen_info + } + +mkClassTyCon name kind tyvars argvrcs con clas flavour is_rec + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = length tyvars, + tyConTyVars = tyvars, + tyConArgVrcs = argvrcs, + algTyConTheta = [], + dataCons = DataCons [con], + selIds = [], + algTyConClass = Just clas, + algTyConFlavour = flavour, + algTyConRec = is_rec, + genInfo = Nothing } -mkTupleTyCon name kind arity tyvars con boxed + +mkTupleTyCon name kind arity tyvars con boxed gen_info = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, @@ -217,17 +305,46 @@ mkTupleTyCon name kind arity tyvars con boxed tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, - dataCon = con + dataCon = con, + 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, - primTyConArgVrcs = arg_vrcs, - primTyConRep = rep + tyConName = name, + tyConUnique = nameUnique name, + tyConKind = kind, + tyConArity = arity, + tyConArgVrcs = arg_vrcs, + 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 @@ -238,101 +355,154 @@ mkSynTyCon name kind arity tyvars rhs argvrcs tyConArity = arity, tyConTyVars = tyvars, synTyConDefn = rhs, - synTyConArgVrcs = argvrcs + tyConArgVrcs = argvrcs } setTyConName tc name = tc {tyConName = name, tyConUnique = nameUnique name} + \end{code} \begin{code} +isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True isFunTyCon _ = False +isPrimTyCon :: TyCon -> Bool isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False -isUnLiftedTyCon (PrimTyCon {}) = True -isUnLiftedTyCon (TupleTyCon { tyConBoxed = False }) = True -isUnLiftedTyCon _ = False +isUnLiftedTyCon :: TyCon -> Bool +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 :: TyCon -> Bool isBoxedTyCon (AlgTyCon {}) = True isBoxedTyCon (FunTyCon {}) = True -isBoxedTyCon (TupleTyCon {tyConBoxed = boxed}) = boxed +isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep -- isAlgTyCon returns True for both @data@ and @newtype@ +isAlgTyCon :: TyCon -> Bool 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 - NewType -> False - other -> True -isDataTyCon (TupleTyCon {tyConBoxed = True}) = True +isDataTyCon :: TyCon -> Bool +-- 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}) + = case new_or_data of + NewTyCon _ -> False + other -> True + +isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False -isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True -isNewTyCon other = False +isNewTyCon :: TyCon -> Bool +isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True +isNewTyCon other = False --- A "product" tycon is --- non-recursive --- has one constructor, +isProductTyCon :: TyCon -> Bool +-- A "product" tycon +-- has *one* constructor, -- is *not* existential --- is *not* an unboxed tuple --- whether DataType or NewType -isProductTyCon (AlgTyCon {dataCons = [data_con], algTyConRec = NonRecursive}) - = not (isExistentialDataCon data_con) -isProductTyCon (TupleTyCon { tyConBoxed = boxed }) - = boxed -isProductTyCon other = False - +-- but +-- may be DataType or NewType, +-- may be unboxed or not, +-- may be recursive or not +isProductTyCon (AlgTyCon {dataCons = DataCons [data_con]}) = not (isExistentialDataCon data_con) +isProductTyCon (TupleTyCon {}) = True +isProductTyCon other = False + +isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False -isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumType}) = True -isEnumerationTyCon other = False +isEnumerationTyCon :: TyCon -> Bool +isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True +isEnumerationTyCon other = False --- The unit tycon isn't classed as a tuple tycon -isTupleTyCon (TupleTyCon {tyConArity = arity, tyConBoxed = True}) = arity >= 2 -isTupleTyCon other = False +isTupleTyCon :: TyCon -> Bool +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon (TupleTyCon {}) = True +isTupleTyCon other = False -isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = False}) = True +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnboxedTupleTyCon other = False + +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity +isBoxedTupleTyCon other = False + +tupleTyConBoxity tc = tyConBoxed tc + +isRecursiveTyCon :: TyCon -> Bool +isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True +isRecursiveTyCon other = False + +isForeignTyCon :: TyCon -> Bool +-- 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 (AlgTyCon {dataCons = cons}) = cons -tyConDataCons (TupleTyCon {dataCon = con}) = [con] -tyConDataCons 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. +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +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 {dataCons = cons}) = length cons -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 -tyConPrimRep :: TyCon -> PrimRep -tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep -tyConPrimRep _ = PtrRep +tyConSelIds :: TyCon -> [Id] +tyConSelIds (AlgTyCon {selIds = sels}) = sels +tyConSelIds other_tycon = [] \end{code} \begin{code} -tyConDerivings :: TyCon -> [Class] -tyConDerivings (AlgTyCon {dataTyConDerivings = derivs}) = derivs -tyConDerivings other = [] +newTyConRep :: TyCon -> ([TyVar], Type) +newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep) + +tyConPrimRep :: TyCon -> PrimRep +tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep +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 -> [(Class, [Type])] -tyConTheta (AlgTyCon {dataTyConTheta = theta}) = theta --- should ask about anything else +tyConTheta :: TyCon -> [PredType] +tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta +tyConTheta (TupleTyCon {}) = [] +-- shouldn't ask about anything else \end{code} @tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for @@ -343,10 +513,10 @@ actually computed (in another file). tyConArgVrcs_maybe :: TyCon -> Maybe ArgVrcs tyConArgVrcs_maybe (FunTyCon {} ) = Just [(False,True),(True,False)] -tyConArgVrcs_maybe (AlgTyCon {dataTyConArgVrcs = oi}) = Just oi -tyConArgVrcs_maybe (PrimTyCon {primTyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (AlgTyCon {tyConArgVrcs = oi}) = Just oi +tyConArgVrcs_maybe (PrimTyCon {tyConArgVrcs = oi}) = Just oi tyConArgVrcs_maybe (TupleTyCon {tyConArity = arity }) = Just (replicate arity (True,False)) -tyConArgVrcs_maybe (SynTyCon {synTyConArgVrcs = oi }) = Just oi +tyConArgVrcs_maybe (SynTyCon {tyConArgVrcs = oi }) = Just oi tyConArgVrcs_maybe _ = Nothing \end{code} @@ -357,19 +527,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 = Just _}) = True +isClassTyCon other_tycon = False + tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {dataTyConClass_maybe = maybe_cls}) = maybe_cls -tyConClass_maybe other_tycon = Nothing +tyConClass_maybe (AlgTyCon {algTyConClass = maybe_clas}) = maybe_clas +tyConClass_maybe ther_tycon = Nothing \end{code} @@ -400,7 +573,7 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc instance Outputable TyCon where - ppr tc = ppr (getName tc) + ppr tc = ppr (getName tc) instance NamedThing TyCon where getName = tyConName @@ -427,3 +600,6 @@ matchesTyCon tc1 tc2 = uniq1 == uniq2 || uniq1 == anyBoxConKey uniq1 = tyConUnique tc1 uniq2 = tyConUnique tc2 \end{code} + + +