PR 1265 but without the tuple, testing for speed....

lib/Echidna.hs

@@ -9,6 +9,7 @@ import Data.List.NonEmpty (NonEmpty)
 import Data.List.NonEmpty qualified as NE
 import Data.Map.Strict qualified as Map
 import Data.Set qualified as Set
+import Data.TLS.GHC (mkTLS)
 import System.FilePath ((</>))
 
 import EVM (cheatCode)
@@ -119,6 +120,7 @@ mkEnv cfg buildOutput tests world slitherInfo = do
   chainId <- maybe (pure Nothing) EVM.Fetch.fetchChainIdFrom cfg.rpcUrl
   eventQueue <- newChan
   coverageRef <- newIORef mempty
+  statsRef <- mkTLS $ newIORef mempty
   corpusRef <- newIORef mempty
   testRefs <- traverse newIORef tests
   (contractCache, slotCache) <- Onchain.loadRpcCache cfg
@@ -127,6 +129,6 @@ mkEnv cfg buildOutput tests world slitherInfo = do
   -- TODO put in real path
   let dapp = dappInfo "/" buildOutput
   pure $ Env { cfg, dapp, codehashMap, fetchContractCache, fetchSlotCache
-             , chainId, eventQueue, coverageRef, corpusRef, testRefs, world
+             , chainId, eventQueue, coverageRef, statsRef, corpusRef, testRefs, world
              , slitherInfo
              }

lib/Echidna/Exec.hs

@@ -7,7 +7,7 @@ module Echidna.Exec where
 import Optics.Core
 import Optics.State.Operators
 
