performance - `friday` 包很慢

Question

我正在编写一个绘制 big maps 的 Haskell 程序来自 Knytt Stories世界文件。我使用 friday 包来制作图像文件，我需要组合我从 Sprite 表放在一起的许多图形层。现在，我为此使用了我自己的丑陋函数:

import qualified Vision.Primitive as Im
import qualified Vision.Image.Type as Im
import qualified Vision.Image.Class as Im
import Vision.Image.RGBA.Type (RGBA, RGBAPixel(..))

-- Map a Word8 in [0, 255] to a Double in [0, 1].
w2f :: Word8 -> Double
w2f = (/255) . fromIntegral . fromEnum

-- Map a Double in [0, 1] to a Word8 in [0, 255].
f2w :: Double -> Word8
f2w = toEnum . round . (*255)

-- Compose two images into one. `bottom` is wrapped to `top`'s size.
compose :: RGBA -> RGBA -> RGBA
compose bottom top =
    let newSize = Im.manifestSize top
        bottom' = wrap newSize bottom
    in Im.fromFunction newSize $ \p ->
        let RGBAPixel rB gB bB aB = bottom' Im.! p
            RGBAPixel rT gT bT aT = top Im.! p
            aB' = w2f aB; aT' = w2f aT
            ovl :: Double -> Double -> Double
            ovl cB cT = (cT * aT' + cB * aB' * (1.0 - aT')) / (aT' + aB' * (1.0 - aT'))
            (~*~) :: Word8 -> Word8 -> Word8
            cB ~*~ cT = f2w $ w2f cB `ovl` w2f cT
            aO = f2w (aT' + aB' * (1.0 - aT'))
        in RGBAPixel (rB ~*~ rT) (gB ~*~ gT) (bB ~*~ bT) aO

它只是简单地组合了底层和顶层，如下所示:



如果“底部”层是纹理，它将水平和垂直循环(通过 wrap)以适应顶层的大小。

渲染 map 所花的时间比它应该的要长得多。为游戏附带的默认世界渲染 map 需要 27 分钟 在 -O3 ，即使游戏本身可以在不到几毫秒的时间内清晰地呈现每个单独的屏幕。 (我上面链接的较小示例输出需要 67 秒；也太长了。)

分析器(输出为 here )表示程序在 compose 上花费了大约 77% 的时间。 .

削减这似乎是一个很好的第一步。看似很简单的操作，却在 friday中找不到原生函数这让我可以这样做。据说 GHC 应该擅长折叠所有 fromFunction东西，但我不知道发生了什么。或者包裹只是 super 慢？

Here’s the full, compileable code.

Answer 1

正如我在评论中所述，我制作的 MCE 表现良好并且不会产生任何有趣的输出:

module Main where
import qualified Vision.Primitive as Im
import Vision.Primitive.Shape
import qualified Vision.Image.Type as Im
import qualified Vision.Image.Class as Im
import Vision.Image.RGBA.Type (RGBA, RGBAPixel(..))
import Vision.Image.Storage.DevIL (load, save, Autodetect(..), StorageError, StorageImage(..))
import Vision.Image (convert)
import Data.Word
import System.Environment (getArgs)

main :: IO ()
main = do
  [input1,input2,output] <- getArgs
  io1 <- load Autodetect input1 :: IO (Either StorageError StorageImage)
  io2 <- load Autodetect input2 :: IO (Either StorageError StorageImage)
  case (io1,io2) of
    (Left err,_) -> error $ show err
    (_,Left err) -> error $ show err
    (Right i1, Right i2) -> go (convert i1) (convert i2) output
 where
  go i1 i2 output =
      do res <- save Autodetect output (compose i1 i2)
         case res of
          Nothing -> putStrLn "Done with compose"
          Just e  -> error (show (e :: StorageError))

-- Wrap an image to a given size.
wrap :: Im.Size -> RGBA -> RGBA
wrap s im =
    let Z :. h :. w = Im.manifestSize im
    in Im.fromFunction s $ \(Z :. y :. x) -> im Im.! Im.ix2 (y `mod` h) (x `mod` w)

-- Map a Word8 in [0, 255] to a Double in [0, 1].
w2f :: Word8 -> Double
w2f = (/255) . fromIntegral . fromEnum

-- Map a Double in [0, 1] to a Word8 in [0, 255].
f2w :: Double -> Word8
f2w = toEnum . round . (*255)

-- Compose two images into one. `bottom` is wrapped to `top`'s size.
compose :: RGBA -> RGBA -> RGBA
compose bottom top =
    let newSize = Im.manifestSize top
        bottom' = wrap newSize bottom
    in Im.fromFunction newSize $ \p ->
        let RGBAPixel rB gB bB aB = bottom' Im.! p
            RGBAPixel rT gT bT aT = top Im.! p
            aB' = w2f aB; aT' = w2f aT
            ovl :: Double -> Double -> Double
            ovl cB cT = (cT * aT' + cB * aB' * (1.0 - aT')) / (aT' + aB' * (1.0 - aT'))
            (~*~) :: Word8 -> Word8 -> Word8
            cB ~*~ cT = f2w $ w2f cB `ovl` w2f cT
            aO = f2w (aT' + aB' * (1.0 - aT'))
        in RGBAPixel (rB ~*~ rT) (gB ~*~ gT) (bB ~*~ bT) aO

此代码加载两个图像，应用您的撰写操作，并保存生成的图像。这几乎立即发生:

% ghc -O2 so.hs && time ./so /tmp/lambda.jpg /tmp/lambda2.jpg /tmp/output.jpg && o /tmp/output.jpg
Done with compose
./so /tmp/lambda.jpg /tmp/lambda2.jpg /tmp/output.jpg  0.05s user 0.00s system 98% cpu 0.050 total

如果您有备用 MCE，请发布它。你的完整代码对我来说太不简单了。