haskell - LFSR 实现中的高效位摆弄

Question

虽然我有一个很好的 LSFR C 实现，但我想我会在 Haskell 中尝试同样的方法——只是为了看看它是如何进行的。到目前为止，我想出的比 C 实现慢两个数量级，这就引出了一个问题：如何提高性能？显然，位摆弄操作是瓶颈，分析器证实了这一点。

这是使用列表和的基线 Haskell 代码Data.Bits：

import           Control.Monad      (when)
import           Data.Bits          (Bits, shift, testBit, xor, (.&.), (.|.))
import           System.Environment (getArgs)
import           System.Exit        (exitFailure, exitSuccess)

tap :: [[Int]]
tap = [
    [],            [],            [],            [3, 2],
    [4, 3],        [5, 3],        [6, 5],        [7, 6],
    [8, 6, 5, 4],  [9, 5],        [10, 7],       [11, 9],
    [12, 6, 4, 1], [13, 4, 3, 1], [14, 5, 3, 1], [15, 14],
    [16,15,13,4],  [17, 14],      [18, 11],      [19, 6, 2, 1],
    [20, 17],      [21, 19],      [22, 21],      [23, 18],
    [24,23,22,17], [25, 22],      [26, 6, 2, 1], [27, 5, 2, 1],
    [28, 25],      [29, 27],      [30, 6, 4, 1], [31, 28],
    [32,22,2,1],   [33,20],       [34,27,2,1],   [35,33],
    [36,25],       [37,5,4,3,2,1],[38,6,5,1],    [39,35],
    [40,38,21,19], [41,38],       [42,41,20,19], [43,42,38,37],
    [44,43,18,17], [45,44,42,41], [46,45,26,25], [47,42],
    [48,47,21,20], [49,40],       [50,49,24,23], [51,50,36,35],
    [52,49],       [53,52,38,37], [54,53,18,17], [55,31],
    [56,55,35,34], [57,50],       [58,39],       [59,58,38,37],
    [60,59],       [61,60,46,45], [62,61,6,5],   [63,62]        ]

xor' :: [Bool] -> Bool
xor' = foldr xor False

mask ::  (Num a, Bits a) => Int -> a
mask len = shift 1 len - 1

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

main :: IO ()
main = do
    args <- getArgs
    when (null args) $ fail "Usage: lsfr <number-of-bits>"
    let len = read $ head args
    when (len < 8) $ fail "No need for LFSR"
    let out = last $ take (shift 1 len) $ iterate (advance len (tap!!len)) 0
    if out == 0 then do
        putStr "OK\n"
        exitSuccess
    else do
        putStr "FAIL\n"
        exitFailure

基本上，它测试为任何给定位长度定义的LSFRtap :: [[Int]]是否具有最大长度。^{（更准确地说，它只是检查 LSFR 在 2 n}次迭代后是否达到初始状态（零） 。）

根据分析器，最昂贵的线路是反馈位d0 = xor' $ map (testBit lfsr) tap'。

到目前为止我已经尝试过：

• use Data.Array: 尝试放弃，因为没有 foldl/r
• 使用Data.Vector：比基线略快

我使用的编译器选项是：-O2, LTS Haskell 8.12 (GHC-8.0.2).

参考 C++ 程序可以在gist.github.com上找到。

不能期望 Haskell 代码（？）运行得和 C 代码一样快，但是两个数量级太多了，必须有更好的方法来做位摆弄。

更新：应用答案中建议的优化的结果

• 输入为 28 的参考 C++ 程序，使用 LLVM 8.0.0 编译，在我的机器上运行 0.67 秒（与 clang 3.7 相同，稍慢，0.68 秒）
• 基线 Haskell 代码运行速度慢约 100 倍（由于空间效率低下，请勿尝试使用大于 25 的输入）
• 随着@Thomas M. DuBuisson的重写，仍然使用默认的 GHC 后端，执行时间下降到 5.2s
• 随着@Thomas M. DuBuisson的重写，现在使用 LLVM 后端（GHC 选项-O2 -fllvm），执行时间下降到 1.7 秒
  • 使用 GHC 选项-O2 -fllvm -optlc -mcpu=native将这个时间缩短到 0.73 秒
• 当使用 Thomas 的代码（使用默认的“本机”后端和 LLVM）时，替换iterate为iterate'@cirdec 没有任何区别。但是，使用基线代码时确实会有所不同。

所以，我们已经从 100x 到 8x 再到 1.09x，即仅比 C 慢 9%！

注意 GHC 8.0.2 的 LLVM 后端需要 LLVM 3.7。在 Mac OS X 上，这意味着使用brew和符号链接安装此版本。见7.10。GHC 后端。optllc

Answer 1

前期事项

对于初学者，我在 Intel I5 ~2.5GHz、linux x86-64 上使用 GHC 8.0.1。

