diff options
| author | Manuel M T Chakravarty <chak@cse.unsw.edu.au> | 2006-09-20 17:48:20 +0000 |
|---|---|---|
| committer | Manuel M T Chakravarty <chak@cse.unsw.edu.au> | 2006-09-20 17:48:20 +0000 |
| commit | cd829ab3b15e6a7c30cedde2ca59fb5617aec32c (patch) | |
| tree | 6e443977f9dce701c9295b1409d836d5ddf5a2f2 /compiler | |
| parent | 204e70a4a6b977116c77226f014ebed5407713c2 (diff) | |
| download | haskell-cd829ab3b15e6a7c30cedde2ca59fb5617aec32c.tar.gz | |
fix some GADT record selector bugs (still some remaining)
Mon Sep 18 16:47:22 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* fix some GADT record selector bugs (still some remaining)
Sun Aug 6 19:42:50 EDT 2006 Manuel M T Chakravarty <chak@cse.unsw.edu.au>
* fix some GADT record selector bugs (still some remaining)
Thu Jul 27 07:04:29 EDT 2006 kevind@bu.edu
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/MkId.lhs | 21 | ||||
| -rw-r--r-- | compiler/codeGen/CgExpr.lhs | 2 |
2 files changed, 17 insertions, 6 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 78211445a5..c621e5b8f5 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -49,7 +49,7 @@ import PrelRules ( primOpRules ) import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType, mkTopTvSubst, substTyVar ) import Coercion ( mkSymCoercion, mkUnsafeCoercion, - splitNewTypeRepCo_maybe ) + splitNewTypeRepCo_maybe, isEqPred ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, mkTyConApp, mkTyVarTys, mkClassPred, mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, @@ -63,7 +63,7 @@ import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel, tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon, newTyConCo, tyConArity ) import Class ( Class, classTyCon, classSelIds ) -import Var ( Id, TyVar, Var, setIdType ) +import Var ( Id, TyVar, Var, setIdType, mkWildCoVar ) import VarSet ( isEmptyVarSet, subVarSet, varSetElems ) import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) ) import OccName ( mkOccNameFS, varName ) @@ -468,7 +468,14 @@ 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 + (pre_field_tyvars,pre_field_theta,field_tau) = tcSplitSigmaTy field_ty + -- tcSplitSigmaTy puts tyvars with EqPred kinds in with the theta, but + -- this is not what we want here, so we need to split out the EqPreds + -- as new wild tyvars + field_tyvars = pre_field_tyvars ++ eq_vars + eq_vars = map (mkWildCoVar . mkPredTy) + (filter isEqPred pre_field_theta) + 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 @@ -547,7 +554,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 - mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id) + pprTrace "mkReboxingAlt" (ppr data_con <+> ppr (arg_prefix ++ arg_ids)) $ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id) where (arg_prefix, arg_ids) | isVanillaDataCon data_con -- Instantiate from commmon base @@ -557,7 +564,11 @@ mkRecordSelId tycon field_label = (dc_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta), mkTemplateLocalsNum arg_base' dc_arg_tys) - (dc_tvs, dc_theta, dc_arg_tys) = dataConSig data_con + (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_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 unpack_base = arg_base' + length dc_arg_tys diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index e36b2ae236..551a40b633 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -98,7 +98,7 @@ cgExpr (StgLit lit) = do { cmm_lit <- cgLit lit ; performPrimReturn rep (CmmLit cmm_lit) } where - rep = typeCgRep (literalType lit) + rep = (typeCgRep) (literalType lit) \end{code} |