Memory leak with non-firing event

[esoeylemez]

The code below, when executed with +RTS -T, displays the current memory usage (in KiB) together with a counter that can be incremented by typing any character. The memory usage keeps constantly increasing, but is reset whenever the counter is incremented by typing (i.e. triggering the counterEv event). I have observed the following characteristics:

• Sampling counter in debugStr (in a pull) causes the leak.
• Sampling counter in the host monad does not cause the leak.
• The leaked memory is released every time counterEv fires, changing the value of counter.

---

{-# LANGUAGE BangPatterns #-}

module Main where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Ref
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Data.Dependent.Sum
import Data.Maybe
import GHC.Stats
import Reflex
import Reflex.Host.Class
import System.IO
import System.Mem
import Text.Printf


getMemUsed :: (MonadIO m) => m Integer
getMemUsed =
    liftIO $ do
        performGC
        toInteger . currentBytesUsed <$> getGCStats


main :: IO ()
main =
    runSpiderHost $ do
        liftIO $ do
            hSetBuffering stdin NoBuffering
            hSetEcho stdin False

        (memUsedEv, memUsedRef) <- newEventWithTriggerRef
        memUsed <- do mu0 <- getMemUsed; runHostFrame (hold mu0 memUsedEv)

        (counterEv, counterRef) <- newEventWithTriggerRef
        counter <- runHostFrame (hold (0 :: Integer) counterEv)

        debugStr <- runHostFrame $ do
            pure . pull $
                printf "%8.3fk %8d"
                <$> fmap (\mu -> fromInteger mu / 1024 :: Double) (sample memUsed)
                <*> sample counter

        forever $ do
            mCounterVal <- runMaybeT $ do
                trig <- MaybeT (readRef counterRef)
                liftIO (hReady stdin) >>= guard
                liftIO getChar
                !c <- (+ 1) <$> lift (sample counter)
                pure (trig ==> c)

            mMemUsedVal <- runMaybeT $ do
                trig <- MaybeT (readRef memUsedRef)
                mu' <- lift (sample memUsed)
                mu <- getMemUsed
                guard (mu /= mu')
                pure (trig ==> mu)

            fireEvents (catMaybes [mCounterVal, mMemUsedVal])

            s <- runHostFrame (sample debugStr)
            liftIO $ do
                hPutStr stderr ('\r' : s ++ "\027[K")
                hFlush stderr

[3noch]

@ryantrinkle What's the scoop on this? Any updates?