dataConRepType, dataConSig, dataConFullSig,
dataConName, dataConTag, dataConTyCon, dataConUserType,
dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
- dataConEqSpec, dataConTheta, dataConStupidTheta,
+ dataConInstTys,
+ dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta,
dataConInstArgTys, dataConOrigArgTys,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon,
- splitProductType_maybe, splitProductType,
+ splitProductType_maybe, splitProductType, deepSplitProductType,
+ deepSplitProductType_maybe
) where
#include "HsVersions.h"
import Type ( Type, ThetaType,
substTyWith, substTyVar, mkTopTvSubst,
mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys,
- splitTyConApp_maybe,
- mkPredTys, isStrictPred, pprType
+ splitTyConApp_maybe, newTyConInstRhs,
+ mkPredTys, isStrictPred, pprType, mkPredTy
)
import Coercion ( isEqPred, mkEqPred )
import TyCon ( TyCon, FieldLabel, tyConDataCons,
isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
- isNewTyCon )
+ isNewTyCon, isRecursiveTyCon, tyConFamily_maybe )
import Class ( Class, classTyCon )
-import Name ( Name, NamedThing(..), nameUnique )
-import Var ( TyVar, Id )
+import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName )
+import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique,
+ mkCoVar )
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
import Util ( zipEqual, zipWithEqual )
import List ( partition )
import Maybes ( expectJust )
+import FastString
\end{code}
The data con has one or two Ids associated with it:
- The "worker Id", is the actual data constructor.
- Its type may be different to the Haskell source constructor
- because:
- - useless dict args are dropped
- - strict args may be flattened
- The worker is very like a primop, in that it has no binding.
+The "worker Id", is the actual data constructor.
+* Every data constructor (newtype or data type) has a worker
- Newtypes have no worker Id
+* The worker is very like a primop, in that it has no binding.
+* For a *data* type, the worker *is* the data constructor;
+ it has no unfolding
- The "wrapper Id", $WC, whose type is exactly what it looks like
- in the source program. It is an ordinary function,
- and it gets a top-level binding like any other function.
+* For a *newtype*, the worker has a compulsory unfolding which
+ does a cast, e.g.
+ newtype T = MkT Int
+ The worker for MkT has unfolding
+ \(x:Int). x `cast` sym CoT
+ Here CoT is the type constructor, witnessing the FC axiom
+ axiom CoT : T = Int
- The wrapper Id isn't generated for a data type if the worker
- and wrapper are identical. It's always generated for a newtype.
+The "wrapper Id", $WC, goes as follows
+
+* Its type is exactly what it looks like in the source program.
+
+* It is an ordinary function, and it gets a top-level binding
+ like any other function.
+
+* The wrapper Id isn't generated for a data type if there is
+ nothing for the wrapper to do. That is, if its defn would be
+ $wC = C
+
+Why might the wrapper have anything to do? Two reasons:
+
+* Unboxing strict fields (with -funbox-strict-fields)
+ data T = MkT !(Int,Int)
+ $wMkT :: (Int,Int) -> T
+ $wMkT (x,y) = MkT x y
+ Notice that the worker has two fields where the wapper has
+ just one. That is, the worker has type
+ MkT :: Int -> Int -> T
+
+* Equality constraints for GADTs
+ data T a where { MkT :: a -> T [a] }
+
+ The worker gets a type with explicit equality
+ constraints, thus:
+ MkT :: forall a b. (a=[b]) => b -> T a
+
+ The wrapper has the programmer-specified type:
+ $wMkT :: a -> T [a]
+ $wMkT a x = MkT [a] a [a] x
+ The third argument is a coerion
+ [a] :: [a]:=:[a]
-- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds,
- dcInfix :: Bool -- True <=> declared infix
+ dcInfix :: Bool, -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
+
+ dcInstTys :: Maybe [Type] -- If this data constructor is part of a
+ -- data instance, then these are the type
+ -- patterns of the instance.
}
data DataConIds
- = NewDC Id -- Newtypes have only a wrapper, but no worker
- | AlgDC (Maybe Id) Id -- Algebraic data types always have a worker, and
+ = DCIds (Maybe Id) Id -- Algebraic data types always have a worker, and
-- may or may not have a wrapper, depending on whether
- -- the wrapper does anything.
+ -- the wrapper does anything. Newtypes just have a worker
-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
-- The worker takes dcRepArgTys as its arguments
-- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys
- -- The 'Nothing' case of AlgDC is important
+ -- The 'Nothing' case of DCIds is important
-- Not only is this efficient,
-- but it also ensures that the wrapper is replaced
-- by the worker (becuase it *is* the wroker)
-> [TyVar] -> [TyVar]
-> [(TyVar,Type)] -> ThetaType
-> [Type] -> TyCon
+ -> Maybe [Type]
-> ThetaType -> DataConIds
-> DataCon
-- Can get the tag from the TyCon
univ_tvs ex_tvs
eq_spec theta
orig_arg_tys tycon
+ mb_typats
stupid_theta ids
- = con
+ = ASSERT( not (any isEqPred theta) )
+ -- We don't currently allow any equality predicates on
+ -- a data constructor (apart from the GADT ones in eq_spec)
+ con
where
is_vanilla = null ex_tvs && null eq_spec && null theta
con = ASSERT( is_vanilla || not (isNewTyCon tycon) )
dcStupidTheta = stupid_theta, dcTheta = theta,
dcOrigArgTys = orig_arg_tys, dcTyCon = tycon,
dcRepArgTys = rep_arg_tys,
- dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts,
+ dcStrictMarks = arg_stricts,
+ dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = ty,
- dcIds = ids }
+ dcIds = ids,
+ dcInstTys = mb_typats }
-- Strictness marks for source-args
-- *after unboxing choices*,
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
- (more_eq_preds, dict_preds) = partition isEqPred theta
dict_tys = mkPredTys theta
real_arg_tys = dict_tys ++ orig_arg_tys
- real_stricts = map mk_dict_strict_mark dict_preds ++ arg_stricts
+ real_stricts = map mk_dict_strict_mark theta ++ arg_stricts
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
- AlgDC _ wrk_id -> wrk_id
- NewDC _ -> pprPanic "dataConWorkId" (ppr dc)
+ DCIds _ wrk_id -> wrk_id
dataConWrapId_maybe :: DataCon -> Maybe Id
-- Returns Nothing if there is no wrapper for an algebraic data con
-- and also for a newtype (whose constructor is inlined compulsorily)
dataConWrapId_maybe dc = case dcIds dc of
- AlgDC mb_wrap _ -> mb_wrap
- NewDC wrap -> Nothing
+ DCIds mb_wrap _ -> mb_wrap
dataConWrapId :: DataCon -> Id
-- Returns an Id which looks like the Haskell-source constructor
dataConWrapId dc = case dcIds dc of
- AlgDC (Just wrap) _ -> wrap
- AlgDC Nothing wrk -> wrk -- worker=wrapper
- NewDC wrap -> wrap
+ DCIds (Just wrap) _ -> wrap
+ DCIds Nothing wrk -> wrk -- worker=wrapper
dataConImplicitIds :: DataCon -> [Id]
dataConImplicitIds dc = case dcIds dc of
- AlgDC (Just wrap) work -> [wrap,work]
- AlgDC Nothing work -> [work]
- NewDC wrap -> [wrap]
+ DCIds (Just wrap) work -> [wrap,work]
+ DCIds Nothing work -> [work]
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels = dcFields
where
env = mkTopTvSubst (dcEqSpec dc)
+dataConInstTys :: DataCon -> Maybe [Type]
+dataConInstTys = dcInstTys
+
dataConUserType :: DataCon -> Type
-- The user-declared type of the data constructor
-- in the nice-to-read form
-- T :: forall a. a -> T [a]
-- rather than
-- T :: forall b. forall a. (a=[b]) => a -> T b
+-- NB: If the constructor is part of a data instance, the result type
+-- mentions the family tycon, not the internal one.
dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
dcTheta = theta, dcOrigArgTys = arg_tys,
- dcTyCon = tycon })
+ dcTyCon = tycon, dcInstTys = mb_insttys })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys (mkPredTys theta) $
mkFunTys arg_tys $
- mkTyConApp tycon (map (substTyVar subst) univ_tvs)
+ case mb_insttys of
+ Nothing -> mkTyConApp tycon (map (substTyVar subst) univ_tvs)
+ Just insttys -> mkTyConApp ftycon insttys -- data instance
+ where
+ ftycon = case tyConFamily_maybe tycon of
+ Just ftycon -> ftycon
+ Nothing -> panic err
+ err = "dataConUserType: type patterns without family tycon"
where
subst = mkTopTvSubst eq_spec
where
tyvars = univ_tvs ++ ex_tvs
+
-- And the same deal for the original arg tys
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
-dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys,
+dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dcUnivTyVars = univ_tvs,
dcExTyVars = ex_tvs}) inst_tys
- = ASSERT( length tyvars == length inst_tys )
+ = ASSERT2( length tyvars == length inst_tys, ptext SLIT("dataConInstOrigArgTys") <+> ppr dc <+> ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = univ_tvs ++ ex_tvs
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+deepSplitProductType_maybe ty
+ = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
+ ; let {result
+ | isNewTyCon tycon && not (isRecursiveTyCon tycon)
+ = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args)
+ | isNewTyCon tycon = Nothing -- cannot unbox through recursive newtypes
+ | otherwise = Just res}
+ ; result
+ }
+
+deepSplitProductType str ty
+ = case deepSplitProductType_maybe ty of
+ Just stuff -> stuff
+ Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
+
computeRep :: [StrictnessMark] -- Original arg strictness
-> [Type] -- and types
-> ([StrictnessMark], -- Representation arg strictness
unbox NotMarkedStrict ty = [(NotMarkedStrict, ty)]
unbox MarkedStrict ty = [(MarkedStrict, ty)]
unbox MarkedUnboxed ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
- where
- (_, _, arg_dc, arg_tys) = splitProductType "unbox_strict_arg_ty" ty
+ where
+ (tycon, tycon_args, arg_dc, arg_tys)
+ = deepSplitProductType "unbox_strict_arg_ty" ty
\end{code}
projects / ghc-hetmet.git / blobdiff