optimization - para - ¿Es posible hacer que las funciones genéricas de GHC optimicen(deforestación) como los catamorfismos?

efectos de la deforestacion

Question

Me gusta mucho la idea de trabajar con catamorfismos / anamorfismos de manera genérica, pero me parece que tiene un inconveniente significativo en el rendimiento:

Supongamos que queremos trabajar con una estructura de árbol de forma categórica: para describir diferentes plegados utilizando una función de catamorfismo genérica:

newtype Fix f = Fix { unfix :: f (Fix f) }

data TreeT r = Leaf | Tree r r
instance Functor TreeT where
    fmap f Leaf         = Leaf
    fmap f (Tree l r)   = Tree (f l) (f r)

type Tree = Fix TreeT

catam :: (Functor f) => (f a -> a) -> (Fix f -> a)
catam f = f . fmap (catam f) . unfix

Ahora podemos escribir funciones como:

depth1 :: Tree -> Int
depth1 = catam g
  where
    g Leaf       = 0
    g (Tree l r) = max l r

Desafortunadamente, este enfoque tiene un inconveniente importante: durante el cálculo, se crean nuevas instancias de TreeT Int en todos los niveles en fmap para que sean inmediatamente consumidas por g . Comparado con la definición clásica

depth2 :: Tree -> Int
depth2 (Fix Leaf) = 0
depth2 (Fix (Tree l r)) = max (depth1 l) (depth1 r)

nuestra depth1 siempre será más lenta, lo que depth1 una tensión innecesaria en el GC. Una solución sería usar hylomorphisms y combinar la creación y el plegado de árboles. Pero a menudo no queremos hacer eso, es posible que queramos que se cree un árbol en un lugar y luego se pase a otra parte para que se pliegue más tarde. O, para ser carpeta varias veces con diferentes catamorfismos.

¿Hay alguna manera de hacer que GHC optimice la depth1 ? Algo como catam g y luego fusing/deforesting g . fmap ... g . fmap ... dentro?

Answer 1

Creo que encontré una respuesta. Recordé haber leído ¿Por qué GHC arregla tan confuso? Y eso me sugirió una solución.

El problema con la definición anterior de catam es que es recursiva, por lo que cualquier intento de INLINE se ignora. Compilando la versión original con -ddump-simpl -ddump-to-file y leyendo el core :

Main.depth1 = Main.catam_$scatam @ GHC.Types.Int Main.depth3

Main.depth3 =
  / (ds_dyI :: Main.TreeT GHC.Types.Int) ->
    case ds_dyI of _ {
      Main.Leaf -> Main.depth4;
      Main.Tree l_aah r_aai -> GHC.Classes.$fOrdInt_$cmax l_aah r_aai
    }

Main.depth4 = GHC.Types.I# 0

Rec {
Main.catam_$scatam =
  / (@ a_ajB)
    (eta_B1 :: Main.TreeT a_ajB -> a_ajB)
    (eta1_X2 :: Main.Fix Main.TreeT) ->
    eta_B1
      (case eta1_X2
            `cast` (Main.NTCo:Fix <Main.TreeT>
                    :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))
       of _ {
         Main.Leaf -> Main.Leaf @ a_ajB;
         Main.Tree l_aan r_aao ->
           Main.Tree
             @ a_ajB
             (Main.catam_$scatam @ a_ajB eta_B1 l_aan)
             (Main.catam_$scatam @ a_ajB eta_B1 r_aao)
       })
end Rec }

es claramente peor (creación / eliminación del constructor en catam_$scatam , más llamadas a funciones) en comparación con

Main.depth2 =
  / (w_s1Rz :: Main.Tree) ->
    case Main.$wdepth2 w_s1Rz of ww_s1RC { __DEFAULT ->
    GHC.Types.I# ww_s1RC
    }

Rec {
Main.$wdepth2 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int#
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S]
Main.$wdepth2 =
  / (w_s1Rz :: Main.Tree) ->
    case w_s1Rz
         `cast` (Main.NTCo:Fix <Main.TreeT>
                 :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))
    of _ {
      Main.Leaf -> 0;
      Main.Tree l_aaj r_aak ->
        case Main.$wdepth2 l_aaj of ww_s1RC { __DEFAULT ->
        case Main.$wdepth2 r_aak of ww1_X1Sh { __DEFAULT ->
        case GHC.Prim.<=# ww_s1RC ww1_X1Sh of _ {
          GHC.Types.False -> ww_s1RC;
          GHC.Types.True -> ww1_X1Sh
        }
        }
        }
    }
end Rec }

Pero si definimos catam como

{-# INLINE catam #-}
catam :: (Functor f) => (f a -> a) -> (Fix f -> a)
catam f = let u = f . fmap u . unfix
          in u

entonces ya no es recursivo, solo u está dentro. De esta manera, GHC inscribe en la definición de depth1 y fusiona fmap con la g depth1 , justo lo que queremos:

Main.depth1 =
  / (w_s1RJ :: Main.Tree) ->
    case Main.$wdepth1 w_s1RJ of ww_s1RM { __DEFAULT ->
    GHC.Types.I# ww_s1RM
    }

Rec {
Main.$wdepth1 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int#
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S]
Main.$wdepth1 =
  / (w_s1RJ :: Main.Tree) ->
    case w_s1RJ
         `cast` (Main.NTCo:Fix <Main.TreeT>
                 :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT))
    of _ {
      Main.Leaf -> 0;
      Main.Tree l_aar r_aas ->
        case Main.$wdepth1 l_aar of ww_s1RM { __DEFAULT ->
        case Main.$wdepth1 r_aas of ww1_X1So { __DEFAULT ->
        case GHC.Prim.<=# ww_s1RM ww1_X1So of _ {
          GHC.Types.False -> ww_s1RM;
          GHC.Types.True -> ww1_X1So
        }
        }
        }
    }
end Rec }

que ahora es lo mismo que el volcado de depth2 .