-import Control.Monad (when, forM_)
+import Control.Monad (when)
 import Control.Monad.Catch (MonadThrow(..))
 import Control.Monad.State.Strict (MonadState(get, put), execState, runStateT, MonadIO(liftIO), gets, modify', execStateT)
 import Control.Monad.Reader (MonadReader, ask, asks)
@@ -18,6 +18,7 @@ import Data.IORef (readIORef, atomicWriteIORef, newIORef, writeIORef, modifyIORe
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe, fromJust)
 import Data.Text qualified as T
+import Data.TLS.GHC (getTLS)
 import Data.Vector qualified as V
 import Data.Vector.Unboxed.Mutable qualified as VMut
 import System.Process (readProcessWithExitCode)
@@ -287,14 +288,20 @@ execTxWithCov tx = do
       addCoverage !vm = do
         let (pc, opIx, depth) = currentCovLoc vm
             contract = currentContract vm
+            contractSize = BS.length . forceBuf . fromJust . view bytecode $ contract
 
         maybeCovVec <- lookupUsingCodehashOrInsert env.codehashMap contract env.dapp env.coverageRef $ do
-          let size = BS.length . forceBuf . fromJust . view bytecode $ contract
-          if size == 0 then pure Nothing else do
+          if contractSize == 0 then pure Nothing else do
             -- IO for making a new vec
-            vec <- VMut.new size
             -- We use -1 for opIx to indicate that the location was not covered
-            forM_ [0..size-1] $ \i -> VMut.write vec i (-1, 0, 0)
+            vec <- VMut.replicate contractSize (-1, 0, 0)
+            pure $ Just vec
+
+        statsRef <- getTLS env.statsRef
+        maybeStatsVec <- lookupUsingCodehashOrInsert env.codehashMap contract env.dapp statsRef $ do
+          if contractSize == 0 then pure Nothing else do
+            -- IO for making a new vec
+            vec <- VMut.replicate contractSize 0
             pure $ Just vec
 
         case maybeCovVec of
@@ -305,7 +312,8 @@ execTxWithCov tx = do
             -- bug in another place, investigate.
             -- ... this should be fixed now, since we use `codeContract` instead
             -- of `contract` for everything; it may be safe to remove this check.
-            when (pc < VMut.length vec) $
+            when (pc < VMut.length vec) $ do
+              VMut.modify (fromJust maybeStatsVec) (+ 1) opIx
               VMut.read vec pc >>= \case
                 (_, depths, results) | depth < 64 && not (depths `testBit` depth) -> do
                   VMut.write vec pc (opIx, depths `setBit` depth, results `setBit` fromEnum Stop)

lib/Echidna/Output/Source.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ParallelListComp #-}
 
 module Echidna.Output.Source where
 
@@ -7,7 +8,7 @@ import Prelude hiding (writeFile)
 import Control.Monad (unless)
 import Data.ByteString qualified as BS
 import Data.Foldable
-import Data.IORef (readIORef)
+import Data.IORef (readIORef, IORef)
 import Data.List (nub, sort)
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Map (Map)
@@ -18,7 +19,9 @@ import Data.Text (Text, pack)
 import Data.Text qualified as T
 import Data.Text.Encoding (decodeUtf8)
 import Data.Text.IO (writeFile)
+import Data.TLS.GHC (allTLS, TLS)
 import Data.Vector qualified as V
+import qualified Data.Vector.Unboxed as U
 import Data.Vector.Unboxed.Mutable qualified as VU
 import HTMLEntities.Text qualified as HTML
 import System.Directory (createDirectoryIfMissing)
@@ -30,9 +33,26 @@ import EVM.Solidity (SourceCache(..), SrcMap, SolcContract(..))
 
 import Echidna.Types.Campaign (CampaignConf(..))
 import Echidna.Types.Config (Env(..), EConfig(..))
-import Echidna.Types.Coverage (OpIx, unpackTxResults, CoverageMap, CoverageFileType (..))
+import Echidna.Types.Coverage (OpIx, unpackTxResults, CoverageMap, CoverageFileType (..), StatsMap, StatsMapV, StatsInfo)
 import Echidna.Types.Tx (TxResult(..))
 import Echidna.SourceAnalysis.Slither (AssertLocation(..), assertLocationList, SlitherInfo(..))
+import EVM.Types (W256)
+
+zipSumStats :: IO [StatsInfo] -> IO [StatsInfo] -> IO [StatsInfo]
+zipSumStats v1 v2 = do
+  vec1 <- v1
+  vec2 <- v2
+  return [exec1 + exec2 | exec1 <- vec1 | exec2 <- vec2]
+
+combineStats :: TLS (IORef StatsMap) -> IO StatsMapV
+combineStats statsRef = do
+  threadStats' <- allTLS statsRef
+  threadStats <-  mapM readIORef threadStats' :: IO [StatsMap]
+  let statsLists = map (Map.map mvToList) threadStats :: [Map EVM.Types.W256 (IO [StatsInfo])]
+  traverse (U.fromList <$>) $ Map.unionsWith zipSumStats statsLists
+  where
+    mvToList :: (VU.Unbox a) => VU.IOVector a -> IO [a]
+    mvToList = fmap U.toList . U.freeze
 
 saveCoverages
   :: Env
@@ -44,7 +64,8 @@ saveCoverages
 saveCoverages env seed d sc cs = do
   let fileTypes = env.cfg.campaignConf.coverageFormats
   coverage <- readIORef env.coverageRef
-  mapM_ (\ty -> saveCoverage ty seed d sc cs coverage) fileTypes
+  stats <- combineStats env.statsRef
+  mapM_ (\ty -> saveCoverage ty seed d sc cs coverage stats) fileTypes
 
 saveCoverage
   :: CoverageFileType
@@ -53,11 +74,12 @@ saveCoverage
   -> SourceCache
   -> [SolcContract]
   -> CoverageMap
+  -> StatsMapV
   -> IO ()
-saveCoverage fileType seed d sc cs covMap = do
+saveCoverage fileType seed d sc cs covMap statMap = do
   let extension = coverageFileExtension fileType
       fn = d </> "covered." <> show seed <> extension
-  cc <- ppCoveredCode fileType sc cs covMap
+  cc <- ppCoveredCode fileType sc cs covMap statMap
   createDirectoryIfMissing True d
   writeFile fn cc
 
@@ -67,11 +89,11 @@ coverageFileExtension Html = ".html"
 coverageFileExtension Txt = ".txt"
 
 -- | Pretty-print the covered code
-ppCoveredCode :: CoverageFileType -> SourceCache -> [SolcContract] -> CoverageMap -> IO Text
-ppCoveredCode fileType sc cs s | null s = pure "Coverage map is empty"
+ppCoveredCode :: CoverageFileType -> SourceCache -> [SolcContract] -> CoverageMap -> StatsMapV -> IO Text
+ppCoveredCode fileType sc cs s sm | null s = pure "Coverage map is empty"
   | otherwise = do
   -- List of covered lines during the fuzzing campaign
-  covLines <- srcMapCov sc s cs
+  covLines <- srcMapCov sc s sm cs
   let
     -- Collect all the possible lines from all the files
     allFiles = (\(path, src) -> (path, V.fromList (decodeUtf8 <$> BS.split 0xa src))) <$> Map.elems sc.files
@@ -99,13 +121,13 @@ ppCoveredCode fileType sc cs s | null s = pure "Coverage map is empty"
     -- ^ Alter file name, in the case of html turning it into bold text
     changeFileLines ls = case fileType of
       Lcov -> ls ++ ["end_of_record"]
-      Html -> "<code>" : ls ++ ["", "</code>","<br />"]
+      Html -> "<br /><b>Legend:</b> Line # | Execs # | Reverts # | Code<br /><code>" : ls ++ ["", "</code>","<br />"]
       Txt  -> ls
     -- ^ Alter file contents, in the case of html encasing it in <code> and adding a line break
   pure $ topHeader <> T.unlines (map ppFile allFiles)
 
 -- | Mark one particular line, from a list of lines, keeping the order of them
-markLines :: CoverageFileType -> V.Vector Text -> S.Set Int -> Map Int [TxResult] -> V.Vector Text
+markLines :: CoverageFileType -> V.Vector Text -> S.Set Int -> Map Int ([TxResult], StatsInfo) -> V.Vector Text
 markLines fileType codeLines runtimeLines resultMap =
   V.map markLine . V.filter shouldUseLine $ V.indexed codeLines
   where
@@ -114,7 +136,8 @@ markLines fileType codeLines runtimeLines resultMap =
     _ -> True
   markLine (i, codeLine) =
     let n = i + 1
-        results  = fromMaybe [] (Map.lookup n resultMap)
+        (results, execs) = fromMaybe ([], 0) (Map.lookup n resultMap)
+        reverts = 0 :: Int
         markers = sort $ nub $ getMarker <$> results
         wrapLine :: Text -> Text
         wrapLine line = case fileType of
@@ -125,11 +148,16 @@ markLines fileType codeLines runtimeLines resultMap =
           where
           cssClass = if n `elem` runtimeLines then getCSSClass markers else "neutral"
         result = case fileType of
-          Lcov -> pack $ printf "DA:%d,%d" n (length results)
-          _ -> pack $ printf " %*d | %-4s| %s" lineNrSpan n markers (wrapLine codeLine)
+          Lcov -> pack $ printf "DA:%d,%d" n execs
+          Html -> pack $ printf "%*d | %4s | %4s | %-4s| %s" lineNrSpan n (prettyCount execs) (prettyCount reverts) markers (wrapLine codeLine)
+          _    -> pack $ printf "%*d | %-4s| %s" lineNrSpan n markers (wrapLine codeLine)
 
     in result
   lineNrSpan = length . show $ V.length codeLines + 1
+  prettyCount x = prettyCount' x 0
+  prettyCount' x n | x >= 1000          = prettyCount' (x `div` 1000) (n + 1)
+                   | x < 1000 && n == 0 = show x
+                   | otherwise          = show x <> [" kMGTPEZY" !! n]
 
 getCSSClass :: String -> Text
 getCSSClass markers =
@@ -148,11 +176,11 @@ getMarker ErrorOutOfGas = 'o'
 getMarker _             = 'e'
 
 -- | Given a source cache, a coverage map, a contract returns a list of covered lines
-srcMapCov :: SourceCache -> CoverageMap -> [SolcContract] -> IO (Map FilePath (Map Int [TxResult]))
-srcMapCov sc covMap contracts = do
+srcMapCov :: SourceCache -> CoverageMap -> StatsMapV -> [SolcContract] -> IO (Map FilePath (Map Int ([TxResult], StatsInfo)))
+srcMapCov sc covMap statMap contracts = do
   Map.unionsWith Map.union <$> mapM linesCovered contracts
   where
-  linesCovered :: SolcContract -> IO (Map FilePath (Map Int [TxResult]))
+  linesCovered :: SolcContract -> IO (Map FilePath (Map Int ([TxResult], StatsInfo)))
   linesCovered c =
     case Map.lookup c.runtimeCodehash covMap of
       Just vec -> VU.foldl' (\acc covInfo -> case covInfo of
@@ -169,8 +197,13 @@ srcMapCov sc covMap contracts = do
                   where
                   innerUpdate =
                     Map.alter
-                      (Just . (<> unpackTxResults txResults) . fromMaybe mempty)
+                      updateLine
                       line
+                  updateLine (Just (r, s)) = Just ((<> unpackTxResults txResults) r, maxStats s idxStats)
+                  updateLine Nothing = Just (unpackTxResults txResults, idxStats)
+                  fileStats = Map.lookup c.runtimeCodehash statMap
+                  idxStats = maybe 0 (U.! opIx) fileStats
+                  maxStats = max
                 Nothing -> acc
             Nothing -> acc
         ) mempty vec
