X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FDataCon.lhs;h=0fb7fae87bd61fd7f209d929dad180185620a178;hp=3eaadf759f533dbebeab04783778737ebd0b900c;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=d5bba9ee196f64a077e922680b16fe6f28fb79db diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 3eaadf7..0fb7fae 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1998 % \section[DataCon]{@DataCon@: Data Constructors} @@ -11,7 +12,7 @@ module DataCon ( dataConRepType, dataConSig, dataConFullSig, dataConName, dataConTag, dataConTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys, - dataConEqSpec, dataConTheta, dataConStupidTheta, + dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConInstOrigArgTys, dataConRepArgTys, dataConFieldLabels, dataConFieldType, @@ -23,31 +24,25 @@ module DataCon ( 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 - ) -import Coercion ( isEqPred, mkEqPred ) -import TyCon ( TyCon, FieldLabel, tyConDataCons, - isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, - isNewTyCon ) -import Class ( Class, classTyCon ) -import Name ( Name, NamedThing(..), nameUnique ) -import Var ( TyVar, Id ) -import BasicTypes ( Arity, StrictnessMark(..) ) +import Type +import Coercion +import TyCon +import Class +import Name +import Var +import BasicTypes import Outputable -import Unique ( Unique, Uniquable(..) ) -import ListSetOps ( assoc, minusList ) -import Util ( zipEqual, zipWithEqual ) -import List ( partition ) -import Maybes ( expectJust ) +import Unique +import ListSetOps +import Util +import Maybes +import FastString \end{code} @@ -101,22 +96,55 @@ data constructor. The type checker translates it into either the wrapper Id 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] @@ -225,6 +253,9 @@ data DataCon -- [This is a change (Oct05): previously, vanilla datacons guaranteed to -- have the same type variables as their parent TyCon, but that seems ugly.] + -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames + -- Reason: less confusing, and easier to generate IfaceSyn + dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type, -- *as written by the programmer* -- This field allows us to move conveniently between the two ways @@ -278,6 +309,7 @@ data DataCon -- and *including* existential dictionaries dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument + -- See also Note [Data-con worker strictness] in MkId.lhs dcRepType :: Type, -- Type of the constructor -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a @@ -305,10 +337,9 @@ data DataCon } 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 @@ -316,7 +347,7 @@ data DataConIds -- 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) @@ -409,19 +440,29 @@ mkDataCon name declared_infix eq_spec theta orig_arg_tys tycon stupid_theta ids - = con +-- Warning: mkDataCon is not a good place to check invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that asaertions here +-- are a little dodgy. + + = 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) ) - -- Invariant: newtypes have a vanilla data-con - MkData {dcName = name, dcUnique = nameUnique name, + con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, 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 } @@ -432,10 +473,9 @@ mkDataCon name declared_infix -- 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 @@ -491,28 +531,24 @@ dataConTheta = dcTheta 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 @@ -573,6 +609,8 @@ dataConUserType :: DataCon -> Type -- 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, @@ -580,7 +618,9 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs, = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ - mkTyConApp tycon (map (substTyVar subst) univ_tvs) + case tyConFamInst_maybe tycon of + Nothing -> mkTyConApp tycon (substTyVars subst univ_tvs) + Just (ftc, insttys) -> mkTyConApp ftc insttys -- data instance where subst = mkTopTvSubst eq_spec @@ -599,12 +639,13 @@ dataConInstArgTys (MkData {dcRepArgTys = arg_tys, 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 @@ -685,6 +726,22 @@ splitProductType str ty Nothing -> pprPanic (str ++ ": not a product") (pprType ty) +deepSplitProductType_maybe ty + = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty + ; let {result + | isClosedNewTyCon tycon && not (isRecursiveTyCon tycon) + = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args) + | isNewTyCon tycon = Nothing -- cannot unbox through recursive + -- newtypes nor through families + | 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 @@ -696,6 +753,7 @@ computeRep stricts tys 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}