Multicore WIP

lib/Echidna/Campaign.hs

@@ -2,7 +2,7 @@
 
 module Echidna.Campaign where
 
-import Optics.Core
+import Optics.Core hiding ((|>))
 
 import Control.DeepSeq (force)
 import Control.Monad (foldM, replicateM, when, unless, void)
@@ -19,6 +19,7 @@ import Data.IORef (readIORef, writeIORef)
 import Data.Map qualified as Map
 import Data.Map (Map, (\\))
 import Data.Maybe (fromMaybe, isJust, mapMaybe)
+import Data.Sequence ((|>))
 import Data.Set (Set)
 import Data.Set qualified as Set
 import Data.Text (Text)
@@ -38,13 +39,15 @@ import Echidna.Test
 import Echidna.Transaction
 import Echidna.Types (Gas)
 import Echidna.Types.Buffer (forceBuf)
-import Echidna.Types.Corpus (Corpus)
 import Echidna.Types.Campaign
+import Echidna.Types.Corpus (Corpus)
+import Echidna.Types.Coverage (scoveragePoints)
 import Echidna.Types.Config
 import Echidna.Types.Signature (makeBytecodeCache, FunctionName)
 import Echidna.Types.Test
 import Echidna.Types.Tx (TxCall(..), Tx(..), call)
 import Echidna.Types.World (World)
+import Echidna.Utility (getTimestamp)
 
 instance MonadThrow m => MonadThrow (RandT g m) where
   throwM = lift . throwM
@@ -73,7 +76,7 @@ isDone c = do
 
 -- | Given a 'Campaign', check if the test results should be reported as a
 -- success or a failure.
-isSuccessful :: Campaign -> Bool
+isSuccessful :: GenericCampaign a -> Bool
 isSuccessful Campaign{tests} =
   all (\case { Passed -> True; Open _ -> True; _ -> False; }) ((.state) <$> tests)
 
@@ -118,6 +121,7 @@ runCampaign callback vm world tests dict initialCorpus = do
                         , newCoverage = False
                         , corpus = Set.empty
                         , ncallseqs = 0
+                        , events = mempty
                         }
 
   flip execStateT campaign $ do
@@ -250,6 +254,10 @@ callseq vm txSeq = do
     , ncallseqs = camp'.ncallseqs + 1
     }
 