@@ -195,22 +228,23 @@ buildRuntimeLinesMap sc contracts =
 checkAssertionsCoverage
   :: SourceCache
   -> Env
+  -> StatsMapV
   -> IO ()
-checkAssertionsCoverage sc env = do
+checkAssertionsCoverage sc env sm = do
   let
     cs = Map.elems env.dapp.solcByName
     asserts = maybe [] (concatMap assertLocationList . Map.elems . (.asserts)) env.slitherInfo
   covMap <- readIORef env.coverageRef
-  covLines <- srcMapCov sc covMap cs
+  covLines <- srcMapCov sc covMap sm cs
   mapM_ (checkAssertionReached covLines) asserts
 
 -- | Helper function for `checkAssertionsCoverage` which checks a single assertion
 -- and logs a warning if it wasn't hit
-checkAssertionReached :: Map String (Map Int [TxResult]) -> AssertLocation -> IO ()
+checkAssertionReached :: Map String (Map Int ([TxResult], StatsInfo)) -> AssertLocation -> IO ()
 checkAssertionReached covLines assert =
   maybe
     warnAssertNotReached checkCoverage
-    (Map.lookup assert.filenameAbsolute covLines)
+    (Map.lookup assert.filenameAbsolute $ fmap (fmap fst) covLines)
   where
    checkCoverage coverage = let lineNumbers = Map.keys coverage in
      unless ((head assert.assertLines) `elem` lineNumbers) warnAssertNotReached

