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

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index f8462be..96e9559 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -673,7 +673,7 @@ simplUnfolding env _ _ _ _ (DFunUnfolding con ops)
 simplUnfolding env top_lvl _ _ _ 
     (CoreUnfolding { uf_tmpl = expr, uf_arity = arity
                    , uf_guidance = guide@(InlineRule {}) })
-  = do { expr' <- simplExpr (setMode simplGentlyForInlineRules env) expr
+  = do { expr' <- simplExpr (updMode updModeForInlineRules env) expr
        	       -- See Note [Simplifying gently inside InlineRules] in SimplUtils
        ; let mb_wkr' = CoreSubst.substInlineRuleInfo (mkCoreSubst env) (ir_info guide)
        ; return (mkCoreUnfolding (isTopLevel top_lvl) expr' arity 
@@ -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