From e380d180947b309f6d548ddb8a3f8144c08aaff4 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 17:48:55 +0000 Subject: [PATCH] GADT selector bugfix, bits of cleanup Mon Sep 18 16:48:32 EDT 2006 Manuel M T Chakravarty * GADT selector bugfix, bits of cleanup Sun Aug 6 19:43:47 EDT 2006 Manuel M T Chakravarty * GADT selector bugfix, bits of cleanup Thu Jul 27 08:10:58 EDT 2006 kevind@bu.edu --- compiler/basicTypes/MkId.lhs | 10 ++++++++-- compiler/codeGen/SMRep.lhs | 4 ++-- compiler/coreSyn/CoreLint.lhs | 3 +-- 3 files changed, 11 insertions(+), 6 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index c621e5b..5fe7dc0 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -47,6 +47,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType, + PredType(..), mkTopTvSubst, substTyVar ) import Coercion ( mkSymCoercion, mkUnsafeCoercion, splitNewTypeRepCo_maybe, isEqPred ) @@ -554,7 +555,7 @@ mkRecordSelId tycon field_label 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 - pprTrace "mkReboxingAlt" (ppr data_con <+> ppr (arg_prefix ++ arg_ids)) $ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id) + mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id) where (arg_prefix, arg_ids) | isVanillaDataCon data_con -- Instantiate from commmon base @@ -566,7 +567,12 @@ mkRecordSelId tycon field_label (pre_dc_tvs, pre_dc_theta, dc_arg_tys) = dataConSig data_con -- again we need to pull the EqPreds out of dc_theta, into dc_tvs - dc_eqvars = map (mkWildCoVar . mkPredTy) (filter isEqPred pre_dc_theta) + dc_eqvars = map (mkWildCoVar . mkPredTy . fixEqPred) (filter isEqPred pre_dc_theta) + -- The type of the record selector Id does not contain the univ tvs + -- but rather their substitution according to the eq_spec. Therefore + -- the coercion arguments bound in the case alternative will just + -- have reflexive coercion kinds + fixEqPred (EqPred ty1 ty2) = EqPred ty2 ty2 dc_tvs = drop (length (dataConUnivTyVars data_con)) pre_dc_tvs ++ dc_eqvars dc_theta = filter (not . isEqPred) pre_dc_theta arg_base' = arg_base + length dc_theta diff --git a/compiler/codeGen/SMRep.lhs b/compiler/codeGen/SMRep.lhs index c807703..521b626 100644 --- a/compiler/codeGen/SMRep.lhs +++ b/compiler/codeGen/SMRep.lhs @@ -158,13 +158,13 @@ primRepHint FloatRep = FloatHint primRepHint DoubleRep = FloatHint idCgRep :: Id -> CgRep -idCgRep = typeCgRep . idType +idCgRep x = typeCgRep . idType $ x tyConCgRep :: TyCon -> CgRep tyConCgRep = primRepToCgRep . tyConPrimRep typeCgRep :: Type -> CgRep -typeCgRep = primRepToCgRep . typePrimRep +typeCgRep = primRepToCgRep . typePrimRep typeHint :: Type -> MachHint typeHint = primRepHint . typePrimRep diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 354b95c..a147ce2 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -509,8 +509,7 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs) -- NB: args must be in scope here so that the lintCoreArgs line works. -- NB: relies on existential type args coming *after* ordinary type args - ; con_result_ty <- - lintCoreArgs (dataConRepType con) + ; con_result_ty <- lintCoreArgs (dataConRepType con) (map Type tycon_arg_tys ++ varsToCoreExprs args) ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) } -- 1.7.10.4