optimization - 优化Haskell程序

Question

我从昨天开始着眼于Haskell，旨在实际学习它。我在编程语言 class 中用它编写了一些琐碎的程序，但是没有一个人真正关心效率。我试图了解如何改善以下程序的运行时间。

我的程序解决了以下玩具问题(我知道，如果您知道阶乘是什么，那么手工计算答案很简单，但是我正在使用后继函数进行暴力破解):

http://projecteuler.net/problem=24

给定有限长度的列表，我的字典顺序后继函数算法如下:

如果列表已经按降序排列，则我们按词典顺序具有最大元素，因此没有后继元素。

给定一个列表h:t，在词典编排顺序中t不是最大值，否则不是。在后一种情况下，计算t的后继。在前一种情况下，请执行以下操作。

在t中选择大于h的最小元素d。

用h in t替换d，得到一个新列表t'。排序中的下一个元素是d:(sort t')

我的实现此目的的程序如下(这些功能的很多可能在标准库中):

max_list :: (Ord a) => [a] -> a
max_list []     = error "Empty list has no maximum!"
max_list (h:[]) = h
max_list (h:t)  = max h (max_list t)

min_list :: (Ord a) => [a] -> a
min_list []     = error "Empty list has no minimum!"
min_list (h:[]) = h
min_list (h:t)  = min h (min_list t)

-- replaces first occurrence of x in list with y
replace :: (Eq a) => a -> a -> [a] -> [a]
replace _ _ []  = []
replace x y (h:t)
    | h == x    = y : t
    | otherwise = h : (replace x y t)

-- sort in increasing order
sort_list :: (Ord a) => [a] -> [a]
sort_list []    = []
sort_list (h:t) = (sort_list (filter (\x -> x <= h) t))
               ++ [h]
               ++ (sort_list (filter (\x -> x > h) t))

-- checks if list is in descending order
descending :: (Ord a) => [a] -> Bool
descending []     = True
descending (h:[]) = True
descending (h:t)
    | h > (max_list t) = descending t
    | otherwise        = False

succ_list :: (Ord a) => [a] -> [a]
succ_list []      = []
succ_list (h:[])  = [h]
succ_list (h:t)
    | descending (h:t)   = (h:t)
    | not (descending t) = h : succ_list t
    | otherwise = next_h : sort_list (replace next_h h t)
    where next_h = min_list (filter (\x -> x > h) t)

-- apply function n times
apply_times :: (Integral n) => n -> (a -> a) -> a -> a
apply_times n _ a
    | n <= 0      = a
apply_times n f a = apply_times (n-1) f (f a)

main = putStrLn (show (apply_times 999999 succ_list [0,1,2,3,4,5,6,7,8,9]))

现在是实际问题。注意到我的程序花了一些时间才能运行后，我编写了一个等效的C程序进行比较。我的猜测是，对Haskell的惰性计算会导致apply_times函数在实际开始评估结果之前先在内存中建立一个巨大的列表。我必须增加运行时堆栈的大小才能运行它。由于高效的Haskell编程似乎与技巧有关，是否有任何不错的技巧可用于最大程度地减少内存消耗？那么如何减少复制和垃圾回收的方法呢，因为列表不断地被创建，而C实现会完成所有准备工作。

由于Haskell据说是高效的，所以我想必须有办法吗？关于Haskell，我不得不说的一件很酷的事情是，该程序在首次编译时就可以正常工作，因此该语言的一部分确实可以兑现其 promise 。

Answer 1

这些功能中有很多可能在标准库中

确实。如果您使用import Data.List，这使得sort可用，那么maximum可以使用minimum和Prelude。 sort中的Data.List总比准快速排序更有效率，特别是因为您在列表中有很多排序的块。

descending :: (Ord a) => [a] -> Bool
descending []     = True
descending (h:[]) = True
descending (h:t)
    | h > (max_list t) = descending t
    | otherwise        = False

是无效的- O(n²)-因为它遍历了每一步的整个左尾，但是如果列表是降序的，则尾的最大值必须是它的头。 但是在这里有一个很好的结果。由于 succ_list的第三个方程式的第一个后卫会强制对列表进行完全评估，因此可以防止积木的堆积。但是，这可以通过显式强制列表一次来更有效地完成。

descending (h:t@(ht:_)) = h > ht && descending t

将使其线性。那

注意到我的程序花了一些时间才能运行后，我编写了一个等效的C程序进行比较。

