Утечка пространства при глянцевом рендеринге изменяемого изображения

Question

Я использовалJuicyPixelбиблиотека для генерации визуализированного изображения иglossбиблиотека для предварительного просмотра в реальном времени.

Приведенный ниже фрагмент кода вызывает утечку пространства

      
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])

Некоторый дополнительный контекст:

      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 (репозиторий, содержащий всю кодовую базу)

---

Идея состоит в том, чтобы постоянно писатьrendererразветвляется в фоновом режиме и отображает результат в каждом кадре. Хотя, как сказано,viewportRendererвызывает утечку пространства. Мне интересно, можно ли это исправить, изменив строгость, или мне, вероятно, следует использовать другую структуру данных для передачи изображения.

Я бы не назвал это «лучшей практикой», но мне действительно не нужно иметь дело с условиями гонки.

• Я экспериментировал с использованиемIORef RenderedImageиMVar RenderedImageхотя оба они не устранили утечку пространства.

• Его также невозможно было оптимизировать путем передачи-O2как вариант компиляции.

• Я попробовал это, просто генерируя новое изображение в каждом кадре, и это не привело к утечке пространства. Если я не создаю изображение изRenderedImage.

• Я прочитал изображение в обоихfreezeImage, хотя оба вызвали утечку пространства. (unsafeFreezeImageбыл быстрее и дал те же результаты, что странно, поскольку в документации библиотеки упоминается, что вы не должны иметь возможность использоватьMutableImageпосле прохождения)

Изменить: я провел некоторое профилирование, которое привело к следующим результатам.

Выходные данные профилировщика:https://pastebin.com/3YMFpAem

Результаты, по общему признанию, весьма неожиданны, посколькуcreateMutableImageнесет ответственность за большую часть ассигнований.

Answer 1

Проблема решена, по-видимому, это связано с тем, что функция Gloss-Jicy , которую я использовал, постоянно кэшировала изображение в каждом кадре. Это реализовано как:

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

Поэтому я просто скопировал его и установил Boolаргумент для bitmapOfForeignPtrкFalse.