[commit: ghc] master: Don't do the RhsCtxt thing for join points (8649535)
git at git.haskell.org
git at git.haskell.org
Fri Aug 25 11:57:38 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/8649535c1c99b851ba3a9fd5a88ca0a3a28b2c18/ghc
>---------------------------------------------------------------
commit 8649535c1c99b851ba3a9fd5a88ca0a3a28b2c18
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Fri Aug 25 12:52:14 2017 +0100
Don't do the RhsCtxt thing for join points
This minor change fixes Trac #14137.
It is described in Note [Join point RHSs] in OccurAnal
>---------------------------------------------------------------
8649535c1c99b851ba3a9fd5a88ca0a3a28b2c18
compiler/simplCore/OccurAnal.hs | 24 +++++++--
testsuite/tests/simplCore/should_compile/T14137.hs | 15 ++++++
.../tests/simplCore/should_compile/T14137.stderr | 63 ++++++++++++++++++++++
testsuite/tests/simplCore/should_compile/all.T | 1 +
4 files changed, 99 insertions(+), 4 deletions(-)
diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs
index 113f8bd..1ae5bbe 100644
--- a/compiler/simplCore/OccurAnal.hs
+++ b/compiler/simplCore/OccurAnal.hs
@@ -1554,19 +1554,24 @@ occAnalNonRecRhs :: OccEnv
occAnalNonRecRhs env bndr bndrs body
= occAnalLamOrRhs rhs_env bndrs body
where
- -- See Note [Cascading inlines]
- env1 | certainly_inline = env
+ env1 | is_join_point = env -- See Note [Join point RHSs]
+ | certainly_inline = env -- See Note [Cascading inlines]
| otherwise = rhsCtxt env
-- See Note [Sources of one-shot information]
rhs_env = env1 { occ_one_shots = argOneShots dmd }
certainly_inline -- See Note [Cascading inlines]
- = case idOccInfo bndr of
+ = case occ of
OneOcc { occ_in_lam = in_lam, occ_one_br = one_br }
-> not in_lam && one_br && active && not_stable
_ -> False
+ is_join_point = isAlwaysTailCalled occ
+ -- Like (isJoinId bndr) but happens one step earlier
+ -- c.f. willBeJoinId_maybe
+
+ occ = idOccInfo bndr
dmd = idDemandInfo bndr
active = isAlwaysActive (idInlineActivation bndr)
not_stable = not (isStableUnfolding (idUnfolding bndr))
@@ -1627,7 +1632,18 @@ occAnalRules env mb_expected_join_arity rec_flag id
= case mb_expected_join_arity of
Just ar | args `lengthIs` ar -> uds
_ -> markAllNonTailCalled uds
-{-
+{- Note [Join point RHSs]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ x = e
+ join j = Just x
+
+We want to inline x into j right away, so we don't want to give
+the join point a RhsCtxt (Trac #14137). It's not a huge deal, because
+the FloatIn pass knows to float into join point RHSs; and the simplifier
+does not float things out of join point RHSs. But it's a simple, cheap
+thing to do. See Trac #14137.
+
Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
By default we use an rhsCtxt for the RHS of a binding. This tells the
diff --git a/testsuite/tests/simplCore/should_compile/T14137.hs b/testsuite/tests/simplCore/should_compile/T14137.hs
new file mode 100644
index 0000000..ef8c307
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T14137.hs
@@ -0,0 +1,15 @@
+module T14137 where
+
+-- The point of this test is that we should inline 'thunk'
+-- into j's RHS, and we can do so quite agressively, even
+-- when we aren't optimising. See the ticket.
+--
+-- It's not a big deal, because in the end FloatIn
+-- does the same job, only later
+
+f xs = let thunk = length xs
+ j = Just thunk
+ g 0 = j
+ g n = g (n-1)
+ in
+ g 7
diff --git a/testsuite/tests/simplCore/should_compile/T14137.stderr b/testsuite/tests/simplCore/should_compile/T14137.stderr
new file mode 100644
index 0000000..602a740
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T14137.stderr
@@ -0,0 +1,63 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+ = {terms: 45, types: 41, coercions: 0, joins: 2/2}
+
+-- RHS size: {terms: 30, types: 24, coercions: 0, joins: 2/2}
+f :: forall (t :: * -> *) a. Foldable t => t a -> Maybe Int
+[GblId, Arity=2]
+f = \ (@ (t :: * -> *))
+ (@ a)
+ ($dFoldable :: Foldable t)
+ (xs :: t a) ->
+ join {
+ j :: Maybe Int
+ [LclId[JoinId(0)], Unf=OtherCon []]
+ j = GHC.Base.Just @ Int (length @ t $dFoldable @ a xs) } in
+ joinrec {
+ g [Occ=LoopBreaker] :: Integer -> Maybe Int
+ [LclId[JoinId(1)], Arity=1, Unf=OtherCon []]
+ g (ds :: Integer)
+ = case ==
+ @ Integer
+ integer-gmp-1.0.1.0:GHC.Integer.Type.$fEqInteger
+ ds
+ (fromInteger @ Integer GHC.Num.$fNumInteger 0)
+ of {
+ False ->
+ jump g
+ (- @ Integer
+ GHC.Num.$fNumInteger
+ ds
+ (fromInteger @ Integer GHC.Num.$fNumInteger 1));
+ True -> jump j
+ }; } in
+ jump g 7
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule1 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$trModule1 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule2 :: GHC.Types.TrName
+[GblId, Caf=NoCafRefs]
+$trModule2 = GHC.Types.TrNameS $trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule3 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$trModule3 = "T14137"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule4 :: GHC.Types.TrName
+[GblId, Caf=NoCafRefs]
+$trModule4 = GHC.Types.TrNameS $trModule3
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T14137.$trModule :: GHC.Types.Module
+[GblId, Caf=NoCafRefs]
+T14137.$trModule = GHC.Types.Module $trModule2 $trModule4
+
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index edc24bf..82a5124 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -269,3 +269,4 @@ test('T12600',
['$MAKE -s --no-print-directory T12600'])
test('T13658', normal, compile, ['-dcore-lint'])
test('T13708', normal, compile, [''])
+test('T14137', normal, compile, ['-dsuppress-uniques -ddump-simpl'])
More information about the ghc-commits
mailing list