X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreUtils.lhs;h=fcd59998476c7a359f369c2ed4c401f5289df34a;hb=155cf24cf7fc7bf7c347aa9709b7ec0ef806224d;hp=24cf2e539e7a68c6d743acf19fdb531b4af9959b;hpb=5822cb8d13aa3c05d2b46b4510c13d94b902eb21;p=ghc-hetmet.git

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 24cf2e5..fcd5999 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -6,6 +6,13 @@
 Utility functions on @Core@ syntax
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module CoreUtils (
 	-- Construction
 	mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
@@ -48,6 +55,7 @@ import SrcLoc
 import VarSet
 import VarEnv
 import Name
+import Module
 #if mingw32_TARGET_OS
 import Packages
 #endif
@@ -63,7 +71,6 @@ import TyCon
 import TysWiredIn
 import CostCentre
 import BasicTypes
-import PackageConfig
 import Unique
 import Outputable
 import DynFlags
@@ -750,7 +757,7 @@ exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 -- Returns (Just (dc, [x1..xn])) if the argument expression is 
 -- a constructor application of the form (dc x1 .. xn)
 exprIsConApp_maybe (Cast expr co)
-  =     -- Here we do the PushC reduction rule as described in the FC paper
+  =     -- Here we do the KPush reduction rule as described in the FC paper
     case exprIsConApp_maybe expr of {
 	Nothing 	   -> Nothing ;
 	Just (dc, dc_args) -> 
@@ -780,17 +787,20 @@ exprIsConApp_maybe (Cast expr co)
     let
 	tc_arity = tyConArity from_tc
 
-        (univ_args, rest1)  = splitAt tc_arity dc_args
-        (ex_args, rest2)    = splitAt n_ex_tvs rest1
-	(co_args, val_args) = splitAt n_cos rest2
+        (univ_args, rest1)        = splitAt tc_arity dc_args
+        (ex_args, rest2)          = splitAt n_ex_tvs rest1
+	(co_args_spec, rest3)     = splitAt n_cos_spec rest2
+	(co_args_theta, val_args) = splitAt n_cos_theta rest3
 
         arg_tys 	    = dataConRepArgTys dc
 	dc_univ_tyvars	    = dataConUnivTyVars dc
         dc_ex_tyvars        = dataConExTyVars dc
 	dc_eq_spec	    = dataConEqSpec dc
+        dc_eq_theta         = dataConEqTheta dc
         dc_tyvars           = dc_univ_tyvars ++ dc_ex_tyvars
         n_ex_tvs            = length dc_ex_tyvars
-	n_cos		    = length dc_eq_spec
+	n_cos_spec	    = length dc_eq_spec
+	n_cos_theta	    = length dc_eq_theta
 
 	-- Make the "theta" from Fig 3 of the paper
         gammas              = decomposeCo tc_arity co
@@ -798,10 +808,15 @@ exprIsConApp_maybe (Cast expr co)
         theta               = zipOpenTvSubst dc_tyvars new_tys
 
           -- First we cast the existential coercion arguments
-        cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv)
-					   `mkTransCoercion` co
-					   `mkTransCoercion` (substTy theta ty)
-        new_co_args = zipWith cast_co dc_eq_spec co_args
+        cast_co_spec (tv, ty) co 
+          = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co
+        cast_co_theta eqPred (Type co) 
+          | (ty1, ty2) <- getEqPredTys eqPred
+          = Type $ mkSymCoercion (substTy theta ty1)
+		   `mkTransCoercion` co
+		   `mkTransCoercion` (substTy theta ty2)
+        new_co_args = zipWith cast_co_spec  dc_eq_spec  co_args_spec ++
+                      zipWith cast_co_theta dc_eq_theta co_args_theta
   
           -- ...and now value arguments
 	new_val_args = zipWith cast_arg arg_tys val_args