Don't do the RhsCtxt thing for join points
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 25 Aug 2017 11:52:14 +0000 (12:52 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 25 Aug 2017 11:57:13 +0000 (12:57 +0100)
This minor change fixes Trac #14137.

It is described in Note [Join point RHSs] in OccurAnal

compiler/simplCore/OccurAnal.hs
testsuite/tests/simplCore/should_compile/T14137.hs [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/T14137.stderr [new file with mode: 0644]
testsuite/tests/simplCore/should_compile/all.T

index 113f8bd..1ae5bbe 100644 (file)
@@ -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 (file)
index 0000000..ef8c307
--- /dev/null
@@ -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 (file)
index 0000000..602a740
--- /dev/null
@@ -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
+
+
+
index edc24bf..82a5124 100644 (file)
@@ -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'])