Resolve UI memory leaks

lib/Echidna/Campaign.hs

@@ -481,10 +481,15 @@ callseq vm txSeq = do
       in (corp', corpusSize corp')
 
     (points, numCodehashes) <- liftIO $ coverageStats env.coverageRefInit env.coverageRefRuntime
+    -- force the list eagerly: `transactions` is a non-strict field, so a
+    -- lazy `force (...)` is itself stored as a thunk that pins every
+    -- VMResult (and its returndata) of the executed sequence until some
+    -- consumer demands it -- and none does under the default config
+    let !transactions = force $ fst <$> results
     pushWorkerEvent NewCoverage { points
                                 , numCodehashes
                                 , corpusSize = newSize
-                                , transactions = fst <$> results
+                                , transactions
                                 }
 
   modify' $ \workerState ->
@@ -634,10 +639,18 @@ updateOpenTest vm reproducer test = do
   case test.state of
     Open -> do
       (testValue, vm') <- checkETest test vm
+      -- forced in the branches that store it so the stored test (and its
+      -- VM-free event copies) does not retain vm' through an unevaluated
+      -- selector; must stay unevaluated on the fall-through path where
+      -- vm' may carry no result
       let result = getResultFromVM vm'
       case testValue of
         BoolValue False -> do
           workerId <- Just <$> gets (.workerId)
+          -- collapse the suspended execution state before storing the VM,
+          -- otherwise the stored thunks retain every intermediate VM
+          let !_ = forceVMData vm
+          let !_ = result
           let test' = test { Test.state = Large 0
                            , reproducer
                            , vm = Just vm
@@ -648,6 +661,8 @@ updateOpenTest vm reproducer test = do
           pure $ Just test'
 
         IntValue value' | value' > value -> do
+          let !_ = forceVMData vm
+          let !_ = result
           let test' = test { reproducer
                            , value = IntValue value'
                            , vm = Just vm

lib/Echidna/Exec.hs

@@ -14,6 +14,7 @@ import Data.ByteString qualified as BS
 import Data.IORef (readIORef, newIORef, writeIORef, modifyIORef')
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe, fromJust)
+import Data.Set qualified as Set
 import Data.Text qualified as T
 import Data.Vector qualified as V
 import Data.Vector.Unboxed.Mutable qualified as VMut
@@ -323,3 +324,44 @@ initialVM ffi = do
             & #block % #number .~ Lit initialBlockNumber
             & #env % #contracts .~ mempty -- fixes weird nonce issues
             & #config % #allowFFI .~ ffi
+
+-- | Force the parts of a VM that accumulate suspended computation during
+-- execution. Lens-based state updates leave record fields as thunk chains
+-- referencing every intermediate VM of the run; storing such a VM (e.g. in
+-- 'EchidnaTest.vm' on falsification or per shrink step) would otherwise
+-- retain the whole execution history until the field is demanded -- which
+-- reporting only does once at campaign end, and the interactive UI's
+-- periodic test snapshots turn into gigabytes of standing heap.
+forceVMData :: VM Concrete -> ()
+forceVMData vm =
+    contractsWhnf `seq`
+    storesWhnf `seq`
+    subStateWhnf `seq`
+    Set.size vm.keccakPreImgs `seq`
+    length vm.constraints `seq`
+    length vm.logs `seq`
+    vm.burned `seq`
+    ()
+  where
+    -- the substate's list elements are pushed lazily (hevm's pushTo conses
+    -- an unevaluated Expr EAddr closing over the mid-execution VM), so a
+    -- stored VM otherwise chains to every intermediate VM of its
+    -- transaction; Set elements are already forced by Ord on insert, but
+    -- the suspended inserts still need their spines demanded via size
+    subStateWhnf =
+      let ss = vm.tx.subState
+          whnfElems = foldl (flip seq) ()
+      in whnfElems ss.selfdestructs `seq`
+         whnfElems ss.touchedAccounts `seq`
+         whnfElems (map fst ss.refunds) `seq`
+         Set.size ss.accessedAddresses `seq`
+         Set.size ss.accessedStorageKeys `seq`
+         Set.size ss.createdContracts `seq`
+         ()
+    contractsWhnf = Map.size vm.env.contracts
+    storesWhnf =
+      Map.foldl' (\acc c -> acc + storeSize c.storage + storeSize c.origStorage)
+                 (0 :: Int) vm.env.contracts
+    storeSize :: Expr Storage -> Int
+    storeSize (ConcreteStore m) = Map.size m
+    storeSize _ = 0

lib/Echidna/Shrink.hs

