X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=6ae9587e084d89ead882ed9aec97e34f0b5c702d;hp=f8462be79fccc3dd4f1ab0ac841dfcc4fb712929;hb=b7aa1a08693f2b9b7c2ac9451b7be64f66f88be1;hpb=e97df85e14fa5b088fcfee0c2acbd961869e05fe

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f8462be..6ae9587 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -942,14 +942,19 @@ simplCast env body co0 cont0
 
        add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont)
                 -- (f |> g) ty  --->   (f ty) |> (g @ ty)
-                -- This implements the PushT rule from the paper
+                -- This implements the PushT and PushC rules from the paper
          | Just (tyvar,_) <- splitForAllTy_maybe s1s2
-         , not (isCoVar tyvar)
-         = ApplyTo dup (Type ty') (zapSubstEnv env) (addCoerce (mkInstCoercion co ty') cont)
+         = let 
+             (new_arg_ty, new_cast)
+               | isCoVar tyvar = (new_arg_co, mkCselRCoercion co)       -- PushC rule
+               | otherwise     = (ty',        mkInstCoercion co ty')    -- PushT rule
+           in 
+           ApplyTo dup (Type new_arg_ty) (zapSubstEnv env) (addCoerce new_cast cont)
          where
            ty' = substTy (arg_se `setInScope` env) arg_ty
-
-        -- ToDo: the PushC rule is not implemented at all
+	   new_arg_co = mkCsel1Coercion co  `mkTransCoercion`
+                              ty'           `mkTransCoercion`
+                        mkSymCoercion (mkCsel2Coercion co)
 
        add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont)
          | not (isTypeArg arg)  -- This implements the Push rule from the paper