Pourquoi ce code Haskell s'exécute-t-il plus lentement avec -O?

Ce morceau de code Haskell fonctionne beaucoup plus lentement avec -O, mais -One devrait pas être dangereux . Quelqu'un peut-il me dire ce qui s'est passé? Si cela compte, c'est une tentative de résoudre ce problème , et il utilise la recherche binaire et l'arborescence de segments persistants:

import Control.Monad
import Data.Array

data Node =
      Leaf   Int           -- value
    | Branch Int Node Node -- sum, left child, right child
type NodeArray = Array Int Node

-- create an empty node with range [l, r)
create :: Int -> Int -> Node
create l r
    | l + 1 == r = Leaf 0
    | otherwise  = Branch 0 (create l m) (create m r)
    where m = (l + r) `div` 2

-- Get the sum in range [0, r). The range of the node is [nl, nr)
sumof :: Node -> Int -> Int -> Int -> Int
sumof (Leaf val) r nl nr
    | nr <= r   = val
    | otherwise = 0
sumof (Branch sum lc rc) r nl nr
    | nr <= r   = sum
    | r  > nl   = (sumof lc r nl m) + (sumof rc r m nr)
    | otherwise = 0
    where m = (nl + nr) `div` 2

-- Increase the value at x by 1. The range of the node is [nl, nr)
increase :: Node -> Int -> Int -> Int -> Node
increase (Leaf val) x nl nr = Leaf (val + 1)
increase (Branch sum lc rc) x nl nr
    | x < m     = Branch (sum + 1) (increase lc x nl m) rc
    | otherwise = Branch (sum + 1) lc (increase rc x m nr)
    where m = (nl + nr) `div` 2

