Arity analysis fails badly

Here's an interesting program, derived from the implementation of coVarsOfType in GHC.Core.TyCo.FVs. It came up @Mikolaj's MR !12037 (closed), where the bug described below made GHC allocate six times as much to compile the same program. Six times!

Here's the issue.

module Foo where

import Data.List
import Data.Monoid

data Type = Tv Int | Tc [Type]

foldTyCo :: Monoid a => (Int -> a) -> Type -> a
{-# INLINE foldTyCo #-}
foldTyCo do_tv = go
 where
   go (Tv x) = do_tv x

   ----------------- foldl version --------------
   go (Tc tys) = foldl (\ acc ty -> acc `mappend` go ty) mempty tys

   ----------------- foldr version --------------
   --   go (Tc tys) = foldr (\t acc -> go t `mappend` acc) mempty tys

   ----------------- Explicit version --------------
   --   go (Tc tys) = go_tys tys
   --   go_tys [] = mempty
   --   go_tys (t:ts) = go t `mappend` go_tys ts


free_tvs :: Type -> [Int]
free_tvs ty = appEndo (foldTyCo f ty) []
  where
    f :: Int -> Endo [Int]
    f x = Endo (\xs -> x:xs)

Reminder:

• foldTyCo is specialised (by inlining) at every call site.
• In this case free_tvs specialises it at Endo [Int].
• newtype Endo = Endo (a->a); so free_tvs has an accumulating parameter.

We expect to get nice code like this:

Foo.free_tvs1 [Occ=LoopBreaker] :: [Type] -> [Int] -> [Int]
[GblId, Arity=2, Str=<1L><ML>, Unf=OtherCon []]
Foo.free_tvs1
  = \ (ds_a1ez :: [Type]) (eta_X2 [OS=OneShot] :: [Int]) ->
      case ds_a1ez of {
        [] -> eta_X2;
        : y_a1eC ys_a1eD ->
          case y_a1eC of {
            Tv x_aBb   -> GHC.Types.: @Int x_aBb (Foo.free_tvs1 ys_a1eD eta_X2);
            Tc tys_aBc -> Foo.free_tvs1 tys_aBc (Foo.free_tvs1 ys_a1eD eta_X2)
          }
      }

And we do get this code with

• The Explicit version which uses explicit recursion.
• The foldr version which uses foldr.

But with the "foldl version" we get

go1_r1f2 :: [Type] -> Endo [Int] -> Endo [Int]
[GblId[StrictWorker([!])], Arity=2, Str=<1L><L>, Unf=OtherCon []]
go1_r1f2
  = \ (ds_a1eC :: [Type]) (eta_B0 [OS=OneShot] :: Endo [Int]) ->
      case ds_a1eC of {
        [] -> eta_B0;
        : y_a1eF ys_a1eG ->
          go1_r1f2
            ys_a1eG
            (let {
               g_s1eq [Dmd=LC(S,L)] :: Endo [Int]
               [LclId]
               g_s1eq = Foo.free_tvs_go y_a1eF } in
             (\ (x_a1ej :: [Int]) ->
                (eta_B0
                 `cast` (base:Data.Semigroup.Internal.N:Endo[0] <[Int]>_R
                         :: Endo [Int] ~R# ([Int] -> [Int])))
                  ((g_s1eq
                    `cast` (base:Data.Semigroup.Internal.N:Endo[0] <[Int]>_R
                            :: Endo [Int] ~R# ([Int] -> [Int])))
                     x_a1ej))
             `cast` (Sym (base:Data.Semigroup.Internal.N:Endo[0] <[Int]>_R)
                     :: ([Int] -> [Int]) ~R# Endo [Int]))  }

Foo.free_tvs_go [Occ=LoopBreaker] :: Type -> Endo [Int]
[GblId, Arity=1, Str=<1L>, Unf=OtherCon []]
Foo.free_tvs_go
  = \ (ds_dVv :: Type) ->
      case ds_dVv of {
        Tv x_aB5 ->
          (\ (xs_aRa :: [Int]) -> GHC.Types.: @Int x_aB5 xs_aRa)
          `cast` (Sym (base:Data.Semigroup.Internal.N:Endo[0] <[Int]>_R)
                  :: ([Int] -> [Int]) ~R# Endo [Int]);
        Tc tys_aB6 ->
          go1_r1f2
            tys_aB6
            ((id @[Int])
             `cast` (Sym (base:Data.Semigroup.Internal.N:Endo[0] <[Int]>_R)
                     :: ([Int] -> [Int]) ~R# Endo [Int]))  }

This is very bad. Two mutually-recursive functions, with higher order arguments. No no no. A heavy cost for switching from foldr to foldl.

Reminder: not only are we using higher order stuff in the form of Endo, but also foldl is implemented in terms of foldr. See this in GHC.Internal.List:

foldl k z0 xs =
  foldr (\(v::a) (fn::b->b) -> oneShot (\(z::b) -> fn (k z v))) (id :: b -> b) xs z0
  -- See Note [Left folds via right fold]

{-
Note [Left folds via right fold]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...

Diagnosis

At an earlier stage in the pipeline we have

go_s1em [Occ=LoopBreaker] :: Type -> Endo [Int]
go_s1em
  = \ (ds_dVv :: Type) ->
      case ds_dVv of {
        Tv x_aB6 ->
          (\ (xs_aRa :: [Int]) -> GHC.Types.: @Int x_aB6 xs_aRa)
          `cast` <Co:4> :: ([Int] -> [Int]) ~R# Endo [Int];
        Tc tys_aB7 ->
          letrec {
            go1_a1et [Occ=LoopBreaker] :: [Type] -> Endo [Int]
            go1_a1et
              = \ (ds_a1eu :: [Type]) ->
                  case ds_a1eu of {
                    [] -> (id @[Int]) `cast` <Co:4> :: ([Int] -> [Int]) ~R# Endo [Int];
                    : y_a1ex ys_a1ey ->
                      (let {
                         f_s1ei :: Endo [Int]
                         f_s1ei = go_s1em y_a1ex } in
                       let {
                         acc_aLK [OS=OneShot] :: Endo [Int]
                         acc_aLK = go1_a1et ys_a1ey } in
                       \ (x_a1e9 :: [Int]) ->
                         (f_s1ei `cast` <Co:3> :: Endo [Int] ~R# ([Int] -> [Int]))
                           ((acc_aLK `cast` <Co:3> :: Endo [Int] ~R# ([Int] -> [Int]))
                              x_a1e9))
                      `cast` <Co:4> :: ([Int] -> [Int]) ~R# Endo [Int]
                  }; } in
          go1_a1et tys_aB7
      }

We want to eta-expand go_s1em and go1_a1et; then all would be well. And indeed, if we hypothesis that both have arity 2, we can indeed eta-expand. But GHC.Core.Opt.Arity.findRhsArity only works on self-recursive functions; it is defeated by nested mutual recursion like the example above. And apparently Call Arity analysis is defeated too.

Mabye @sgraf812's new plan will catch this.

Meanwhile, this ticket just serves to immortalise the missed opportunity.