From eae703aa60f41fd232be5478e196b661839ec3de Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 22 May 2015 14:41:54 +0100 Subject: [PATCH] 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 --- 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 365ed821b4..2e84d838fe 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 52f4c0d7aa..a3665ed96a 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 f67ffacdc4..fac5eb7d0a 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")) -- GitLab