Mengapa kode Haskell ini berjalan lebih lambat dengan -O?

Potongan kode Haskell ini berjalan jauh lebih lambat -O, tetapi -Oseharusnya tidak berbahaya . Adakah yang bisa memberi tahu saya apa yang terjadi? Jika penting, ini merupakan upaya untuk memecahkan masalah ini , dan menggunakan pencarian biner dan pohon segmen persisten:

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

(Ini adalah kode yang sama persis dengan tinjauan kode tetapi pertanyaan ini membahas masalah lain.)

Ini adalah generator input saya di 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);
    }
}

Jika Anda tidak memiliki kompiler C ++ yang tersedia, ini adalah hasil dari./gen.exe 1000 .

Berikut hasil eksekusi di komputer saya:

$ 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

Dan ini ringkasan profil heap:

$ 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

Saya kira sudah saatnya pertanyaan ini mendapat jawaban yang tepat.

Apa yang terjadi dengan kode Anda -O

Izinkan saya memperbesar fungsi utama Anda, dan menulis ulang sedikit:

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

Jelas, maksudnya di sini adalah bahwa NodeArrayitu dibuat sekali, dan kemudian digunakan dalam setiap mpemanggilan query.

Sayangnya, GHC mengubah kode ini menjadi, secara efektif,

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

dan Anda bisa langsung melihat masalahnya di sini.

Apa yang dimaksud dengan peretasan negara, dan mengapa hal itu merusak kinerja program saya

Alasannya adalah peretasan negara, yang mengatakan (secara kasar): "Ketika sesuatu memiliki tipe IO a, anggap itu dipanggil hanya sekali.". The dokumentasi resmi tidak jauh lebih rumit:

-fno-state-hack

Matikan "peretasan status" di mana lambda apa pun dengan token Status # sebagai argumen dianggap sebagai entri tunggal, oleh karena itu dianggap OK untuk menyebariskan hal-hal di dalamnya. Ini dapat meningkatkan kinerja kode monad IO dan ST, tetapi berisiko mengurangi pembagian.

Secara kasar, idenya adalah sebagai berikut: Jika Anda mendefinisikan fungsi dengan IOklausa type dan where, misalnya

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

Sesuatu dari tipe IO adapat dipandang sebagai sesuatu yang bertipe RealWord -> (a, RealWorld). Dalam pandangan itu, di atas menjadi (secara kasar)

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

Panggilan ke foo(biasanya) akan terlihat seperti ini foo argument world. Tetapi definisi foohanya membutuhkan satu argumen, dan yang lainnya hanya dikonsumsi kemudian oleh ekspresi lambda lokal! Itu akan menjadi panggilan yang sangat lambat foo. Akan jauh lebih cepat jika kodenya terlihat seperti ini:

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

Ini disebut ekspansi eta dan dilakukan dengan berbagai alasan (misalnya dengan menganalisis definisi fungsi , dengan memeriksa bagaimana dipanggil , dan - dalam hal ini - heuristik terarah tipe).

Sayangnya, ini menurunkan kinerja jika panggilan ke foosebenarnya dalam bentuk let fooArgument = foo argument, yaitu dengan argumen, tetapi tidak worldlulus (belum). Dalam kode aslinya, jika fooArgumentkemudian digunakan beberapa kali, ytetap akan dihitung hanya sekali, dan dibagikan. Dalam kode yang dimodifikasi, yakan dihitung ulang setiap saat - tepatnya apa yang terjadi pada Anda nodes.

Bisakah hal-hal diperbaiki?

Mungkin. Lihat # 9388 untuk mencoba melakukannya. Masalah dengan memperbaikinya adalah bahwa ini akan membebani kinerja dalam banyak kasus di mana transformasi terjadi dengan baik, meskipun kompiler tidak mungkin mengetahui hal itu dengan pasti. Dan mungkin ada kasus di mana secara teknis tidak baik, yaitu berbagi hilang, tetapi masih bermanfaat karena percepatan dari panggilan yang lebih cepat lebih besar daripada biaya tambahan penghitungan ulang. Jadi tidak jelas kemana harus pergi dari sini.