Почему мой код использует монадические списки из пакета списков такими медленными?

Question

На прошлой неделе пользователь Masse спросил Вопрос о рекурсивном перечислении файлов в каталоге в Хаскелле. Моя первая мысль заключалась в том, чтобы попытаться использовать монадические списки из 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, но может быть больше. Простое профилирование не появилось много, я бы добавил несколько дополнительных центров затрат и пошел оттуда ...