diff --git a/lib/Echidna/Campaign.hs b/lib/Echidna/Campaign.hs index b0a9401be..f0a30fb90 100644 --- a/lib/Echidna/Campaign.hs +++ b/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 diff --git a/lib/Echidna/Exec.hs b/lib/Echidna/Exec.hs index 7d02e052b..6326f7ab9 100644 --- a/lib/Echidna/Exec.hs +++ b/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 diff --git a/lib/Echidna/Shrink.hs b/lib/Echidna/Shrink.hs index e345a8702..f569ca163 100644 --- a/lib/Echidna/Shrink.hs +++ b/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 diff --git a/lib/Echidna/UI.hs b/lib/Echidna/UI.hs index 16987c60e..9489b103e 100644 --- a/lib/Echidna/UI.hs +++ b/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,17 +131,20 @@ 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 @@ -130,9 +152,14 @@ 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 + 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 }) -> diff --git a/lib/Echidna/UI/Widgets.hs b/lib/Echidna/UI/Widgets.hs index ad9cc5214..bf66c4aa4 100644 --- a/lib/Echidna/UI/Widgets.hs +++ b/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 $