Performance concerns when converting GTK image to greyscale

Question

I have a function which takes GTK Image (It is RGB) and returns a representation of this image as list of grey levels.

This is my code:

grayscaleFromRGB :: Image -> IO [Word8]
grayscaleFromRGB img = do
    imgType <- img `get` imageStorageType
    if imgType == ImageEmpty
        then
            return (replicate 256 0)
        else do
            pixbuf <- imageGetPixbuf img
            pixels <- (pixbufGetPixels pixbuf :: IO (PixbufData Int Word8))
            rgbList <- getElems pixels
            nChannels <- pixbufGetNChannels pixbuf
            return (map convert $ chunksOf nChannels rgbList)

    where
        convert channels = round $ foldl (+) 0 $ zipWith (*) [0.3, 0.59, 0.11] $ map fromIntegral channels

But I have a problem: this function uses too much memory and CPU time. For example for an image with a size of 500x500 it takes nearly 100MB of memory. Opening an image with a size of 2000x1000 it use more than 1GB of memory and it takes a lot of time.

How can it be written in an efficient way? What is the reason for this behavior?

Update:

Whole code which use this function (this program takes too much RAM):

import Graphics.Rendering.Cairo
import Graphics.UI.Gtk
import Data.List.Split
import Data.Array.MArray
import Data.Array.IO
import Data.Word
import Data.List
import Foreign.Storable

grayscaleFromRGB :: Image -> IO [Word8]
grayscaleFromRGB img = do
    imgType <- img `get` imageStorageType
    if imgType == ImageEmpty
        then
            return (replicate 256 0)
        else do
            pixbuf <- imageGetPixbuf img
            pixels <- (pixbufGetPixels pixbuf :: IO (PixbufData Int Word8))
            rgbList <- getElems pixels
            nChannels <- pixbufGetNChannels pixbuf
            return (map convert $ chunksOf nChannels rgbList)

    where
        convert channels = round $ foldl' (+) 0 $ zipWith (*) [0.3, 0.59, 0.11] $ map fromIntegral channels 

main :: IO ()
main= do
     initGUI
     window <- windowNew
     set window [windowTitle := "Hello Cairo",
                 windowDefaultWidth := 300, windowDefaultHeight := 200,
                 containerBorderWidth := 30 ]

     image <- imageNew
     let menuBarData = [
                  ("File", [("Open", openPressed image),
                            ("Exit", mainQuit)
                           ])
                      ]

     tab <- tableNew 5 10 True

     menuBar <- createMenuBar menuBarData

     scrolled <- scrolledWindowNew Nothing Nothing
     scrolledWindowAddWithViewport scrolled image


     tableAttachDefaults tab menuBar    0 10 0 1 
     tableAttachDefaults tab scrolled   0 5 1 10 

     containerAdd window tab

     widgetShowAll window     
     onDestroy window mainQuit
     mainGUI

createMenuBar menuBarData = do
    menuBar <- menuBarNew

    mapM_ (setMenuEntries menuBar) menuBarData
    return menuBar

    where
        setMenuEntries menuBar (entryName, items) = do
            entry <- menuItemNewWithLabel entryName
            menu <- menuNew
            mapM_ (addItemToEntry menu) items
            menuItemSetSubmenu entry menu
            menuShellAppend menuBar entry

        addItemToEntry menu (name, action) = do
            item <- menuItemNewWithLabel name
            item `on` menuItemActivated $ action 
            menuShellAppend menu item


openPressed :: Image -> IO ()
openPressed image = do
    chooser <- fileChooserDialogNew 
                (Just "Open file") 
                Nothing 
                FileChooserActionOpen
                [("OK", ResponseOk),
                 ("Cancel", ResponseCancel)]

    widgetShow chooser
    res <- dialogRun chooser
    filename <- performResponse res chooser
    widgetHide chooser

    where
        performResponse ResponseCancel _ = return ()
        performResponse ResponseOk chooser = do
            Just fname <- fileChooserGetFilename chooser
            imageSetFromFile image fname
            grey <- grayscaleFromRGB image
            putStrLn $ show $ grey

Answer 1

By commenting out various parts of grayscaleFromRGB, we can deduce that what is taking the most time is getElems (and possibly the computations after return). Indeed, for a 2000x1000 picture, there are 2M pixels (x3 or 4 channels), and getElems is putting them in a list word by word. Lists are quite inefficient for storing large amounts of data like pictures (at least 4 or 5 extra words per element, and the GC comes with an extra x2 factor).

To reduce memory usage, we can write a custom loop to process the elements in the array as we read them, like below. To reduce that further, don't use lists to store large amounts of data. It still takes a while to read millions of elements from memory byte by byte; there may be a better way using a specialized data processing library but I don't know it.

grayscaleFromRGB :: Image -> IO [Word8]
grayscaleFromRGB img = do
    imgType <- img `get` imageStorageType
    if imgType == ImageEmpty
        then
            return (replicate 256 0)
        else do
            pixbuf <- imageGetPixbuf img
            pixels <- (pixbufGetPixels pixbuf :: IO (PixbufData Int Word8))
            nChannels <- pixbufGetNChannels pixbuf
            (_, bound) <- getBounds pixels
            loop pixels nChannels bound 0 []

    where
        -- the returned list will be reversed compared to the original code
        loop pixels n bound i acc | i + 2 > bound = return acc
        loop pixels n bound i acc = do
          let get i = fromIntegral <$> (readArray (pixels :: PixbufData Int Word8) i) :: IO Double
          a <- (0.3 *) <$> get i
          b <- (0.59 *) <$> get (i + 1)
          c <- (0.11 *) <$> get (i + 2)
          loop pixels n bound (i + n) $! (((:) $! round (a + b + c)) $! acc)