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

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index de8db07..6c9029c 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -54,12 +54,12 @@ import HsBinds          ( ExprCoFn(..), isIdCoercion )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, 
                           splitNewTypeRepCo_maybe, isEqPred )
 import TcType		( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, 
-			  mkTyConApp, mkTyVarTys, mkClassPred, 
-			  mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, 
+			  mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
+			  mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType,
 			  isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
 			  tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
 			)
-import CoreUtils	( exprType, dataConInstPat )
+import CoreUtils	( exprType, dataConOrigInstPat )
 import CoreUnfold 	( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal		( nullAddrLit, mkStringLit )
 import TyCon		( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
@@ -551,46 +551,34 @@ mkRecordSelId tycon field_label
 	--	foo = /\a. \t:T. case t of { MkT f -> f a }
 
     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) rhs
+      =   ASSERT2( res_ty `tcEqType` field_tau, ppr data_con $$ ppr res_ty $$ ppr field_tau )
+	  mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) 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
-	   = (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
+           -- get pattern binders with types appropriately instantiated
+	arg_uniqs = map mkBuiltinUnique [arg_base..]
+        (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con res_tys
 
-        (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys
-        (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
+	rebox_base  = arg_base + length ex_tvs + length co_tvs + length arg_vs
+	rebox_uniqs = map mkBuiltinUnique [rebox_base..]
 
-	(_, pre_dc_theta, dc_arg_tys) = dataConSig data_con
-        dc_theta  = filter (not . isEqPred) pre_dc_theta
-
-	arg_base' = arg_base + length dc_theta
-
-	unpack_base = arg_base' + length dc_arg_tys
-
-	uniq_list = map mkBuiltinUnique [unpack_base..]
+	-- data T :: *->* where T1 { fld :: Maybe b } -> T [b]
+	--	Hence T1 :: forall a b. (a=[b]) => b -> T a
+	-- fld :: forall b. T [b] -> Maybe b
+	-- fld = /\b.\(t:T[b]). case t of 
+	--		T1 b' (c : [b]=[b']) (x:Maybe b') 
+	--			-> x `cast` Maybe (sym (right c))
 
         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)
+        (co_fn, res_ty) = refineType refinement (idType the_arg_id)
+		-- Generate the refinement for b'=b, 
+		-- and apply to (Maybe b'), to get (Maybe b)
 
-        takeHalf [] = []
-        takeHalf (h:_:t) = h:(takeHalf t)  
-        takeHalf (h:t) = [h]
+        rhs = case co_fn of
+		ExprCoFn co -> Cast (Var the_arg_id) co
+		id_co	    -> ASSERT(isIdCoercion id_co) Var the_arg_id
 
-    	the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
+	field_vs    = filter (not . isPredTy . idType) arg_vs 
+    	the_arg_id  = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
     	field_lbls  = dataConFieldLabels data_con
 
     error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
@@ -616,7 +604,7 @@ unboxProduct i arg arg_ty body res_ty
   = result
   where 
     result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs
-    (tycon, tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
+    (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
     ([the_id], i') = mkLocals i [arg_ty]
     (con_args, i'') = mkLocals i' tys
     rhs = body i'' con_args
@@ -646,7 +634,7 @@ reboxProduct :: [Unique]     -- uniques to create new local binders
                  [Id])       -- Ids being boxed into product
 reboxProduct us ty
   = let 
-	(tycon, tycon_args, pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
+	(_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
  
         us' = dropList con_arg_tys us
 
@@ -661,7 +649,7 @@ mkProductBox :: [Id] -> Type -> CoreExpr
 mkProductBox arg_ids ty 
   = result_expr
   where 
-    (tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty
+    (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
 
     result_expr
       | isNewTyCon tycon && not (isRecursiveTyCon tycon)