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

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, d2, ... dk, ，然后申请 join 您会（大致）： (...(([] ++ d1) ++ d2) ... ++ dk). 。自从 x ++ y 需要时间 O(length x) 整个事情将需要时间 O(d1 + (d1 + d2) + ... + (d1 + ... dk-1)). 。如果我们假设文件数为 n 它们均匀分布在 d1 ... dk 然后时间计算 join 将会 O(n*k) 这只是第一级 listFiles.

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

Answer 2

我很好奇，同一程序写得如何 徽标 为你工作？ 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 <$> 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
     <$> (path </>)
     <$> (filter valid =<< fromList <$> liftIO (getDirectoryContents path))

Answer 3

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