lib/Echidna/Types/Config.hs

@@ -8,6 +8,7 @@ import Data.Set (Set)
 import Data.Text (Text)
 import Data.Time (LocalTime)
 import Data.Word (Word64)
+import Data.TLS.GHC
 
 import EVM.Dapp (DappInfo)
 import EVM.Types (Addr, Contract, W256)
@@ -16,7 +17,7 @@ import Echidna.SourceAnalysis.Slither (SlitherInfo)
 import Echidna.SourceMapping (CodehashMap)
 import Echidna.Types.Campaign (CampaignConf, CampaignEvent)
 import Echidna.Types.Corpus (Corpus)
-import Echidna.Types.Coverage (CoverageMap)
+import Echidna.Types.Coverage (CoverageMap, StatsMap)
 import Echidna.Types.Solidity (SolConf)
 import Echidna.Types.Test (TestConf, EchidnaTest)
 import Echidna.Types.Tx (TxConf)
@@ -72,6 +73,7 @@ data Env = Env
 
   , testRefs :: [IORef EchidnaTest]
   , coverageRef :: IORef CoverageMap
+  , statsRef :: TLS (IORef StatsMap)
   , corpusRef :: IORef Corpus
 
   , slitherInfo :: Maybe SlitherInfo

lib/Echidna/Types/Coverage.hs

@@ -6,6 +6,7 @@ import Data.List (foldl')
 import Data.Map qualified as Map
 import Data.Map.Strict (Map)
 import Data.Text (toLower)
+import Data.Vector.Unboxed (Vector)
 import Data.Vector.Unboxed.Mutable (IOVector)
 import Data.Vector.Unboxed.Mutable qualified as V
 import Data.Word (Word64)
@@ -17,9 +18,23 @@ import Echidna.Types.Tx (TxResult)
 -- Indexed by contracts' compile-time codehash; see `CodehashMap`.
 type CoverageMap = Map W256 (IOVector CoverageInfo)
 
+-- | Map with the statistic information needed for source code printing.
+-- Indexed by contracts' compile-time codehash; see `CodehashMap`.
+-- Used during runtime data collection
+type StatsMap = Map W256 (IOVector StatsInfo)
+
+-- | Map with the statistic information needed for source code printing.
+-- Indexed by contracts' compile-time codehash; see `CodehashMap`.
+-- Used during statistics summarization (combining multiple `StatsMap`)
+-- and coverage report generation.
+type StatsMapV = Map W256 (Vector StatsInfo)
+
 -- | Basic coverage information
 type CoverageInfo = (OpIx, StackDepths, TxResults)
 
+-- | Basic stats information
+type StatsInfo = ExecQty
+
 -- | Index per operation in the source code, obtained from the source mapping
 type OpIx = Int
 
@@ -29,6 +44,12 @@ type StackDepths = Word64
 -- | Packed TxResults used for coverage, corresponding bits are set
 type TxResults = Word64
 
+-- | Hit count
+type ExecQty = Word64
+
+-- | Revert count
+type RevertQty = Word64
+
 -- | Given good point coverage, count the number of unique points but
 -- only considering the different instruction PCs (discarding the TxResult).
 -- This is useful for reporting a coverage measure to the user

package.yaml

@@ -67,6 +67,7 @@ library:
     - signal
     - split
     - strip-ansi-escape
+    - thread-local-storage
     - time
     - unliftio
     - utf8-string

src/Main.hs

@@ -70,7 +70,7 @@ main = withUtf8 $ withCP65001 $ do
 
   tests <- traverse readIORef env.testRefs
 
-  checkAssertionsCoverage buildOutput.sources env
+  checkAssertionsCoverage buildOutput.sources env mempty
 
   Onchain.saveRpcCache env