-- signature said it all
tonodes :: Int -> [Int] -> [Node]
tonodes n = reverse . tonodes' . reverse
    where
        tonodes' :: [Int] -> [Node]
        tonodes' (h:t) = increase h' h 0 n : s' where s'@(h':_) = tonodes' t
        tonodes' _ = [create 0 n]

-- find the minimum m in [l, r] such that (predicate m) is True
binarysearch :: (Int -> Bool) -> Int -> Int -> Int
binarysearch predicate l r
    | l == r      = r
    | predicate m = binarysearch predicate l m
    | otherwise   = binarysearch predicate (m+1) r
    where m = (l + r) `div` 2

-- main, literally
main :: IO ()
main = do
    [n, m] <- fmap (map read . words) getLine
    nodes <- fmap (listArray (0, n) . tonodes n . map (subtract 1) . map read . words) getLine
    replicateM_ m $ query n nodes
    where
        query :: Int -> NodeArray -> IO ()
        query n nodes = do
            [p, k] <- fmap (map read . words) getLine
            print $ binarysearch (ok nodes n p k) 0 n
            where
                ok :: NodeArray -> Int -> Int -> Int -> Int -> Bool
                ok nodes n p k s = (sumof (nodes ! min (p + s + 1) n) s 0 n) - (sumof (nodes ! max (p - s) 0) s 0 n) >= k

(C'est exactement le même code avec la révision de code mais cette question aborde un autre problème.)

Voici mon générateur d'entrée en C ++:

#include <cstdio>
#include <cstdlib>
using namespace std;
int main (int argc, char * argv[]) {
    srand(1827);
    int n = 100000;
    if(argc > 1)
        sscanf(argv[1], "%d", &n);
    printf("%d %d\n", n, n);
    for(int i = 0; i < n; i++)
        printf("%d%c", rand() % n + 1, i == n - 1 ? '\n' : ' ');
    for(int i = 0; i < n; i++) {
        int p = rand() % n;
        int k = rand() % n + 1;
        printf("%d %d\n", p, k);
    }
}

Si vous n'avez pas de compilateur C ++ disponible, c'est le résultat de./gen.exe 1000 .

Voici le résultat de l'exécution sur mon ordinateur:

$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 7.8.3
$ ghc -fforce-recomp 1827.hs
[1 of 1] Compiling Main             ( 1827.hs, 1827.o )
Linking 1827.exe ...
$ time ./gen.exe 1000 | ./1827.exe > /dev/null
real    0m0.088s
user    0m0.015s
sys     0m0.015s
$ ghc -fforce-recomp -O 1827.hs
[1 of 1] Compiling Main             ( 1827.hs, 1827.o )
Linking 1827.exe ...
$ time ./gen.exe 1000 | ./1827.exe > /dev/null
real    0m2.969s
user    0m0.000s
sys     0m0.045s

Et voici le résumé du profil du tas:

$ ghc -fforce-recomp -rtsopts ./1827.hs
[1 of 1] Compiling Main             ( 1827.hs, 1827.o )
Linking 1827.exe ...
$ ./gen.exe 1000 | ./1827.exe +RTS -s > /dev/null
      70,207,096 bytes allocated in the heap
       2,112,416 bytes copied during GC
         613,368 bytes maximum residency (3 sample(s))
          28,816 bytes maximum slop
               3 MB total memory in use (0 MB lost due to fragmentation)
                                    Tot time (elapsed)  Avg pause  Max pause
  Gen  0       132 colls,     0 par    0.00s    0.00s     0.0000s    0.0004s
  Gen  1         3 colls,     0 par    0.00s    0.00s     0.0006s    0.0010s
  INIT    time    0.00s  (  0.00s elapsed)
  MUT     time    0.03s  (  0.03s elapsed)
  GC      time    0.00s  (  0.01s elapsed)
  EXIT    time    0.00s  (  0.00s elapsed)
  Total   time    0.03s  (  0.04s elapsed)
  %GC     time       0.0%  (14.7% elapsed)
  Alloc rate    2,250,213,011 bytes per MUT second
  Productivity 100.0% of total user, 83.1% of total elapsed
$ ghc -fforce-recomp -O -rtsopts ./1827.hs
[1 of 1] Compiling Main             ( 1827.hs, 1827.o )
Linking 1827.exe ...
$ ./gen.exe 1000 | ./1827.exe +RTS -s > /dev/null
   6,009,233,608 bytes allocated in the heap
     622,682,200 bytes copied during GC
         443,240 bytes maximum residency (505 sample(s))
          48,256 bytes maximum slop
               3 MB total memory in use (0 MB lost due to fragmentation)
                                    Tot time (elapsed)  Avg pause  Max pause
  Gen  0     10945 colls,     0 par    0.72s    0.63s     0.0001s    0.0004s
  Gen  1       505 colls,     0 par    0.16s    0.13s     0.0003s    0.0005s
  INIT    time    0.00s  (  0.00s elapsed)
  MUT     time    2.00s  (  2.13s elapsed)
  GC      time    0.87s  (  0.76s elapsed)
  EXIT    time    0.00s  (  0.00s elapsed)
  Total   time    2.89s  (  2.90s elapsed)
  %GC     time      30.3%  (26.4% elapsed)
  Alloc rate    3,009,412,603 bytes per MUT second
  Productivity  69.7% of total user, 69.4% of total elapsed

Je suppose qu'il est temps que cette question reçoive une réponse appropriée.

Qu'est-il arrivé à votre code avec -O

Permettez-moi de zoomer sur votre fonction principale et de la réécrire légèrement:

main :: IO ()
main = do
    [n, m] <- fmap (map read . words) getLine
    line <- getLine
    let nodes = listArray (0, n) . tonodes n . map (subtract 1) . map read . words $ line
    replicateM_ m $ query n nodes

Clairement, l'intention ici est que le NodeArrayest créé une fois, puis utilisé dans chacune des minvocations dequery .

Malheureusement, GHC transforme ce code en

main = do
    [n, m] <- fmap (map read . words) getLine
    line <- getLine
    replicateM_ m $ do
        let nodes = listArray (0, n) . tonodes n . map (subtract 1) . map read . words $ line
        query n nodes

et vous pouvez immédiatement voir le problème ici.

Qu'est-ce que le hack d'état et pourquoi détruit-il les performances de mes programmes

La raison en est le piratage de l'état, qui dit (en gros): «Quand quelque chose est de type IO a, supposons qu'il ne soit appelé qu'une seule fois.». La documentation officielle n'est pas beaucoup plus élaborée:

-fno-state-hack

Désactivez le "hack d'état" par lequel tout lambda avec un jeton State # comme argument est considéré comme une entrée unique, par conséquent, il est considéré comme OK d'insérer des éléments à l'intérieur. Cela peut améliorer les performances du code monade IO et ST, mais cela risque de réduire le partage.

En gros, l'idée est la suivante: Si vous définissez une fonction avec un IOtype et une clause where, par exemple

foo x = do
    putStrLn y
    putStrLn y
  where y = ...x...

Quelque chose de type IO apeut être considéré comme quelque chose de type RealWord -> (a, RealWorld). Dans cette optique, ce qui précède devient (à peu près)

foo x = 
   let y = ...x... in 
   \world1 ->
     let (world2, ()) = putStrLn y world1
     let (world3, ()) = putStrLn y world2
     in  (world3, ())

Un appel à fooressemblerait (généralement) à ceci foo argument world. Mais la définition de foone prend qu'un seul argument, et l'autre n'est consommé que plus tard par une expression lambda locale! Cela va être un appel très lent foo. Ce serait beaucoup plus rapide si le code ressemblait à ceci:

foo x world1 = 
   let y = ...x... in 
   let (world2, ()) = putStrLn y world1
   let (world3, ()) = putStrLn y world2
   in  (world3, ())

Cela s'appelle eta-expansion et se fait pour divers motifs (par exemple en analysant la définition de la fonction , en vérifiant comment elle est appelée , et - dans ce cas - l'heuristique dirigée de type).

Malheureusement, cela dégrade les performances si l'appel à fooest réellement de la forme let fooArgument = foo argument, c'est-à-dire avec un argument, mais pas world(encore) passé. Dans le code d'origine, s'il fooArgumentest ensuite utilisé plusieurs fois, il ysera toujours calculé une seule fois et partagé. Dans le code modifié, ysera recalculé à chaque fois - précisément ce qui est arrivé à votrenodes .

Les choses peuvent-elles être réparées?

Peut-être. Voir # 9388 pour une tentative de le faire. Le problème avec la fixation est qu'il va coûter la performance dans beaucoup de cas où la transformation arrive à ok, même si le compilateur ne peut pas savoir que , pour sûr. Et il y a probablement des cas où cela n'est techniquement pas correct, c'est-à-dire que le partage est perdu, mais cela reste avantageux car les accélérations de l'appel plus rapide l'emportent sur le coût supplémentaire du recalcul. Il n'est donc pas clair où aller à partir d'ici.