X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=9818eba2f99ec6ce93c42c291f5cc0adeb1c0f22;hp=8f71aabf065113789db7d6e5d25f4cce928a53fd;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hpb=0119bfdc7ae348c0f45b591391d1b68bc6bd8cc8 diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 8f71aab..9818eba 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -20,12 +20,13 @@ module MkId ( mkRecordSelId, mkPrimOpId, mkFCallId, - mkReboxingAlt, mkNewTypeBody, + mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, + mkUnpackCase, mkProductBox, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId, - lazyId, lazyIdUnfolding, lazyIdKey, + lazyId, lazyIdUnfolding, lazyIdKey, mkRuntimeErrorApp, rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID, @@ -45,31 +46,41 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, ) import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) -import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes ) +import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, + newTyConInstRhs, mkTopTvSubst, substTyVar, + substTys, zipTopTvSubst ) +import TcGadt ( gadtRefine, refineType, emptyRefinement ) +import HsBinds ( HsWrapper(..), isIdHsWrapper ) +import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, - mkTyConApp, mkTyVarTys, mkClassPred, - mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, + mkTyConApp, mkTyVarTys, mkClassPred, isPredTy, + mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta ) -import CoreUtils ( exprType ) +import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding ) import Literal ( nullAddrLit, mkStringLit ) -import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, - tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon ) +import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, + FieldLabel, + tyConStupidTheta, isProductTyCon, isDataTyCon, + isRecursiveTyCon, isFamInstTyCon, + tyConFamInst_maybe, tyConFamilyCoercion_maybe, + newTyConCo_maybe ) import Class ( Class, classTyCon, classSelIds ) -import Var ( Id, TyVar, Var ) +import Var ( Id, TyVar, Var, setIdType ) import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) -import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) ) +import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..)) import OccName ( mkOccNameFS, varName ) import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag ) import ForeignCall ( ForeignCall ) -import DataCon ( DataCon, DataConIds(..), dataConTyVars, +import DataCon ( DataCon, DataConIds(..), dataConTyCon, + dataConUnivTyVars, dataConFieldLabels, dataConRepArity, dataConResTys, - dataConRepArgTys, dataConRepType, - dataConSig, dataConStrictMarks, dataConExStricts, + dataConRepArgTys, dataConRepType, dataConFullSig, + dataConStrictMarks, dataConExStricts, splitProductType, isVanillaDataCon, dataConFieldType, - dataConInstOrigArgTys + deepSplitProductType, ) import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId, @@ -91,7 +102,7 @@ import PrelNames import Util ( dropList, isSingleton ) import Outputable import FastString -import ListSetOps ( assoc ) +import ListSetOps ( assoc, minusList ) \end{code} %************************************************************************ @@ -181,33 +192,80 @@ 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 - -- Makes the *worker* for the data constructor; that is, the function - -- that takes the reprsentation arguments and builds the constructor. mkDataConIds wrap_name wkr_name data_con | isNewTyCon tycon - = NewDC nt_wrap_id + = DCIds Nothing nt_work_id -- Newtype, only has a worker - | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper - = AlgDC (Just alg_wrap_id) wrk_id + | 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 - = AlgDC Nothing wrk_id + | otherwise -- Algebraic, no wrapper + = DCIds Nothing wrk_id where - (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con - - dict_tys = mkPredTys theta - all_arg_tys = dict_tys ++ orig_arg_tys - result_ty = mkTyConApp tycon res_tys + (univ_tvs, ex_tvs, eq_spec, + theta, orig_arg_tys) = dataConFullSig data_con + tycon = dataConTyCon data_con - wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty) + ----------- Wrapper -------------- -- We used to include the stupid theta in the wrapper's args -- but now we don't. Instead the type checker just injects these -- 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 + 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 + -- constraints in data constructor signatures ----------- Worker (algebraic data types only) -------------- + -- The *worker* for the data constructor is the function that + -- takes the representation arguments and builds the constructor. wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name (dataConRepType data_con) wkr_info @@ -243,9 +301,9 @@ mkDataConIds wrap_name wkr_name data_con -- RetCPR is only true for products that are real data types; -- that is, not unboxed tuples or [non-recursive] newtypes - ----------- Wrappers for newtypes -------------- - nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info - nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + ----------- Workers for newtypes -------------- + nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info + nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 `setUnfoldingInfo` newtype_unf newtype_unf = ASSERT( isVanillaDataCon data_con && @@ -253,8 +311,9 @@ mkDataConIds wrap_name wkr_name data_con -- No existentials on a newtype, but it can have a context -- e.g. newtype Eq a => T a = MkT (...) mkCompulsoryUnfolding $ - mkLams tyvars $ Lam id_arg1 $ - mkNewTypeBody tycon result_ty (Var id_arg1) + mkLams wrap_tvs $ Lam id_arg1 $ + wrapNewTypeBody tycon result_ty_args + (Var id_arg1) id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) @@ -282,14 +341,17 @@ mkDataConIds wrap_name wkr_name data_con -- we want to see that w is strict in its two arguments alg_unf = mkTopUnfolding $ Note InlineMe $ - mkLams tyvars $ + mkLams wrap_tvs $ mkLams dict_args $ mkLams id_args $ foldr mk_case con_app (zip (dict_args ++ id_args) all_strict_marks) i3 [] - con_app i rep_ids = mkApps (Var wrk_id) - (map varToCoreExpr (tyvars ++ 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 @@ -310,14 +372,9 @@ mkDataConIds wrap_name wkr_name data_con Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))] MarkedUnboxed - -> case splitProductType "do_unbox" (idType arg) of - (tycon, tycon_args, con, tys) -> - Case (Var arg) arg result_ty - [(DataAlt con, - con_args, - body i' (reverse con_args ++ rep_args))] - where - (con_args, i') = mkLocals i tys + -> unboxProduct i (Var arg) (idType arg) the_body + where + the_body i con_args = body i (reverse con_args ++ rep_args) mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 @@ -333,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} @@ -391,11 +460,13 @@ We obviously can't define Nevertheless we *do* put a RecordSelId into the type environment so that if the user tries to use 'x' as a selector we can bleat helpfully, rather than saying unhelpfully that 'x' is not in scope. -Hence the sel_naughty flag, to identify record selcectors that don't really exist. +Hence the sel_naughty flag, to identify record selectors that don't really exist. In general, a field is naughty if its type mentions a type variable that isn't in the result type of the constructor. +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For GADTs, we require that all constructors with a common field 'f' have the same result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] E.g. @@ -424,7 +495,7 @@ mkRecordSelId tycon field_label | is_naughty = naughty_id | otherwise = sel_id where - is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set) + is_naughty = not (tyVarsOfType field_ty `subVarSet` res_tv_set) sel_id_details = RecordSelId tycon field_label is_naughty -- Escapist case here for naughty construcotrs @@ -440,8 +511,8 @@ mkRecordSelId tycon field_label con1 = head data_cons_w_field res_tys = dataConResTys con1 - tyvar_set = tyVarsOfTypes res_tys - tyvars = varSetElems tyvar_set + res_tv_set = tyVarsOfTypes res_tys + res_tvs = varSetElems res_tv_set data_ty = mkTyConApp tycon res_tys field_ty = dataConFieldType con1 field_label @@ -456,7 +527,9 @@ mkRecordSelId tycon field_label stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field) n_stupid_dicts = length stupid_dict_tys - (field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty + (field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty + + field_theta = filter (not . isEqPred) pre_field_theta field_dict_tys = mkPredTys field_theta n_field_dict_tys = length field_dict_tys -- If the field has a universally quantified type we have to @@ -475,7 +548,7 @@ mkRecordSelId tycon field_label -- op (R op) = op selector_ty :: Type - selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $ + selector_ty = mkForAllTys res_tvs $ mkForAllTys field_tyvars $ mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $ mkFunTy data_ty field_tau @@ -515,12 +588,14 @@ mkRecordSelId tycon field_label caf_info | no_default = NoCafRefs | otherwise = MayHaveCafRefs - sel_rhs = mkLams tyvars $ mkLams field_tyvars $ + sel_rhs = mkLams res_tvs $ mkLams field_tyvars $ mkLams stupid_dict_ids $ mkLams field_dict_ids $ - Lam data_id $ sel_body + Lam data_id $ mk_result sel_body - sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id)) - | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts) + -- NB: A newtype always has a vanilla DataCon; no existentials etc + -- res_tys will simply be the dataConUnivTyVars + sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon res_tys (Var data_id) + | otherwise = Case (Var data_id) data_id field_ty (default_alt ++ the_alts) mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids -- We pull the field lambdas to the top, so we need to @@ -531,30 +606,112 @@ mkRecordSelId tycon field_label -- foo = /\a. \t:T. case t of { MkT f -> f a } mk_alt data_con - = -- In the non-vanilla case, the pattern must bind type variables and - -- the context stuff; hence the arg_prefix binding below - mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) - (mk_result (Var the_arg_id)) + = ASSERT2( res_ty `tcEqType` field_ty, ppr data_con $$ ppr res_ty $$ ppr field_ty ) + mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs where - (arg_prefix, arg_ids) - | isVanillaDataCon data_con -- Instantiate from commmon base - = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys)) - | otherwise -- The case pattern binds type variables, which are used - -- in the types of the arguments of the pattern - = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta), - mkTemplateLocalsNum arg_base' dc_arg_tys) + -- get pattern binders with types appropriately instantiated + arg_uniqs = map mkBuiltinUnique [arg_base..] + (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con res_tys + + rebox_base = arg_base + length ex_tvs + length co_tvs + length arg_vs + rebox_uniqs = map mkBuiltinUnique [rebox_base..] + + -- data T :: *->* where T1 { fld :: Maybe b } -> T [b] + -- Hence T1 :: forall a b. (a=[b]) => b -> T a + -- fld :: forall b. T [b] -> Maybe b + -- fld = /\b.\(t:T[b]). case t of + -- T1 b' (c : [b]=[b']) (x:Maybe b') + -- -> x `cast` Maybe (sym (right c)) + + Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs + (co_fn, res_ty) = refineType refinement (idType the_arg_id) + -- Generate the refinement for b'=b, + -- and apply to (Maybe b'), to get (Maybe b) + + rhs = case co_fn of + 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 + field_lbls = dataConFieldLabels data_con - (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con - arg_base' = arg_base + length dc_theta + error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg + full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) - unpack_base = arg_base' + length dc_arg_tys - uniqs = map mkBuiltinUnique [unpack_base..] +-- unbox a product type... +-- we will recurse into newtypes, casting along the way, and unbox at the +-- first product data constructor we find. e.g. +-- +-- data PairInt = PairInt Int Int +-- newtype S = MkS PairInt +-- newtype T = MkT S +-- +-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of +-- ids, we get (modulo int passing) +-- +-- case (e `cast` CoT) `cast` CoS of +-- PairInt a b -> body [a,b] +-- +-- The Ints passed around are just for creating fresh locals +unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr +unboxProduct i arg arg_ty body + = result + where + result = mkUnpackCase the_id arg con_args boxing_con rhs + (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty + ([the_id], i') = mkLocals i [arg_ty] + (con_args, i'') = mkLocals i' tys + rhs = body i'' con_args + +mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr +-- (mkUnpackCase x e args Con body) +-- returns +-- case (e `cast` ...) of bndr { Con args -> body } +-- +-- the type of the bndr passed in is irrelevent +mkUnpackCase bndr arg unpk_args boxing_con body + = Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)] + where + (cast_arg, bndr_ty) = go (idType bndr) arg + go ty arg + | (tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty + , isNewTyCon tycon && not (isRecursiveTyCon tycon) + = go (newTyConInstRhs tycon tycon_args) + (unwrapNewTypeBody tycon tycon_args arg) + | otherwise = (arg, ty) + +-- ...and the dual +reboxProduct :: [Unique] -- uniques to create new local binders + -> Type -- type of product to box + -> ([Unique], -- remaining uniques + CoreExpr, -- boxed product + [Id]) -- Ids being boxed into product +reboxProduct us ty + = let + (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty + + us' = dropList con_arg_tys us + + arg_ids = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys + + bind_rhs = mkProductBox arg_ids ty - the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label - field_lbls = dataConFieldLabels data_con + in + (us', bind_rhs, arg_ids) + +mkProductBox :: [Id] -> Type -> CoreExpr +mkProductBox arg_ids ty + = result_expr + where + (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty - error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg - full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) + result_expr + | isNewTyCon tycon && not (isRecursiveTyCon tycon) + = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args)) + | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids) + + wrap expr = wrapNewTypeBody tycon tycon_args expr -- (mkReboxingAlt us con xs rhs) basically constructs the case @@ -590,7 +747,7 @@ mkReboxingAlt us con args rhs where stricts = dataConExStricts con ++ dataConStrictMarks con - go [] stricts us = ([], []) + go [] _stricts _us = ([], []) -- Type variable case go (arg:args) stricts us @@ -601,16 +758,11 @@ mkReboxingAlt us con args rhs -- Term variable case go (arg:args) (str:stricts) us | isMarkedUnboxed str - = let - (_, tycon_args, pack_con, con_arg_tys) - = splitProductType "mkReboxingAlt" (idType arg) - - unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys - (binds, args') = go args stricts (dropList con_arg_tys us) - con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args) - in - (NonRec arg con_app : binds, unpacked_args ++ args') - + = + let (binds, unpacked_args') = go args stricts us' + (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg) + in + (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args') | otherwise = let (binds, args') = go args stricts us in (binds, arg:args') @@ -672,26 +824,59 @@ mkDictSelId name clas tycon = classTyCon clas [data_con] = tyConDataCons tycon - tyvars = dataConTyVars data_con - arg_tys = dataConRepArgTys data_con + tyvars = dataConUnivTyVars data_con + arg_tys = ASSERT( isVanillaDataCon data_con ) dataConRepArgTys data_con the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name pred = mkClassPred clas (mkTyVarTys tyvars) (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys) - rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $ - mkNewTypeBody tycon (head arg_tys) (Var dict_id) - | otherwise = mkLams tyvars $ Lam dict_id $ - Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, arg_ids, Var the_arg_id)] - -mkNewTypeBody tycon result_ty result_expr - -- Adds a coerce where necessary - -- Used for both wrapping and unwrapping - | isRecursiveTyCon tycon -- Recursive case; use a coerce - = Note (Coerce result_ty (exprType result_expr)) result_expr - | otherwise -- Normal case + rhs = mkLams tyvars (Lam dict_id rhs_body) + rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) + | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) + [(DataAlt data_con, arg_ids, Var the_arg_id)] + +wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +-- The wrapper for the data constructor for a newtype looks like this: +-- newtype T a = MkT (a,Int) +-- MkT :: forall a. (a,Int) -> T a +-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) +-- where CoT is the coercion TyCon assoicated with the newtype +-- +-- The call (wrapNewTypeBody T [a] e) returns the +-- body of the wrapper, namely +-- e `cast` (CoT [a]) +-- +-- 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 + = 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_maybe tycon + = mkCoerce (mkTyConApp co_con args) result_expr + | otherwise = result_expr + + \end{code} @@ -710,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 @@ -849,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 @@ -882,7 +1067,8 @@ unsafeCoerceId (mkFunTy openAlphaTy openBetaTy) [x] = mkTemplateLocals [openAlphaTy] rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $ - Note (Coerce openBetaTy openAlphaTy) (Var x) +-- Note (Coerce openBetaTy openAlphaTy) (Var x) + Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy) -- nullAddr# :: Addr# -- The reason is is here is because we don't provide