Space leak when using the Applicative instance of Behavior

[albertov]

I've encountered a space leak in the Reflex library when using the Applicative instance of Behavior. The space leak occurs when a Behavior is constructed with the Applicative instance and sampled, as shown in the following snippet:

sample ((<>) <$> current dynA <*> current dynB)

However, when the Behavior is constructed by calling current on a Dynamic which is constructed with the Applicative instance, there is no space leak:

sample ( current ( (<>) <$> dynA <*> dynB ))

I've profiled my program and found that the space leak is related to DEAD_WEAK objects created by the behaviorPull closure and retained by the accumMaybeMDyn closure.

I'm currently working around it by using a forked version of reflex-vty which defines _vtyResult_picture :: Dynamic t V.Picture instead of _vtyResult_picture :: Behavior t V.Picture (see https://github.com/plow-technologies/reflex-vty/commit/e426a01ec52e5c37312ddb4c41c24426d2b4e8f9) but I believe a proper fix belongs in Reflex since the documentation suggests that sampling a Behavior for outputs by the host framework is the recommended pattern.

I'm using GHC 9.2.4 and reflex-0.8.2.1 but I've also reproduced it with the develop branch of Reflex. I'm attaching the simplest reproducer I could came up with. It can be called with constant-memory or increasing-memory as an argument, the later demos the space leak. I've also attatched the SVG rendering of the .hp files for each run (GitHub won't allow the .hp files)

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Control.Concurrent
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Identity
import Control.Monad.Ref
import Data.Dependent.Sum
import Data.IORef
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time
import Reflex
import Reflex.Host.Class
import System.Environment
import System.Exit

type MonadTestApp t m =
  ( Reflex t,
    MonadHold t m,
    MonadHold t (Performable m),
    MonadFix m,
    MonadFix (Performable m),
    ReflexHost t,
    PostBuild t m,
    PerformEvent t m,
    MonadIO m,
    MonadIO (Performable m),
    MonadIO (HostFrame t),
    Ref m ~ IORef,
    Ref (HostFrame t) ~ IORef,
    MonadRef (HostFrame t),
    NotReady t m,
    TriggerEvent t m
  )

type TestApp t m =
  MonadTestApp t m =>
  m (Behavior t T.Text)

-- | Run a program written in the framework.  This will do all the necessary
--   work to integrate the Reflex-based guest program with the outside world
--   via IO.
host ::
  (forall t m. TestApp t m) ->
  IO ()
host myGuest =
  -- Use the Spider implementation of Reflex.
  runSpiderHost $ do
    (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

    events <- liftIO newChan

    -- Evaluate our user's program to set up the data flow graph.
    (b, fc@(FireCommand fire)) <-
      hostPerformEventT $
        flip runPostBuildT postBuild $
          flip runTriggerEventT events myGuest

    mPostBuildTrigger <- readRef postBuildTriggerRef

    forM_ mPostBuildTrigger $ \postBuildTrigger ->
      fire [postBuildTrigger :=> Identity ()] $ return ()

    -- Begin our event processing loop.
    forever $ do
      ers <- liftIO $ readChan events
      liftIO . T.putStr . T.unlines
        =<< fireEventTriggerRefs fc ers (sample b)
  where
    fireEventTriggerRefs ::
      (Monad (ReadPhase m), MonadIO m) =>
      FireCommand t m ->
      [DSum (EventTriggerRef t) TriggerInvocation] ->
      ReadPhase m a ->
      m [a]
    fireEventTriggerRefs (FireCommand fire) ers rcb = do
      mes <- liftIO $
        forM ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
          me <- readIORef er
          return $! fmap (\e -> e `seq` e :=> Identity a) me
      a <- fire (catMaybes mes) rcb
      liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
      return a

-- | This guest does not have a space leak
guestDynApplicative :: TestApp t m
guestDynApplicative = do
  (messages1D, messages2D) <- twoMessageBuffers
  pure $ current $ fmap (T.unlines . reverse) $ (<>) <$> messages1D <*> messages2D

-- | This guest does have a space leak
guestBhvApplicative :: TestApp t m
guestBhvApplicative = do
  (messages1D, messages2D) <- twoMessageBuffers
  pure $ fmap (T.unlines . reverse) $ (<>) <$> current messages1D <*> current messages2D

twoMessageBuffers ::
  ( Reflex t,
    MonadIO m,
    MonadHold t m,
    TriggerEvent t m,
    MonadFix m,
    PostBuild t m,
    PerformEvent t m,
    MonadIO (Performable m)
  ) =>
  m (Dynamic t [T.Text], Dynamic t [T.Text])
twoMessageBuffers = do
  message1E <- ("message1" <$) <$> (tickLossy 0.5 =<< liftIO getCurrentTime)
  let acc10 x xs = x : take 9 xs
  messages1D <- foldDyn acc10 [] message1E

  -- The 'never' in the following line causes a space leak when 'messages2D' is
  -- turned into a Behavior with 'current' and this Behavior value is then used in
  -- an 'Applicative' expression (see guestBhvApplicative).
  messages2D <- foldDyn acc10 [] never
  pure (messages1D, messages2D)

main :: IO ()
main =
  getArgs >>= \case
    ["constant-mem"] -> host guestDynApplicative
    ["increasing-mem"] -> host guestBhvApplicative
    _ -> die "Usage: repro-leak ( constant-mem | increasing-mem )"