Bogus one-shot info on floated join point

Consider this program

module Foo(f) where

wongle :: String
wongle = reverse (reverse "hello")

f :: String -> String
f ps = let {-# NOINLINE j #-}
           j :: String -> String
           j ys = f (reverse (reverse ys)) ++ wongle
       in case ps of
           (p:[])     -> j [p,p]
           (p1:p2:[]) -> j [p2]
           _          -> "wombat"

Here j is immediately discovered as a join point. (I have marked it NOINLINE to stop it inlining, but instead I could just have given it a big RHS.

Look at what happens after the FloatOut pass, after occurrence analysis, just before the Simplifier:

Foo.wongle [Occ=Once1] :: GHC.Base.String
Foo.wongle
  = GHC.List.reverse1 @GHC.Types.Char lvl_sP8 (GHC.Types.[] @GHC.Types.Char)

Rec {
Foo.f :: GHC.Base.String -> GHC.Base.String
Foo.f
  = \ (ps_ayb [Occ=Once1!] :: GHC.Base.String) ->
      case ps_ayb of {
        [] -> lvl_sPd;
        : p_ayf ds_dA1 [Occ=Once1!] ->
          case ds_dA1 of {
            [] ->
              j_sPa
                (GHC.Base.build
                   @GHC.Types.Char
                   (\ (@a_dzV)
                      (c_dzW [OS=OneShot] :: GHC.Types.Char -> a_dzV -> a_dzV)
                      (n_dzX [Occ=Once1, OS=OneShot] :: a_dzV) ->
                      c_dzW p_ayf (c_dzW p_ayf n_dzX)));
            : p2_ayh [Occ=Once1] ds_dA2 [Occ=Once1!] ->
              case ds_dA2 of {
                [] ->
                  j_sPa
                    (GHC.Base.build
                       @GHC.Types.Char
                       (\ (@a_dzY)
                          (c_dzZ [Occ=Once1!, OS=OneShot]
                             :: GHC.Types.Char -> a_dzY -> a_dzY)
                          (n_dA0 [Occ=Once1, OS=OneShot] :: a_dzY) ->
                          c_dzZ p2_ayh n_dA0));
                : _ [Occ=Dead] _ [Occ=Dead] -> lvl_sPg
              }
          }
      }

j_sPa [InlPrag=NOINLINE, Occ=LoopBreaker] :: GHC.Base.String -> GHC.Base.String
j_sPa
  = \ (ys_ayd [Occ=Once1, OS=OneShot] :: GHC.Base.String) ->      <---------------------- yikes! --------------
      GHC.Base.augment
        @GHC.Types.Char
        (\ (@b_aAx)
           (c_aAy [Occ=Once1, OS=OneShot] :: GHC.Types.Char -> b_aAx -> b_aAx)
           (n_aAz [Occ=Once1, OS=OneShot] :: b_aAx) ->
           GHC.Base.foldr
             @GHC.Types.Char
             @b_aAx
             c_aAy
             n_aAz
             (Foo.f
                (GHC.List.reverse1
                   @GHC.Types.Char
                   (GHC.List.reverse1
                      @GHC.Types.Char ys_ayd (GHC.Types.[] @GHC.Types.Char))
                   (GHC.Types.[] @GHC.Types.Char))))
        Foo.wongle
end Rec }

The join point has been floated to the top level, which is fair enough. But we have failed to zap the one-shot info its binder ys_ayd. When it was a join point, nested in the body of f, it was indeed a one-shot binder. But not when it is floated to top level!

This is bad. Now wongle occurs just once, in j's RHS, so preInlineUnconditionally inlines it. Disaster:

Rec {
f :: String -> String
f = \ (ps_ayb :: String) ->
      case ps_ayb of {
        [] -> lvl_sPd;
        : p_ayf ds_dA1 ->
          case ds_dA1 of {
            [] ->
              j_sPa
                (GHC.Base.build
                   @Char
                   (\ (@a_dzV)
                      (c_dzW [OS=OneShot] :: Char -> a_dzV -> a_dzV)
                      (n_dzX [OS=OneShot] :: a_dzV) ->
                      c_dzW p_ayf (c_dzW p_ayf n_dzX)));
            : p2_ayh ds_dA2 ->
              case ds_dA2 of {
                [] ->
                  j_sPa
                    (GHC.Base.build
                       @Char
                       (\ (@a_dzY)
                          (c_dzZ [OS=OneShot] :: Char -> a_dzY -> a_dzY)
                          (n_dA0 [OS=OneShot] :: a_dzY) ->
                          c_dzZ p2_ayh n_dA0));
                : ipv_sP0 ipv_sP1 -> lvl_sPg
              }
          }
      }

j_sPa [InlPrag=NOINLINE, Occ=LoopBreaker] :: String -> String
j_sPa
  = \ (ys_ayd [OS=OneShot] :: String) ->
      GHC.Base.augment
        @Char
        (\ (@b_aAx)
           (c_aAy [OS=OneShot] :: Char -> b_aAx -> b_aAx)
           (n_aAz [OS=OneShot] :: b_aAx) ->
           GHC.Base.foldr
             @Char
             @b_aAx
             c_aAy
             n_aAz
             (f (GHC.List.reverse1
                   @Char
                   (GHC.List.reverse1 @Char ys_ayd (GHC.Types.[] @Char))
                   (GHC.Types.[] @Char))))
        (GHC.List.reverse1
           @Char
           (GHC.List.reverse1
              @Char
              (GHC.Base.build
                 @Char
                 (\ (@b_aAd) -> GHC.CString.unpackFoldrCString# @b_aAd "hello"#))
              (GHC.Types.[] @Char))
           (GHC.Types.[] @Char))
end Rec }

Now wongle's work is done every time around the loop.

I tripped over this when poking about in nofig spectral/ansi, while working on #17910. It is clearly totally wrong; but I'm not sure how much impact it will have outside artificial benchmarks, because it just duplicates a CAF and real programs don't have many expensive CAFs I think.