为什么我的代码使用 List 包中的一元列表如此慢？

Question

上周，用户 Masse 提出了一个关于在 Haskell 目录中递归列出文件的问题。我的第一个想法是尝试使用 List 包 中的单子列表以避免在打印开始之前在内存中构建整个列表。我的实现如下：

module Main where

import Prelude hiding (filter) 
import Control.Applicative ((<$>))
import Control.Monad (join)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.ListT (ListT)
import Data.List.Class (cons, execute, filter, fromList, mapL)
import System (getArgs)
import System.Directory (getDirectoryContents, doesDirectoryExist)
import System.FilePath ((</>))

main = execute . mapL putStrLn . listFiles =<< head <$> getArgs

listFiles :: FilePath -> ListT IO FilePath
listFiles path = liftIO (doesDirectoryExist path) >>= listIfDir
  where
    valid "."  = False
    valid ".." = False
    valid _ = True
    listIfDir False = return path
    listIfDir True
      =  cons path
      $  join
      $  listFiles
     <$> (path </>)
     <$> (filter valid =<< fromList <$> liftIO (getDirectoryContents path))

它工作得很好，因为它立即开始打印并且使用很少的内存。不幸的是，它也比类似的 FilePath -> 慢几十倍。 IO [FilePath] 版本。

我做错了什么？我从未在像这样的玩具示例之外使用过 List 包的 ListT，所以我不知道期望什么样的性能，但是 30 秒（相对于几分之一秒）来处理大约 40,000 个文件的目录似乎太慢了。

Answer 1

分析显示 join（与 doesDirectoryExists 一起）占用了代码中的大部分时间。让我们看看它的定义是如何展开的：

  join x
=> (definition of join in Control.Monad)
  x >>= id
=> (definition of >>= in Control.Monad.ListT)
  foldrL' mappend mempty (fmap id x)
=> (fmap id = id)
  foldrL' mappend mempty x

如果在搜索的根目录中有 k 个子目录，并且它们的内容已经在列表中计算：d1, d 2, ... dk，然后在应用 join 后，您将得到（大致）： (. ..(([] ++ d1) ++ d2) ... ++ dk)。由于 x ++ y 需要时间 O(length x) 整个过程将需要时间 O(d1 + (d< sub>1 + d2) + ... + (d1 + ... dk-1))。如果我们假设文件数量为 n 并且它们均匀分布在 d1 ... dk 那么计算join 的时间将为O(n*k)，并且这只适用于listFiles 的第一层。

我认为这是您的解决方案的主要性能问题。

Answer 2

我很好奇，使用 logict 为你工作？ LogicT 在语义上与 ListT 相同，但以连续传递风格实现，因此它不应该出现与 concat 相关的问题类型你似乎遇到了。

import Prelude hiding (filter)
import Control.Applicative
import Control.Monad
import Control.Monad.Logic
import System (getArgs)
import System.Directory (getDirectoryContents, doesDirectoryExist)
import System.FilePath ((</>))

main = sequence_ =<< observeAllT . fmap putStrLn . listFiles =<< head <
gt; getArgs

cons :: MonadPlus m => a -> m a -> m a
cons x xs = return x `mplus` xs

fromList :: MonadPlus m => [a] -> m a
fromList = foldr cons mzero

filter :: MonadPlus m => (a -> Bool) -> m a -> m a
filter f xs = do
  x <- xs
  guard $ f x
  return x

listFiles :: FilePath -> LogicT IO FilePath
listFiles path = liftIO (doesDirectoryExist path) >>= listIfDir
  where
    valid "."  = False
    valid ".." = False
    valid _ = True
    listIfDir False = return path
    listIfDir True
      =  cons path
      $  join
      $  listFiles
     <
gt; (path </>)
     <
gt; (filter valid =<< fromList <
gt; liftIO (getDirectoryContents path))

Answer 3

在大目录上运行它会发现内存泄漏。我怀疑这与 getDirectoryContents 的严格性有关，但可能还有更多的事情发生。简单的分析并没有出现太多，我会添加一些额外的成本中心，然后从那里开始......