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, 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 atEndo [Int]
. -
newtype Endo = Endo (a->a)
; sofree_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.