@@ -44,10 +44,15 @@ shrinkTest vm test = do
             pure $ case maybeShrunk of
               -- the test still fails, let's create another test with the reduced sequence
               Just (txs, val, vm') -> do
+                -- collapse the suspended execution state before storing the
+                -- VM, otherwise the stored thunks retain every intermediate
+                -- VM of the replayed sequence until the next shrink step
+                let !_ = forceVMData vm'
+                    !shrunkResult = getResultFromVM vm'
                 Just test { state = Large (i + 1)
                     , reproducer = txs
                     , vm = Just vm'
-                    , result = getResultFromVM vm'
+                    , result = shrunkResult
                     , value = val }
               Nothing ->
                 -- The test passed, so no success with shrinking this time, just bump number of tries to shrink

lib/Echidna/UI.hs

@@ -7,6 +7,7 @@ import Brick.BChan
 import Brick.Widgets.Dialog qualified as B
 import Control.Concurrent (killThread, threadDelay)
 import Control.Concurrent.MVar (readMVar)
+import Control.DeepSeq (deepseq)
 import Control.Exception (AsyncException)
 import Control.Monad
 import Control.Monad.Catch
@@ -17,6 +18,7 @@ import Data.List.Split (splitPlaces)
 import Data.Map (Map)
 import Data.Maybe (isJust, mapMaybe)
 import Data.Sequence ((|>))
+import Data.Sequence qualified as Seq
 import Data.Text (Text)
 import Data.Time
 import Graphics.Vty qualified as Vty
@@ -51,11 +53,28 @@ import Echidna.Utility (timePrefix, getTimestamp)
 import Echidna.Worker (getNWorkers, workerIDToType)
 
 data UIEvent =
-  CampaignUpdated LocalTime [EchidnaTest] [WorkerState]
-  | FetchCacheUpdated (Map Addr (Maybe Contract))
-                      (Map Addr (Map W256 (Maybe W256)))
+  CampaignTick
   | EventReceived (LocalTime, CampaignEvent)
 
+-- | Latest campaign snapshot, read by the UI when handling 'CampaignTick'.
+-- It is deliberately kept in an IORef instead of being carried inside the
+-- event queue: queued payloads would pin one '[EchidnaTest]' generation
+-- (each with full VM snapshots) per tick whenever the render loop falls
+-- behind the producer, retaining gigabytes during shrinking. With an IORef
+-- at most one generation is ever reachable.
+type UISnapshot =
+  ( LocalTime
+  , [EchidnaTest]
+  , [WorkerState]
+  , Map Addr (Maybe Contract)
+  , Map Addr (Map W256 (Maybe W256))
+  )
+
+-- | Bound for the log pane history; it is also rendered with an O(n) fold,
+-- so an unbounded sequence would grow both heap and frame time forever.
+maxUILogEvents :: Int
+maxUILogEvents = 5000
+
 -- | Gas tracking state for calculating gas consumption rate
 data GasTracker = GasTracker
   { lastUpdateTime :: LocalTime
@@ -112,27 +131,35 @@ ui vm dict initialCorpus cliSelectedContract = do
       uiEventsForwarderStopVar <- spawnListener forwardEvent
       workers <- spawnWorkers
 
+      snapshotRef <- liftIO $ newIORef (Nothing :: Maybe UISnapshot)
       ticker <- liftIO . forkIO . forever $ do
         threadDelay 200_000 -- 200 ms
 
         now <- getTimestamp
         tests <- traverse readIORef env.testRefs
         states <- workerStates workers
-        writeBChan uiChannel (CampaignUpdated now tests states)
-
         -- TODO: remove and use events for this
         (c, s) <- EVM.Fetch.getCacheState env.fetchSession
-        writeBChan uiChannel (FetchCacheUpdated c s)
+        -- publish the snapshot out-of-band and only signal via the queue;
+        -- dropping the tick when the queue is full is fine, the next handled
+        -- tick reads the freshest snapshot anyway
+        writeIORef snapshotRef $ Just (now, tests, states, c, s)
+        void $ writeBChanNonBlocking uiChannel CampaignTick
 
       -- UI initialization
       let buildVty = do
             v <- mkVty =<< vtyConfig
             let output = Vty.outputIface v
             when (Vty.supportsMode output Vty.Mouse) $
               Vty.setMode output Vty.Mouse True
-            pure v
+            -- deep-force every picture before it reaches vty: brick's
+            -- renderFinal composes pictures lazily and threads suspended
+            -- viewport state across renders, so the picture parked in
+            -- vty's lastPicRef otherwise grows a thunk chain that pins
+            -- one UI state generation (and its test snapshots) per render
+            pure v { Vty.update = \pic -> pic `deepseq` Vty.update v pic }
       initialVty <- liftIO buildVty
-      app <- customMain initialVty buildVty (Just uiChannel) <$> monitor
+      app <- customMain initialVty buildVty (Just uiChannel) <$> monitor snapshotRef
 
       liftIO $ do
         tests <- traverse readIORef env.testRefs
@@ -158,6 +185,9 @@ ui vm dict initialCorpus cliSelectedContract = do
           , numCodehashes = 0
           , lastNewCov = now
           , tests
+          , testsPane = emptyWidget
+          , testsPaneDigest = []
+          , testsPaneBuilt = now
           , campaignWidget = emptyWidget -- temporary, will be overwritten below
           }
         initialCampaignWidget <- runReaderT (campaignStatus uiState) env
@@ -294,8 +324,8 @@ vtyConfig = do
     ] }
 
 -- | Check if we should stop drawing (or updating) the dashboard, then do the right thing.
