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.

Author: elopez

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

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 =