From 1c692ce2c7db08092170d87819415c44afbb0995 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Emilio=20L=C3=B3pez?= <emilio.lopez@trailofbits.com>
Date: Tue, 14 Jul 2026 10:38:54 -0300
Subject: [PATCH] Drain campaign event queue to fix root-cursor memory leak

Every consumer reads campaign events from its own dupChan, so the
original Chan's read end is never advanced and pins every event ever
written, keeping the whole campaign's event history (including full VM
snapshots) alive. Drain the original queue from a dedicated thread so
the GC can reclaim delivered events, and publish VM-free, strictly
forced copies of falsified/optimized tests so queued events can't
retain a VM through a lazy thunk.
---
 lib/Echidna.hs          | 9 ++++++++-
 lib/Echidna/Campaign.hs | 9 +++++++--
 2 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/lib/Echidna.hs b/lib/Echidna.hs
index e4e2bce9f..a91675600 100644
--- a/lib/Echidna.hs
+++ b/lib/Echidna.hs
@@ -1,6 +1,8 @@
 module Echidna where
 
-import Control.Concurrent (newChan)
+import Control.Concurrent (forkIO, newChan, readChan)
+import Control.Exception (SomeException, handle)
+import Control.Monad (forever, void)
 import Control.Monad.Catch (MonadThrow(..))
 import Control.Monad.IO.Class (liftIO)
 import Data.IORef (newIORef)
@@ -125,6 +127,11 @@ mkEnv cfg buildOutput tests world slitherInfo = do
   codehashMap <- newIORef mempty
   chainId <- Onchain.fetchChainIdFrom cfg.rpcUrl
   eventQueue <- newChan
+  -- Consumers read events from their own 'dupChan', so this original read end
+  -- is never advanced and would otherwise pin every event ever written. Drain
+  -- it from a dedicated thread so the GC can reclaim delivered events.
+  void $ forkIO $ handle (\(_ :: SomeException) -> pure ()) $
+    forever $ void $ readChan eventQueue
   coverageRefInit <- newIORef mempty
   coverageRefRuntime <- newIORef mempty
   corpusRef <- newIORef mempty
diff --git a/lib/Echidna/Campaign.hs b/lib/Echidna/Campaign.hs
index 183d02e2e..a9c79883c 100644
--- a/lib/Echidna/Campaign.hs
+++ b/lib/Echidna/Campaign.hs
@@ -651,7 +651,10 @@ updateOpenTest vm reproducer test = do
                            , result
                            , workerId
                            }
-          pushWorkerEvent (TestFalsified test')
+          -- Publish a VM-free copy, forced strict so the event can't retain the
+          -- VM through a thunk. testRefs keeps the full 'test'' for shrinking.
+          let !vmFreeTest = test' { Test.vm = Nothing }
+          pushWorkerEvent (TestFalsified vmFreeTest)
           pure $ Just test'
 
         IntValue value' | value' > value -> do
@@ -660,7 +663,9 @@ updateOpenTest vm reproducer test = do
                            , vm = Just vm
                            , result
                            }
-          pushWorkerEvent (TestOptimized test')
+          -- VM-free copy, as in the TestFalsified case above.
+          let !vmFreeTest = test' { Test.vm = Nothing }
+          pushWorkerEvent (TestOptimized vmFreeTest)
           pure $ Just test'
           where
           value =