[commit: ghc] master: Reduce magic for seqId (eae703a)
git at git.haskell.org
git at git.haskell.org
Fri May 22 14:14:39 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/eae703aa60f41fd232be5478e196b661839ec3de/ghc
>---------------------------------------------------------------
commit eae703aa60f41fd232be5478e196b661839ec3de
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
>---------------------------------------------------------------
eae703aa60f41fd232be5478e196b661839ec3de
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 365ed82..2e84d83 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -1074,10 +1074,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))
@@ -1087,17 +1092,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
------------------------------------------------
@@ -1203,16 +1209,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 52f4c0d..a3665ed 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 f67ffac..fac5eb7 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -53,7 +53,6 @@ import MkId(proxyHashId)
import Class
import DataCon ( dataConTyCon )
import Name
-import MkId ( seqId )
import IdInfo ( IdDetails(..) )
import Var
import VarSet
@@ -602,11 +601,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"))
More information about the ghc-commits
mailing list