-monitor :: MonadReader Env m => m (App UIState UIEvent Name)
-monitor = do
+monitor :: MonadReader Env m => IORef (Maybe UISnapshot) -> m (App UIState UIEvent Name)
+monitor snapshotRef = do
   let
     drawUI :: UIState -> [Widget Name]
     drawUI uiState =
@@ -323,18 +353,62 @@ monitor = do
       LogPane   -> viewportScroll LogViewPort
 
     onEvent env = \case
-      AppEvent (CampaignUpdated now tests c') -> do
-        state <- get
-        let updatedState = state { campaigns = c', status = Running, now, tests }
-        newWidget <- liftIO $ runReaderT (campaignStatus updatedState) env
-        -- intentionally using lazy modify here, so unnecessary widget states don't get computed
-        modify $ const updatedState { campaignWidget = newWidget }
-      AppEvent (FetchCacheUpdated contracts slots) ->
-        modify' $ \state ->
-          state { fetchedContracts = contracts
-                , fetchedSlots = slots }
+      AppEvent CampaignTick ->
+        liftIO (readIORef snapshotRef) >>= \case
+          Nothing -> pure ()
+          Just (now, tests, c', contracts, slots) -> do
+            state <- get
+            -- rebuild the tests pane only when a test actually changed:
+            -- rebuilding allocates pretty-printing structures (ppTx, traces)
+            -- per test that have been observed to accumulate unboundedly
+            -- when reconstructed on every 200 ms tick
+            let digest = (\t -> (show t.state, t.value)) <$> tests
+            -- also rate-limit rebuilds: during shrinking the digest changes
+            -- on every step, and superseded pane structures are retained,
+            -- so rebuild at most once a second
+            (testsPane, testsPaneBuilt) <-
+              if digest == state.testsPaneDigest
+                 || diffLocalTime now state.testsPaneBuilt < 1
+                then pure (state.testsPane, state.testsPaneBuilt)
+                else do
+                  w <- liftIO $ runReaderT (testsWidget tests) env
+                  pure (w, now)
+            -- sever the previous widget before building the new one: widget
+            -- render closures capture this state record, and if it still
+            -- referenced the previous campaignWidget every tick would chain
+            -- to the one before it, pinning each generation's tests (and
+            -- their VM snapshots) for the whole session
+            -- store a VM-free copy: brick's event loop has been observed to
+            -- chain superseded state generations internally, and each VM
+            -- snapshot reachable from them would be pinned (the tests pane
+            -- above is built from the VM-bearing snapshot and renders to
+            -- forced strings, so nothing else needs the VMs here)
+            -- the stripped copies must be forced: each `t { vm = Nothing }`
+            -- is itself a thunk retaining the VM-bearing original until
+            -- evaluated, and nothing in the render path demands the list
+            -- elements
+            let strippedTests = (\t -> t { vm = Nothing } :: EchidnaTest) <$> tests
+                !_ = foldl (flip seq) () strippedTests
+            let updatedState = state { campaigns = c', status = Running, now
+                                     , tests = strippedTests
+                                     , fetchedContracts = contracts
+                                     , fetchedSlots = slots
+                                     , testsPane
+                                     , testsPaneDigest = digest
+                                     , testsPaneBuilt
+                                     , campaignWidget = emptyWidget }
+            newWidget <- liftIO $ runReaderT (campaignStatus updatedState) env
+            -- strict in the record (WHNF) so ticks don't chain unevaluated
+            -- state generations when rendering can't keep up; the widget
+            -- body itself stays lazy, so unnecessary widget states still
+            -- don't get computed
+            modify' $ const updatedState { campaignWidget = newWidget }
       AppEvent (EventReceived event@(time,campaignEvent)) -> do
-        modify' $ \state -> state { events = state.events |> event }
+        -- bounded log history: drop the oldest entry once at capacity
+        modify' $ \state ->
+          state { events = (if Seq.length state.events >= maxUILogEvents
+                              then Seq.drop 1 state.events
+                              else state.events) |> event }
 
         case campaignEvent of
           WorkerEvent _ _ (NewCoverage { points, numCodehashes, corpusSize }) ->

lib/Echidna/UI/Widgets.hs

@@ -7,6 +7,7 @@ import Brick.AttrMap qualified as A
 import Brick.Widgets.Border
 import Brick.Widgets.Center
 import Brick.Widgets.Dialog qualified as B
+import Control.DeepSeq (force)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Reader (MonadReader, asks, ask)
 import Data.List (nub, intersperse, sortBy)
@@ -65,6 +66,17 @@ data UIState = UIState
   , campaignWidget :: Widget Name
   -- ^ Pre-computed widget to avoid IO in drawing
 
+  , testsPane :: Widget Name
+  -- ^ Cached tests pane; rebuilt only when 'testsPaneDigest' changes.
+  -- Rebuilding it on every tick allocates ppTx/trace pretty-printing
+  -- structures per test per 200 ms that accumulate into an unbounded heap
+  -- on long interactive runs.
+  , testsPaneDigest :: [(String, TestValue)]
+  -- ^ Cheap fingerprint (state + value per test) of the cached tests pane
+  , testsPaneBuilt :: LocalTime
+  -- ^ When the cached tests pane was built; rebuilds are rate-limited
+  -- because superseded widget structures are observed to be retained
+
   , tests :: [EchidnaTest]
   }
 
@@ -108,7 +120,7 @@ data Name
 -- | Render 'Campaign' progress as a 'Widget'.
 campaignStatus :: (MonadReader Env m, MonadIO m) => UIState -> m (Widget Name)
 campaignStatus uiState = do
-  tests <- testsWidget uiState.tests
+  let tests = uiState.testsPane
 
   if uiState.workersAlive == 0 then
     mainbox tests (finalStatus "Campaign complete, C-c or esc to exit")
@@ -349,7 +361,9 @@ tracesWidget vm = do
   -- TODO: showTraceTree does coloring with ANSI escape codes, we need to strip
   -- those because they break the Brick TUI. Fix in hevm so we can display
   -- colors here as well.
-  let traces = stripAnsiEscapeCodes $ showTraceTree dappInfo vm
+  -- strict: the rendered text must not stay a thunk over the VM, since the
+  -- produced widget can be retained well past this VM's lifetime
+  let !traces = force $ stripAnsiEscapeCodes $ showTraceTree dappInfo vm
   pure $
     if T.null traces then str ""
     else str "Traces" <+> str ":" <=> txtBreak traces
@@ -369,8 +383,11 @@ failWidget b test = do
   let vm = fromJust test.vm
   s <- seqWidget vm test.reproducer
   traces <- tracesWidget vm
+  -- strict: don't let the widget capture the test record (and its VM)
+  -- through unevaluated show/format thunks
+  let !resultStr = force (" with " ++ show test.result)
   pure
-    ( failureBadge <+> str (" with " ++ show test.result)
+    ( failureBadge <+> str resultStr
     , shrinkWidget b test <=> titleWidget <=> s <=> str " " <=> traces
     )
 
@@ -411,15 +428,17 @@ shrinkWidget b test =
   case b of
     Nothing -> emptyWidget
     Just (n,m) ->
-      str "Current action: " <+>
-      withAttr (attrName "working")
-               (str ("shrinking " ++ progress n m ++ showWorker))
+      -- strict: don't capture the test record through the format thunk
+      let !line = force ("shrinking " ++ progress n m ++ showWorker)
+      in str "Current action: " <+> withAttr (attrName "working") (str line)
   where
   showWorker = maybe "" (\i -> " (worker " <> show i <> ")") test.workerId
 
 seqWidget :: (MonadReader Env m, MonadIO m) => VM Concrete -> [Tx] -> m (Widget Name)
 seqWidget vm xs = do
-  ppTxs <- mapM (ppTx vm $ length (nub $ (.src) <$> xs) /= 1) xs
+  -- strict: pretty-printed transactions must not stay thunks over the VM,
+  -- since the produced widget can be retained well past this VM's lifetime
+  ppTxs <- force <$> mapM (ppTx vm $ length (nub $ (.src) <$> xs) /= 1) xs
   let ordinals = str . printf "%d. " <$> [1 :: Int ..]
   pure $
     foldl (<=>) emptyWidget $