Stack overflow when creating monochrome PNG images

Question

I found a small library for writing PNG files using Haskell on this page. I just rearranged it so that it supports all monochrome, grayscale and RGB outputs. However, it seems that I always get stack overflow when writing large monochrome images, but not if I use grayscale or RGB. In this example, the size threshold is more or less 2000: if I set `width` less than that, the image is generated, otherwise I get a stack overflow. ``` import Png import qualified Data.ByteString.Lazy as B width = 2000 :: Int main = do let setG = [ [ (r + c) `mod` 256 | c <- [0..width]] | r <- [0..width]] let outputG = pngGrayscale setG putStrLn "Writing grayscale image..." B.writeFile "grayscale.png" outputG putStrLn "Done" let setR = [ [ (r `mod` 256, c `mod` 256, (r+c) `mod` 256) | c <- [0..width]] | r <- [0..width]] let outputR = pngRGB setR putStrLn "Writing RGB image..." B.writeFile "rgb.png" outputR putStrLn "Done" let setM = [ [ even (r + c) | c <- [0..width]] | r <- [0..width]] let outputM = pngMon…

Accepted Answer

The culprit is

```
bitpackMonochrome' :: [Bool] -> Word8 -> Word8 -> B.ByteString
bitpackMonochrome' [] n b = if b /= 0x80 then B.singleton n else B.empty
bitpackMonochrome' (x:xs) n b =
    if b == 1
        then v `B.cons` bitpackMonochrome' xs 0 0x80
        else bitpackMonochrome' xs v (b `shiftR` 1)
    where v = if x then n else n .|. b
```

which uses `B.cons` to concatenate `ByteString`s. That is rather inefficient anyway, and `B.cons` is strict in its second argument.

Therefore, you get a huge (about half a million deep for a `2000×2000` bit image) thunk of the form

```
v1 `B.cons` (v2 `B.cons` (v3 ...)))
```

that overflows the stack.

A simple cure - that still is rather inefficient - is to use lists in `bitpackMonochrome'`, since `(:)` is lazy in its second argument,

```
bitpackMonochrome :: [Bool] -> B.ByteString
bitpackMonochrome xs = B.pack $ bitpackMonochrome' xs 0 0x80

bitpackMonochrome' :: [Bool] -> Word8 -> Word8 -> [Word8]
bitpackMonochrome' [] n b = if b /= 0x80 then [n] else []
bitpackMonochrome' (x:xs) n b =
    if b == 1
        then v : bitpackMonochrome' xs 0 0x80
        else bitpackMonochrome' xs v (b `shiftR` 1)
    where v = if x then n else n .|. b
```

and `B.pack` that in `bitpackMonochrome`.

This way, you don't get the huge thunk, since the `(:)` can be evaluated before its second argument.

A much more efficient version would calculate the needed size from the dimensions and use

```
create :: Int -> (Ptr Word8 -> IO ()) -> IO ByteString
```

or even

```
unsafeCreate :: Int -> (Ptr Word8 -> IO ()) -> ByteString
```

from `Data.ByteString.Internal` to directly fill the allocated buffer of the correct size.

Stack overflow when creating monochrome PNG images

Solution

Problem