X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FbasicTypes%2FMkId.lhs;h=88078e84cdc9d13a775b6665a716efed948740e9;hb=bef62cbd96e3153e9314c7f824cdbbd7b6106305;hp=c06c67c2e49ba9a40a621a1eb041946e054b4bdf;hpb=b822aa0e9411a1909988c0367d342671806a0f75;p=ghc-hetmet.git diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index c06c67c..88078e8 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -37,22 +37,24 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, intPrimTy, realWorldStatePrimTy ) import TysWiredIn ( boolTy, charTy, mkListTy ) -import PrelMods ( pREL_ERR, pREL_GHC ) +import PrelNames ( pREL_ERR, pREL_GHC ) import PrelRules ( primOpRule ) import Rules ( addRule ) -import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys, +import Type ( Type, ClassContext, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy, classesToPreds, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tyVarsOfTypes, - splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp, + splitSigmaTy, splitFunTy_maybe, splitFunTys, splitForAllTys, unUsgTy, mkUsgTy, UsageAnn(..) ) import PprType ( pprParendType ) import Module ( Module ) -import CoreUtils ( mkInlineMe ) +import CoreUtils ( exprType, mkInlineMe ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) +import Literal ( Literal(..) ) import Subst ( mkTopTyVarSubst, substClasses ) -import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, isProductTyCon, isUnboxedTupleTyCon ) +import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, isDataTyCon, + tyConTheta, isProductTyCon, isUnboxedTupleTyCon ) import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar ) import VarSet ( isEmptyVarSet ) @@ -65,10 +67,11 @@ import PrimOp ( PrimOp(DataToTagOp, CCallOp), primOpSig, mkPrimOpIdName, CCall, pprCCallOp ) -import Demand ( wwStrict, wwPrim ) +import Demand ( wwStrict, wwPrim, mkStrictnessInfo ) import DataCon ( DataCon, StrictnessMark(..), dataConFieldLabels, dataConRepArity, dataConTyCon, - dataConArgTys, dataConRepType, dataConRepStrictness, dataConName, + dataConArgTys, dataConRepType, dataConRepStrictness, + dataConName, dataConTheta, dataConSig, dataConStrictMarks, dataConId ) import Id ( idType, mkId, @@ -166,7 +169,7 @@ mkDataConId work_name data_con arity = dataConRepArity data_con - strict_info = StrictnessInfo (dataConRepStrictness data_con) False + strict_info = mkStrictnessInfo (dataConRepStrictness data_con, False) cpr_info | isProductTyCon tycon && not (isUnboxedTupleTyCon tycon) && @@ -284,8 +287,8 @@ mkDataConWrapId data_con (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con all_tyvars = tyvars ++ ex_tyvars - dict_tys = [mkDictTy clas tys | (clas,tys) <- theta] - ex_dict_tys = [mkDictTy clas tys | (clas,tys) <- ex_theta] + dict_tys = mkDictTys theta + ex_dict_tys = mkDictTys ex_theta all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys result_ty = mkTyConApp tycon (mkTyVarTys tyvars) @@ -343,10 +346,39 @@ We're going to build a record selector unfolding that looks like this: T2 ... x ... -> x other -> error "..." +Similarly for newtypes + + newtype N a = MkN { unN :: a->a } + + unN :: N a -> a -> a + unN n = coerce (a->a) n + +We need to take a little care if the field has a polymorphic type: + + data R = R { f :: forall a. a->a } + +Then we want + + f :: forall a. R -> a -> a + f = /\ a \ r = case r of + R f -> f a + +(not f :: R -> forall a. a->a, which gives the type inference mechanism +problems at call sites) + +Similarly for newtypes + + newtype N = MkN { unN :: forall a. a->a } + + unN :: forall a. N -> a -> a + unN = /\a -> \n:N -> coerce (a->a) n + \begin{code} -mkRecordSelId tycon field_label - -- Assumes that all fields with the same field label - -- have the same type +mkRecordSelId tycon field_label unpack_id + -- Assumes that all fields with the same field label have the same type + -- + -- Annoyingly, we have to pass in the unpackCString# Id, because + -- we can't conjure it up out of thin air = sel_id where sel_id = mkId (fieldLabelName field_label) selector_ty info @@ -356,12 +388,25 @@ mkRecordSelId tycon field_label data_cons = tyConDataCons tycon tyvars = tyConTyVars tycon -- These scope over the types in -- the FieldLabels of constructors of this type + tycon_theta = tyConTheta tycon -- The context on the data decl + -- eg data (Eq a, Ord b) => T a b = ... + (field_tyvars,field_tau) = splitForAllTys field_ty - data_ty = mkTyConApp tycon (mkTyVarTys tyvars) + data_ty = mkTyConApp tycon tyvar_tys tyvar_tys = mkTyVarTys tyvars + -- Very tiresomely, the selectors are (unnecessarily!) overloaded over + -- just the dictionaries in the types of the constructors that contain + -- the relevant field. Urgh. + -- NB: this code relies on the fact that DataCons are quantified over + -- the identical type variables as their parent TyCon + dict_tys = [mkDictTy cls tys | (cls, tys) <- tycon_theta, needed_dict (cls, tys)] + needed_dict pred = or [ pred `elem` (dataConTheta dc) + | (DataAlt dc, _, _) <- the_alts] + selector_ty :: Type - selector_ty = mkForAllTys tyvars (mkFunTy data_ty field_ty) + selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $ + mkFunTys dict_tys $ mkFunTy data_ty field_tau info = mkIdInfo (RecordSelId field_label) `setArityInfo` exactArity 1 @@ -372,7 +417,7 @@ mkRecordSelId tycon field_label unfolding = mkTopUnfolding sel_rhs - [data_id] = mkTemplateLocals [data_ty] + (data_id:dict_ids) = mkTemplateLocals (data_ty:dict_tys) alts = map mk_maybe_alt data_cons the_alts = catMaybes alts default_alt | all isJust alts = [] -- No default needed @@ -381,24 +426,27 @@ mkRecordSelId tycon field_label sel_rhs | isNewTyCon tycon = new_sel_rhs | otherwise = data_sel_rhs - data_sel_rhs = mkLams tyvars $ Lam data_id $ - Case (Var data_id) data_id (the_alts ++ default_alt) + data_sel_rhs = mkLams tyvars $ mkLams field_tyvars $ + mkLams dict_ids $ Lam data_id $ + Case (Var data_id) data_id (the_alts ++ default_alt) - new_sel_rhs = mkLams tyvars $ Lam data_id $ - Note (Coerce (unUsgTy field_ty) (unUsgTy data_ty)) (Var data_id) + new_sel_rhs = mkLams tyvars $ mkLams field_tyvars $ Lam data_id $ + Note (Coerce (unUsgTy field_tau) (unUsgTy data_ty)) (Var data_id) mk_maybe_alt data_con = case maybe_the_arg_id of Nothing -> Nothing - Just the_arg_id -> Just (DataAlt data_con, arg_ids, Var the_arg_id) + Just the_arg_id -> Just (DataAlt data_con, arg_ids, + mkVarApps (Var the_arg_id) field_tyvars) where arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys) -- The first one will shadow data_id, but who cares field_lbls = dataConFieldLabels data_con maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label - error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_ty), mkStringLit full_msg] + error_expr = mkApps (Var rEC_SEL_ERROR_ID) [Type (unUsgTy field_tau), err_string] -- preserves invariant that type args are *not* usage-annotated on top. KSW 1999-04. + err_string = App (Var unpack_id) (Lit (MachStr (_PK_ full_msg))) full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id]) \end{code} @@ -415,11 +463,13 @@ there's nothing to do. ToDo: unify with mkRecordSelId. \begin{code} -mkDictSelId name clas ty +mkDictSelId :: Name -> Class -> Id +mkDictSelId name clas = sel_id where + ty = exprType rhs sel_id = mkId name ty info - field_lbl = mkFieldLabel name ty tag + field_lbl = mkFieldLabel name tycon ty tag tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id info = mkIdInfo (RecordSelId field_lbl) @@ -651,10 +701,10 @@ templates, but we don't ever expect to generate code for it. \begin{code} eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR SLIT("error") errorTy -rEC_SEL_ERROR_ID - = generic_ERROR_ID recSelErrIdKey SLIT("patError") pAT_ERROR_ID = generic_ERROR_ID patErrorIdKey SLIT("patError") +rEC_SEL_ERROR_ID + = generic_ERROR_ID recSelErrIdKey SLIT("recSelError") rEC_CON_ERROR_ID = generic_ERROR_ID recConErrorIdKey SLIT("recConError") rEC_UPD_ERROR_ID