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

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}