X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FbasicTypes%2FMkId.lhs;h=de8db07c6dac0d130407e7a79bc9f7a8f1bdb9fe;hb=8912a05e1bcc30c7e8e5e017d9cf10176076f141;hp=78211445a515158118b9333292af2ba725d59552;hpb=c58414c7fc6c259945c457c24f5992af1230a824;p=ghc-hetmet.git

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 7821144..de8db07 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -47,25 +47,29 @@ import TysPrim		( openAlphaTyVars, alphaTyVar, alphaTy,
 import TysWiredIn	( charTy, mkListTy )
 import PrelRules	( primOpRules )
 import Type		( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType,
+                          PredType(..),
 			  mkTopTvSubst, substTyVar )
+import TcGadt           ( gadtRefine, refineType, emptyRefinement )
+import HsBinds          ( ExprCoFn(..), isIdCoercion )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, 
-                          splitNewTypeRepCo_maybe )
+                          splitNewTypeRepCo_maybe, isEqPred )
 import TcType		( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
 			  mkTyConApp, mkTyVarTys, mkClassPred, 
 			  mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
 			  isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
 			  tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
 			)
-import CoreUtils	( exprType )
+import CoreUtils	( exprType, dataConInstPat )
 import CoreUnfold 	( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal		( nullAddrLit, mkStringLit )
 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, mkCoVar, mkWildCoVar )
 import VarSet		( isEmptyVarSet, subVarSet, varSetElems )
-import Name		( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
+import Name		( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..),
+                          mkSysTvName )
 import OccName		( mkOccNameFS, varName )
 import PrimOp		( PrimOp, primOpSig, primOpOcc, primOpTag )
 import ForeignCall	( ForeignCall )
@@ -468,7 +472,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 
@@ -547,21 +553,42 @@ 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)
+	  mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) 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_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
-	      mkTemplateLocalsNum arg_base' dc_arg_tys)
+	   = (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
+
+        (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys
+        (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
+
+	(_, pre_dc_theta, dc_arg_tys) = dataConSig data_con
+        dc_theta  = filter (not . isEqPred) pre_dc_theta
 
-	(dc_tvs, dc_theta, dc_arg_tys) = dataConSig data_con
 	arg_base' = arg_base + length dc_theta
 
 	unpack_base = arg_base' + length dc_arg_tys
-	uniqs = map mkBuiltinUnique [unpack_base..]
+
+	uniq_list = map mkBuiltinUnique [unpack_base..]
+
+        Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+        (co_fn, out_ty) = refineType refinement (idType the_arg_id)
+
+        rhs = ASSERT(out_ty `coreEqType` field_tau) perform_co co_fn (Var the_arg_id)
+
+        perform_co (ExprCoFn co) expr = Cast expr co
+        perform_co id_co expr = ASSERT(isIdCoercion id_co) expr
+
+          -- split the uniq_list into two
+        uniqs  = takeHalf uniq_list
+        uniqs' = takeHalf (drop 1 uniq_list)
+
+        takeHalf [] = []
+        takeHalf (h:_:t) = h:(takeHalf t)  
+        takeHalf (h:t) = [h]
 
     	the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
     	field_lbls  = dataConFieldLabels data_con