[commit: ghc] ghc-7.10: Reduce magic for seqId (cf9f638)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/cf9f638fa2e54e8573e7f042df6bff5d0f059811/ghc

>---------------------------------------------------------------

commit cf9f638fa2e54e8573e7f042df6bff5d0f059811
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri May 22 14:41:54 2015 +0100

    Reduce magic for seqId
    
    An upcoming commit means that the RULES for 'seq' get only
    one value arg, not two.  This patch prepares for that by
    
    - reducing the arity of seq's built-in rule, to take one value arg
    - making 'seq' not inline on the LHS of RULES
    - and removing the horrid un-inlining in DsBinds.decomposeRuleLhs
    
    (cherry picked from commit eae703aa60f41fd232be5478e196b661839ec3de)


>---------------------------------------------------------------

cf9f638fa2e54e8573e7f042df6bff5d0f059811
 compiler/basicTypes/MkId.hs   | 34 ++++++++++++++++++++++++----------
 compiler/coreSyn/CoreSubst.hs | 15 +++++++++++----
 compiler/deSugar/DsBinds.hs   |  6 ------
 3 files changed, 35 insertions(+), 20 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 4d473d5..c6161c5 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -1086,10 +1086,15 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info
 seqId :: Id     -- See Note [seqId magic]
 seqId = pcMiscPrelId seqName ty info
   where
-    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
+    info = noCafIdInfo `setInlinePragInfo` inline_prag
                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs
                        `setSpecInfo`       mkSpecInfo [seq_cast_rule]
 
+    inline_prag = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter 0
+                  -- Make 'seq' not inline-always, so that simpleOptExpr
+                  -- (see CoreSubst.simple_app) won't inline 'seq' on the
+                  -- LHS of rules.  That way we can have rules for 'seq';
+                  -- see Note [seqId magic]
 
     ty  = mkForAllTys [alphaTyVar,betaTyVar]
                       (mkFunTy alphaTy (mkFunTy betaTy betaTy))
@@ -1099,17 +1104,18 @@ seqId = pcMiscPrelId seqName ty info
     rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)])
 
     -- See Note [Built-in RULES for seq]
+    -- NB: ru_nargs = 3, not 4, to match the code in
+    --     Simplify.rebuildCase which tries to apply this rule
     seq_cast_rule = BuiltinRule { ru_name  = fsLit "seq of cast"
                                 , ru_fn    = seqName
-                                , ru_nargs = 4
-                                , ru_try   = match_seq_of_cast
-                                }
+                                , ru_nargs = 3
+                                , ru_try   = match_seq_of_cast }
 
 match_seq_of_cast :: RuleFun
     -- See Note [Built-in RULES for seq]
-match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co, expr]
+match_seq_of_cast _ _ _ [Type _, Type res_ty, Cast scrut co]
   = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
-                              scrut, expr])
+                              scrut])
 match_seq_of_cast _ _ _ _ = Nothing
 
 ------------------------------------------------
@@ -1215,16 +1221,24 @@ transform to
 Rather than attempt some general analysis to support this, I've added
 enough support that you can do this using a rewrite rule:
 
-  RULE "f/seq" forall n.  seq (f n) e = seq n e
+  RULE "f/seq" forall n.  seq (f n) = seq n
 
 You write that rule.  When GHC sees a case expression that discards
 its result, it mentally transforms it to a call to 'seq' and looks for
 a RULE.  (This is done in Simplify.rebuildCase.)  As usual, the
 correctness of the rule is up to you.
 
-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.
+VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2.
+If we wrote
+  RULE "f/seq" forall n e.  seq (f n) e = seq n e
+with rule arity 2, then two bad things would happen:
+
+  - The magical desugaring done in Note [seqId magic] item (c)
+    for saturated application of 'seq' would turn the LHS into
+    a case expression!
+
+  - The code in Simplify.rebuildCase would need to actually supply
+    the value argument, which turns out to be awkward.
 
 Note [Built-in RULES for seq]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index b381dc8..35dbb50 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -954,6 +954,7 @@ simple_app subst (Lam b e) (a:as)
     b2 = add_info subst' b b'
 simple_app subst (Var v) as
   | isCompulsoryUnfolding (idUnfolding v)
+  , isAlwaysActive (idInlineActivation v)
   -- See Note [Unfold compulsory unfoldings in LHSs]
   =  simple_app subst (unfoldingTemplate (idUnfolding v)) as
 simple_app subst (Tick t e) as
@@ -1108,10 +1109,16 @@ to remain visible until Phase 1
 
 Note [Unfold compulsory unfoldings in LHSs]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When the user writes `map coerce = coerce` as a rule, the rule will only ever
-match if we replace coerce by its unfolding on the LHS, because that is the
-core that the rule matching engine will find. So do that for everything that
-has a compulsory unfolding. Also see Note [Desugaring coerce as cast] in Desugar
+When the user writes `RULES map coerce = coerce` as a rule, the rule
+will only ever match if simpleOptExpr replaces coerce by its unfolding
+on the LHS, because that is the core that the rule matching engine
+will find. So do that for everything that has a compulsory
+unfolding. Also see Note [Desugaring coerce as cast] in Desugar.
+
+However, we don't want to inline 'seq', which happens to also have a
+compulsory unfolding, so we only do this unfolding only for things
+that are always-active.  See Note [User-defined RULES for seq] in MkId.
+
 
 ************************************************************************
 *                                                                      *
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index bb10711..b6693aa 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -53,7 +53,6 @@ import MkId(proxyHashId)
 import Class
 import DataCon  ( dataConWorkId )
 import Name
-import MkId     ( seqId )
 import IdInfo   ( IdDetails(..) )
 import Var
 import VarSet
@@ -638,11 +637,6 @@ decomposeRuleLhs orig_bndrs orig_lhs
       | not (fn_id `elemVarSet` orig_bndr_set)
       = Just (fn_id, args)
 
-   decompose (Case scrut bndr ty [(DEFAULT, _, body)]) args
-      | isDeadBinder bndr   -- Note [Matching seqId]
-      , let args' = [Type (idType bndr), Type ty, scrut, body]
-      = Just (seqId, args' ++ args)
-
    decompose _ _ = Nothing
 
    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))