Almoço grátis de paralelismo em Haskell

Hoje irei exagerar um pouco e verificar o quão grátis é o almoço de paralelismo servido pelo ecossistema Haskell.

Para fins de estudo, irei criar um algoritmo bastante simples e ideal para utilizar paralelismo: duas funções distintas com cargas de trabalho parecidas que não possuem dependência entre si.

Uma destas funções calculará qual é o menor valor de uma lista e a outra calculará o maior valor. Sendo assim, as duas precisarão consultar todos os elementos da lista e fazer a mesma quantidade de comparações. Os dois valores serão somados e impressos ao usuário:

module Main where

import Data.List (foldl1')

main = print result
  where result = a + b
        a = foldl1' min list
        b = foldl1' max list
        list = [1..19999999]

Compilei o código com ghc -rtsopts e executei ele com +RTS -s para verificar como ele se comportou:

20000000
     803,172,764 bytes allocated in the heap
     860,135,516 bytes copied during GC
     233,464,876 bytes maximum residency (9 sample(s))
      30,086,296 bytes maximum slop
             483 MB total memory in use (0 MB lost due to fragmentation)

  Generation 0:  1523 collections,     0 parallel,  0.80s,  0.97s elapsed
  Generation 1:     9 collections,     0 parallel,  0.92s,  1.30s elapsed

  INIT  time    0.00s  (  0.00s elapsed)
  MUT   time    0.90s  (  0.98s elapsed)
  GC    time    1.72s  (  2.27s elapsed)
  EXIT  time    0.00s  (  0.00s elapsed)
  Total time    2.62s  (  3.25s elapsed)

  %GC time      65.5%  (69.8% elapsed)

  Alloc rate    887,674,003 bytes per MUT second

  Productivity  34.5% of total user, 27.8% of total elapsed

Esta saída significa que o programa levou 3,25 segundos para executar e ocupou 483 MB de memória. Um valor um tanto absurdo para algo que deveria ser simples e rápido em Haskell. O problema do algoritmo é que durante o cálculo do valor mínimo, o coletor de lixo não coleta os itens já passados pois o cálculo do valor máximo possui referência para o inicio da lista.

Para resolver o problema é possível gerar listas diferentes, uma para cada cálculo na forma de uma função constante:

module Main where

import Data.List (foldl1')

main = print result
  where result = a + b
        a = foldl1' min $ list ()
        b = foldl1' max $ list ()
        list _ = [1..19999999]

Esta versão termina em 1,6 segundos e consome apenas 1 MB de memória. Atenção: se o programa for compilado com -O2, o GHC irá otimizar a declaração de função deixando a referencia para a lista no lugar e o programa continuará a usar os 483 MB de memória.

Este é o momento de refatorar o algoritmo para evitar duplicidade de código. Para um programa deste tamanho, acredito que normalmente não é feito, porém para que a transição para a utilização de paralelismo fique mais suave, é um passo necessário:

module Main where

import Data.List (foldl1')
import Control.Arrow ((&&&))

main = print result
  where result = (+) `uncurry` constMinMax list
        list _ = [1..19999999]

(.:) f g a b = f a (g b)
constApp = ($ ())
constMinMax = constMinList &&& constMaxList
constFold = foldl1' .: constApp
constMinList = constFold min
constMaxList = constFold max

O resultado e o tempo do algoritmo continuam os mesmos. Agora como tornamos este algoritmo preparado para rodar em paralelo? Simples: trocamos a utilização da função uncurry por parUncurry:

module Main where

import Data.List (foldl1')
import Control.Arrow ((&&&))
import Control.Parallel (par, pseq)

main = print result
  where result = (+) `parUncurry` constMinMax list
        list _ = [1..19999999]

(.:) f g a b = f a (g b)
constApp = ($ ())
constMinMax = constMinList &&& constMaxList
constFold = foldl1' .: constApp
constMinList = constFold min
constMaxList = constFold max
parUncurry f (a, b) = a `par` b `pseq` f a b

Adicionamos à compilação do programa o argumento -threaded e para executar utilizamos +RTS -s -N2 para que o programa utilize duas threads do sistema operacional. O resultado:

20000000
   1,606,300,044 bytes allocated in the heap
          74,364 bytes copied during GC
          28,352 bytes maximum residency (1 sample(s))
          24,896 bytes maximum slop
               2 MB total memory in use (0 MB lost due to fragmentation)

  Generation 0:  1566 collections,  1565 parallel,  0.06s,  0.02s elapsed
  Generation 1:     1 collections,     1 parallel,  0.00s,  0.00s elapsed

  Parallel GC work balance: 1.79 (15355 / 8588, ideal 2)

                        MUT time (elapsed)       GC time  (elapsed)
  Task  0 (worker) :    0.00s    (  0.81s)       0.00s    (  0.00s)
  Task  1 (worker) :    0.75s    (  0.81s)       0.06s    (  0.01s)
  Task  2 (bound)  :    0.83s    (  0.81s)       0.00s    (  0.00s)
  Task  3 (worker) :    0.00s    (  0.00s)       0.00s    (  0.00s)

  SPARKS: 1 (1 converted, 0 pruned)

  INIT  time    0.00s  (  0.00s elapsed)
  MUT   time    1.58s  (  0.81s elapsed)
  GC    time    0.06s  (  0.02s elapsed)
  EXIT  time    0.00s  (  0.00s elapsed)
  Total time    1.64s  (  0.83s elapsed)

  %GC time       3.8%  (1.9% elapsed)

  Alloc rate    1,019,478,198 bytes per MUT second

  Productivity  96.2% of total user, 189.6% of total elapsed

gc_alloc_block_sync: 78
whitehole_spin: 0
gen[0].sync_large_objects: 0
gen[1].sync_large_objects: 0

Conseguimos reduzir o tempo de execução para 0,83 segundos: a metade do tempo da versão sequencial. Tudo isto com a mudança de uma chamada (partindo do principio de que o programa está bem escrito).

Qual seria o tamanho da mudança necessária na linguagem que você utiliza hoje para ter este mesmo ganho de desempenho?

Apesar do exemplo deste post ser levemente exagerado, este tipo de ganho com apenas uma mudança é algo real em Haskell. A apresentação The Future is Parallel, and the Future of Parallel is Declarative feita por Simon Peyton Jones dá exemplos de aplicações que se beneficiaram deste paralelismo grátis.