堆栈空间溢出（可能与mapM有关）

Question

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

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

我在 SO 上发现了一些其他似乎相关的问题（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

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

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

对于更复杂的 I/O 应用程序，您希望在小型单元流处理器之间实现更好的可组合性，您应该使用诸如 conduit 或 pipes 之类的库。

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

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

编辑：看来罪魁祸首可能是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) 我们需要显式提升 I/O 操作到转换后的 monad 使用 liftIO 而不是能够直接编写例如L.mapM_ putStrLn.