Эффективная работа с битами в реализации LFSR

я подозреваю, что следующая строка строит большой список, как thunk в памяти, прежде чем оценивать его.

let out = last $ take (shift 1 len) $ iterate (advance len (tap!!len)) 0` is 

Начальная Производительность

запуск вашей программы как lfsr 25 +RTS -s я получаю следующий вывод

OK
   5,420,148,768 bytes allocated in the heap
   6,705,977,216 bytes copied during GC
   1,567,511,384 bytes maximum residency (20 sample(s))
     357,862,432 bytes maximum slop
            3025 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0     10343 colls,     0 par    2.453s   2.522s     0.0002s    0.0009s
  Gen  1        20 colls,     0 par    2.281s   3.065s     0.1533s    0.7128s

  INIT    time    0.000s  (  0.000s elapsed)
  MUT     time    1.438s  (  1.162s elapsed)
  GC      time    4.734s  (  5.587s elapsed)
  EXIT    time    0.016s  (  0.218s elapsed)
  Total   time    6.188s  (  6.967s elapsed)

  %GC     time      76.5%  (80.2% elapsed)

  Alloc rate    3,770,538,273 bytes per MUT second

  Productivity  23.5% of total user, 19.8% of total elapsed

это много памяти, используемой сразу. Очень вероятно, что где-то там есть большое здание.

пытается уменьшить размер thunk

я предположил, что thunk строится в iterate (advance ...). Если это так, мы можем попытаться уменьшить размер thunk, сделав advance более строгий в своем lsfr аргумент. Это не удалит позвоночник thunk (последовательные итерации), но это может уменьшить размер состояния, которое создается по мере оценки позвоночника.

BangPatterns - простой способ сделать функцию строгой в аргументе. f !x = .. сокращенно от f x = seq x $ ...

{-# LANGUAGE BangPatterns #-}

advance :: Int -> [Int] -> Int -> Int
advance len tap = go
  where
    go !lfsr
      | d0        = shifted
      | otherwise = shifted .|. 1
      where
        shifted = shift lfsr 1 .&. mask len
        d0 = xor' $ map (testBit lfsr) tap'
    tap' = map (subtract 1) tap

давайте посмотрим, что это меняет ...

>lfsr 25 +RTS -s
OK
   5,420,149,072 bytes allocated in the heap
   6,705,979,368 bytes copied during GC
   1,567,511,448 bytes maximum residency (20 sample(s))
     357,862,448 bytes maximum slop
            3025 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0     10343 colls,     0 par    2.688s   2.711s     0.0003s    0.0059s
  Gen  1        20 colls,     0 par    2.438s   3.252s     0.1626s    0.8013s

  INIT    time    0.000s  (  0.000s elapsed)
  MUT     time    1.328s  (  1.146s elapsed)
  GC      time    5.125s  (  5.963s elapsed)
  EXIT    time    0.000s  (  0.226s elapsed)
  Total   time    6.484s  (  7.335s elapsed)

  %GC     time      79.0%  (81.3% elapsed)

  Alloc rate    4,081,053,418 bytes per MUT second

  Productivity  21.0% of total user, 18.7% of total elapsed

ничего заметного.

исключения позвоночника

я думаю, это позвоночник это iterate (advance ...) это строится. В конце концов, для команды, которую я запускаю, список будет 2^25, или чуть более 33 миллионов пунктов. Сам список, вероятно, удаляется список fusion, но thunk для последнего элемента списка составляет более 33 миллионов приложений advance ...

чтобы решить эту проблему, нам нужна строгая версия iterate так что значение принудительно к Int перед нанесением advance функции снова. Это должно держать память до одного lfsr значение в то время, наряду с в настоящее время вычисляется применение advance.

к сожалению, нет строгой iterate на Data.List. Вот один, который не отказывается от списка fusion, который предоставляет другие важные (Я думаю) оптимизации производительности для этой проблемы.

{-# LANGUAGE BangPatterns #-}

import GHC.Base (build)

{-# NOINLINE [1] iterate' #-}
iterate' :: (a -> a) -> a -> [a]
iterate' f = go
  where go !x = x : go (f x)

{-# NOINLINE [0] iterateFB' #-}
iterateFB' :: (a -> b -> b) -> (a -> a) -> a -> b
iterateFB' c f = go
  where go !x = x `c` go (f x)

{-# RULES
"iterate'"    [~1] forall f x. iterate' f x = build (\c _n -> iterateFB' c f x)
"iterateFB'"  [1]              iterateFB' (:) = iterate'
 #-}

это просто iterate С GHC.List (вместе со всеми своими правилами переписывания), но сделанный строгим в аккумулированном аргумент.

оснащен строгой итерации,iterate', мы можем изменить хлопотно строки

let out = last $ take (shift 1 len) $ iterate' (advance len (tap!!len)) 0

я ожидаю, что это будет работать гораздо лучше. Давайте посмотрим ...

>lfsr 25 +RTS -s
OK
   3,758,156,184 bytes allocated in the heap
         297,976 bytes copied during GC
          43,800 bytes maximum residency (1 sample(s))
          21,736 bytes maximum slop
               1 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0      7281 colls,     0 par    0.047s   0.008s     0.0000s    0.0000s
  Gen  1         1 colls,     0 par    0.000s   0.000s     0.0002s    0.0002s

  INIT    time    0.000s  (  0.000s elapsed)
  MUT     time    0.750s  (  0.783s elapsed)
  GC      time    0.047s  (  0.008s elapsed)
  EXIT    time    0.000s  (  0.000s elapsed)
  Total   time    0.797s  (  0.792s elapsed)

  %GC     time       5.9%  (1.0% elapsed)

  Alloc rate    5,010,874,912 bytes per MUT second

  Productivity  94.1% of total user, 99.0% of total elapsed

это 0.00002 раз больше памяти и работает в 10 раз быстрее.

я не знаю, если это улучшит на ответ, что улучшает advance но все равно оставляет ленивый iterate advance' на месте. Было бы легко проверить; добавьте iterate' код к этому ответу и используйте iterate' на месте iterate в ответ.

1. поднимает ли компилятор tap !! len выход из цикла? Я подозреваю, что это так, но перемещение его, чтобы гарантировать, что это не повредит:

   let tap1 = tap !! len
   let out = last $ take (shift 1 len) $ iterate (advance len tap1) 0    
   

2. в комментариях вы говорите:"2^len нужен ровно один раз", но это неправильно. Вы делаете это каждый раз в advance. Так что вы можете попробовать

   advance len tap mask lfsr
       | d0        = shifted
       | otherwise = shifted .|. 1
       where
           shifted = shift lfsr 1 .&. mask
           d0 = xor' $ map (testBit lfsr) tap'
           tap' = map (subtract 1) tap
   
   -- in main
   let tap1 = tap !! len
   let numIterations = 2^len
   let mask = numIterations - 1
   let out = iterate (advance len tap1 mask) 0 !! (numIterations - 1)
   

   (компилятор не может оптимизировать last $ take ... to !! в целом, потому что они разные для конечных списков, но iterate всегда возвращает бесконечный один.)

3. вы сравнили foldr С foldl, а foldl почти никогда не то, что вам нужно; С xor всегда нуждается в обоих Аргументах и является ассоциативным,foldl', скорее всего, будет правильным выбором (компилятор может оптимизировать его, но если есть какая-либо реальная разница между foldl и foldr и не просто случайная вариация, в этом случае она могла бы потерпеть неудачу).