Add builtin rule to eliminate unnecessary casts in seq

The patch adds this rule:

  seq (x `cast` co) y = seq x y

This is subject to the usual treatment of seq rules. It also makes them
match more often: it will rewrite

  seq (f x `cast` co) y = seq (f x) y

and allow a seq rule for f to match.

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 449f09f..29ccb62 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -934,6 +934,7 @@ seqId :: Id -- See Note [seqId magic]
 seqId = pcMiscPrelId seqName ty info
   where
     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
 seqId = pcMiscPrelId seqName ty info
   where
     info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs

+                       `setSpecInfo` mkSpecInfo [seq_cast_rule]

            
 
     ty  = mkForAllTys [alphaTyVar,openBetaTyVar]
            
 
     ty  = mkForAllTys [alphaTyVar,openBetaTyVar]

@@ -941,6 +942,18 @@ seqId = pcMiscPrelId seqName ty info
     [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
     rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
 
     [x,y] = mkTemplateLocals [alphaTy, openBetaTy]
     rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
 

+    seq_cast_rule = BuiltinRule { ru_name  = fsLit "seq of cast"
+                                , ru_fn    = seqName
+                                , ru_nargs = 4
+                                , ru_try   = match_seq_of_cast
+                                }
+
+match_seq_of_cast :: [CoreExpr] -> Maybe CoreExpr     -- Note [RULES for seq]
+match_seq_of_cast [Type _, Type res_ty, Cast scrut co, expr]
+  = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty,
+                              scrut, expr])
+match_seq_of_cast _ = Nothing
+

 ------------------------------------------------
 lazyId :: Id   -- See Note [lazyId magic]
 lazyId = pcMiscPrelId lazyIdName ty info
 ------------------------------------------------
 lazyId :: Id   -- See Note [lazyId magic]
 lazyId = pcMiscPrelId lazyIdName ty info

@@ -986,6 +999,12 @@ To make this work, we need to be careful that the magical desugaring
 done in Note [seqId magic] item (c) is *not* done on the LHS of a rule.
 Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs.
 
 done in Note [seqId magic] item (c) is *not* done on the LHS of a rule.
 Or rather, we arrange to un-do it, in DsBinds.decomposeRuleLhs.
 

+We also have the following builtin rule:
+
+  seq (x `cast` co) y = seq x y
+
+This eliminates unnecessary casts and also allows other seq rules to
+match more often.

 
 Note [lazyId magic]
 ~~~~~~~~~~~~~~~~~~~
 
 Note [lazyId magic]
 ~~~~~~~~~~~~~~~~~~~

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 2050f4d..50c926d 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -1450,7 +1450,7 @@ rebuildCase env scrut case_bndr [(_, bndrs, rhs)] cont
 
 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'
 
 rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
   | all isDeadBinder (case_bndr : bndrs)  -- So this is just 'seq'

-  =    -- For this case, see Note [Rules for seq] in MkId
+  =    -- For this case, see Note [RULES for seq] in MkId

     do { let rhs' = substExpr env rhs
              out_args = [Type (substTy env (idType case_bndr)), 
                         Type (exprType rhs'), scrut, rhs']
     do { let rhs' = substExpr env rhs
              out_args = [Type (substTy env (idType case_bndr)), 
                         Type (exprType rhs'), scrut, rhs']

@@ -1540,7 +1540,10 @@ where x::F Int.  Then we'd like to rewrite (F Int) to Int, getting
                     in rhs
 
 so that 'rhs' can take advantage of the form of x'.  Notice that Note
                     in rhs
 
 so that 'rhs' can take advantage of the form of x'.  Notice that Note

-[Case of cast] may then apply to the result.
+[Case of cast] may then apply to the result. We only do this if x is actually
+used in the rhs. There is no point in adding the cast if this is really just a
+seq and doing so would interfere with seq rules (Note [RULES for seq]), in
+particular with the one that removes casts.

 
 This showed up in Roman's experiments.  Example:
   foo :: F Int -> Int -> Int
 
 This showed up in Roman's experiments.  Example:
   foo :: F Int -> Int -> Int

@@ -1564,8 +1567,9 @@ improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv
           -> SimplM (SimplEnv, OutExpr, OutId)
 -- Note [Improving seq]
 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]
           -> SimplM (SimplEnv, OutExpr, OutId)
 -- Note [Improving seq]
 improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]

-  | Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
-  =  do { case_bndr2 <- newId (fsLit "nt") ty2
+  | not (isDeadBinder case_bndr)
+  , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1)
+  = do { case_bndr2 <- newId (fsLit "nt") ty2

         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
               env2 = extendIdSubst env case_bndr rhs
         ; return (env2, scrut `Cast` co, case_bndr2) }
         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co)
               env2 = extendIdSubst env case_bndr rhs
         ; return (env2, scrut `Cast` co, case_bndr2) }