Space Leak on Gloss render of Mutable Image

I used the JuicyPixel library for generating a rendered image and the gloss library for a live preview.

The piece of code below causes a Space Leak

viewportRenderer :: Viewport Picture
viewportRenderer = do
  eventText <- Color [rgb|#FFFFFF|] . scale 0.1 0.1 . Text . show . _lastEvent <$> get

  viewportLoc' <- gets _viewportLoc
  viewportScale' <- gets _viewportScale
  image <- gets _renderedImage >>= unsafeFreezeImage
  let viewport =
        Color [rgb|#323232|] $
          unV2 translate viewportLoc' $
            join scale viewportScale' $
              fromImageRGBA8 image
  return (Pictures [viewport, eventText])

Some additional context:

type RenderedImage = MutableImage RealWorld PixelRGBA8

data ViewportState = ViewPortState
  { _lastEvent :: Event
  , _viewportScale :: !Float
  , _viewportOrigin :: V2 Float
  , _viewportLoc :: V2 Float
  , _repeatActions :: [(Event -> Bool, StateT ViewportState IO ())]
  -- ^ Actions that get repeated until (Event -> Bool) returns True
  , _renderedImage :: !RenderedImage
  }

makeLenses ''ViewportState

type Viewport a = StateT ViewportState IO a
-- Uses lazy StateT

initialViewPortState :: RenderedImage -> ViewportState
initialViewPortState image =
  ViewPortState
    { _lastEvent = EventResize (0, 0) -- Sentinel value
    , _viewportScale = 1
    , _viewportOrigin = 0
    , _viewportLoc = 0
    , _repeatActions = []
    , _renderedImage = image
    }

viewWindow :: RenderedImage -> IO ()
viewWindow !image = do
  playIO
    (InWindow "Reticule-Minor viewport" (400, 300) (100, 100))
    [rgb|#0B0B0B|]
    60
    (initialViewPortState image)
    (fmap fst . runStateT viewportRenderer)
    (\event -> fmap snd . runStateT (eventHandler event))
    (\t -> fmap snd . runStateT (timeHandler t))

renderer :: RenderedImage -> IO ()
renderer image = do
  forM_ [0..399] \x -> forM_ [0..299] \y -> do
    let r = floor @Float $ (fromIntegral x / 399) * 255
        g = floor @Float $ (fromIntegral y / 299) * 255
    writePixel image x y (PixelRGBA8 r g 255 255)
    threadDelay 10

main :: IO ()
main = do
  image <- createMutableImage 400 300 (PixelRGBA8 255 255 255 0) >>= newIORef
  _ <- forkIO $ renderer image
  V.viewWindow image

https://github.com/Perigord-Kleisli/reticule-minor
(Repo containing the whole codebase)

The idea is to have a MutableImage be continually written to by renderer forked in the background and to have viewportRenderer display the result every frame. Though as said, viewportRenderer causes a space leak. I'm wondering if this can be fixed by modifying Strictness or if I should probably utilize another Data Structure for passing the image.

I wouldnt really call it "best practice" but I don't really need to deal with having race conditions here.

• I've experimented on using IORef RenderedImage and MVar RenderedImage though both of these didn't fix the space leak.

• It was also unable to be optimized away by passing -O2 as a compile option.

• I tried it with just generating a new image every frame and it didn't create a space leak. Unless I generate an image from the RenderedImage.

• I've read the image in both freezeImage, unsafeFreezeImage though both caused space leaks. (unsafeFreezeImage was faster and produced the same results which is strange as the library docs mention that you shouldnt be able to use the MutableImage after passing it)

Edit: I did some profiling which resulted in the following results.

With the profiler output being:
https://pastebin.com/3YMFpAem

The results are admittedly quite surprising, with createMutableImage being responsible for most of the allocations.

Solved the issue, apparently it's because the gloss-juicy function I used continually cached the image each frame. It is implemented as:

fromImageRGBA8 :: Image PixelRGBA8 -> Picture
fromImageRGBA8 (Image { imageWidth = w, imageHeight = h, imageData = id }) =
  bitmapOfForeignPtr w h
                     (BitmapFormat TopToBottom PxRGBA)
                     ptr True
    where (ptr, _, _) = unsafeToForeignPtr id

So I just copied it and set the Bool argument to bitmapOfForeignPtr to False.