+  when camp'.newCoverage $ do
+    points <- liftIO (scoveragePoints camp'.coverage)
+    pushEvent (NewCoverage points)
+
   pure vm'
   where
   -- Given a list of transactions and a return typing rule, checks whether we
@@ -352,25 +360,33 @@ runUpdate f = do
 -- (3): The test is unshrunk, and we can shrink it
 -- Then update accordingly, keeping track of how many times we've tried to solve or shrink.
 updateTest
-  :: (MonadIO m, MonadCatch m, MonadRandom m, MonadReader Env m)
+  :: (MonadIO m, MonadCatch m, MonadRandom m, MonadReader Env m, MonadState Campaign m)
   => VM
   -> (VM, [Tx])
   -> EchidnaTest
   -> m EchidnaTest
 updateTest vmForShrink (vm, xs) test = do
-  limit <- asks (.cfg.campaignConf.testLimit)
   dappInfo <- asks (.dapp)
   case test.state of
-    Open i | i > limit -> case test.testType of
-      OptimizationTest _ _ -> pure $ test { state = Large (-1) }
-      _                    -> pure $ test { state = Passed }
     Open i -> do
       (testValue, vm') <- evalStateT (checkETest test) vm
-      let events = extractEvents False dappInfo vm'
-      let results = getResultFromVM vm'
-      pure $ updateOpenTest test xs i (testValue, events, results)
-    _ ->
+      let
+        events = extractEvents False dappInfo vm'
+        results = getResultFromVM vm'
+      let test' = updateOpenTest test xs i (testValue, events, results)
+      case test'.state of
+        Large _ -> do
+          pushEvent (TestFalsified test.testType) >> pure test'
+        _ -> pure test'
+    Large _ ->
       -- TODO: We shrink already in `step`, but we shrink here too. It makes
       -- shrink go faster when some tests are still fuzzed. It's not incorrect
       -- but requires passing `vmForShrink` and feels a bit wrong.
       shrinkTest vmForShrink test
+    _ -> pure test
+
+pushEvent :: (MonadIO m, MonadState Campaign m) => CampaignEvent -> m ()
+pushEvent event = do
+  time <- liftIO getTimestamp
+  modify' $ \campaign ->
+    campaign { Echidna.Types.Campaign.events = campaign.events |> (time, event) }

lib/Echidna/Config.hs

@@ -96,6 +96,7 @@ instance FromJSON EConfigWithUsage where
         <*> v ..:? "corpusDir" ..!= Nothing
         <*> v ..:? "mutConsts" ..!= defaultMutationConsts
         <*> v ..:? "coverageFormats" ..!= [Txt,Html,Lcov]
+        <*> v ..:? "jobs"
 
       solConfParser = SolConf
         <$> v ..:? "contractAddr"    ..!= defaultContractAddr

lib/Echidna/Exec.hs

@@ -38,7 +38,7 @@ import Echidna.Types.Signature (MetadataCache, getBytecodeMetadata, lookupByteco
 import Echidna.Types.Tx (TxCall(..), Tx, TxResult(..), call, dst, initialTimestamp, initialBlockNumber, getResult)
 import Echidna.Types.Config (Env(..), EConfig(..), UIConf(..), OperationMode(..), OutputFormat(Text))
 import Echidna.Types.Solidity (SolConf(..))
-import Echidna.Utility (timePrefix)
+import Echidna.Utility (getTimestamp, timePrefix)
 
 -- | Broad categories of execution failures: reversions, illegal operations, and ???.
 data ErrorClass = RevertE | IllegalE | UnknownE
@@ -219,7 +219,7 @@ logMsg msg = do
   cfg <- asks (.cfg)
   operationMode <- asks (.cfg.uiConf.operationMode)
   when (operationMode == NonInteractive Text && not cfg.solConf.quiet) $ liftIO $ do
-    time <- timePrefix
+    time <- timePrefix <$> getTimestamp
     putStrLn $ time <> msg
 
 -- | Execute a transaction "as normal".

lib/Echidna/Output/JSON.hs

@@ -93,9 +93,9 @@ instance ToJSON Transaction where
     , "gasprice" .= gasprice
     ]
 
-encodeCampaign :: C.Campaign -> IO ByteString
+encodeCampaign :: C.FrozenCampaign -> IO ByteString
 encodeCampaign C.Campaign{..} = do
-  frozenCov <- mapM VU.freeze coverage
+  let frozenCov = coverage
   pure $ encode Campaign
     { _success = True
     , _error = Nothing

lib/Echidna/Output/Source.hs

@@ -24,7 +24,7 @@ import Text.Printf (printf)
 import EVM.Debug (srcMapCodePos)
 import EVM.Solidity (SourceCache(..), SrcMap, SolcContract(..))
 
-import Echidna.Types.Coverage (CoverageMap, FrozenCoverageMap, OpIx, unpackTxResults)
+import Echidna.Types.Coverage (FrozenCoverageMap, OpIx, unpackTxResults)
 import Echidna.Types.Tx (TxResult(..))
 import Echidna.Types.Signature (getBytecodeMetadata)
 
@@ -36,7 +36,7 @@ saveCoverages
   -> FilePath
   -> SourceCache
   -> [SolcContract]
-  -> CoverageMap
+  -> FrozenCoverageMap
   -> IO ()
 saveCoverages fileTypes seed d sc cs s =
   mapM_ (\ty -> saveCoverage ty seed d sc cs s) fileTypes
@@ -47,13 +47,12 @@ saveCoverage
   -> FilePath
   -> SourceCache
   -> [SolcContract]
-  -> CoverageMap
+  -> FrozenCoverageMap
   -> IO ()
 saveCoverage fileType seed d sc cs covMap = do
-  frozenCovMap <- mapM VU.freeze covMap
   let extension = coverageFileExtension fileType
       fn = d </> "covered." <> show seed <> extension
-      cc = ppCoveredCode fileType sc cs frozenCovMap
+      cc = ppCoveredCode fileType sc cs covMap
   createDirectoryIfMissing True d
   writeFile fn cc
 

lib/Echidna/Test.hs

@@ -190,8 +190,11 @@ getIntFromResult (Just (VMSuccess b)) =
 getIntFromResult _ = IntValue minBound
 
 -- | Given a property test, evaluate it and see if it currently passes.
-checkOptimization :: (MonadIO m, MonadReader Env m, MonadState VM m, MonadThrow m)
-                  => Text -> Addr -> m (TestValue, VM)
+checkOptimization
+  :: (MonadIO m, MonadReader Env m, MonadState VM m, MonadThrow m)
+  => Text
+  -> Addr
+  -> m (TestValue, VM)
 checkOptimization f a = do
   TestConf _ s <- asks (.cfg.testConf)
   (vm, vm') <- runTx f s a

lib/Echidna/Types/Campaign.hs

@@ -1,15 +1,21 @@
 module Echidna.Types.Campaign where
 
+import Data.List (transpose)
 import Data.Map (Map)
+import Data.Sequence (Seq)
 import Data.Text (Text)
+import Data.Time (LocalTime)
+import Data.Word (Word8)
 
 import Echidna.ABI (GenDict, emptyDict)
 import Echidna.Output.Source (CoverageFileType)
 import Echidna.Types
 import Echidna.Types.Corpus
 import Echidna.Types.Coverage (CoverageMap, FrozenCoverageMap)
-import Echidna.Types.Test (EchidnaTest)
+import Echidna.Types.Test (EchidnaTest(..), TestType, TestState (..))
 import Echidna.Types.Tx (Tx)
+import qualified Data.Vector.Unboxed as VU
+import qualified Data.Map as Map
 
 -- | Configuration for running an Echidna 'Campaign'.
 data CampaignConf = CampaignConf
@@ -37,11 +43,19 @@ data CampaignConf = CampaignConf
     -- ^ Directory to load and save lists of transactions
   , coverageFormats :: [CoverageFileType]
     -- ^ List of file formats to save coverage reports
+  , jobs :: Maybe Word8
   }
 
+data CampaignEvent where
+  TestFalsified :: TestType -> CampaignEvent -- TestType uniquely identifies the test
+  NewCoverage :: Int -> CampaignEvent
+  TestLimit :: CampaignEvent
+  deriving Show
+
 type FrozenCampaign = GenericCampaign FrozenCoverageMap
 
 type Campaign = GenericCampaign CoverageMap
+
 -- | The state of a fuzzing campaign.
 data GenericCampaign a = Campaign
   { tests       :: ![EchidnaTest]
@@ -58,10 +72,12 @@ data GenericCampaign a = Campaign
     -- ^ List of transactions with maximum coverage
   , ncallseqs   :: !Int
     -- ^ Number of times the callseq is called
+  , events      :: !(Seq (LocalTime, CampaignEvent))
   }
+  deriving Functor
 
 defaultCampaign :: Monoid a => GenericCampaign a
-defaultCampaign = Campaign mempty mempty mempty emptyDict False mempty 0
+defaultCampaign = Campaign mempty mempty mempty emptyDict False mempty 0 mempty
 
 defaultTestLimit :: Int
 defaultTestLimit = 50000
@@ -71,3 +87,38 @@ defaultSequenceLength = 100
 
 defaultShrinkLimit :: Int
 defaultShrinkLimit = 5000
+
+-- Summarize all campaigns from workers as a single campaign
+-- TODO: this should return a richer data structure, good enough for now
+mergeCampaigns :: [FrozenCampaign] -> FrozenCampaign
+mergeCampaigns [] = error "won't happen, fix me with NonEmpty"
+mergeCampaigns [c] = c -- don't even try
+mergeCampaigns campaigns =
+  (defaultCampaign :: FrozenCampaign)
+    { tests = mergeTests <$> transpose ((.tests) <$> campaigns)
+    , coverage = Map.empty -- Map.unionsWith Set.union ((.coverage) <$> campaigns)
+    , gasInfo = mempty -- TODO
+    , genDict = emptyDict -- TODO
+    , corpus = mempty -- TODO
+    , ncallseqs = sum ((.ncallseqs) <$> campaigns)
+    }
+  where
+  mergeTests :: [EchidnaTest] -> EchidnaTest
+  mergeTests [] = error "won't happen, fix me with NonEmpty"
+  mergeTests (f:ts) =
+    foldl (\t acc ->
+      case (t.state, acc.state) of
+        -- update if better what we have so far
+        (Solved, _) -> t
+        (Large i, Large j) -> t { state = Large (i+j) }
+        (Large _, Open _) -> t
+        (Large _, Passed) -> t -- shoudn't happen but just in case
+        (Open i, Open j) -> t { state = Open (i+j) }
+        -- skip otherwise
+        _ -> acc
+      ) f ts
+
+freezeCampaign :: Campaign -> IO FrozenCampaign
+freezeCampaign camp = do
+  frozenCov <- mapM VU.freeze camp.coverage
+  pure camp { coverage = frozenCov }

lib/Echidna/Types/Test.hs

@@ -63,6 +63,14 @@ instance Eq TestType where
   Exploration          == Exploration            = True
   _                    == _                      = False
 
+instance Show TestType where
+  show = \case
+    PropertyTest t _     -> show t
+    AssertionTest _ s _  -> show s
+    OptimizationTest s _ -> show s
+    CallTest t _         -> show t
+    Exploration          -> "Exploration"
+
 instance Eq TestState where
   Open i  == Open j  = i == j
   Large i == Large j = i == j