那是不寻常的。到目前为止，很少有人会在C中使用链接列表，在此之上执行惰性评估将是一项艰巨的任务。

用C语言编写一个等效程序将是非常简单的。在C语言中，实现算法的自然方法是使用数组和就地突变。在这里，这自动会更加高效。

我的猜测是，对Haskell的惰性计算会导致apply_times函数在实际开始评估结果之前先在内存中建立一个巨大的列表。

不完全是，它的构建是巨大的重击，

apply_times 999999 succ_list [0,1,2,3,4,5,6,7,8,9]
~> apply_times 999998 succ_list (succ_list [0 .. 9])
~> apply_times 999997 succ_list (succ_list (succ_list [0 .. 9]))
~> apply_times 999996 succ_list (succ_list (succ_list (succ_list [0 .. 9])))
...
succ_list (succ_list (succ_list ... (succ_list [0 .. 9])...))

并且，在构建了该thunk之后，必须对其进行评估。要评估最外层调用，必须对下一个调用进行足够远的评估，以找出最外层调用中匹配的模式。因此，最外面的调用被压入堆栈，然后开始评估下一个调用。为此，必须确定匹配的模式，因此需要第三次调用的结果的一部分。因此，第二个调用被压入堆栈...。最后，您在堆栈上有999998个调用，并开始评估最里面的调用。然后，您在每个调用和下一个外部调用之间进行一些乒乓(至少，依赖项可能会进一步传播)，同时冒泡并从堆栈中弹出调用。

有没有什么好的技巧可以用来减少内存消耗

是的，强制中间列表成为 apply_times的参数之前要对其进行评估。您需要在此处进行完整评估，因此香草味 seq不够好

import Control.DeepSeq

apply_times' :: (NFData a, Integral n) => n -> (a -> a) -> a -> a
apply_times' 0 _ x = x
apply_times' k f x = apply_times' (k-1) f $!! f x

这样可以防止积木的积累，因此，您不需要比 succ_list和计数器中构造的几个简短列表所需的内存更多。

那么如何减少复制和垃圾回收的方法呢，因为列表不断地被创建，而C实现会完成所有准备工作。

是的，那仍然会分配很多(和垃圾回收)。现在，GHC的 非常好很好，它可以分配和垃圾收集短期数据(在我的盒子上，它可以很容易地以每MUT秒2GB的速度分配而不缓慢)，但是，不分配所有这些列表会更快。

因此，如果要推送它，请使用就地突变。在

STUArray s Int Int

或未装箱的可变 vector (我更喜欢 array包提供的接口(interface)，但最喜欢 vector接口(interface)；就性能而言， vector包为您内置了很多优化，如果您使用 array包，则可以必须自己编写快速代码，但编写良好的代码在所有实际用途上的性能都一样)。

我已经做了一些测试。我尚未测试原始的惰性 apply_times，仅测试了 deepseq的每个应用程序的一个 f，并且已将所有涉及的实体的类型固定为 Int。

通过该设置，用 sort_list替换 Data:list.sort可以将运行时间从1.82秒减少到1.65(但增加了分配的字节数)。差别不大，但是列表的长度不足以使准速排序的糟糕情况真正引起人们的注意。

然后，最大的不同是按照建议的方式更改了 descending，将时间缩短至0.48秒，每MUT每秒分配2,170,566,037字节的Alloc速率，获得了0.01秒的GC时间(然后使用 sort_list代替 sort将时间缩短至0.58秒)。

用更简单的 reverse代替列表结尾部分的排序-算法保证在排序时以降序排序-将时间减少到0.43秒。

一种相当直接的算法翻译，以使用未装箱的可变数组，

