X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=9818eba2f99ec6ce93c42c291f5cc0adeb1c0f22;hp=6af89b74a0a7ed781ec07e9eb6a1ce20136d2dda;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hpb=80c89b80c355b2aaebcd53330e6c6170c3f05aca diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 6af89b7..9818eba 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -47,9 +47,10 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, - newTyConInstRhs, mkTopTvSubst, substTyVar, substTy ) + newTyConInstRhs, mkTopTvSubst, substTyVar, + substTys, zipTopTvSubst ) import TcGadt ( gadtRefine, refineType, emptyRefinement ) -import HsBinds ( ExprCoFn(..), isIdCoercion ) +import HsBinds ( HsWrapper(..), isIdHsWrapper ) import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, mkTyConApp, mkTyVarTys, mkClassPred, isPredTy, @@ -60,9 +61,12 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) import Literal ( nullAddrLit, mkStringLit ) -import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, +import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, + FieldLabel, tyConStupidTheta, isProductTyCon, isDataTyCon, - isRecursiveTyCon, tyConFamily_maybe, newTyConCo ) + isRecursiveTyCon, isFamInstTyCon, + tyConFamInst_maybe, tyConFamilyCoercion_maybe, + newTyConCo_maybe ) import Class ( Class, classTyCon, classSelIds ) import Var ( Id, TyVar, Var, setIdType ) import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) @@ -71,7 +75,7 @@ import OccName ( mkOccNameFS, varName ) import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, DataConIds(..), dataConTyCon, - dataConUnivTyVars, dataConInstTys, + dataConUnivTyVars, dataConFieldLabels, dataConRepArity, dataConResTys, dataConRepArgTys, dataConRepType, dataConFullSig, dataConStrictMarks, dataConExStricts, @@ -93,7 +97,6 @@ import NewDemand ( mkStrictSig, DmdResult(..), import DmdAnal ( dmdAnalTopRhs ) import CoreSyn import Unique ( mkBuiltinUnique, mkPrimOpIdUnique ) -import Maybe ( fromJust ) import Maybes import PrelNames import Util ( dropList, isSingleton ) @@ -189,31 +192,48 @@ Notice that Making an explicit case expression allows the simplifier to eliminate it in the (common) case where the constructor arg is already evaluated. +[Wrappers for data instance tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of data instances, the wrapper also applies the coercion turning +the representation type into the family instance type to cast the result of +the wrapper. For example, consider the declarations + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +The tycon to which the datacon MapPair belongs gets a unique internal name of +the form :R123Map, and we call it the representation tycon. In contrast, Map +is the family tycon (accessible via tyConFamInst_maybe). The wrapper and work +of MapPair get the types + + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +which implies that the wrapper code will have to apply the coercion moving +between representation and family type. It is accessible via +tyConFamilyCoercion_maybe and has kind + + Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v} + +This coercion is conditionally applied by wrapFamInstBody. \begin{code} mkDataConIds :: Name -> Name -> DataCon -> DataConIds mkDataConIds wrap_name wkr_name data_con | isNewTyCon tycon - = DCIds Nothing nt_work_id -- Newtype, only has a worker + = DCIds Nothing nt_work_id -- Newtype, only has a worker - | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper - || not (null eq_spec) - || isInst + | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper + || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs + || isFamInstTyCon tycon -- depends on this test = DCIds (Just alg_wrap_id) wrk_id - | otherwise -- Algebraic, no wrapper + | otherwise -- Algebraic, no wrapper = DCIds Nothing wrk_id where (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con tycon = dataConTyCon data_con - (isInst, instTys, familyTyCon) = - case dataConInstTys data_con of - Nothing -> (False, [] , familyTyCon) - Just instTys -> (True , instTys, familyTyCon) - where - familyTyCon = fromJust $ tyConFamily_maybe tycon - -- this is defined whenever `isInst' ----------- Wrapper -------------- -- We used to include the stupid theta in the wrapper's args @@ -221,12 +241,23 @@ mkDataConIds wrap_name wkr_name data_con -- extra constraints where necessary. wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs subst = mkTopTvSubst eq_spec + famSubst = ASSERT( length (tyConTyVars tycon ) == + length (mkTyVarTys univ_tvs) ) + zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs) + -- substitution mapping the type constructor's type + -- arguments to the universals of the data constructor + -- (crucial when type checking interfaces) dict_tys = mkPredTys theta result_ty_args = map (substTyVar subst) univ_tvs - familyArgs = map (substTy subst) instTys - result_ty = if isInst - then mkTyConApp familyTyCon familyArgs -- instance con - else mkTyConApp tycon result_ty_args -- ordinary con + result_ty = case tyConFamInst_maybe tycon of + -- ordinary constructor + Nothing -> mkTyConApp tycon result_ty_args + -- family instance constructor + Just (familyTyCon, + instTys) -> + mkTyConApp familyTyCon ( substTys subst + . substTys famSubst + $ instTys) wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $ mkFunTys orig_arg_tys $ result_ty -- NB: watch out here if you allow user-written equality @@ -316,10 +347,11 @@ mkDataConIds wrap_name wkr_name data_con (zip (dict_args ++ id_args) all_strict_marks) i3 [] - con_app _ rep_ids = Var wrk_id `mkTyApps` result_ty_args - `mkVarApps` ex_tvs - `mkTyApps` map snd eq_spec - `mkVarApps` reverse rep_ids + con_app _ rep_ids = wrapFamInstBody tycon result_ty_args $ + Var wrk_id `mkTyApps` result_ty_args + `mkVarApps` ex_tvs + `mkTyApps` map snd eq_spec + `mkVarApps` reverse rep_ids (dict_args,i2) = mkLocals 1 dict_tys (id_args,i3) = mkLocals i2 orig_arg_tys @@ -358,6 +390,18 @@ mAX_CPR_SIZE = 10 mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) where n = length tys + +-- If the type constructor is a representation type of a data instance, wrap +-- the expression into a cast adjusting the expression type, which is an +-- instance of the representation type, to the corresponding instance of the +-- family instance type. +-- +wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +wrapFamInstBody tycon args result_expr + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr + | otherwise + = result_expr \end{code} @@ -585,8 +629,8 @@ mkRecordSelId tycon field_label -- and apply to (Maybe b'), to get (Maybe b) rhs = case co_fn of - ExprCoFn co -> Cast (Var the_arg_id) co - id_co -> ASSERT(isIdCoercion id_co) Var the_arg_id + WpCo co -> Cast (Var the_arg_id) co + id_co -> ASSERT(isIdHsWrapper id_co) Var the_arg_id field_vs = filter (not . isPredTy . idType) arg_vs the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label @@ -806,15 +850,28 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- If a coercion constructor is prodivided in the newtype, then we use -- it, otherwise the wrap/unwrap are both no-ops -- +-- If the we are dealing with a newtype instance, we have a second coercion +-- identifying the family instance with the constructor of the newtype +-- instance. This coercion is applied in any case (ie, composed with the +-- coercion constructor of the newtype or applied by itself). +-- wrapNewTypeBody tycon args result_expr - | Just co_con <- newTyConCo tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr - | otherwise - = result_expr + = wrapFamInstBody tycon args inner + where + inner + | Just co_con <- newTyConCo_maybe tycon + = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr + | otherwise + = result_expr +-- When unwrapping, we do *not* apply any family coercion, because this will +-- be done via a CoPat by the type checker. We have to do it this way as +-- computing the right type arguments for the coercion requires more than just +-- a spliting operation (cf, TcPat.tcConPat). +-- unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr - | Just co_con <- newTyConCo tycon + | Just co_con <- newTyConCo_maybe tycon = mkCoerce (mkTyConApp co_con args) result_expr | otherwise = result_expr @@ -838,7 +895,7 @@ mkPrimOpId prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) - Nothing (AnId id) UserSyntax + (AnId id) UserSyntax id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo @@ -977,7 +1034,7 @@ another gun with which to shoot yourself in the foot. \begin{code} mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax + = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId