performance - ¿Cuál es la forma correcta de realizar bucles anidados en el espacio constante en Haskell?

for anidado javascript

Question

Hay dos formas obvias e "idiomáticas" de realizar bucles anidados en Haskell: usar la lista de mónadas o usar forM_ para reemplazar los fors tradicionales. Establecí un punto de referencia para determinar si se compila en bucles ajustados:

import Control.Monad.Loop
import Control.Monad.Primitive
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Vector.Unboxed.Mutable as MV
import qualified Data.Vector.Unboxed as V

times = 100000
side  = 100

-- Using `forM_` to replace traditional fors
test_a mvec = 
    forM_ [0..times-1] $ / n -> do
        forM_ [0..side-1] $ / y -> do
            forM_ [0..side-1] $ / x -> do
                MV.write mvec (y*side+x) 1

-- Using the list monad to replace traditional forms
test_b mvec = sequence_ $ do
    n <- [0..times-1]
    y <- [0..side-1]
    x <- [0..side-1]
    return $ MV.write mvec (y*side+x) 1

main = do
    let vec = V.generate (side*side) (const 0)
    mvec <- V.unsafeThaw vec :: IO (MV.MVector (PrimState IO) Int)
    -- test_a mvec
    -- test_b mvec
    vec'' <- V.unsafeFreeze mvec :: IO (V.Vector Int)
    print $ V.sum vec''

Esta prueba crea un vector de 100x100, escribe 1 en cada índice usando un bucle anidado y lo repite 100 veces. Compilando aquellos con solo ghc -O2 test.hs -o test (ghc versión 7.8.4), los resultados son: 3.853s para la versión 10.460s y 10.460s para la list monad . Para proporcionar una referencia, también programé esta prueba en JavaScript:

var side  = 100;
var times = 100000;
var vec   = [];

for (var i=0; i<side*side; ++i)
    vec.push(0);

for (var n=0; n<times; ++n)
    for (var y=0; y<side; ++y)
        for (var x=0; x<side; ++x)
            vec[x+y*side] = 1;

var s = 0;
for (var i=0; i<side*side; ++i)
    s += vec[i];

console.log(s);

Este programa equivalente de JavaScript tarda 1s en completarse, superando a los vectores no compartidos de Haskell, lo cual es inusual, lo que sugiere que Haskell no está ejecutando el bucle en un espacio constante, sino haciendo asignaciones en su lugar. Luego encontré una biblioteca que dice proporcionar lazos garantizados de tipo control Control.Monad.Loop :

-- Using `for` from Control.Monad.Loop
test_c mvec = exec_ $ do
    n <- for 0 (< times) (+ 1)
    x <- for 0 (< side) (+ 1)
    y <- for 0 (< side) (+ 1)
    liftIO (MV.write mvec (y*side+x) 1)

Que se ejecuta en 1s . Sin embargo, esa biblioteca no es muy utilizada y está lejos de ser idiomática. Entonces, ¿cuál es la forma idiomática de obtener cálculos bidimensionales constantes en el espacio constante? (Tenga en cuenta que este no es un caso para REPA ya que quiero realizar acciones IO arbitrarias en la cuadrícula).

Answer 1

En mi experiencia forM_ [0..n-1] puede funcionar bien, pero desafortunadamente no es confiable. Simplemente agregando un pragma test_a a test_a y usando -O2 hace que se ejecute mucho más rápido (de 4s a 1s para mí), pero al alinearlo manualmente (copiar y pegar) lo vuelve a ralentizar.

Una función más confiable es for statistics que se implementan como

-- | Simple for loop.  Counts from /start/ to /end/-1.
for :: Monad m => Int -> Int -> (Int -> m ()) -> m ()
for n0 !n f = loop n0
  where
    loop i | i == n    = return ()
           | otherwise = f i >> loop (i+1)
{-# INLINE for #-}

forM_ uso es similar a forM_ con listas:

test_d :: MV.IOVector Int -> IO ()
test_d mv =
  for 0 times $ /_ ->
    for 0 side $ /i ->
      for 0 side $ /j ->
        MV.unsafeWrite mv (i*side + j) 1

pero funciona de manera confiable (0.85s para mí) sin ningún riesgo de asignar una lista.

Answer 2

Escribir código de mutación ajustada con GHC puede ser complicado a veces. Voy a escribir sobre un par de cosas diferentes, probablemente de una manera que es más divagable y tímida de lo que yo preferiría.

Para empezar, deberíamos usar GHC 7.10 en cualquier caso, ya que, de lo otherwise las soluciones de mónadas forM_ y de lista nunca se fusionarían.

Además, reemplacé MV.write con MV.unsafeWrite , en parte porque es más rápido, pero lo más importante es que reduce parte del desorden en el Core resultante. A partir de ahora, las estadísticas de tiempo de ejecución se refieren al código con unsafeWrite .

El temido dejó flotando

Incluso con GHC 7.10, primero deberíamos observar todas esas [0..times-1] y [0..side-1] , ya que arruinarán el rendimiento cada vez que no tomemos las medidas necesarias. El problema es que son rangos constantes, y -ffull-laziness (que está habilitada por defecto en -O ) los lleva al nivel superior. Esto evita la fusión de listas, y iterar sobre un rango Int# es más barato que iterar en una lista de Int -s encasillados de todos modos, por lo que es una optimización realmente mala.

Veamos algunos tiempos de ejecución en segundos para el código sin cambios (aparte del uso de unsafeWrite ). ghc -O2 -fllvm , y uso +RTS -s para el tiempo.

test_a: 1.6
test_b: 6.2
test_c: 0.6

Para la visualización de GHC Core usé ghc -O2 -ddump-simpl -dsuppress-all -dno-suppress-type-signatures .

En el caso de test_a , los rangos [0..99] se eliminan:

main4 :: [Int]
main4 = eftInt 0 99 -- means "enumFromTo" for Int.

aunque el bucle más externo [0..9999] se fusiona en un ayudante recursivo de cola:

letrec {
          a3_s7xL :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
          a3_s7xL =
            / (x_X5zl :: Int#) (s1_X4QY :: State# RealWorld) ->
              case a2_s7xF 0 s1_X4QY of _ { (# ipv2_a4NA, ipv3_a4NB #) ->
              case x_X5zl of wild_X1S {
                __DEFAULT -> a3_s7xL (+# wild_X1S 1) ipv2_a4NA;
                99999 -> (# ipv2_a4NA, () #)
              }
              }; }

En el caso de test_b , nuevamente solo se levanta el [0..99] . Sin embargo, test_b es mucho más lento, porque tiene que compilar y secuenciar listas [IO ()] reales. Al menos GHC es lo suficientemente sensible como para construir solo un único [IO ()] para los dos bucles internos, y luego realizar la secuencia 10000 veces.

 let {
          lvl7_s4M5 :: [IO ()]
          lvl7_s4M5 = -- omitted
        letrec {
          a2_s7Av :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
          a2_s7Av =
            / (x_a5xi :: Int#) (eta_B1 :: State# RealWorld) ->
              letrec {
                a3_s7Au
                  :: [IO ()] -> State# RealWorld -> (# State# RealWorld, () #)
                a3_s7Au =
                  / (ds_a4Nu :: [IO ()]) (eta1_X1c :: State# RealWorld) ->
                    case ds_a4Nu of _ {
                      [] ->
                        case x_a5xi of wild1_X1y {
                          __DEFAULT -> a2_s7Av (+# wild1_X1y 1) eta1_X1c;
                          99999 -> (# eta1_X1c, () #)
                        };
                      : y_a4Nz ys_a4NA ->
                        case (y_a4Nz `cast` ...) eta1_X1c
                        of _ { (# ipv2_a4Nf, ipv3_a4Ng #) ->
                        a3_s7Au ys_a4NA ipv2_a4Nf
                        }
                    }; } in
              a3_s7Au lvl7_s4M5 eta_B1; } in
-- omitted

¿Cómo podemos remediar esto? Podríamos atacar el problema con {-# OPTIONS_GHC -fno-full-laziness #-} . Esto de hecho ayuda mucho en nuestro caso:

test_a: 0.5
test_b: 0.48
test_c: 0.5

Alternativamente, podríamos jugar con pragmas INLINE . Al parecer, las funciones de alineación después de dejar flotar conservan un buen rendimiento. Descubrí que GHC enumera nuestras funciones de prueba incluso sin un pragma, pero un pragma explícito hace que se alinee solo después de dejar de flotar. Por ejemplo, esto da como resultado un buen rendimiento sin -fno-full-laziness :

test_a mvec = 
    forM_ [0..times-1] $ / n -> 
        forM_ [0..side-1] $ / y -> 
            forM_ [0..side-1] $ / x -> 
                MV.unsafeWrite mvec (y*side+x) 1
{-# INLINE test_a #-}

Pero al incluir resultados demasiado tempranos, el rendimiento es deficiente:

test_a mvec = 
    forM_ [0..times-1] $ / n -> 
        forM_ [0..side-1] $ / y -> 
            forM_ [0..side-1] $ / x -> 
                MV.unsafeWrite mvec (y*side+x) 1
{-# INLINE [~2] test_a #-} -- "inline before the first phase please"

El problema con esta solución INLINE es que es bastante frágil frente a la embestida flotante de GHC. Por ejemplo, la incorporación manual no preserva el rendimiento. El siguiente código es lento porque de forma similar a INLINE [~2] le da a GHC la oportunidad de flotar:

main = do
    let vec = V.generate (side*side) (const 0)
    mvec <- V.unsafeThaw vec :: IO (MV.MVector (PrimState IO) Int)
    forM_ [0..times-1] $ / n -> 
        forM_ [0..side-1] $ / y -> 
            forM_ [0..side-1] $ / x -> 
                MV.unsafeWrite mvec (y*side+x) 1    

¿Entonces, qué debemos hacer?

En primer lugar, creo que usar -fno-full-laziness es una opción perfectamente viable e incluso preferible para aquellos a los que les gustaría escribir un código de alto rendimiento y tener una buena idea de lo que están haciendo. Por ejemplo, se usa en unordered-containers . Con él tenemos un control más preciso sobre el uso compartido, y siempre podemos simplemente flotar o alinearnos manualmente.

Para obtener un código más regular, creo que no hay nada de malo en usar Control.Monad.Loop o cualquier otro paquete que proporcione la funcionalidad. Muchos usuarios de Haskell no son escrupulosos en cuanto a depender de pequeñas bibliotecas "marginales". También podemos simplemente reimplementarnos, en una generalidad deseada. Por ejemplo, lo siguiente funciona tan bien como las otras soluciones:

for :: Monad m => a -> (a -> Bool) -> (a -> a) -> (a -> m ()) -> m ()
for init while step body = go init where
  go !i | while i = body i >> go (step i)
  go i = return ()
{-# INLINE for #-}

Looping en un espacio realmente constante

Al principio me desconcertaban los datos de +RTS -s sobre la asignación de heap. test_a asignado no trivialmente con -fno-full-laziness , y también test_c sin holgazanería completa, y estas asignaciones escalaron linealmente con el número de iteraciones, pero test_b con holgazanería completa asignada solo para el vector:

-- with -fno-full-laziness, no INLINE pragmas
test_a: 242,521,008 bytes
test_b: 121,008 bytes
test_c: 121,008 bytes -- but 240,120,984 with full laziness!

Además, los pragmas INLINE para test_c no ayudaron en absoluto en este caso.

Pasé algún tiempo tratando de encontrar signos de asignación de montón en el núcleo para los programas pertinentes, sin éxito, hasta que me di cuenta de que los marcos de pila de GHC estaban en el montón, incluidos los marcos del hilo principal y las funciones que estaban haciendo la asignación del montón esencialmente ejecutaba los bucles anidados tres veces en un máximo de tres marcos de pila . La asignación de montón registrada por +RTS -s es solo la aparición y el empuje constantes de los fotogramas de pila.

Esto es bastante evidente desde el núcleo para el siguiente código:

{-# OPTIONS_GHC -fno-full-laziness #-}

-- ...

test_a mvec = 
    forM_ [0..times-1] $ / n -> 
        forM_ [0..side-1] $ / y -> 
            forM_ [0..side-1] $ / x -> 
                MV.unsafeWrite mvec (y*side+x) 1
main = do
    let vec = V.generate (side*side) (const 0)
    mvec <- V.unsafeThaw vec :: IO (MV.MVector (PrimState IO) Int)
    test_a mvec

Lo cual estoy incluyendo aquí en su gloria. Siéntase libre de saltar.

main1 :: State# RealWorld -> (# State# RealWorld, () #)
main1 =
  / (s_a5HK :: State# RealWorld) ->
    case divInt# 9223372036854775807 8 of ww4_a5vr { __DEFAULT ->

    -- start of vector creation ----------------------
    case tagToEnum# (># 10000 ww4_a5vr) of _ {
      False ->
        case newByteArray# 80000 (s_a5HK `cast` ...)
        of _ { (# ipv_a5fv, ipv1_a5fw #) ->
        letrec {
          $s$wa_s8jS
            :: Int#
               -> Int#
               -> State# (PrimState IO)
               -> (# State# (PrimState IO), Int #)
          $s$wa_s8jS =
            / (sc_s8jO :: Int#)
              (sc1_s8jP :: Int#)
              (sc2_s8jR :: State# (PrimState IO)) ->
              case tagToEnum# (<# sc1_s8jP 10000) of _ {
                False -> (# sc2_s8jR, I# sc_s8jO #);
                True ->
                  case writeIntArray# ipv1_a5fw sc_s8jO 0 (sc2_s8jR `cast` ...)
                  of s''#_a5Gn { __DEFAULT ->
                  $s$wa_s8jS (+# sc_s8jO 1) (+# sc1_s8jP 1) (s''#_a5Gn `cast` ...)
                  }
              }; } in
        case $s$wa_s8jS 0 0 (ipv_a5fv `cast` ...)
        -- end of vector creation -------------------

        of _ { (# ipv6_a4Hv, ipv7_a4Hw #) ->
        letrec {
          a2_s7MJ :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
          a2_s7MJ =
            / (x_a5Ho :: Int#) (eta_B1 :: State# RealWorld) ->
              letrec {
                a3_s7ME :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
                a3_s7ME =
                  / (x1_X5Id :: Int#) (eta1_XR :: State# RealWorld) ->
                    case ipv7_a4Hw of _ { I# dt4_a5x6 ->
                    case writeIntArray#
                           (ipv1_a5fw `cast` ...) (*# x1_X5Id 100) 1 (eta1_XR `cast` ...)
                    of s''#_a5Gn { __DEFAULT ->
                    letrec {
                      a4_s7Mz :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
                      a4_s7Mz =
                        / (x2_X5J8 :: Int#) (eta2_X1U :: State# RealWorld) ->
                          case writeIntArray#
                                 (ipv1_a5fw `cast` ...)
                                 (+# (*# x1_X5Id 100) x2_X5J8)
                                 1
                                 (eta2_X1U `cast` ...)
                          of s''#1_X5Hf { __DEFAULT ->
                          case x2_X5J8 of wild_X2o {
                            __DEFAULT -> a4_s7Mz (+# wild_X2o 1) (s''#1_X5Hf `cast` ...);
                            99 -> (# s''#1_X5Hf `cast` ..., () #)
                          }
                          }; } in
                    case a4_s7Mz 1 (s''#_a5Gn `cast` ...)
                    of _ { (# ipv2_a4QH, ipv3_a4QI #) ->
                    case x1_X5Id of wild_X1e {
                      __DEFAULT -> a3_s7ME (+# wild_X1e 1) ipv2_a4QH;
                      99 -> (# ipv2_a4QH, () #)
                    }
                    }
                    }
                    }; } in
              case a3_s7ME 0 eta_B1 of _ { (# ipv2_a4QH, ipv3_a4QI #) ->
              case x_a5Ho of wild_X1a {
                __DEFAULT -> a2_s7MJ (+# wild_X1a 1) ipv2_a4QH;
                99999 -> (# ipv2_a4QH, () #)
              }
              }; } in
        a2_s7MJ 0 (ipv6_a4Hv `cast` ...)
        }
        };
      True ->
        case error
               (unpackAppendCString#
                  "Primitive.basicUnsafeNew: length to large: "#
                  (case $wshowSignedInt 0 10000 ([])
                   of _ { (# ww5_a5wm, ww6_a5wn #) ->
                   : ww5_a5wm ww6_a5wn
                   }))
        of wild_00 {
        }
    }
    }

main :: IO ()
main = main1 `cast` ...

main2 :: State# RealWorld -> (# State# RealWorld, () #)
main2 = runMainIO1 (main1 `cast` ...)

main :: IO ()
main = main2 `cast` ...

También podemos demostrar muy bien la asignación de marcos de la siguiente manera. Cambiemos test_a :

test_a mvec = 
    forM_ [0..times-1] $ / n -> 
        forM_ [0..side-1] $ / y -> 
            forM_ [0..side-50] $ / x -> -- change here
                MV.unsafeWrite mvec (y*side+x) 1

Ahora la asignación de montón permanece exactamente igual, porque el ciclo más interno es recursivo de cola y usa un solo cuadro. Con el siguiente cambio, la asignación del montón se reduce a la mitad (a 124,921,008 bytes), porque presionamos y hacemos saltar la mitad de los cuadros:

test_a mvec = 
    forM_ [0..times-1] $ / n -> 
        forM_ [0..side-50] $ / y -> -- change here
            forM_ [0..side-1] $ / x -> 
                MV.unsafeWrite mvec (y*side+x) 1

test_b y test_c (sin holgazanería) compilan en su lugar código que utiliza una construcción de caso anidada dentro de un único marco de pila, y recorre los índices para ver cuál se debe incrementar. Vea el núcleo para la siguiente información main :

{-# LANGUAGE BangPatterns #-} -- later I''ll talk about this
{-# OPTIONS_GHC -fno-full-laziness #-}

main = do
    let vec = V.generate (side*side) (const 0)
    !mvec <- V.unsafeThaw vec :: IO (MV.MVector (PrimState IO) Int)
    test_c mvec

Voila:

main1 :: State# RealWorld -> (# State# RealWorld, () #)
main1 =
  / (s_a5Iw :: State# RealWorld) ->
    case divInt# 9223372036854775807 8 of ww4_a5vT { __DEFAULT ->

    -- start of vector creation ----------------------
    case tagToEnum# (># 10000 ww4_a5vT) of _ {
      False ->
        case newByteArray# 80000 (s_a5Iw `cast` ...)
        of _ { (# ipv_a5g3, ipv1_a5g4 #) ->
        letrec {
          $s$wa_s8ji
            :: Int#
               -> Int#
               -> State# (PrimState IO)
               -> (# State# (PrimState IO), Int #)
          $s$wa_s8ji =
            / (sc_s8je :: Int#)
              (sc1_s8jf :: Int#)
              (sc2_s8jh :: State# (PrimState IO)) ->
              case tagToEnum# (<# sc1_s8jf 10000) of _ {
                False -> (# sc2_s8jh, I# sc_s8je #);
                True ->
                  case writeIntArray# ipv1_a5g4 sc_s8je 0 (sc2_s8jh `cast` ...)
                  of s''#_a5GP { __DEFAULT ->
                  $s$wa_s8ji (+# sc_s8je 1) (+# sc1_s8jf 1) (s''#_a5GP `cast` ...)
                  }
              }; } in
        case $s$wa_s8ji 0 0 (ipv_a5g3 `cast` ...)
        of _ { (# ipv6_a4MX, ipv7_a4MY #) ->
        case ipv7_a4MY of _ { I# dt4_a5xy ->
        -- end of vector creation

        letrec {
          a2_s7Q6 :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
          a2_s7Q6 =
            / (x_a5HT :: Int#) (eta_B1 :: State# RealWorld) ->
              letrec {
                a3_s7Q5 :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
                a3_s7Q5 =
                  / (x1_X5J9 :: Int#) (eta1_XP :: State# RealWorld) ->
                    letrec {
                      a4_s7MZ :: Int# -> State# RealWorld -> (# State# RealWorld, () #)
                      a4_s7MZ =
                        / (x2_X5Jl :: Int#) (s1_X4Xb :: State# RealWorld) ->
                          case writeIntArray#
                                 (ipv1_a5g4 `cast` ...)
                                 (+# (*# x1_X5J9 100) x2_X5Jl)
                                 1
                                 (s1_X4Xb `cast` ...)
                          of s''#_a5GP { __DEFAULT ->

                          -- the interesting part! ------------------
                          case x2_X5Jl of wild_X1y {
                            __DEFAULT -> a4_s7MZ (+# wild_X1y 1) (s''#_a5GP `cast` ...);
                            99 ->
                              case x1_X5J9 of wild1_X1o {
                                __DEFAULT -> a3_s7Q5 (+# wild1_X1o 1) (s''#_a5GP `cast` ...);
                                99 ->
                                  case x_a5HT of wild2_X1c {
                                    __DEFAULT -> a2_s7Q6 (+# wild2_X1c 1) (s''#_a5GP `cast` ...);
                                    99999 -> (# s''#_a5GP `cast` ..., () #)
                                  }
                              }
                          }
                          }; } in
                    a4_s7MZ 0 eta1_XP; } in
              a3_s7Q5 0 eta_B1; } in
        a2_s7Q6 0 (ipv6_a4MX `cast` ...)
        }
        }
        };
      True ->
        case error
               (unpackAppendCString#
                  "Primitive.basicUnsafeNew: length to large: "#
                  (case $wshowSignedInt 0 10000 ([])
                   of _ { (# ww5_a5wO, ww6_a5wP #) ->
                   : ww5_a5wO ww6_a5wP
                   }))
        of wild_00 {
        }
    }
    }

main :: IO ()
main = main1 `cast` ...

main2 :: State# RealWorld -> (# State# RealWorld, () #)
main2 = runMainIO1 (main1 `cast` ...)

main :: IO ()
main = main2 `cast` ...

Debo admitir que, básicamente, no sé por qué algunos códigos evitan la creación de marcos de pila y otros no. Sospecho que la entrada desde "adentro" ayuda, y una inspección rápida me informó que Control.Monad.Loop usa una codificación CPS, que podría ser relevante aquí, aunque la solución Monad.Loop es sensible a la flotación, y no pude No determinan con poca antelación del Core por qué test_c con let floating no puede ejecutarse en un único marco de pila.

Ahora, el beneficio de rendimiento de correr en un solo marco de pila es pequeño. Hemos visto que test_b es solo un poco más rápido que test_a . Incluyo este desvío en la respuesta porque lo encontré edificante.

El estado hackear y enlaces estrictos

El llamado estado de hack hace que GHC sea agresivo al incluir acciones de IO y ST. Creo que debería mencionarlo aquí, porque además de dejar flotar esta es la otra cosa que puede arruinar por completo el rendimiento.

El hack de estado se habilita con optimizaciones -O , y puede ralentizar los programas asintóticamente. Un simple ejemplo de Reid Barton :

import Control.Monad
import Debug.Trace

expensive :: String -> String
expensive x = trace "$$$" x

main :: IO ()
main = do
  str <- fmap expensive getLine
  replicateM_ 3 $ print str

Con GHC-7.10.2, esto imprime "$$$" una vez sin optimizaciones pero tres veces con -O2 . Y parece que con GHC-7.10, no podemos deshacernos de este comportamiento con -fno-state-hack (que es el tema del ticket vinculado de Reid Barton).

Estrictas uniones monádicas se deshacen de este problema:

main :: IO ()
main = do
  !str <- fmap expensive getLine
  replicateM_ 3 $ print str

Creo que es una buena costumbre hacer enlaces estrictos en IO y ST. Y tengo algo de experiencia (aunque no es definitivo, estoy lejos de ser un experto en GHC) que las ataduras estrictas son especialmente necesarias si usamos -fno-full-laziness . Aparentemente, la pereza total puede ayudar a deshacerse de parte de la duplicación de trabajo introducida por la creación de líneas causada por el hack de estado; con test_b y sin holgazanería completa, omitir el estricto enlace en !mvec <- V.unsafeThaw vec provocó una ligera desaceleración y una salida del núcleo extremadamente fea.