From: Roman Leshchinskiy <rl@cse.unsw.edu.au>
Date: Wed, 4 Nov 2009 23:30:14 +0000 (+0000)
Subject: Add builtin rule to eliminate unnecessary casts in seq
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=ad9239172c453e4244de8eccc172e2c679766ea5;hp=c01e472e205f09e6cdadc1c878263998f637bc8d

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
--- 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
+                       `setSpecInfo` mkSpecInfo [seq_cast_rule]
            
 
     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)])
 
+    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
@@ -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.
 
+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]
 ~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 2050f4d..50c926d 100644
--- 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'
-  = 	-- 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']
@@ -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
-[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
@@ -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,_,_)]
-  | 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) }