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

• Li-yao Xia: Are you compiling with optimizations? Try using foldl' instead of foldl.
• Shadasviar: @Li-yaoXia, I even replaced convert function without using lists, it increased performance but not much. Profiling says that most allocations are made from grayscaleFromRGB by itself.
• Li-yao Xia: I can't find anything wrong with that function. Do you have a minimal compilable example?
• Shadasviar: @Li-yaoXia, updated with example

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)