haskell - 堆栈空间溢出(可能与mapM有关)

Question

我正在编写一个程序，该程序创建一个 shell 脚本，其中包含针对目录中每个图像文件的一个命令。目录中有667,944张图片，所以我需要正确处理严格/惰性问题。

这是一个简单的示例，它给出了堆栈空间溢出。如果我使用 +RTS -Ksize -RTS 给它更多的空间，它确实可以工作，但它应该能够用很少的内存运行，立即产生输出。所以我一直在阅读 Haskell wiki 和 Haskell wikibook 中有关严格性的内容，试图找出解决问题的方法，我认为这是给我的 mapM 命令之一悲伤，但我仍然对严格性理解不够，无法解决问题。

我发现了一些其他似乎相关的问题( Is mapM in Haskell strict? Why does this program get a stack overflow? 和 Is Haskell's mapM not lazy? )，但我仍然无法得到启发。

import System.Environment (getArgs)
import System.Directory (getDirectoryContents)

genCommand :: FilePath -> FilePath -> FilePath -> IO String
genCommand indir outdir file = do
  let infile = indir ++ '/':file
  let angle = 0 -- have to actually read the file to calculate this for real
  let outfile = outdir ++ '/':file
  return $! "convert " ++ infile ++ " -rotate " ++ show angle ++ 
    " -crop 143x143+140+140 " ++ outfile

main :: IO ()
main = do
  putStrLn "#!/bin/sh"
  (indir:outdir:_) <- getArgs
  files <- getDirectoryContents indir
  let imageFiles = filter (`notElem` [".", ".."]) files
  commands <- mapM (genCommand indir outdir) imageFiles
  mapM_ putStrLn commands

<小时/>

编辑:测试#1

这是该示例的最新版本。

import System.Environment (getArgs)
import System.Directory (getDirectoryContents)
import Control.Monad ((>=>))

genCommand :: FilePath -> FilePath -> FilePath -> IO String
genCommand indir outdir file = do
  let infile = indir ++ '/':file
  let angle = 0 -- have to actually read the file to calculate this for real
  let outfile = outdir ++ '/':file
  return $! "convert " ++ infile ++ " -rotate " ++ show angle ++ 
    " -crop 143x143+140+140 " ++ outfile

main :: IO ()
main = do
  putStrLn "TEST 1"
  (indir:outdir:_) <- getArgs
  files <- getDirectoryContents indir
  putStrLn $ show (length files)
  let imageFiles = filter (`notElem` [".", ".."]) files
  -- mapM_ (genCommand indir outdir >=> putStrLn) imageFiles
  mapM_ (\filename -> genCommand indir outdir filename >>= putStrLn) imageFiles

我使用命令 ghc --make -O2 amy2.hs -rtsopts 来编译它。如果我使用命令 ./amy2 ~/nosync/GalaxyZoo/table2/images/wombat 运行它，我得到

TEST 1
Stack space overflow: current size 8388608 bytes.
Use `+RTS -Ksize -RTS' to increase it.

如果我使用命令 ./amy2 ~/nosync/GalaxyZoo/table2/images/wombat +RTS -K20M 运行它，我会得到正确的输出...最终:

TEST 1
667946
convert /home/amy/nosync/GalaxyZoo/table2/images//587736546846572812.jpeg -rotate 0 -crop 143x143+140+140 wombat/587736546846572812.jpeg
convert /home/amy/nosync/GalaxyZoo/table2/images//587736542558617814.jpeg -rotate 0 -crop 143x143+140+140 wombat/587736542558617814.jpeg

...等等。

Answer 1

这并不是真正的严格性问题(*)，而是评估顺序问题。与惰性评估的纯值不同，一元效应必须以确定性顺序发生。 mapM 执行给定列表中的每个操作并收集结果，但在执行整个操作列表之前它无法返回，因此您无法获得与纯列表函数相同的流行为。

这种情况下的简单解决方法是在同一个 mapM_ 内运行 genCommand 和 putStrLn。请注意，mapM_ 不会遇到同样的问题，因为它没有构建中间列表。

mapM_ (genCommand indir outdir >=> putStrLn) imageFiles

上面使用了“kleisli组合运算符”>=>来自 Control.Monad ，它类似于函数组合运算符 .，但一元函数除外。您还可以使用普通绑定(bind)和 lambda。

mapM_ (\filename -> genCommand indir outdir filename >>= putStrLn) imageFiles

对于更复杂的 I/O 应用程序，您希望小型单一流处理器之间具有更好的可组合性，您应该使用类似 conduit 的库。或pipes .

此外，请确保您使用 -O 或 -O2 进行编译。

(*) 准确地说，这也是一个严格性问题，因为除了在内存中构建一个大型的中间列表之外，惰性还会导致 mapM 构建不必要的thunks 并用完堆栈。

编辑:所以看来罪魁祸首可能是getDirectoryContents。查看函数的source code ，它本质上在内部执行与 mapM 相同类型的列表累积。

为了进行流目录列表，我们需要使用 System.Posix.Directory不幸的是，这使得该程序与非 POSIX 系统(如 Windows)不兼容。您可以通过以下方式流式传输目录内容:使用连续传递风格

import System.Environment (getArgs)
import Control.Monad ((>=>))

import System.Posix.Directory (openDirStream, readDirStream, closeDirStream)
import Control.Exception (bracket)

genCommand :: FilePath -> FilePath -> FilePath -> IO String
genCommand indir outdir file = do
  let infile = indir ++ '/':file
  let angle = 0 -- have to actually read the file to calculate this for real
  let outfile = outdir ++ '/':file
  return $! "convert " ++ infile ++ " -rotate " ++ show angle ++
    " -crop 143x143+140+140 " ++ outfile

streamingDirContents :: FilePath -> (FilePath -> IO ()) -> IO ()
streamingDirContents root cont = do
    let loop stream = do
            fp <- readDirStream stream
            case fp of
                [] -> return ()
                _   | fp `notElem` [".", ".."] -> cont fp >> loop stream
                    | otherwise -> loop stream
    bracket (openDirStream root) loop closeDirStream


main :: IO ()
main = do
  putStrLn "TEST 1"
  (indir:outdir:_) <- getArgs
  streamingDirContents indir (genCommand indir outdir >=> putStrLn)

以下是使用 conduit 执行相同操作的方法:

import System.Environment (getArgs)

import System.Posix.Directory (openDirStream, readDirStream, closeDirStream)

import Data.Conduit
import qualified  Data.Conduit.List as L
import Control.Monad.IO.Class (liftIO, MonadIO)

genCommand :: FilePath -> FilePath -> FilePath -> IO String
genCommand indir outdir file = do
  let infile = indir ++ '/':file
  let angle = 0 -- have to actually read the file to calculate this for real
  let outfile = outdir ++ '/':file
  return $! "convert " ++ infile ++ " -rotate " ++ show angle ++
    " -crop 143x143+140+140 " ++ outfile

dirSource :: (MonadResource m, MonadIO m) => FilePath -> Source m FilePath
dirSource root = do
    bracketP (openDirStream root) closeDirStream $ \stream -> do
        let loop = do
                fp <- liftIO $ readDirStream stream
                case fp of
                    [] -> return ()
                    _  -> yield fp >> loop
        loop

main :: IO ()
main = do
    putStrLn "TEST 1"
    (indir:outdir:_) <- getArgs
    let files    = dirSource indir $= L.filter (`notElem` [".", ".."])
        commands = files $= L.mapM (liftIO . genCommand indir outdir)

    runResourceT $ commands $$ L.mapM_ (liftIO . putStrLn)

conduit 的好处是，您可以重新获得使用 filter 和 mapM 的管道版本等功能来组合功能的能力。 $= 运算符在链中向前传输内容，并且 $$ 将流连接到使用者。

不太好的事情是，现实世界是复杂的，编写高效且健壮的代码需要我们克服资源管理方面的一些障碍。这就是为什么所有操作都在 ResourceT monad 转换器中工作，该转换器跟踪例如打开文件句柄，并在不再需要它们时或例如，立即确定地清理它们。如果计算因异常而中止(这与使用惰性 I/O 并依赖垃圾收集器最终释放任何稀缺资源形成对比)。

但是，这意味着我们a)需要使用runResourceT运行最终生成的管道操作，并且b)我们需要显式提升使用 liftIO 对转换后的 monad 进行 I/O 操作，而不是直接写入，例如L.mapM_ putStrLn。