初稿：哦不！减速！

带有参数 25 的起始代码运行：

% ghc -O2 orig.hs && time ./orig 25
[1 of 1] Compiling Main             ( orig.hs, orig.o )
Linking orig ...
OK
./orig 25  7.25s user 0.50s system 99% cpu 7.748 total

所以击败的时间是 77 毫秒 - 比这个 Haskell 代码好两个数量级。让我们潜入。

问题 1：多变的代码

我在代码中发现了一些奇怪的地方。首先是shift在高性能代码中的使用。Shift 支持左移和右移，为此它需要一个分支。让我们用更具可读性的两个等（shift 1 x~>2^x和shift x 1~> 2*x）来杀死它：

% ghc -O2 noShift.hs && time ./noShift 25
[1 of 1] Compiling Main             ( noShift.hs, noShift.o )
Linking noShift ...
OK
./noShift 25  0.64s user 0.00s system 99% cpu 0.637 total

（正如您在评论中指出的那样：是的，这值得调查。可能是先前代码的一些奇怪阻止了重写规则的触发，结果导致代码更糟糕）

问题 2：位列表？int 操作节省了一天！

一个变化，一个数量级。耶。还有什么？好吧，你有这个尴尬的比特位置列表，你正在挖掘它，这似乎是在乞求效率低下和/或依赖于脆弱的优化。在这一点上，我会注意到对该列表中的任何一个选择进行硬编码会产生非常好的性能（例如testBit lsfr 24 `xor` testBit lsfr 21），但我们需要更通用的快速解决方案。

我建议我们计算所有点击位置的掩码，然后进行单指令弹出计数。为此，我们只需要一个Int传入的 toadvance而不是整个列表。popcount 指令需要良好的汇编生成，这需要 llvm 和可能-optlc-mcpu=native或其他非悲观的指令集选择。

这一步给了我们pc下面。我已经折叠advance了评论中提到的防护移除：

let tp = sum $ map ((2^) . subtract 1) (tap !! len)
    pc lfsr = fromEnum (even (popCount (lfsr .&. tp)))
    mask = 2^len - 1
    advance' :: Int -> Int
    advance' lfsr = (2*lfsr .&. mask) .|. pc lfsr 
    out :: Int
    out = last $ take (2^len) $ iterate advance' 0

我们的结果是：

% ghc -O2 so.hs -fforce-recomp -fllvm -optlc-mcpu=native && time ./so 25      
[1 of 1] Compiling Main             ( so.hs, so.o )
Linking so ...
OK
./so 25  0.06s user 0.00s system 96% cpu 0.067 total

从开始到结束，这超过了两个数量级，所以希望它与您的 C 相匹配。最后，在部署的代码中，实际上很常见 Haskell 包与 C 绑定，但这通常是一个教育练习，所以我希望你玩得开心。

编辑：现在可用的 C++ 代码需要我的系统 0.10 ( g++ -O3) 和 0.12 ( clang++ -O3 -march=native) 秒，所以看起来我们已经超越了我们的标记。

Answer 2

我怀疑以下行在评估之前在内存中构建了一个类似列表的大型 thunk。

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

让我们看看我是否正确，如果是，我们会解决它。第一个调试步骤是了解程序使用的内存。为此，我们将使用-rtsopts除-O2. 这允许使用RTS 选项运行程序，+RTS -s包括输出一个小的内存摘要。

初始性能

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 大小

我假设 thunk 是内置的iterate (advance ...)。如果是这种情况，我们可以尝试通过advance更严格的lsfr参数来减小 thunk 大小。这不会删除 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，或者超过 3300 万个项目。列表本身可能正在被列表融合删除，但列表最后一项的 thunk 超过 3300 万个应用程序advance ...

为了解决这个问题，我们需要一个严格的版本，iterate以便在再次应用函数Int之前将值强制为 an。advance这应该将内存一次只保留一个lfsr值，以及当前计算的advance.

不幸的是，没有严格iterate的Data.List. 这是一个不会放弃为这个问题提供其他重要（我认为）性能优化的列表融合。

{-# 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 倍。

我不知道这是否会改善 Thomas DeBuisson 的答案，该答案有所改善，advance但仍然留下了一个懒惰iterate advance'的地方。很容易检查；将iterate'代码添加到该答案并iterate'代替iterate该答案使用。

Answer 3

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 ...（编译器通常无法优化!!，因为它们对于有限列表是不同的，但iterate总是返回一个无限列表。）

3. 你与之相比foldr，foldl却foldl几乎从来不是你所需要的；因为xor总是需要两个参数并且是关联的，foldl'所以很可能是正确的选择（编译器可以优化它，但如果两者之间存在任何真正的差异，foldl而foldr不仅仅是随机变化，那么在这种情况下它可能会失败）。