Sever UI-state generation retention via vty lastPicRef

The interactive (Brick/vty) UI retained one UIState generation per rendered
frame, unbounded: vty parks the last Picture in an IORef (lastPicRef) for
resize redraws, and Brick builds that Picture lazily -- its image/viewport
nodes are renderFinal/viewportScroll thunks closing over the UIState they
were rendered from, which through the prior render closes over the previous
UIState. The single unforced Picture is thus a thunk chain reaching back
through every frame, pinning each generation's campaigns/WorkerState/GenDict
and (on falsifying contracts) its test VM snapshots.

ghc-debug on a live process showed a single retainer path with 788 chained
renderFinal/viewportScroll thunk pairs off lastPicRef. Measured: +12 kB/s
unbounded on a trivial non-falsifying contract (interactive), and 681 MB
pinned on a 20-failing-assert stress contract.

Fixes:
- UI.hs: deep-force each Picture before handing it to vty, so lastPicRef
  holds concrete images instead of a UIState-closing thunk chain (primary).
- UI.hs: force the VM-stripped test copies; `t { vm = Nothing }` was a thunk
  retaining the VM-bearing original.
- Campaign.hs: bind NewCoverage.transactions strictly; `force (...)` on a
  non-strict field was itself a thunk pinning the sequence's VMResults.
- Exec.hs: forceVMData now also forces vm.tx.subState, whose lazily-consed
  Expr EAddr elements otherwise chain a stored VM to every intermediate VM
  of its transaction.

Validated: trivial-contract interactive growth +12,071 -> +517 B/s (UIState
generation growth +4.1 MB -> +0); stress-contract live heap 681 -> 39 MB
flat; ghc-debug generation chain 788 -> 0.

Author: elopez

lib/Echidna/Campaign.hs

@@ -481,13 +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
-                                  -- force the list so the event doesn't hold a
-                                  -- thunk pinning every VMResult (and its
-                                  -- returndata) of the executed sequence
-                                , transactions = force $ fst <$> results
+                                , transactions
                                 }
 
   modify' $ \workerState ->

lib/Echidna/Exec.hs

@@ -336,12 +336,28 @@ 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 (\u x -> x `seq` u) ()
+      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)

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
@@ -151,7 +152,12 @@ ui vm dict initialCorpus cliSelectedContract = do
             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 snapshotRef
 
@@ -377,7 +383,12 @@ monitor snapshotRef = do
             -- 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 (\u t -> t `seq` u) () strippedTests
             let updatedState = state { campaigns = c', status = Running, now
                                      , tests = strippedTests
                                      , fetchedContracts = contracts