{-# LANGUAGE BangPatterns #-}
module Main (main) where

import Data.Array.ST
import Data.Array.Base
import Control.Monad.ST
import Control.Monad (when, replicateM_)

sortPart :: STUArray s Int Int -> Int -> Int -> ST s ()
sortPart a lo hi
   | lo < hi   = do
       let lscan !p h i
               | i < h = do
                   v <- unsafeRead a i
                   if p < v then return i else lscan p h (i+1)
               | otherwise = return i
           rscan !p l i
               | l < i = do
                   v <- unsafeRead a i
                   if v < p then return i else rscan p l (i-1)
               | otherwise = return i
           swap i j = do
               v <- unsafeRead a i
               unsafeRead a j >>= unsafeWrite a i
               unsafeWrite a j v
           sloop !p l h
               | l < h = do
                   l1 <- lscan p h l
                   h1 <- rscan p l1 h
                   if (l1 < h1) then (swap l1 h1 >> sloop p l1 h1) else return l1
               | otherwise = return l
       piv <- unsafeRead a hi
       i <- sloop piv lo hi
       swap i hi
       sortPart a lo (i-1)
       sortPart a (i+1) hi
   | otherwise = return ()

descending :: STUArray s Int Int -> Int -> Int -> ST s Bool
descending arr lo hi
    | lo < hi   = do
        let check i !v
                | hi < i    = return True
                | otherwise = do
                    w <- unsafeRead arr i
                    if w < v
                      then check (i+1) w
                      else return False
        x <- unsafeRead arr lo
        check (lo+1) x
    | otherwise = return True

findAndReplace :: STUArray s Int Int -> Int -> Int -> ST s ()
findAndReplace arr lo hi
    | lo < hi   = do
        x <- unsafeRead arr lo
        let go !mi !mv i
                | hi < i    = when (lo < mi) $ unsafeWrite arr mi x >> unsafeWrite arr lo mv
                | otherwise = do
                    w <- unsafeRead arr i
                    if x < w && w < mv
                      then go i w (i+1)
                      else go mi mv (i+1)
            look i
                | hi < i    = return ()
                | otherwise = do
                    w <- unsafeRead arr i
                    if x < w
                      then go i w (i+1)
                      else look (i+1)
        look (lo+1)
    | otherwise = return ()

succArr :: STUArray s Int Int -> Int -> Int -> ST s ()
succArr arr lo hi
    | lo < hi   = do
        end <- descending arr lo hi
        if end
          then return ()
          else do
              needSwap <- descending arr (lo+1) hi
              if needSwap
                then do
                    findAndReplace arr lo hi
                    sortPart arr (lo+1) hi
                else succArr arr (lo+1) hi
    | otherwise = return ()

solution :: [Int]
solution = runST $ do
    arr <- newListArray (0,9) [0 .. 9]
    replicateM_ 999999 $ succArr arr 0 9
    getElems arr

main :: IO ()
main = print solution

在0.15秒内完成。用更简单的零件替换来代替排序，使零件下降到0.11。

将算法拆分为小的顶级函数，每个函数执行一个任务，使其更具可读性，但这是有代价的。在函数之间需要传递更多的参数，因此，并非所有参数都可以在寄存器中传递，并且根本不使用某些传递的参数(数组边界和元素计数)，因此传递了自重权。在 solution中将所有其他函数设置为局部函数会稍微减少整体分配和运行时间(排序时为0.13秒，反向时为0.09)，因为现在仅需要传递必要的参数。

进一步偏离给定的算法，使其回到最前端，

module Main (main) where

import Data.Array.ST
import Data.Array.Base
import Data.Array.Unboxed
import Control.Monad.ST
import Control.Monad (when)
import Data.Bits

lexPerm :: Int -> Int -> [Int]
lexPerm idx num = elems (runSTUArray $ do
    arr <- unsafeNewArray_ (0,num)
    let fill i
            | num < i   = return ()
            | otherwise = unsafeWrite arr i i >> fill (i+1)
        swap i j = do
            x <- unsafeRead arr i
            y <- unsafeRead arr j
            unsafeWrite arr j x
            unsafeWrite arr i y
        flop i j
            | i < j     = do
                swap i j
                flop (i+1) (j-1)
            | otherwise = return ()
        binsearch v a b = go a b
          where
            go i j
              | i < j     = do
                let m = (i+j+1) `unsafeShiftR` 1
                w <- unsafeRead arr m
                if w < v
                  then go i (m-1)
                  else go m j
              | otherwise = swap a i
        upstep k j
            | k < 1     = return ()
            | j == num-1 = unsafeRead arr num >>= flip (back k) (num-1)
            | otherwise  = nextP k (num-1)
        back k v i
            | i < 0     = return ()
            | otherwise = do
                w <- unsafeRead arr i
                if w < v
                  then nextP k i
                  else back k w (i-1)
        nextP k up
            | k < 1 || up < 0   = return ()
            | otherwise = do
                v <- unsafeRead arr up
                binsearch v up num
                flop (up+1) num
                upstep (k-1) up
    fill 0
    nextP (idx-1) (num-1)
    return arr)

main :: IO ()
main = print $ lexPerm 1000000 9

我们可以在0.02秒内完成任务。

但是，该问题中提到的巧妙算法可在更少的时间内用更少的代码解决任务。