hevm 0.55.1 → 0.56.0

raw patch · 32 files changed

+3350/−2761 lines, 32 filesdep +aeson-prettydep +jsonldep −unordered-containersdep ~QuickCheckdep ~aesondep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson-pretty, jsonl

Dependencies removed: unordered-containers

Dependency ranges changed: QuickCheck, aeson, containers, directory, filepath, here, mtl, operational, optics-core, optics-extra, unliftio-core, vector, witch

API changes (from Hackage documentation)

Files

• CHANGELOG.md +61/−0
• bench/bench.hs +3/−2
• cli/cli.hs +99/−49
• hevm.cabal +18/−15
• src/EVM.hs +299/−254
• src/EVM/ABI.hs +24/−12
• src/EVM/CheatsTH.hs +2/−2
• src/EVM/Effects.hs +4/−7
• src/EVM/Exec.hs +3/−2
• src/EVM/Expr.hs +34/−50
• src/EVM/Fetch.hs +289/−68
• src/EVM/Format.hs +70/−19
• src/EVM/Fuzz.hs +0/−262
• src/EVM/Keccak.hs +29/−35
• src/EVM/SMT.hs +128/−373
• src/EVM/SMT/SMTLIB.hs +217/−0
• src/EVM/SMT/Types.hs +67/−0
• src/EVM/Solidity.hs +173/−118
• src/EVM/Solvers.hs +90/−126
• src/EVM/Stepper.hs +2/−1
• src/EVM/SymExec.hs +132/−74
• src/EVM/Tracing.hs +161/−0
• src/EVM/Traversals.hs +7/−7
• src/EVM/Types.hs +86/−43
• src/EVM/UnitTest.hs +151/−65
• test/EVM/Test/BlockchainTests.hs +4/−3
• test/EVM/Test/FuzzSymExec.hs +829/−0
• test/EVM/Test/Tracing.hs +0/−948
• test/EVM/Test/Utils.hs +20/−17
• test/clitest.hs +114/−33
• test/rpc.hs +56/−44
• test/test.hs +178/−132

@@ -5,6 +5,67 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). +## [0.56.0] - 2025-10-13++## Added+- Output geth compatible jsonl traces in `hevm exec` via `--json-trace`+- Allow dumping unsolved SMT files via `--dump-unsolved`+- Allow resolving unknown addresses to only those that are already deployed+  via option `--only-deployed`+- New empty solver option that simply makes sure that all SMT queries return+  unknown+- Allow `verifyInputs` to return partial expressions+- Counterexamples are now validated when running in `hevm test` mode+- RPC mocking framework that allows users to mock responses from an RPC+  node via `--mock-file FILE.json`. This will improve reliability of+  tests that depend on RPC responses+- We now map back (add,pc) warnings to lines of source code+- Calldata decoding is now more robust: we try to decode+  as much as possible even in case of trailing bytes++## Fixed+- We now extract more Keccak computations than before from the Props to assert+  more Keccak equalities.+- Fixed false positive caused by loss of information about concrete+  Keccak computations.+- Faster word256Bytes and word160Bytes functions to help concrete execution+  performance+- We avoid crashing if a cheatcode or a precompiled is invalid or not implemented in concrete mode+- RPC fetching was sometimes incorrect in case of writing to storage+  before fetching it via RPC+- We no longer increment branch depth twice when branching both ways+- We now take into account loop heuristic setting for `test`+- We no longer fetch `Latest` more than once, thereby potentially having+  more than one interpretation of `Latest`. Instead, we fetch it once, and+  fix any further `Latest` block to the previously fetched fixed block number+- RPC fetching is now done through a single HTTPS session.+- RPC cache is now more effective, as it's persisted through different+  threads of the symbolic execution+- During running in --only-deployed mode, we forgot to force the address+  in the constraints to be the one we computed it to be. Fixed.+- We now properly collect all storage reads from the program and build+  a proper counterexample. Previously, some information might have been missing.+- Fixed int calldata decoding of solc's v1 ABI encoding++## Changed+- Updated forge to 1.2.3 and forge-std to 60acb7aa (1.9.7+)+- We now gather Keccak axioms during `setUp()` and inject them into the SMT solver.+  This helps us finding more correct Keccak preimages+- The "origin" address is now symbolic by default when running in `symbolic` mode+- The printed expressions when running in `symbolic` mode are now simplified+- The printed reachable expression is now simplified+- hevm and solidity has been moved to under github.com/argotorg+- Extra range constraints for ABI symbolic types are no longer added. They are+  not needed as they are enforced in the bytecode.+- We no longer try to fuzz the Expr to find a concrete value that satisfies+  the expression. This was not very effective and made the system more complex+  to maintain. Echidna is an excellent fuzzer that can be used instead.+- Shrinking of the calldata is now more aggressive, shrinking even small (<1024B)+  buffers+- Rename confusing function name runSolidityTest to runForgeTest++## [0.55.1] - 2025-07-22+ ## Added - When a staticcall is made to a contract that does not exist, we overapproximate   and return symbolic values

@@ -105,8 +105,9 @@ mkbench c name iters counts = localOption WallTime $ env c (bgroup name . bmarks)   where     bmarks c' = concat $ [-       [ bench ("cvc5-" <> show i) $ nfIO $ runApp $ findPanics CVC5 i iters c'-       , bench ("z3-" <> show i) $ nfIO $ runApp $ findPanics Z3 i iters c'+       [ bench ("bitwuzla-" <> show i) $ nfIO $ runApp $ findPanics Bitwuzla i iters c'+      --  , bench ("z3-" <> show i) $ nfIO $ runApp $ findPanics Z3 i iters c'+      --  , bench ("cvc5-" <> show i) $ nfIO $ runApp $ findPanics CVC5 i iters c'        ]        | i <- counts      ]

@@ -8,11 +8,13 @@ module Main where  import Control.Monad (when, forM_, unless)+import Control.Monad.State.Strict (runStateT) import Control.Monad.ST (RealWorld, stToIO) import Control.Monad.IO.Unlift import Control.Exception (try, IOException) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BS+import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Char8 as BC import Data.DoubleWord (Word256) import Data.List (intersperse, intercalate)@@ -33,6 +35,7 @@ import System.Exit (exitFailure, exitWith, ExitCode(..)) import Data.List.Split (splitOn) import Text.Read (readMaybe)+import JSONL (jsonlBuilder, jsonLine)  import EVM (initialContract, abstractContract, makeVm) import EVM.ABI (Sig(..))@@ -53,6 +56,7 @@ import EVM.UnitTest import EVM.Effects import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp)+import EVM.Tracing (interpretWithTrace, VMTraceStepResult(..))  data AssertionType = DSTest | Forge   deriving (Eq, Show, Read)@@ -86,14 +90,15 @@   , solverThreads ::Natural   , smttimeout    ::Natural   , smtdebug      ::Bool+  , dumpUnsolved  ::Maybe String   , numSolvers    ::Maybe Natural-  , numCexFuzz    ::Integer   , maxIterations ::Integer   , promiseNoReent::Bool   , maxBufSize    ::Int   , maxWidth      ::Int   , maxDepth      ::Maybe Int   , noSimplify    ::Bool+  , onlyDeployed  ::Bool   }  commonOptions :: Parser CommonOptions@@ -113,14 +118,15 @@   <*> (option auto $ long "solver-threads"  <> showDefault <> value 1 <> help "Number of threads for each solver instance. Only respected for Z3")   <*> (option auto $ long "smttimeout"      <> value 300 <> help "Timeout given to SMT solver in seconds")   <*> (switch $ long "smtdebug"             <> help "Print smt queries sent to the solver")+  <*> (optional $ strOption $ long "dump-unsolved" <> help "Dump unsolved SMT queries to this (relative) path")   <*> (optional $ option auto $ long "num-solvers" <> help "Number of solver instances to use (default: number of cpu cores)")-  <*> (option auto $ long "num-cex-fuzz"    <> showDefault <> value 3 <> help "Number of fuzzing tries to do to generate a counterexample")   <*> (option auto $ long "max-iterations"  <> showDefault <> value 5 <> help "Number of times we may revisit a particular branching point. For no bound, set -1")   <*> (switch $ long "promise-no-reent"     <> help "Promise no reentrancy is possible into the contract(s) being examined")   <*> (option auto $ long "max-buf-size"    <> value 64 <> help "Maximum size of buffers such as calldata and returndata in exponents of 2 (default: 64, i.e. 2^64 bytes)")   <*> (option auto $ long "max-width"      <> showDefault <> value 100 <> help "Max number of concrete values to explore when encountering a symbolic value. This is a form of branch width limitation per symbolic value")   <*> (optional $ option auto $ long "max-depth" <> help "Limit maximum depth of branching during exploration (default: unlimited)")   <*> (switch $ long "no-simplify" <> help "Don't perform simplification of expressions")+  <*> (switch $ long "only-deployed" <> help "When trying to resolve unknown addresses, only use addresses of deployed contracts")  data CommonExecOptions = CommonExecOptions   { address       ::Maybe Addr@@ -182,6 +188,7 @@   , match         ::Maybe String   , prefix        ::String   , ffi           ::Bool+  , mockFile      ::Maybe String   }  testOptions :: Parser TestOptions@@ -193,6 +200,7 @@   <*> (optional $ strOption $ long "match" <> help "Test case filter - only run methods matching regex")   <*> (strOption $ long "prefix"  <> showDefault <> value "prove" <> help "Prefix for test cases to prove")   <*> (switch $ long "ffi" <> help "Allow the usage of the hevm.ffi() cheatcode (WARNING: this allows test authors to execute arbitrary code on your machine)")+  <*> (optional $ strOption $ long "mock-file" <> help "Read mocked RPC response data from JSON file")   data EqOptions = EqOptions@@ -240,13 +248,15 @@   <*> createParser  data ExecOptions = ExecOptions-  { projectType   ::ProjectType+  { projectType :: ProjectType   , create :: Bool+  , jsonTrace :: Bool   } execOptions :: Parser ExecOptions execOptions = ExecOptions   <$> projectTypeParser   <*> createParser+  <*> (switch $ long "json-trace" <> help "Output a geth compatible json trace")  -- Combined options data type data Command@@ -328,8 +338,8 @@             exitFailure           Right out -> do             -- TODO: which functions here actually require a BuildOutput, and which can take it as a Maybe?-            unitTestOpts <- liftIO $ unitTestOptions testOpts cOpts solvers (Just out)-            res <- unitTest unitTestOpts out.contracts+            unitTestOpts <- unitTestOptions testOpts cOpts solvers (Just out)+            res <- unitTest unitTestOpts out             liftIO $ unless (uncurry (&&) res) exitFailure     Exec cFileOpts execOpts cExecOpts cOpts-> do       env <- makeEnv cOpts@@ -346,10 +356,10 @@         exitFailure       pure Env { config = defaultConfig         { dumpQueries = cOpts.smtdebug+        , dumpUnsolved = cOpts.dumpUnsolved         , debug = cOpts.debug         , dumpEndStates = cOpts.debug         , dumpExprs = cOpts.debug-        , numCexFuzz = cOpts.numCexFuzz         , dumpTrace = cOpts.trace         , decomposeStorage = Prelude.not cOpts.noDecompose         , promiseNoReent = cOpts.promiseNoReent@@ -358,11 +368,12 @@         , maxDepth = cOpts.maxDepth         , verb = cOpts.verb         , simp = Prelude.not cOpts.noSimplify+        , onlyDeployed = cOpts.onlyDeployed         } }  -getCode :: Maybe String -> Maybe ByteString -> IO (Maybe ByteString)-getCode fname code = do+getCode :: App m => Maybe String -> Maybe ByteString -> m (Maybe ByteString)+getCode fname code = liftIO $ do   when (isJust fname && isJust code) $ do     putStrLn "Error: Cannot provide both a file and code"     exitFailure@@ -381,8 +392,8 @@  equivalence :: App m => EqOptions -> CommonOptions -> m () equivalence eqOpts cOpts = do-  bytecodeA' <- liftIO $ getCode eqOpts.codeAFile eqOpts.codeA-  bytecodeB' <- liftIO $ getCode eqOpts.codeBFile eqOpts.codeB+  bytecodeA' <- getCode eqOpts.codeAFile eqOpts.codeA+  bytecodeB' <- getCode eqOpts.codeBFile eqOpts.codeB   let bytecodeA = decipher bytecodeA'   let bytecodeB = decipher bytecodeB'   when (isNothing bytecodeA) $ liftIO $ do@@ -396,7 +407,7 @@                             , askSmtIters = cOpts.askSmtIterations                             , loopHeuristic = cOpts.loopDetectionHeuristic                             }-                          , rpcInfo = Nothing+                          , rpcInfo = mempty                           }   calldata <- buildCalldata cOpts eqOpts.sig eqOpts.arg   solver <- liftIO $ getSolver cOpts.solver@@ -409,7 +420,7 @@       (False, False) -> putStrLn "   \x1b[32m[PASS]\x1b[0m Contracts behave equivalently"       (True, _)      -> putStrLn "   \x1b[31m[FAIL]\x1b[0m Contracts do not behave equivalently"       (_, True)      -> putStrLn "   \x1b[31m[FAIL]\x1b[0m Contracts may not behave equivalently"-    liftIO $ printWarnings eq.partials (map fst eq.res) "the contracts under test"+    liftIO $ printWarnings Nothing eq.partials (map fst eq.res) "the contracts under test"     case any (isCex . fst) eq.res of       False -> liftIO $ do         when anyIssues exitFailure@@ -433,6 +444,7 @@   "z3" -> pure Z3   "cvc5" -> pure CVC5   "bitwuzla" -> pure Bitwuzla+  "empty" -> pure EmptySolver   input -> do     putStrLn $ "unrecognised solver: " <> input     exitFailure@@ -483,9 +495,10 @@ symbCheck :: App m => CommonFileOptions -> SymbolicOptions -> CommonExecOptions -> CommonOptions -> m () symbCheck cFileOpts sOpts cExecOpts cOpts = do   let block' = maybe Fetch.Latest Fetch.BlockNumber cExecOpts.block-      rpcinfo = (,) block' <$> cExecOpts.rpc+      blockUrlInfo = (,) block' <$> cExecOpts.rpc+  sess <- Fetch.mkSession   calldata <- buildCalldata cOpts sOpts.sig sOpts.arg-  preState <- liftIO $ symvmFromCommand cExecOpts sOpts cFileOpts calldata+  preState <- symvmFromCommand cExecOpts sOpts cFileOpts sess calldata   errCodes <- case sOpts.assertions of     Nothing -> pure defaultPanicCodes     Just s -> case (mapM readMaybe $ splitOn "," s) of@@ -503,9 +516,10 @@                               , askSmtIters = cOpts.askSmtIterations                               , loopHeuristic = cOpts.loopDetectionHeuristic                               }-                            , rpcInfo = rpcinfo+                            , rpcInfo = mempty {Fetch.blockNumURL = blockUrlInfo}                             }-    (expr, res) <- verify solvers veriOpts preState (Just $ checkAssertions errCodes)+    let fetcher = Fetch.oracle solvers (Just sess) veriOpts.rpcInfo+    (expr, res) <- verify solvers fetcher veriOpts preState (Just $ checkAssertions errCodes)     case res of       [Qed] -> do         liftIO $ putStrLn "\nQED: No reachable property violations discovered\n"@@ -520,7 +534,7 @@                  , ""                  ] <> fmap (formatCex (fst calldata) Nothing) cexs         liftIO $ T.putStrLn $ T.unlines counterexamples-        liftIO $ printWarnings [expr] res "symbolically"+        liftIO $ printWarnings Nothing [expr] res "symbolically"         showExtras solvers sOpts calldata expr         liftIO exitFailure @@ -528,13 +542,13 @@ showExtras solvers sOpts calldata expr = do   when sOpts.showTree $ liftIO $ do     putStrLn "=== Expression ===\n"-    T.putStrLn $ formatExpr expr+    T.putStrLn $ formatExpr $ Expr.simplify expr     putStrLn ""   when sOpts.showReachableTree $ do     reached <- reachable solvers expr     liftIO $ do       putStrLn "=== Potentially Reachable Expression ===\n"-      T.putStrLn (formatExpr . snd $ reached)+      T.putStrLn (formatExpr . Expr.simplify $ reached)       putStrLn ""   when sOpts.getModels $ do     liftIO $ putStrLn $ "=== Models for " <> show (Expr.numBranches expr) <> " branches ==="@@ -550,14 +564,31 @@ launchExec :: App m => CommonFileOptions -> ExecOptions -> CommonExecOptions -> CommonOptions -> m () launchExec cFileOpts execOpts cExecOpts cOpts = do   dapp <- getSrcInfo execOpts cOpts-  vm <- liftIO $ vmFromCommand cOpts cExecOpts cFileOpts execOpts+  sess <- Fetch.mkSession+  vm <- vmFromCommand cOpts cExecOpts cFileOpts execOpts sess   let     block = maybe Fetch.Latest Fetch.BlockNumber cExecOpts.block-    rpcinfo = (,) block <$> cExecOpts.rpc+    blockUrlInfo = (,) block <$> cExecOpts.rpc+    rpcDat :: Fetch.RpcInfo = mempty { Fetch.blockNumURL = blockUrlInfo }    -- TODO: we shouldn't need solvers to execute this code   withSolvers Z3 0 1 Nothing $ \solvers -> do-    vm' <- EVM.Stepper.interpret (Fetch.oracle solvers rpcinfo) vm EVM.Stepper.runFully+    let fetcher = Fetch.oracle solvers (Just sess) rpcDat+    vm' <- if execOpts.jsonTrace+           then do+             (vm', (_, traces)) <- runStateT (interpretWithTrace fetcher EVM.Stepper.runFully) (vm, [])+             liftIO $ do+               let ret = case vm'.result of+                           Just (VMSuccess (ConcreteBuf r)) -> ByteStringS r+                           Just (VMFailure (Revert (ConcreteBuf r))) -> ByteStringS r+                           _ -> ByteStringS ""+               let res = VMTraceStepResult ret (vm.state.gas - vm'.state.gas)+               let jsonl = toLazyByteString $ jsonlBuilder traces <> jsonLine res+               let file = "hevm-trace.jsonl"+               BS.writeFile file jsonl+               putStrLn $ "Wrote json trace to " <> show file+             pure vm'+           else EVM.Stepper.interpret fetcher vm EVM.Stepper.runFully     writeTraceDapp dapp vm'     case vm'.result of       Just (VMFailure (Revert msg)) -> liftIO $ do@@ -578,11 +609,12 @@         internalError "no EVM result"  -- | Creates a (concrete) VM from command line options-vmFromCommand :: CommonOptions -> CommonExecOptions -> CommonFileOptions -> ExecOptions -> IO (VM Concrete RealWorld)-vmFromCommand cOpts cExecOpts cFileOpts execOpts= do+vmFromCommand :: App m => CommonOptions -> CommonExecOptions -> CommonFileOptions -> ExecOptions -> Fetch.Session -> m (VM Concrete RealWorld)+vmFromCommand cOpts cExecOpts cFileOpts execOpts sess = do+  conf <- readConfig   (miner,ts,baseFee,blockNum,prevRan) <- case cExecOpts.rpc of     Nothing -> pure (LitAddr 0,Lit 0,0,Lit 0,0)-    Just url -> Fetch.fetchBlockFrom block url >>= \case+    Just url -> liftIO $ Fetch.fetchBlockWithSession conf sess block url >>= \case       Nothing -> do         putStrLn $ "Error, Could not fetch block" <> show block <> " from URL: " <> show url         exitFailure@@ -595,27 +627,26 @@    codeWrapped <- getCode cFileOpts.codeFile cFileOpts.code   contract <- case (cExecOpts.rpc, cExecOpts.address, codeWrapped) of-    (Just url, Just addr', Just c) -> do+    (Just url, Just addr', Just c) -> liftIO $ do       let code = hexByteString $ strip0x c       if isNothing code then do         putStrLn $ "Error, invalid code: " <> show c         exitFailure       else-        Fetch.fetchContractFrom block url addr' >>= \case+        Fetch.fetchContractWithSession conf sess block url addr' >>= \case           Nothing -> do             putStrLn $ "Error: contract not found: " <> show address             exitFailure           Just contract ->             -- if both code and url is given,             -- fetch the contract and overwrite the code-            pure $-              initialContract  (mkCode $ fromJust code)+            pure $ initialContract (mkCode $ fromJust code)                 & set #balance  (contract.balance)                 & set #nonce    (contract.nonce)                 & set #external (contract.external)      (Just url, Just addr', Nothing) ->-      Fetch.fetchContractFrom block url addr' >>= \case+      liftIO $ Fetch.fetchContractWithSession conf sess block url addr' >>= \case         Nothing -> do           putStrLn $ "Error, contract not found: " <> show address           exitFailure@@ -623,12 +654,12 @@      (_, _, Just c)  -> do       let code = hexByteString $ strip0x c-      if (isNothing code) then do+      if (isNothing code) then liftIO $ do         putStrLn $ "Error, invalid code: " <> show c         exitFailure       else pure $ initialContract (mkCode $ fromJust code) -    (_, _, Nothing) -> do+    (_, _, Nothing) -> liftIO $ do       putStrLn "Error, must provide at least (rpc + address) or code"       exitFailure @@ -636,10 +667,10 @@         Just t -> t         Nothing -> internalError "unexpected symbolic timestamp when executing vm test" -  if (isNothing bsCallData) then do+  if (isNothing bsCallData) then liftIO $ do     putStrLn $ "Error, invalid calldata: " <> show calldata     exitFailure-  else do+  else liftIO $ do     vm <- stToIO $ vm0 baseFee miner ts' blockNum prevRan contract     pure $ EVM.Transaction.initTx vm   where@@ -690,11 +721,14 @@         addr f def = maybe def LitAddr (f cExecOpts)         bytes f def = maybe def decipher (f cOpts) -symvmFromCommand :: CommonExecOptions -> SymbolicOptions -> CommonFileOptions -> (Expr Buf, [Prop]) -> IO (VM EVM.Types.Symbolic RealWorld)-symvmFromCommand cExecOpts sOpts cFileOpts calldata = do+symvmFromCommand :: App m =>+  CommonExecOptions -> SymbolicOptions -> CommonFileOptions -> Fetch.Session ->+  (Expr Buf, [Prop]) -> m (VM EVM.Types.Symbolic RealWorld)+symvmFromCommand cExecOpts sOpts cFileOpts sess calldata = do+  conf <- readConfig   (miner,blockNum,baseFee,prevRan) <- case cExecOpts.rpc of     Nothing -> pure (SymAddr "miner",Lit 0,0,0)-    Just url -> Fetch.fetchBlockFrom block url >>= \case+    Just url -> liftIO $ Fetch.fetchBlockWithSession conf sess block url >>= \case       Nothing -> do         putStrLn $ "Error, Could not fetch block" <> show block <> " from URL: " <> show url         exitFailure@@ -713,7 +747,7 @@   codeWrapped <- getCode cFileOpts.codeFile cFileOpts.code   contract <- case (cExecOpts.rpc, cExecOpts.address, codeWrapped) of     (Just url, Just addr', _) ->-      Fetch.fetchContractFrom block url addr' >>= \case+      liftIO $ Fetch.fetchContractWithSession conf sess block url addr' >>= \case         Nothing -> do           putStrLn "Error, contract not found."           exitFailure@@ -733,7 +767,7 @@                         & set #nonce       (contract'.nonce)                         & set #external    (contract'.external) -    (_, _, Just c)  -> do+    (_, _, Just c) -> liftIO $ do       let c' = decipher c       if isNothing c' then do         putStrLn $ "Error, invalid code: " <> show c@@ -742,11 +776,11 @@         EmptyBase -> pure (initialContract . mkCode $ fromJust c')         AbstractBase -> pure ((`abstractContract` address) . mkCode $ fromJust c') -    (_, _, Nothing) -> do+    (_, _, Nothing) -> liftIO $ do       putStrLn "Error, must provide at least (rpc + address) or code"       exitFailure -  vm <- stToIO $ vm0 baseFee miner ts blockNum prevRan calldata callvalue caller contract storageBase+  vm <- liftIO $ stToIO $ vm0 baseFee miner ts blockNum prevRan calldata callvalue caller contract storageBase   pure $ EVM.Transaction.initTx vm    where@@ -757,9 +791,11 @@                    then InitCode bs mempty                    else RuntimeCode (ConcreteRuntimeCode bs)     address = eaddr (.address) (SymAddr "entrypoint")+    originAddr = eaddr (.origin) (SymAddr "origin")+    originContr = abstractContract (RuntimeCode (SymbolicRuntimeCode mempty)) originAddr     vm0 baseFee miner ts blockNum prevRan cd callvalue caller c baseState = makeVm $ VMOpts       { contract       = c-      , otherContracts = []+      , otherContracts = [(originAddr, originContr)]       , calldata       = cd       , value          = callvalue       , address        = address@@ -789,24 +825,37 @@     word64 f def = fromMaybe def (f cExecOpts)     eaddr f def = maybe def LitAddr (f cExecOpts) -unitTestOptions :: TestOptions -> CommonOptions -> SolverGroup -> Maybe BuildOutput -> IO (UnitTestOptions RealWorld)+unitTestOptions :: App m => TestOptions -> CommonOptions -> SolverGroup -> Maybe BuildOutput -> m (UnitTestOptions RealWorld) unitTestOptions testOpts cOpts solvers buildOutput = do-  root <- getRoot cOpts+  root <- liftIO $ getRoot cOpts+  mockData <- if isJust testOpts.mockFile then liftIO $ do+      ret <- Fetch.readMockData (fromJust testOpts.mockFile)+      case ret of+        Left err -> do+          putStrLn $ "Error reading mock file: " <> err+          exitFailure+        Right md -> pure md+    else pure mempty+   let srcInfo = maybe emptyDapp (dappInfo root) buildOutput-  let rpcinfo = case (testOpts.number, testOpts.rpc) of+  let blockUrlInfo = case (testOpts.number, testOpts.rpc) of           (Just block, Just url) -> Just (Fetch.BlockNumber block, url)           (Nothing, Just url) -> Just (Fetch.Latest, url)           _ -> Nothing-  params <- paramsFromRpc rpcinfo+      rpcDat = Fetch.mkRpcInfo blockUrlInfo mockData+  sess <- Fetch.mkSession+  params <- paramsFromRpc rpcDat sess   let testn = params.number       block' = if 0 == testn        then Fetch.Latest        else Fetch.BlockNumber testn   pure UnitTestOptions     { solvers = solvers-    , rpcInfo = case testOpts.rpc of-         Just url -> Just (block', url)-         Nothing  -> Nothing+    , sess = sess+    , rpcInfo = let i = case testOpts.rpc of+                     Just url -> Just (block', url)+                     Nothing  -> Nothing+                in rpcDat { Fetch.blockNumURL = i }     , maxIter = parseMaxIters cOpts.maxIterations     , askSmtIters = cOpts.askSmtIterations     , smtTimeout = Just cOpts.smttimeout@@ -816,6 +865,7 @@     , dapp = srcInfo     , ffiAllowed = testOpts.ffi     , checkFailBit = cOpts.assertionType == DSTest+    , loopHeuristic = cOpts.loopDetectionHeuristic     } parseInitialStorage :: InitialStorage -> BaseState parseInitialStorage Empty = EmptyBase

@@ -2,13 +2,13 @@ name:   hevm version:-  0.55.1+  0.56.0 synopsis:   Symbolic EVM Evaluator description:   Symbolic EVM semantics in Haskell. homepage:-  https://github.com/ethereum/hevm+  https://github.com/argotorg/hevm license:   AGPL-3.0-only author:@@ -47,7 +47,7 @@  source-repository head   type:     git-  location: https://github.com/ethereum/hevm.git+  location: https://github.com/argotorg/hevm.git  common shared   if flag(ci)@@ -99,7 +99,6 @@     EVM.Expr,     EVM.SMT,     EVM.Solvers,-    EVM.Fuzz,     EVM.Exec,     EVM.Format,     EVM.Fetch,@@ -109,6 +108,7 @@     EVM.RLP,     EVM.Solidity,     EVM.Stepper,+    EVM.Tracing,     EVM.SymExec,     EVM.Traversals,     EVM.CSE,@@ -120,6 +120,8 @@     EVM.Effects,   other-modules:     EVM.CheatsTH,+    EVM.SMT.Types,+    EVM.SMT.SMTLIB,     Paths_hevm   autogen-modules:     Paths_hevm@@ -142,9 +144,9 @@     ethjet/tinykeccak.h, ethjet/ethjet.h, ethjet/ethjet-ff.h, ethjet/blake2.h   build-depends:     system-cxx-std-lib                >= 1.0 && < 2.0,-    QuickCheck                        >= 2.13.2 && < 2.15,+    QuickCheck                        >= 2.13.2 && < 2.16,     Decimal                           >= 0.5.1 && < 0.6,-    containers                        >= 0.6.0 && < 0.7,+    containers                        >= 0.6.0 && < 0.8,     transformers                      >= 0.5 && < 0.7,     tree-view                         >= 0.5 && < 0.6,     aeson                             >= 2.0.0 && < 2.3,@@ -152,12 +154,11 @@     scientific                        >= 0.3.6 && < 0.4,     binary                            >= 0.8.6 && < 0.9,     text                              >= 1.2.3 && < 2.2,-    unordered-containers              >= 0.2.10 && < 0.3,     vector                            >= 0.12.1 && < 0.14,     base16                            >= 1.0 && < 1.1,     megaparsec                        >= 9.0.0 && < 10.0,     mtl                               >= 2.2 && < 2.4,-    filepath                          >= 1.4.2 && < 1.5,+    filepath                          >= 1.4.2 && < 1.6,     cereal                            >= 0.5.8 && < 0.6,     cryptonite                        >= 0.30 && < 0.31,     memory                            >= 0.16.0 && < 0.20,@@ -175,17 +176,17 @@     wreq                              >= 0.5.3 && < 0.6,     regex-tdfa                        >= 1.2.3 && < 1.4,     base                              >= 4.9 && < 5,-    here                              >= 1.2.13 && < 1.3,     smt2-parser                       >= 0.1.0 && < 0.2,     spool                             >= 0.1 && < 0.2,     stm                               >= 2.5.0 && < 2.6.0,     spawn                             >= 0.3 && < 0.4,     filepattern                       >= 0.1.2 && < 0.2,-    witch                             >= 1.1 && < 1.3,+    witch                             >= 1.1 && < 1.4,     unliftio-core                     >= 0.2.1 && < 0.3,     split                             >= 0.2.3 && < 0.3,     template-haskell                  >= 2.19.0 && < 3,     extra                             >= 1.7.14 && < 2,+    aeson-pretty                      >= 0.8.8 && < 0.9.0,   hs-source-dirs:     src @@ -208,9 +209,11 @@     directory                         >= 1.3.6 && < 1.4,     filepath,     hevm,+    jsonl                             >= 0.2.0.0 && < 0.3.0.0,     optparse-generic,     optparse-applicative              >= 0.18.0.0 && < 0.20.0.0,     text,+    mtl,     optics-core,     githash                           >= 0.1.5 && < 0.2,     witch,@@ -249,9 +252,7 @@     text,     vector,     witherable,-    operational,     optics-core,-    optics-extra,     witch,     unliftio-core,     exceptions@@ -261,7 +262,7 @@   default-language: GHC2021   exposed-modules:     EVM.Test.Utils-    EVM.Test.Tracing+    EVM.Test.FuzzSymExec     EVM.Test.BlockchainTests  common test-common@@ -273,7 +274,7 @@     test-utils   other-modules:     EVM.Test.Utils-    EVM.Test.Tracing+    EVM.Test.FuzzSymExec     EVM.Test.BlockchainTests  --- Test Suites ---@@ -292,6 +293,7 @@     extra,     here,     time,+    optics-extra,     regex  -- these tests require network access so we split them into a separate test@@ -313,6 +315,7 @@     BlockchainTests.hs  test-suite cli-test+  import: test-common   type:     exitcode-stdio-1.0   default-language: GHC2021@@ -322,6 +325,7 @@     clitest.hs   build-depends:     base,+    here,     hevm,     hspec,     process,@@ -329,7 +333,6 @@     bytestring,     filepath,     split,-    here,  --- Benchmarks --- 

@@ -3,7 +3,7 @@  module EVM where -import Prelude hiding (exponent)+import Prelude hiding (exponent, Foldable(..))  import Optics.Core import Optics.State@@ -11,8 +11,8 @@ import Optics.Zoom  import EVM.ABI-import EVM.Expr (readStorage, writeStorage, readByte, readWord, writeWord,-  writeByte, bufLength, indexWord, readBytes, copySlice, wordToAddr)+import EVM.Expr (readStorage, concStoreContains, writeStorage, readByte, readWord, writeWord,+  writeByte, bufLength, indexWord, readBytes, copySlice, wordToAddr, maybeLitByteSimp, maybeLitWordSimp, maybeLitAddrSimp) import EVM.Expr qualified as Expr import EVM.FeeSchedule (FeeSchedule (..)) import EVM.Op@@ -23,7 +23,6 @@ import EVM.Sign qualified import EVM.Concrete qualified as Concrete import EVM.CheatsTH-import EVM.Expr (maybeLitByteSimp, maybeLitWordSimp, maybeLitAddrSimp) import EVM.Effects (Config (..))  import Control.Monad (unless, when)@@ -41,12 +40,12 @@ import Data.DoubleWord (Int256, Word256) import Data.Either (partitionEithers) import Data.Either.Extra (maybeToEither)-import Data.Foldable (toList)+import Data.Foldable (toList, Foldable(..)) import Data.List (find, isPrefixOf) import Data.List.Split (splitOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)+import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, mapMaybe) import Data.Set (insert, member, fromList) import Data.Sequence (Seq) import Data.Sequence qualified as Seq@@ -58,7 +57,7 @@ import Data.Vector qualified as V import Data.Vector.Storable qualified as VS import Data.Vector.Storable.Mutable qualified as VS.Mutable-import Data.Vector.Storable.ByteString (vectorToByteString)+import Data.Vector.Storable.ByteString (vectorToByteString, byteStringToVector) import Data.Word (Word8, Word32, Word64) import Text.Read (readMaybe) import Witch (into, tryFrom, unsafeInto, tryInto)@@ -152,7 +151,6 @@       , resetCaller = False       }     , env = env-    , cache = cache     , burned = initialGas     , constraints = snd o.calldata     , iterations = mempty@@ -160,12 +158,14 @@       { allowFFI = o.allowFFI       , baseState = o.baseState       }-    , forks = Seq.singleton (ForkState env block cache "")+    , forks = Seq.singleton (ForkState env block mempty "")     , currentFork = 0     , labels = mempty     , osEnv = mempty     , freshVar = 0     , exploreDepth = 0+    , keccakPreImgs = fromList []+    , pathsVisited = mempty     }     where     env = Env@@ -184,7 +184,6 @@       , baseFee = o.baseFee       , schedule = o.schedule       }-    cache = Cache mempty mempty  -- https://eips.ethereum.org/EIPS/eip-4788 setEIP4788Storage :: VMOpts t -> VM t s -> VM t s@@ -274,7 +273,7 @@  -- | Update program counter next :: (?op :: Word8) => EVM t s ()-next = modifying (#state % #pc) (+ (opSize ?op))+next = modifying' (#state % #pc) (+ (opSize ?op))  getOpW8 :: forall (t :: VMType) s . FrameState t s -> Word8 getOpW8 state = case state.code of@@ -289,7 +288,7 @@ getOpName state = intToOpName $ fromEnum $ getOpW8 state  -- | Executes the EVM one step-exec1 :: forall (t :: VMType) s. (VMOps t) => Config ->  EVM t s ()+exec1 :: forall (t :: VMType) s. (VMOps t, Typeable t) => Config ->  EVM t s () exec1 conf = do   vm <- get @@ -332,13 +331,13 @@       let ?op = getOpW8 vm.state       case getOp (?op) of -        OpPush0 -> do+        OpPush0 -> {-# SCC "OpPush0" #-} do           limitStack 1 $             burn g_base $ do               next               pushSym (Lit 0) -        OpPush n' -> do+        OpPush n' -> {-# SCC "OpPushN" #-} do           let n = into n'               !xs = case vm.state.code of                 UnknownCode _ -> internalError "Cannot execute unknown code"@@ -352,7 +351,7 @@               next               pushSym xs -        OpDup i ->+        OpDup i -> {-# SCC "OpDup" #-}           case preview (ix (into i - 1)) stk of             Nothing -> underrun             Just y ->@@ -361,7 +360,7 @@                   next                   pushSym y -        OpSwap i ->+        OpSwap i -> {-# SCC "OpSwap" #-}           case (stk ^? ix_i, stk ^? ix_0) of             (Just ei, Just e0) ->               burn g_verylow $ do@@ -373,7 +372,7 @@           where             (ix_i, ix_0) = (ix (into i), ix 0) -        OpLog n ->+        OpLog n -> {-# SCC "OpLog" #-}           notStatic $           case stk of             (xOffset:xSize:xs) ->@@ -387,48 +386,48 @@                   accessMemoryRange xOffset xSize $ do                     traceTopLog logs'                     next-                    assign (#state % #stack) xs'+                    assign' (#state % #stack) xs'                     assign #logs logs'             _ ->               underrun -        OpStop -> doStop+        OpStop -> {-# SCC "OpStop" #-} doStop -        OpAdd -> stackOp2 g_verylow Expr.add-        OpMul -> stackOp2 g_low Expr.mul-        OpSub -> stackOp2 g_verylow Expr.sub+        OpAdd -> {-# SCC "OpAdd" #-} stackOp2 g_verylow Expr.add+        OpMul -> {-# SCC "OpMul" #-} stackOp2 g_low Expr.mul+        OpSub -> {-# SCC "OpSub" #-} stackOp2 g_verylow Expr.sub -        OpDiv -> stackOp2 g_low Expr.div+        OpDiv -> {-# SCC "OpDiv" #-} stackOp2 g_low Expr.div -        OpSdiv -> stackOp2 g_low Expr.sdiv+        OpSdiv -> {-# SCC "OpSdiv" #-} stackOp2 g_low Expr.sdiv -        OpMod -> stackOp2 g_low Expr.mod+        OpMod -> {-# SCC "OpMod" #-} stackOp2 g_low Expr.mod -        OpSmod -> stackOp2 g_low Expr.smod-        OpAddmod -> stackOp3 g_mid Expr.addmod-        OpMulmod -> stackOp3 g_mid Expr.mulmod+        OpSmod -> {-# SCC "OpSmod" #-} stackOp2 g_low Expr.smod+        OpAddmod -> {-# SCC "OpAddmod" #-} stackOp3 g_mid Expr.addmod+        OpMulmod -> {-# SCC "OpMulmod" #-} stackOp3 g_mid Expr.mulmod -        OpLt -> stackOp2 g_verylow Expr.lt-        OpGt -> stackOp2 g_verylow Expr.gt-        OpSlt -> stackOp2 g_verylow Expr.slt-        OpSgt -> stackOp2 g_verylow Expr.sgt+        OpLt -> {-# SCC "OpLt" #-} stackOp2 g_verylow Expr.lt+        OpGt -> {-# SCC "OpGt" #-} stackOp2 g_verylow Expr.gt+        OpSlt -> {-# SCC "OpSlt" #-} stackOp2 g_verylow Expr.slt+        OpSgt -> {-# SCC "OpSgt" #-} stackOp2 g_verylow Expr.sgt -        OpEq -> stackOp2 g_verylow Expr.eq-        OpIszero -> stackOp1 g_verylow Expr.iszero+        OpEq -> {-# SCC "OpEq" #-} stackOp2 g_verylow Expr.eq+        OpIszero -> {-# SCC "OpIszero" #-} stackOp1 g_verylow Expr.iszero -        OpAnd -> stackOp2 g_verylow Expr.and-        OpOr -> stackOp2 g_verylow Expr.or-        OpXor -> stackOp2 g_verylow Expr.xor-        OpNot -> stackOp1 g_verylow Expr.not+        OpAnd -> {-# SCC "OpAnd" #-} stackOp2 g_verylow Expr.and+        OpOr -> {-# SCC "OpOr" #-} stackOp2 g_verylow Expr.or+        OpXor -> {-# SCC "OpXor" #-} stackOp2 g_verylow Expr.xor+        OpNot -> {-# SCC "OpNot" #-} stackOp1 g_verylow Expr.not -        OpByte -> stackOp2 g_verylow (\i w -> Expr.padByte $ Expr.indexWord i w)+        OpByte -> {-# SCC "OpByte" #-} stackOp2 g_verylow (\i w -> Expr.padByte $ Expr.indexWord i w) -        OpShl -> stackOp2 g_verylow Expr.shl-        OpShr -> stackOp2 g_verylow Expr.shr-        OpSar -> stackOp2 g_verylow Expr.sar+        OpShl -> {-# SCC "OpShl" #-} stackOp2 g_verylow Expr.shl+        OpShr -> {-# SCC "OpShr" #-} stackOp2 g_verylow Expr.shr+        OpSar -> {-# SCC "OpSar" #-} stackOp2 g_verylow Expr.sar          -- more accurately referred to as KECCAK-        OpSha3 ->+        OpSha3 -> {-# SCC "OpSha3" #-}           case stk of             xOffset:xSize:xs ->               burnSha3 xSize $@@ -437,82 +436,86 @@                     orig@(ConcreteBuf bs) ->                       whenSymbolicElse                         (pure $ Keccak orig)-                        (pure $ Lit (keccak' bs))+                        (do+                          let kc = keccak' bs+                          modifying #keccakPreImgs (insert (bs, kc))+                          pure $ Lit kc+                        )                     buf -> pure $ Keccak buf                   next-                  assign (#state % #stack) (hash : xs)+                  assign' (#state % #stack) (hash : xs)             _ -> underrun -        OpAddress ->+        OpAddress -> {-# SCC "OpAddress" #-}           limitStack 1 $             burn g_base (next >> pushAddr self) -        OpBalance ->+        OpBalance -> {-# SCC "OpBalance" #-}           case stk of             x:xs -> forceAddr x (freshVarFallback xs) $ \a ->               accessAndBurn a $                 fetchAccountWithFallback a (freshVarFallback xs) $ \c -> do                   next-                  assign (#state % #stack) xs+                  assign' (#state % #stack) xs                   pushSym c.balance             [] -> underrun -        OpOrigin ->+        OpOrigin -> {-# SCC "OpOrigin" #-}           limitStack 1 . burn g_base $             next >> pushAddr vm.tx.origin -        OpCaller ->+        OpCaller -> {-# SCC "OpCaller" #-}           limitStack 1 . burn g_base $             next >> pushAddr vm.state.caller -        OpCallvalue ->+        OpCallvalue -> {-# SCC "OpCallvalue" #-}           limitStack 1 . burn g_base $             next >> pushSym vm.state.callvalue -        OpCalldataload -> stackOp1 g_verylow $+        OpCalldataload -> {-# SCC "OpCalldataload" #-} stackOp1 g_verylow $           \ind -> Expr.readWord ind vm.state.calldata -        OpCalldatasize ->+        OpCalldatasize -> {-# SCC "OpCalldatasize" #-}           limitStack 1 . burn g_base $             next >> pushSym (bufLength vm.state.calldata) -        OpCalldatacopy ->+        OpCalldatacopy -> {-# SCC "OpCalldatacopy" #-}           case stk of             xTo:xFrom:xSize:xs ->               burnCalldatacopy xSize $                 accessMemoryRange xTo xSize $ do                   next-                  assign (#state % #stack) xs+                  assign' (#state % #stack) xs                   copyBytesToMemory vm.state.calldata xSize xFrom xTo             _ -> underrun -        OpCodesize ->+        OpCodesize -> {-# SCC "OpCodesize" #-}           limitStack 1 . burn g_base $             next >> pushSym (codelen vm.state.code) -        OpCodecopy ->+        OpCodecopy -> {-# SCC "OpCodecopy" #-}           case stk of             memOffset:codeOffset:n:xs ->               burnCodecopy n $ do                 accessMemoryRange memOffset n $ do                   next-                  assign (#state % #stack) xs+                  assign' (#state % #stack) xs                   case toBuf vm.state.code of                     Just b -> copyBytesToMemory b n codeOffset memOffset                     Nothing -> internalError "Cannot produce a buffer from UnknownCode"             _ -> underrun -        OpGasprice ->+        OpGasprice -> {-# SCC "OpGasprice" #-}           limitStack 1 . burn g_base $             next >> push vm.tx.gasprice -        OpExtcodesize ->+        OpExtcodesize -> {-# SCC "OpExtcodesize" #-}           case stk of             x':xs -> forceAddr x' (freshVarFallback xs) $ \x -> do               let impl = accessAndBurn x $                            fetchAccountWithFallback x (freshVarFallback xs) $ \c -> do                              next-                             assign (#state % #stack) xs+                             assign' (#state % #stack) xs                              case view bytecode c of                                Just b -> pushSym (bufLength b)                                Nothing -> pushSym $ CodeSize x@@ -520,14 +523,14 @@                 a@(LitAddr _) -> if a == cheatCode                   then do                     next-                    assign (#state % #stack) xs+                    assign' (#state % #stack) xs                     pushSym (Lit 1)                   else impl                 _ -> impl             [] ->               underrun -        OpExtcodecopy ->+        OpExtcodecopy -> {-# SCC "OpExtcodecopy" #-}           case stk of             extAccount':memOffset:codeOffset:codeSize:xs ->               forceAddr extAccount' (unexpectedSymArgW "EXTCODECOPY") $ \extAccount -> do@@ -535,23 +538,23 @@                   accessMemoryRange memOffset codeSize $                     fetchAccount extAccount $ \c -> do                       next-                      assign (#state % #stack) xs+                      assign' (#state % #stack) xs                       case view bytecode c of                         Just b -> copyBytesToMemory b codeSize codeOffset memOffset                         Nothing -> unexpectedSymArg "Cannot copy from unknown code at" [extAccount]             _ -> underrun -        OpReturndatasize ->+        OpReturndatasize -> {-# SCC "OpReturndatasize" #-}           limitStack 1 . burn g_base $             next >> pushSym (bufLength vm.state.returndata) -        OpReturndatacopy ->+        OpReturndatacopy -> {-# SCC "OpReturndatacopy" #-}           case stk of             xTo:xFrom:xSize:xs ->               burnReturndatacopy xSize $                 accessMemoryRange xTo xSize $ do                   next-                  assign (#state % #stack) xs+                  assign' (#state % #stack) xs                    let jump True = vmError ReturnDataOutOfBounds                       jump False = copyBytesToMemory vm.state.returndata xSize xFrom xTo@@ -565,13 +568,13 @@                       branch conf.maxDepth (Expr.or oob overflow) jump             _ -> underrun -        OpExtcodehash ->+        OpExtcodehash -> {-# SCC "OpExtcodehash" #-}           case stk of             x':xs -> forceAddr x' (freshVarFallback xs) $ \x ->               accessAndBurn x $ do                 fetchAccountWithFallback x (freshVarFallback xs) $ \c -> do                    next-                   assign (#state % #stack) xs+                   assign' (#state % #stack) xs                    if accountEmpty c                      then push (W256 0)                      else case view bytecode c of@@ -580,7 +583,7 @@             [] ->               underrun -        OpBlockhash -> do+        OpBlockhash -> {-# SCC "OpBlockhash" #-} do           stackOp1 g_blockhash $ \case             Lit i -> case vm.block.number of               Lit vmBlockNumber ->@@ -597,51 +600,51 @@             where               fakeBlockHash i = (into i :: Integer) & show & Char8.pack & keccak' & Lit -        OpCoinbase ->+        OpCoinbase -> {-# SCC "OpCoinbase" #-}           limitStack 1 . burn g_base $             next >> pushAddr vm.block.coinbase -        OpTimestamp ->+        OpTimestamp -> {-# SCC "OpTimestamp" #-}           limitStack 1 . burn g_base $             next >> pushSym vm.block.timestamp -        OpNumber ->+        OpNumber -> {-# SCC "OpNumber" #-}           limitStack 1 . burn g_base $             next >> pushSym vm.block.number -        OpPrevRandao -> do+        OpPrevRandao -> {-# SCC "OpPrevRandao" #-} do           limitStack 1 . burn g_base $             next >> push vm.block.prevRandao -        OpGaslimit ->+        OpGaslimit -> {-# SCC "OpGaslimit" #-}           limitStack 1 . burn g_base $             next >> push (into vm.block.gaslimit) -        OpChainid ->+        OpChainid -> {-# SCC "OpChainid" #-}           limitStack 1 . burn g_base $             next >> push vm.env.chainId -        OpSelfbalance ->+        OpSelfbalance -> {-# SCC "OpSelfbalance" #-}           limitStack 1 . burn g_low $             next >> pushSym this.balance -        OpBaseFee ->+        OpBaseFee -> {-# SCC "OpBaseFee" #-}           limitStack 1 . burn g_base $             next >> push vm.block.baseFee -        OpBlobhash ->+        OpBlobhash -> {-# SCC "OpBlobhash" #-}           stackOp1 g_verylow $ \_ -> Lit 0 -        OpBlobBaseFee ->+        OpBlobBaseFee -> {-# SCC "OpBlobBaseFee" #-}           limitStack 1 . burn g_base $             next >> push 0 -        OpPop ->+        OpPop -> {-# SCC "OpPop" #-}           case stk of-            _:xs -> burn g_base (next >> assign (#state % #stack) xs)+            _:xs -> burn g_base (next >> assign' (#state % #stack) xs)             _    -> underrun -        OpMload ->+        OpMload -> {-# SCC "OpMload" #-}           case stk of             x:xs ->               burn g_verylow $@@ -649,11 +652,11 @@                   next                   buf <- readMemory x (Lit 32)                   let w = Expr.readWordFromBytes (Lit 0) buf-                  assign (#state % #stack) (w : xs)+                  assign' (#state % #stack) (w : xs)             _ -> underrun  -        OpMcopy ->+        OpMcopy -> {-# SCC "OpMcopy" #-}           case stk of             dstOff:srcOff:sz:xs ->  do               case sz of@@ -668,7 +671,7 @@                   -- symbolic, ignore gas                   next                   mcopy sz srcOff dstOff-              assign (#state % #stack) xs+              assign' (#state % #stack) xs             _ -> underrun             where             mcopy sz srcOff dstOff = do@@ -680,7 +683,7 @@                     SymbolicMemory mem -> do                       assign (#state % #memory) (SymbolicMemory $ copySlice srcOff dstOff sz mem mem) -        OpMstore ->+        OpMstore -> {-# SCC "OpMstore" #-}           case stk of             x:y:xs ->               burn g_verylow $@@ -697,10 +700,10 @@                           assign (#state % #memory) (SymbolicMemory $ writeWord x y buf)                     SymbolicMemory mem ->                       assign (#state % #memory) (SymbolicMemory $ writeWord x y mem)-                  assign (#state % #stack) xs+                  assign' (#state % #stack) xs             _ -> underrun -        OpMstore8 ->+        OpMstore8 -> {-# SCC "OpMstore8" #-}           case stk of             x:y:xs ->               burn g_verylow $@@ -719,10 +722,10 @@                     SymbolicMemory mem ->                       assign (#state % #memory) (SymbolicMemory $ writeByte x yByte mem) -                  assign (#state % #stack) xs+                  assign' (#state % #stack) xs             _ -> underrun -        OpSload ->+        OpSload -> {-# SCC "OpSload" #-}           case stk of             x:xs -> do               acc <- accessStorageForGas self x@@ -730,10 +733,10 @@               burn cost $                 accessStorage self x $ \y -> do                   next-                  assign (#state % #stack) (y:xs)+                  assign' (#state % #stack) (y:xs)             _ -> underrun -        OpSstore ->+        OpSstore -> {-# SCC "OpSstore" #-}           notStatic $           case stk of             x:new:xs ->@@ -760,7 +763,7 @@                   let cold_storage_cost = if acc then 0 else g_cold_sload                   burn (storage_cost + cold_storage_cost) $ do                     next-                    assign (#state % #stack) xs+                    assign' (#state % #stack) xs                     modifying (#env % #contracts % ix self % #storage) (writeStorage x new)                      case (maybeLitWordSimp current, maybeLitWordSimp new) of@@ -783,26 +786,26 @@                        _ -> noop             _ -> underrun -        OpTload ->+        OpTload -> {-# SCC "OpTload" #-}           case stk of             x:xs -> do               burn g_warm_storage_read $                 accessTStorage self x $ \y -> do                   next-                  assign (#state % #stack) (y:xs)+                  assign' (#state % #stack) (y:xs)             _ -> underrun -        OpTstore ->+        OpTstore -> {-# SCC "OpTstore" #-}           notStatic $           case stk of             x:new:xs ->               burn g_sload $ do                 next                 modifying (#env % #contracts % ix self % #tStorage) (writeStorage x new)-                assign (#state % #stack) xs+                assign' (#state % #stack) xs             _ -> underrun -        OpJump ->+        OpJump -> {-# SCC "OpJump" #-}           case stk of             x:xs ->               burn g_mid $ forceConcreteLimitSz x 2 "JUMP: symbolic jumpdest" $ \x' ->@@ -811,33 +814,33 @@                   Right i -> checkJump i xs             _ -> underrun -        OpJumpi ->+        OpJumpi -> {-# SCC "OpJumpi" #-}           case stk of             x:y:xs -> forceConcreteLimitSz x 2 "JUMPI: symbolic jumpdest" $ \x' ->               burn g_high $                 let jump :: Bool -> EVM t s ()-                    jump False = assign (#state % #stack) xs >> next+                    jump False = assign' (#state % #stack) xs >> next                     jump _    = case tryInto x' of                       Left _ -> vmError BadJumpDestination                       Right i -> checkJump i xs                 in branch conf.maxDepth y jump             _ -> underrun -        OpPc ->+        OpPc -> {-# SCC "OpPc" #-}           limitStack 1 . burn g_base $             next >> push (unsafeInto vm.state.pc) -        OpMsize ->+        OpMsize -> {-# SCC "OpMsize" #-}           limitStack 1 . burn g_base $             next >> push (into vm.state.memorySize) -        OpGas ->+        OpGas -> {-# SCC "OpGas" #-}           limitStack 1 . burn g_base $             next >> pushGas -        OpJumpdest -> burn g_jumpdest next+        OpJumpdest -> {-# SCC "OpJumpdest" #-} burn g_jumpdest next -        OpExp ->+        OpExp -> {-# SCC "OpExp" #-}           -- NOTE: this can be done symbolically using unrolling like this:           --       https://hackage.haskell.org/package/sbv-9.0/docs/src/Data.SBV.Core.Model.html#.%5E           --       However, it requires symbolic gas, since the gas depends on the exponent@@ -845,12 +848,12 @@             base:exponent:xs ->               burnExp exponent $ do                 next-                (#state % #stack) .= Expr.exp base exponent : xs+                assign' (#state % #stack) $ Expr.exp base exponent : xs             _ -> underrun -        OpSignextend -> stackOp2 g_low Expr.sex+        OpSignextend -> {-# SCC "OpSignextend" #-} stackOp2 g_low Expr.sex -        OpCreate ->+        OpCreate -> {-# SCC "OpCreate" #-}           notStatic $           case stk of             xValue:xOffset:xSize:xs ->@@ -877,7 +880,7 @@                   create from' this xSize gas' xValue xs newAddr initCode             _ -> underrun -        OpCall ->+        OpCall -> {-# SCC "OpCall" #-}           case stk of             xGas:xTo':xValue:xInOffset:xInSize:xOutOffset:xOutSize:xs ->               branch conf.maxDepth (Expr.gt xValue (Lit 0)) $ \gt0 -> do@@ -904,7 +907,7 @@               where fallback = freshBufFallback xs             _ -> underrun -        OpCallcode ->+        OpCallcode -> {-# SCC "OpCallcode" #-}           case stk of             xGas:xTo':xValue:xInOffset:xInSize:xOutOffset:xOutSize:xs ->               forceAddr xTo' (unexpectedSymArgW "unable to determine a call target") $ \xTo ->@@ -919,7 +922,7 @@                       touchAccount self             _ -> underrun -        OpReturn ->+        OpReturn -> {-# SCC "OpReturn" #-}           case stk of             xOffset:xSize:_ ->               accessMemoryRange xOffset xSize $ do@@ -952,7 +955,7 @@                    finishFrame (FrameReturned output)             _ -> underrun -        OpDelegatecall ->+        OpDelegatecall -> {-# SCC "OpDelegatecall" #-}           case stk of             xGas:xTo:xInOffset:xInSize:xOutOffset:xOutSize:xs ->               forceAddr xTo (const $ unexpectedSymArg "unable to determine a call target" [xTo]) $ \xTo' ->@@ -965,7 +968,7 @@                         \_ -> touchAccount self             _ -> underrun -        OpCreate2 -> notStatic $+        OpCreate2 -> {-# SCC "OpCreate2" #-} notStatic $           case stk of             xValue:xOffset:xSize:xSalt':xs ->               forceConcrete xSalt' "CREATE2" $ \(xSalt) ->@@ -990,7 +993,7 @@                         create from' this xSize gas' xValue xs newAddr (ConcreteBuf initCode)             _ -> underrun -        OpStaticcall ->+        OpStaticcall -> {-# SCC "OpStaticcall" #-}           case stk of             xGas:xTo:xInOffset:xInSize:xOutOffset:xOutSize:xs ->               forceAddr xTo (const fallback) $ \xTo' -> case gasTryFrom xGas of@@ -1010,7 +1013,7 @@                   fallback = freshBufFallback xs             _ -> underrun -        OpSelfdestruct ->+        OpSelfdestruct -> {-# SCC "OpSelfdestruct" #-}           notStatic $           case stk of             [] -> underrun@@ -1041,7 +1044,7 @@                       doStop               a -> unexpectedSymArg "trying to self destruct to a symbolic address" [a] -        OpRevert ->+        OpRevert -> {-# SCC "OpRevert" #-}           case stk of             xOffset:xSize:_ ->               accessMemoryRange xOffset xSize $ do@@ -1049,7 +1052,7 @@                 finishFrame (FrameReverted output)             _ -> underrun -        OpUnknown xxx -> vmError $ UnrecognizedOpcode xxx+        OpUnknown xxx -> {-# SCC "OpUnknown" #-} vmError $ UnrecognizedOpcode xxx  transfer :: (VMOps t, ?conf::Config) => Expr EAddr -> Expr EAddr -> Expr EWord -> EVM t s () transfer _ _ (Lit 0) = pure ()@@ -1110,7 +1113,7 @@         let checkCallDepth =               if length vm.frames >= 1024               then do-                assign (#state % #stack) (Lit 0 : xs)+                assign' (#state % #stack) (Lit 0 : xs)                 assign (#state % #returndata) mempty                 pushTrace $ ErrorTrace CallDepthLimitReached                 next@@ -1124,7 +1127,7 @@             burn (cost - gas') $               branch (?conf).maxDepth (Expr.gt xValue fb) $ \case                 True -> do-                  assign (#state % #stack) (Lit 0 : xs)+                  assign' (#state % #stack) (Lit 0 : xs)                   assign (#state % #returndata) mempty                   pushTrace $ ErrorTrace (BalanceTooLow xValue this.balance)                   next@@ -1186,14 +1189,16 @@   input <- readMemory inOffset inSize   let fees = vm.block.schedule       cost = costOfPrecompile fees preCompileAddr input-      notImplemented = internalError $ "precompile at address " <> show preCompileAddr <> " not yet implemented"+      notImplemented = whenSymbolicElse+        (partial $ PrecompileMissing {pc = vm.state.pc, addr = vm.state.contract, preAddr = preCompileAddr})+        (vmError $ NonexistentPrecompile preCompileAddr)       precompileFail = burn' (subGas gasCap cost) $ do-                         assign (#state % #stack) (Lit 0 : xs)+                         assign' (#state % #stack) (Lit 0 : xs)                          pushTrace $ ErrorTrace PrecompileFailure                          next   if not (enoughGas cost gasCap) then     burn' gasCap $ do-      assign (#state % #stack) (Lit 0 : xs)+      assign' (#state % #stack) (Lit 0 : xs)       next   else burn cost $     case preCompileAddr of@@ -1204,11 +1209,11 @@           case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of             Nothing -> do               -- return no output for invalid signature-              assign (#state % #stack) (Lit 1 : xs)+              assign' (#state % #stack) (Lit 1 : xs)               assign (#state % #returndata) mempty               next             Just output -> do-              assign (#state % #stack) (Lit 1 : xs)+              assign' (#state % #stack) (Lit 1 : xs)               assign (#state % #returndata) (ConcreteBuf output)               copyBytesToMemory (ConcreteBuf output) outSize (Lit 0) outOffset               next@@ -1219,7 +1224,7 @@           let             hash = sha256Buf input'             sha256Buf x = ConcreteBuf $ BA.convert (Crypto.hash x :: Digest SHA256)-          assign (#state % #stack) (Lit 1 : xs)+          assign' (#state % #stack) (Lit 1 : xs)           assign (#state % #returndata) hash           copyBytesToMemory hash outSize (Lit 0) outOffset           next@@ -1232,14 +1237,14 @@             padding = BS.pack $ replicate 12 0             hash' = BA.convert (Crypto.hash input' :: Digest RIPEMD160)             hash  = ConcreteBuf $ padding <> hash'-          assign (#state % #stack) (Lit 1 : xs)+          assign' (#state % #stack) (Lit 1 : xs)           assign (#state % #returndata) hash           copyBytesToMemory hash outSize (Lit 0) outOffset           next        -- IDENTITY       0x4 -> do-          assign (#state % #stack) (Lit 1 : xs)+          assign' (#state % #stack) (Lit 1 : xs)           assign (#state % #returndata) input           copyCallBytesToMemory input outSize outOffset           next@@ -1261,7 +1266,7 @@                   m = asInteger $ lazySlice (96 + lenb + lene) lenm input'                 in                   padLeft (unsafeInto lenm) (asBE (expFast b e m))-          assign (#state % #stack) (Lit 1 : xs)+          assign' (#state % #stack) (Lit 1 : xs)           assign (#state % #returndata) output           copyBytesToMemory output outSize (Lit 0) outOffset           next@@ -1274,7 +1279,7 @@             Nothing -> precompileFail             Just output -> do               let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output-              assign (#state % #stack) (Lit 1 : xs)+              assign' (#state % #stack) (Lit 1 : xs)               assign (#state % #returndata) truncpaddedOutput               copyBytesToMemory truncpaddedOutput outSize (Lit 0) outOffset               next@@ -1287,7 +1292,7 @@           Nothing -> precompileFail           Just output -> do             let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output-            assign (#state % #stack) (Lit 1 : xs)+            assign' (#state % #stack) (Lit 1 : xs)             assign (#state % #returndata) truncpaddedOutput             copyBytesToMemory truncpaddedOutput outSize (Lit 0) outOffset             next@@ -1300,7 +1305,7 @@           Nothing -> precompileFail           Just output -> do             let truncpaddedOutput = ConcreteBuf $ truncpadlit 32 output-            assign (#state % #stack) (Lit 1 : xs)+            assign' (#state % #stack) (Lit 1 : xs)             assign (#state % #returndata) truncpaddedOutput             copyBytesToMemory truncpaddedOutput outSize (Lit 0) outOffset             next@@ -1313,7 +1318,7 @@             (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of               Just output -> do                 let truncpaddedOutput = ConcreteBuf $ truncpadlit 64 output-                assign (#state % #stack) (Lit 1 : xs)+                assign' (#state % #stack) (Lit 1 : xs)                 assign (#state % #returndata) truncpaddedOutput                 copyBytesToMemory truncpaddedOutput outSize (Lit 0) outOffset                 next@@ -1375,7 +1380,7 @@     assign #result $ Just $ HandleEffect (RunBoth c)   else do     vm <- get-    assign #result $ Just $ Unfinished (BranchTooDeep {pc = vm.state.pc})+    assign #result $ Just $ Unfinished (BranchTooDeep {pc = vm.state.pc, addr = vm.state.contract})  runAll :: Maybe Int -> Int -> RunAll s -> EVM Symbolic s () runAll depthLimit exploreDepth c = do@@ -1383,7 +1388,7 @@     assign #result $ Just $ HandleEffect (RunAll c)   else do     vm <- get-    assign #result $ Just $ Unfinished (BranchTooDeep {pc = vm.state.pc})+    assign #result $ Just $ Unfinished (BranchTooDeep {pc = vm.state.pc, addr = vm.state.contract})  fetchAccount :: VMOps t => Expr EAddr -> (Contract -> EVM t s ()) -> EVM t s () fetchAccount addr continue =@@ -1398,22 +1403,15 @@     Nothing -> case addr of       SymAddr _ -> fallback addr       LitAddr a -> do-        use (#cache % #fetched % at a) >>= \case-          Just c -> do+        base <- use (#config % #baseState)+        assign (#result) . Just . HandleEffect . Query $+          PleaseFetchContract a base $ \c -> do             assign (#env % #contracts % at addr) (Just c)+            assign #result Nothing             continue c-          Nothing -> do-            base <- use (#config % #baseState)-            assign (#result) . Just . HandleEffect . Query $-              PleaseFetchContract a base $ \c -> do-                assign (#cache % #fetched % at a) (Just c)-                assign (#env % #contracts % at addr) (Just c)-                assign #result Nothing-                continue c       GVar _ -> internalError "Unexpected GVar" -accessStorage-  :: (?conf :: Config, VMOps t) => Expr EAddr+accessStorage :: forall s t . (?conf :: Config, VMOps t, Typeable t) => Expr EAddr   -> Expr EWord   -> (Expr EWord -> EVM t s ())   -> EVM t s ()@@ -1428,31 +1426,35 @@       --     However, without concretization, it may not find things that are actually in the storage       case readStorage slot c.storage of         Just x -> case readStorage slotConc c.storage of-          Just _ -> continue x-          Nothing -> rpcCall c slotConc+          Just (Lit _) -> continue x+          Just _ | not c.external -> continue x+          _ -> rpcCall c slotConc         Nothing -> rpcCall c slotConc     Nothing ->-      fetchAccount addr $ \_ ->-        accessStorage addr slot continue+      fetchAccount addr $ \_ -> accessStorage addr slot continue   where       rpcCall c slotConc = fetchAccount addr $ \_ ->         if c.external         then forceConcreteAddr addr "cannot read storage from symbolic addresses via rpc" $ \addr' ->           forceConcrete slotConc "cannot read symbolic slots via RPC" $ \slot' -> do-            -- check if the slot is cached             use (#env % #contracts % at (LitAddr addr')) >>= \case               Nothing -> internalError $ "contract addr " <> show addr' <> " marked external not found in cache"-              Just fetched -> case readStorage (Lit slot') fetched.storage of-                          Nothing -> mkQuery addr' slot'-                          Just val -> continue val+              -- At this point, we know the contract is external and the underlying storage+              -- is concrete. Check if the slot has already been fetched+              Just contr -> if concStoreContains (Lit slot') contr.storage+                then continue $ SLoad (Lit slot') contr.storage+                else mkQuery addr' slot'         else do+          -- Symbolic address that cannot be cajoled/solved into a concrete one+          -- We cannot query the underlying storage, as we don't know which one to query+          -- So we store and return 0, as it is the only sound option           modifying (#env % #contracts % ix addr % #storage) (writeStorage slot (Lit 0))           continue $ Lit 0+      mkQuery :: Addr -> W256 -> EVM t s ()       mkQuery a s = query $ PleaseFetchSlot a s $ \x -> do-              modifying (#cache % #fetched % ix a % #storage) (writeStorage (Lit s) (Lit x))-              modifying (#env % #contracts % ix (LitAddr a) % #storage) (writeStorage (Lit s) (Lit x))-              assign #result Nothing-              continue $ Lit x+        modifying (#env % #contracts % ix (LitAddr a) % #storage) (writeStorage (Lit s) (Lit x))+        assign #result Nothing+        continue $ Lit x  accessTStorage   :: VMOps t => Expr EAddr@@ -1599,23 +1601,49 @@               EmptyBase -> const emptyContract   (#env % #contracts) %= (Map.insertWith (\_ e -> e) addr (mkc addr)) -forceAddr :: (?conf :: Config, VMOps t) =>+onlyDeployed :: forall t s . (?conf :: Config, VMOps t, Typeable t) =>   Expr EWord   -> (Expr EWord -> EVM t s ())   -> (Expr EAddr -> EVM t s ())   -> EVM t s ()-forceAddr n fallback continue = case wordToAddr n of-  Nothing -> manySolutions (?conf).maxDepth n 20 $ \case+onlyDeployed addrExpr fallback continue = do+    vm <- get+    if not (?conf.onlyDeployed) then fallback addrExpr+    else case eqT @t @Symbolic of+      Just Refl -> do+        let deployedAddrs = map forceEAddrToEWord $ mapMaybe (codeMustExist vm) $ Map.keys vm.env.contracts+        runAll (?conf.maxDepth) vm.exploreDepth $ PleaseRunAll addrExpr deployedAddrs runAllPaths+      _ -> internalError "Unknown address in Concrete mode"+  where+    codeMustExist :: (VM t s) -> Expr EAddr -> Maybe (Expr EAddr)+    codeMustExist vm addr = do+      contr <- Map.lookup addr vm.env.contracts+      case contr.code of+        RuntimeCode (ConcreteRuntimeCode _) -> Just addr+        _ -> Nothing+    runAllPaths val = do+        assign #result Nothing+        pushTo #constraints $ Expr.simplifyProp (addrExpr .== val)+        continue (forceEWordToEAddr val)++forceAddr :: forall t s . (?conf :: Config, VMOps t, Typeable t) =>+  Expr EWord+  -> (Expr EWord -> EVM t s ())+  -> (Expr EAddr -> EVM t s ())+  -> EVM t s ()+forceAddr addrExpr fallback continue = case wordToAddr addrExpr of+  Nothing -> manySolutions (?conf).maxDepth addrExpr 20 $ \case     Just sol -> continue $ LitAddr (truncateToAddr sol)-    Nothing -> fallback n+    Nothing -> onlyDeployed addrExpr fallback continue   Just c -> continue c + unexpectedSymArg :: (Typeable a, VMOps t) => String -> [Expr a] -> EVM t s () unexpectedSymArg msg n = do   pc <- use (#state % #pc)   state <- use #state   let opName = getOpName state-  partial $ UnexpectedSymbolicArg pc opName msg (wrap n)+  partial $ UnexpectedSymbolicArg pc state.contract opName msg (wrap n)  unexpectedSymArgW :: (Typeable a, VMOps t) => String -> Expr a -> EVM t s () unexpectedSymArgW msg n = unexpectedSymArg msg [n]@@ -1637,7 +1665,7 @@   let freshReturndataExpr = AbstractBuf (opName <> "-result-data-fresh-" <> (pack . show) freshVar)   modifying #constraints ((:) (PLEq (bufLength freshReturndataExpr) (Lit (2 ^ ?conf.maxBufSize))))   assign (#state % #returndata) freshReturndataExpr-  next >> assign (#state % #stack) (freshVarExpr:xs)+  next >> assign' (#state % #stack) (freshVarExpr:xs)  freshVarFallback:: (VMOps t, ?op :: Word8) => [Expr EWord] -> Expr a -> EVM t s () freshVarFallback xs _ = do@@ -1649,7 +1677,7 @@   assign #freshVar (freshVar + 1)   let opName = pack $ show $ getOp ?op   let freshVarExpr = Var (opName <> "-result-stack-fresh-" <> (pack . show) freshVar)-  next >> assign (#state % #stack) (freshVarExpr:xs)+  next >> assign' (#state % #stack) (freshVarExpr:xs)  forceConcrete :: (?conf :: Config, VMOps t) => Expr EWord -> String -> (W256 -> EVM t s ()) -> EVM t s () forceConcrete n = forceConcreteLimitSz n 32@@ -1737,7 +1765,7 @@ cheatCode = LitAddr $ unsafeInto (keccak' "hevm cheat code")  cheat-  :: forall t s . (?conf :: Config, ?op :: Word8, VMOps t)+  :: forall t s . (?conf :: Config, ?op :: Word8, VMOps t, Typeable t)   => Gas t -> (Expr EWord, Expr EWord) -> (Expr EWord, Expr EWord) -> [Expr EWord]   -> EVM t s () cheat gas (inOffset, inSize) (outOffset, outSize) xs = do@@ -1767,19 +1795,19 @@       case Map.lookup abi' cheatActions of         Nothing -> do           vm <- get-          partial $ CheatCodeMissing vm.state.pc abi'+          whenSymbolicElse (partial $ CheatCodeMissing vm.state.pc vm.state.contract abi') (vmError $ BadCheatCode "Cannot understand cheatcode." abi')         Just action -> action input  type CheatAction t s = Expr Buf -> EVM t s () -cheatActions :: (?conf :: Config, VMOps t) => Map FunctionSelector (CheatAction t s)+cheatActions :: (?conf :: Config, VMOps t, Typeable t) => Map FunctionSelector (CheatAction t s) cheatActions = Map.fromList   [ action "ffi(string[])" $       \sig input -> do         vm <- get         if vm.config.allowFFI then           case decodeBuf [AbiArrayDynamicType AbiStringType] input of-            CAbi valsArr -> case valsArr of+            (CAbi valsArr,"") -> case valsArr of               [AbiArrayDynamic AbiStringType strsV] ->                 let                   cmd = fmap@@ -1792,7 +1820,7 @@                 in query (PleaseDoFFI cmd vm.osEnv cont)               _ -> vmError (BadCheatCode "ffi(string[]) decoding of string failed" sig)             _ -> vmError (BadCheatCode "ffi(string[]) parameter decoding failed" sig)-        else unexpectedSymArg "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" ([] :: [Expr EWord])+        else vmError $ BadCheatCode "ffi disabled: run again with --ffi if you want to allow tests to call external scripts" sig    , action "warp(uint256)" $       \sig input -> case decodeStaticArgs 0 1 input of@@ -1893,11 +1921,11 @@    , action "createFork(string)" $       \sig input -> case decodeBuf [AbiStringType] input of-        CAbi valsArr -> case valsArr of+        (CAbi valsArr,"") -> case valsArr of           [AbiString bytes] -> do             forkId <- length <$> gets (.forks)             let urlOrAlias = Char8.unpack bytes-            modify' $ \vm -> vm { forks = vm.forks Seq.|> ForkState vm.env vm.block vm.cache urlOrAlias }+            modify' $ \vm -> vm { forks = vm.forks Seq.|> ForkState vm.env vm.block vm.pathsVisited urlOrAlias }             frameReturn $ AbiUInt 256 (fromIntegral forkId)           _ -> vmError (BadCheatCode "createFork(string) string provided may be incorrect?" sig)         _ -> vmError (BadCheatCode "createFork(string) parameter decoding failed" sig)@@ -1924,7 +1952,7 @@                       { env = newEnv                       , block = forkState.block                       , forks = Seq.adjust' (\state -> (state :: ForkState)-                          { env = vm.env, block = vm.block, cache = vm.cache }+                          { env = vm.env, block = vm.block, pathsVisited = vm.pathsVisited }                         ) vm.currentFork  vm.forks                       , currentFork = forkId'                       }@@ -1940,7 +1968,7 @@    , action "label(address,string)" $       \sig input -> case decodeBuf [AbiAddressType, AbiStringType] input of-        CAbi valsArr -> case valsArr of+        (CAbi valsArr,"") -> case valsArr of           [AbiAddress addr, AbiString label] -> do             #labels %= Map.insert addr (decodeUtf8 label)             doStop@@ -1949,7 +1977,7 @@    , action "setEnv(string,string)" $       \sig input -> case decodeBuf [AbiStringType, AbiStringType] input of-        CAbi valsArr -> case valsArr of+        (CAbi valsArr,"") -> case valsArr of           [AbiString variable, AbiString value] -> do             let (varStr, varVal) = (toString variable, toString value)             #osEnv %= Map.insert varStr varVal@@ -1976,9 +2004,9 @@   , $(envReadMultipleCheat "envBytes(bytes,bytes)" AbiBytesDynamicType) stringHexToByteString   , action "assertTrue(bool)" $ \sig input ->       case decodeBuf [AbiBoolType] input of-        CAbi [AbiBool True] -> doStop-        CAbi [AbiBool False] -> frameRevert "assertion failed"-        SAbi [eword] -> case (Expr.simplify (Expr.iszero eword)) of+        (CAbi [AbiBool True],"") -> doStop+        (CAbi [AbiBool False],"") -> frameRevert "assertion failed"+        (SAbi [eword],"") -> case (Expr.simplify (Expr.iszero eword)) of           Lit 1 -> frameRevert "assertion failed"           Lit 0 -> doStop           ew -> branch (?conf).maxDepth ew $ \case@@ -1987,9 +2015,9 @@         k -> vmError $ BadCheatCode ("assertTrue(bool) parameter decoding failed: " <> show k) sig   , action "assertFalse(bool)" $ \sig input ->       case decodeBuf [AbiBoolType] input of-        CAbi [AbiBool False] -> doStop-        CAbi [AbiBool True] -> frameRevert "assertion failed"-        SAbi [eword] -> case (Expr.simplify (Expr.iszero eword)) of+        (CAbi [AbiBool False],"") -> doStop+        (CAbi [AbiBool True],"") -> frameRevert "assertion failed"+        (SAbi [eword],"") -> case (Expr.simplify (Expr.iszero eword)) of           Lit 0 -> frameRevert "assertion failed"           Lit 1 -> doStop           ew -> branch (?conf).maxDepth ew $ \case@@ -2018,6 +2046,13 @@   , action "assertGt(int256,int256)"   $ assertSGt (AbiIntType 256)   , action "assertGe(uint256,uint256)" $ assertGe (AbiUIntType 256)   , action "assertGe(int256,int256)"   $ assertSGe (AbiIntType 256)+  --+  , action "toString(address)" $ toStringCheat AbiAddressType+  , action "toString(bool)"    $ toStringCheat AbiBoolType+  , action "toString(uint256)" $ toStringCheat (AbiUIntType 256)+  , action "toString(int256)"  $ toStringCheat (AbiIntType 256)+  , action "toString(bytes32)" $ toStringCheat (AbiBytesType 32)+  , action "toString(bytes)"   $ toStringCheat AbiBytesDynamicType   ]   where     action s f = (abiKeccak s, f (abiKeccak s))@@ -2063,9 +2098,9 @@       BS8.pack (show a) <> " " <> comp <> " " <> BS8.pack (show b)     genAssert comp exprComp invComp name abitype sig input = do       case decodeBuf [abitype, abitype] input of-        CAbi [a, b] | a `comp` b -> doStop-        CAbi [a, b] -> revertErr a b invComp-        SAbi [ew1, ew2] -> case (Expr.simplify (Expr.iszero $ exprComp ew1 ew2)) of+        (CAbi [a, b],"") | a `comp` b -> doStop+        (CAbi [a, b],"")-> revertErr a b invComp+        (SAbi [ew1, ew2],"") -> case (Expr.simplify (Expr.iszero $ exprComp ew1 ew2)) of           Lit 0 -> doStop           Lit _ -> revertErr ew1 ew2 invComp           ew -> branch (?conf).maxDepth ew $ \case@@ -2082,11 +2117,15 @@     assertSLe =   genAssert (<=) (\a b -> Expr.iszero $ Expr.sgt a b) ">" "assertLe"     assertGe =    genAssert (>=) Expr.geq "<" "assertGe"     assertSGe =   genAssert (>=) (\a b -> Expr.iszero $ Expr.slt a b) "<" "assertGe"+    toStringCheat abitype sig input = do+      case decodeBuf [abitype] input of+        (CAbi [val],"") -> frameReturn $ AbiTuple $ V.fromList [AbiString $ Char8.pack $ show val]+        _ -> vmError (BadCheatCode ("toString parameter decoding failed for " <> show abitype) sig)  -- * General call implementation ("delegateCall") -- note that the continuation is ignored in the precompile case delegateCall-  :: (VMOps t, ?op :: Word8, ?conf :: Config)+  :: forall t s . (VMOps t, ?op :: Word8, ?conf :: Config, Typeable t)   => Contract   -> Gas t   -> Expr EAddr@@ -2113,49 +2152,55 @@           resetCaller <- use $ #state % #resetCaller           when resetCaller $ assign (#state % #overrideCaller) Nothing           vm0 <- get-          fetchAccountWithFallback xTo fallback $ \target -> case target.code of-              UnknownCode _ -> fallback xTo-              _ -> do-                burn' xGas $ do-                  calldata <- readMemory xInOffset xInSize-                  abi <- maybeLitWordSimp . readBytes 4 (Lit 0) <$> readMemory xInOffset (Lit 4)-                  let newContext = CallContext-                                    { target    = xTo-                                    , context   = xContext-                                    , offset    = xOutOffset-                                    , size      = xOutSize-                                    , codehash  = target.codehash-                                    , callreversion = vm0.env.contracts-                                    , subState  = vm0.tx.subState-                                    , abi-                                    , calldata-                                    }-                  pushTrace (FrameTrace newContext)-                  next-                  vm1 <- get-                  pushTo #frames $ Frame-                    { state = vm1.state { stack = xs }-                    , context = newContext-                    }+          fetchAccountWithFallback xTo (betterFallback xGas vm0) $ \target -> case target.code of+              UnknownCode _ -> betterFallback xGas vm0 xTo+              _ -> actualCall target xTo xGas vm0+  where+    betterFallback :: Gas t -> (VM t s) -> Expr 'EAddr -> EVM t s ()+    betterFallback xGas vm0 addr = onlyDeployed (forceEAddrToEWord addr) (fallback . forceEWordToEAddr) $ \a -> do+        let target = fromJust $ Map.lookup a vm0.env.contracts+        actualCall target a xGas vm0+    actualCall target addr xGas vm0 = do+        burn' xGas $ do+          calldata <- readMemory xInOffset xInSize+          abi <- maybeLitWordSimp . readBytes 4 (Lit 0) <$> readMemory xInOffset (Lit 4)+          let newContext = CallContext+                            { target    = addr+                            , context   = xContext+                            , offset    = xOutOffset+                            , size      = xOutSize+                            , codehash  = target.codehash+                            , callreversion = vm0.env.contracts+                            , subState  = vm0.tx.subState+                            , abi+                            , calldata+                            }+          pushTrace (FrameTrace newContext)+          next+          vm1 <- get+          pushTo #frames $ Frame+            { state = vm1.state { stack = xs }+            , context = newContext+            } -                  let clearInitCode = \case-                        (InitCode _ _) -> InitCode mempty mempty-                        a -> a+          let clearInitCode = \case+                (InitCode _ _) -> InitCode mempty mempty+                a -> a -                  newMemory <- ConcreteMemory <$> VS.Mutable.new 0-                  zoom #state $ do-                    assign #gas xGas-                    assign #pc 0-                    assign #code (clearInitCode target.code)-                    assign #codeContract xTo-                    assign #stack mempty-                    assign #memory newMemory-                    assign #memorySize 0-                    assign #returndata mempty-                    assign #calldata calldata-                    assign #overrideCaller Nothing-                    assign #resetCaller False-                  continue xTo+          newMemory <- ConcreteMemory <$> VS.Mutable.new 0+          zoom #state $ do+            assign #gas xGas+            assign #pc 0+            assign #code (clearInitCode target.code)+            assign #codeContract addr+            assign #stack mempty+            assign #memory newMemory+            assign #memorySize 0+            assign #returndata mempty+            assign #calldata calldata+            assign #overrideCaller Nothing+            assign #resetCaller False+          continue addr  -- -- * Contract creation @@ -2176,20 +2221,20 @@   -- are we exceeding the max init code size   if xSize > Lit (vm0.block.maxCodeSize * 2)   then do-    assign (#state % #stack) (Lit 0 : xs)+    assign' (#state % #stack) (Lit 0 : xs)     assign (#state % #returndata) mempty     vmError $ MaxInitCodeSizeExceeded (vm0.block.maxCodeSize * 2) xSize   -- are we overflowing the nonce   else if this.nonce == Just maxBound   then do-    assign (#state % #stack) (Lit 0 : xs)+    assign' (#state % #stack) (Lit 0 : xs)     assign (#state % #returndata) mempty     pushTrace $ ErrorTrace NonceOverflow     next   -- are we overflowing the stack   else if length vm0.frames >= 1024   then do-    assign (#state % #stack) (Lit 0 : xs)+    assign' (#state % #stack) (Lit 0 : xs)     assign (#state % #returndata) mempty     pushTrace $ ErrorTrace CallDepthLimitReached     next@@ -2199,14 +2244,14 @@   -- safe to perform statically   else if collision $ Map.lookup newAddr vm0.env.contracts   then burn' xGas $ do-    assign (#state % #stack) (Lit 0 : xs)+    assign' (#state % #stack) (Lit 0 : xs)     assign (#state % #returndata) mempty     modifying (#env % #contracts % ix self % #nonce) (fmap ((+) 1))     next   -- do we have enough balance   else branch (?conf).maxDepth (Expr.gt xValue this.balance) $ \case       True -> do-        assign (#state % #stack) (Lit 0 : xs)+        assign' (#state % #stack) (Lit 0 : xs)         assign (#state % #returndata) mempty         pushTrace $ ErrorTrace $ BalanceTooLow xValue this.balance         next@@ -2451,6 +2496,7 @@                     Nothing -> partial $                       UnexpectedSymbolicArg                         oldVm.state.pc+                        oldVm.state.contract                         (getOpName oldVm.state)                         "runtime code cannot have an abstract length"                         (wrap [output])@@ -2641,11 +2687,11 @@ push = pushSym . Lit  pushSym :: Expr EWord -> EVM t s ()-pushSym x = #state % #stack %= (x :)+pushSym x = modifying' (#state % #stack) (x :)  pushAddr :: Expr EAddr -> EVM t s ()-pushAddr (LitAddr x) = #state % #stack %= (Lit (into x) :)-pushAddr x@(SymAddr _) = #state % #stack %= (WAddr x :)+pushAddr (LitAddr x) = modifying' (#state % #stack) (Lit (into x) :)+pushAddr x@(SymAddr _) = modifying' (#state % #stack) (WAddr x :) pushAddr (GVar _) = internalError "Unexpected GVar"  stackOp1@@ -2659,7 +2705,7 @@       burn cost $ do         next         let !y = f x-        #state % #stack .= y : xs+        assign' (#state % #stack) $ y : xs     _ ->       underrun @@ -2673,7 +2719,7 @@     x:y:xs ->       burn cost $ do         next-        #state % #stack .= f x y : xs+        assign' (#state % #stack) $ f x y : xs     _ ->       underrun @@ -2687,7 +2733,7 @@     x:y:z:xs ->       burn cost $ do       next-      (#state % #stack) .= f x y z : xs+      assign' (#state % #stack) $ f x y z : xs     _ ->       underrun @@ -2698,8 +2744,8 @@   vm <- get   case isValidJumpDest vm x of     True -> do-      #state % #stack .= xs-      #state % #pc .= x+      assign' (#state % #stack) xs+      assign' (#state % #pc) x     False -> vmError BadJumpDestination  -- fails with partial if we're trying to jump into the symbolic region of an `InitCode`@@ -2713,7 +2759,7 @@     -- init code has a symbolic region, so check if we're trying to jump into     -- the symbolic region and return partial if we are     InitCode ops _ -> if idx > BS.length ops-                      then partial $ JumpIntoSymbolicCode vm.state.pc idx+                      then partial $ JumpIntoSymbolicCode vm.state.pc vm.state.contract idx                       else cont     -- we're not executing init code, so nothing to check here     _ -> cont@@ -2767,7 +2813,7 @@  mkOpIxMap (RuntimeCode (SymbolicRuntimeCode ops))   = VS.create $ VS.Mutable.new (length ops) >>= \v ->-      let (_, _, _, m) = foldl (go v) (0, 0, 0, pure ()) (stripBytecodeMetadataSym $ V.toList ops)+      let (_, _, _, m) = foldl' (go v) (0, 0, 0, pure ()) (stripBytecodeMetadataSym $ V.toList ops)       in m >> pure v       where         go v (0, !i, !j, !m) x = case maybeLitByteSimp x of@@ -2970,8 +3016,8 @@ writeMemory :: MutableMemory s -> Int -> ByteString -> EVM t s () writeMemory memory offset buf = do   memory' <- expandMemory (offset + BS.length buf)-  mapM_ (uncurry (VS.Mutable.write memory'))-        (zip [offset..] (BS.unpack buf))+  VS.iforM_ (byteStringToVector buf) $ \i v -> do+    VS.Mutable.unsafeWrite memory' (offset + i) v   where   expandMemory requiredSize = do     let currentSize = VS.Mutable.length memory@@ -3032,11 +3078,11 @@       condSimpConc = Expr.concKeccakSimpExpr condSimp       runBothPaths loc _ (Case v) = do         assign #result Nothing-        pushTo #constraints $ if v then Expr.simplifyProp (condSimpConc ./= Lit 0)-                                   else Expr.simplifyProp (condSimpConc .== Lit 0)+        pushTo #constraints $ if v then Expr.simplifyProp (Lit 0 ./= condSimpConc)+                                   else Expr.simplifyProp (Lit 0 .== condSimpConc)         (iteration, _) <- use (#iterations % at loc % non (0,[]))         stack <- use (#state % #stack)-        assign (#cache % #path % at (loc, iteration)) (Just v)+        assign (#pathsVisited % at (loc, iteration)) (Just v)         assign (#iterations % at loc) (Just (iteration + 1, stack))         continue v       -- Both paths are possible; we ask for more input@@ -3046,7 +3092,7 @@   -- numBytes allows us to specify how many bytes of the returned value is relevant   -- if it's e.g.a JUMP, only 2 bytes can be relevant. This allows us to avoid   -- getting solutions that are nonsensical-  manySolutions depthLimit ewordExpr numBytes continue = do+  manySolutions maxDepth ewordExpr numBytes continue = do     pathconds <- use #constraints     vm <- get     query $ PleaseGetSols ewordExpr numBytes pathconds $ \case@@ -3060,15 +3106,17 @@             assign #result Nothing             pushTo #constraints $ Expr.simplifyProp (ewordExpr .== (Lit val))             continue $ Just val-          _ -> runAll depthLimit vm.exploreDepth $ PleaseRunAll ewordExpr concVals runAllPaths+          _ -> runAll maxDepth vm.exploreDepth $ PleaseRunAll ewordExpr (map Lit concVals) runAllPaths       Nothing -> do         assign #result Nothing         continue Nothing     where       runAllPaths val = do         assign #result Nothing-        pushTo #constraints $ Expr.simplifyProp (ewordExpr .== Lit val)-        continue $ Just val+        pushTo #constraints $ Expr.simplifyProp (ewordExpr .== val)+        case val of+          Lit v -> continue $ Just v+          _ -> internalError "runAllPaths can only get concrete values here"  instance VMOps Concrete where   burn' n continue = do@@ -3221,9 +3269,6 @@     VMFailure e -> VMFailure e     VMSuccess b -> VMSuccess b -forceLit :: Expr EWord -> W256-forceLit (Lit w) = w-forceLit _ = internalError "concrete vm, shouldn't ever happen"  burn :: VMOps t => Word64 -> EVM t s () -> EVM t s () burn = burn' . toGas

@@ -38,6 +38,7 @@   , Anonymity (..)   , Indexed (..)   , Sig(..)+  , callSig   , putAbi   , getAbi   , getAbiSeq@@ -58,6 +59,8 @@   , showAlter   ) where +import Prelude hiding (Foldable(..))+ import EVM.Expr (readWord, isLitWord) import EVM.Types import EVM.Expr (maybeLitWordSimp)@@ -66,7 +69,7 @@ import Control.Monad (replicateM, replicateM_, forM_, void) import Data.Binary.Get (Get, runGet, runGetOrFail, label, getWord8, getWord32be, skip) import Data.Binary.Put (Put, runPut, putWord8, putWord32be)-import Data.Bits (shiftL, shiftR, (.&.))+import Data.Bits (shiftL, shiftR, (.&.), testBit, bit, complement, (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as BS16@@ -75,13 +78,14 @@ import Data.Char (isHexDigit) import Data.Data (Data) import Data.DoubleWord (Word256, Int256, signedWord)+import Data.Foldable (Foldable(..)) import Data.Functor (($>)) import Data.List (intercalate) import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding (encodeUtf8)-import Data.Vector (Vector, toList)+import Data.Vector (Vector) import Data.Vector qualified as Vector import Data.Word (Word32) import GHC.Generics (Generic)@@ -223,7 +227,13 @@       xs <- replicateM word32Count getWord32be       pure (AbiUInt n (pack32 word32Count xs)) -    AbiIntType n   -> asUInt n (AbiInt n)+    AbiIntType 256 -> asUInt 256 (AbiInt 256)+    AbiIntType n  -> do+      (AbiUInt _ w) <- getAbi (AbiUIntType n)+      let truncate' n' w' = w' .&. (bit n' - 1)+      let signExtend n' w' = if testBit w' (n' - 1) then w' .|. complement (bit n' - 1) else w'+      pure (AbiInt n (fromIntegral $ (signExtend n) . (truncate' n) $ w))+     AbiAddressType -> asUInt 256 AbiAddress     AbiBoolType    -> asUInt 256 (AbiBool . (> (0 :: Integer))) @@ -390,7 +400,7 @@     parseSize t "" = AbiArrayDynamicType t     parseSize t s  = AbiArrayType (read s) t -  pure (foldl parseSize base sizes)+  pure (foldl' parseSize base sizes)  basicType :: Vector AbiType -> P.Parsec () Text AbiType basicType v =@@ -502,22 +512,21 @@ data AbiVals = NoVals | CAbi [AbiValue] | SAbi [Expr EWord]   deriving (Show) -decodeBuf :: [AbiType] -> Expr Buf -> AbiVals+decodeBuf :: [AbiType] -> Expr Buf -> (AbiVals, String) decodeBuf tps (ConcreteBuf b) =   case runGetOrFail (getAbiSeq (length tps) tps) (BSLazy.fromStrict b) of-    Right ("", _, args) -> CAbi (toList args)-    _ -> NoVals+    Right ("", _, args) -> (CAbi (toList args), "")+    Right (str, _, args) -> (CAbi (toList args), "with trailing bytes: " ++ show (BSLazy.unpack str))+    Left (_, _, err) -> (NoVals, "error decoding abi: " ++ err) decodeBuf tps buf =-  if any isDynamic tps then NoVals+  if any isDynamic tps then (NoVals, "dynamic types not supported in symbolic decoding")   else     let       vs = decodeStaticArgs 0 (length tps) buf       asBS = mconcat $ fmap word256Bytes (mapMaybe maybeLitWordSimp vs)     in if not (all isLitWord vs)-       then SAbi vs-       else case runGetOrFail (getAbiSeq (length tps) tps) (BSLazy.fromStrict asBS) of-         Right ("", _, args) -> CAbi (toList args)-         _ -> NoVals+       then (SAbi vs, "")+       else decodeBuf tps (ConcreteBuf asBS)   where     isDynamic t = abiKind t == Dynamic @@ -614,3 +623,6 @@        smol <- choose (into mn `max` (-k), mx `min` k)        mid <- choose (0, maxbound)        elements [fromIntegral smol, fromIntegral mid, fromIntegral (maxbound - (fromIntegral smol))]++callSig :: Sig -> Text+callSig (Sig name args) = name <> "(" <> (Text.intercalate "," (map abiTypeSolidity args)) <> ")"

@@ -30,7 +30,7 @@   \wrap convert ->     action $sigL $       \sig input -> case decodeBuf [AbiStringType] input of-        CAbi [AbiString variable] -> let+        (CAbi [AbiString variable],"") -> let           varStr = toString variable           cont value = continueOnce $ do             either' (convert value) frameRevert $ \v ->@@ -50,7 +50,7 @@   \convert ->     action $sigL $       \sig input -> case decodeBuf [AbiStringType, AbiStringType] input of-        CAbi [AbiString variable, AbiString delimiter] -> let+        (CAbi [AbiString variable, AbiString delimiter],"") -> let           (varStr, delimStr) = (toString variable, toString delimiter)           cont value = continueOnce $ do             let (errors, values) = partitionEithers $ map convert $ splitOn delimStr value

@@ -35,13 +35,9 @@   { dumpQueries      :: Bool   , dumpExprs        :: Bool   , dumpEndStates    :: Bool+  , dumpUnsolved     :: Maybe FilePath   , debug            :: Bool   , dumpTrace        :: Bool-  , numCexFuzz       :: Integer-   -- Used to debug fuzzer in test.hs. It disables the SMT solver-   -- and uses the fuzzer ONLY to try to find a counterexample.-   -- Returns Unknown if the Cex cannot be found via fuzzing-  , onlyCexFuzz      :: Bool   , decomposeStorage :: Bool   , promiseNoReent   :: Bool   , maxBufSize       :: Int@@ -49,6 +45,7 @@   , maxDepth         :: Maybe Int   , verb             :: Int   , simp             :: Bool+  , onlyDeployed     :: Bool   }   deriving (Show, Eq) @@ -57,10 +54,9 @@   { dumpQueries = False   , dumpExprs = False   , dumpEndStates = False+  , dumpUnsolved = Nothing   , debug = False   , dumpTrace = False-  , numCexFuzz = 10-  , onlyCexFuzz  = False   , decomposeStorage = True   , promiseNoReent = False   , maxBufSize = 64@@ -68,6 +64,7 @@   , maxDepth = Nothing   , verb = 0   , simp = True+  , onlyDeployed = False   }  -- Write to the console

@@ -11,6 +11,7 @@ import Optics.Core import Control.Monad.ST (ST) import EVM.Effects (Config)+import Data.Data (Typeable)  ethrunAddress :: Addr ethrunAddress = Addr 0x00a329c0648769a73afac7f9381e08fb43dbea72@@ -47,14 +48,14 @@     }) <&> set (#env % #contracts % at (LitAddr ethrunAddress))              (Just (initialContract (RuntimeCode (ConcreteRuntimeCode "")))) -exec :: (VMOps t) => Config -> EVM t s (VMResult t s)+exec :: (VMOps t, Typeable t) => Config -> EVM t s (VMResult t s) exec conf = do   vm <- get   case vm.result of     Nothing -> exec1 conf >> exec conf     Just r -> pure r -run :: (VMOps t) => Config -> EVM t s (VM t s)+run :: (VMOps t, Typeable t) => Config -> EVM t s (VM t s) run conf = do   vm <- get   case vm.result of

@@ -27,7 +27,7 @@ import Data.Vector.Storable qualified as VS import Data.Vector.Storable.ByteString import Data.Word (Word8, Word32)-import Witch (unsafeInto, into, tryFrom, tryInto)+import Witch (unsafeInto, into, tryInto) import Data.Containers.ListUtils (nubOrd)  import Optics.Core@@ -44,7 +44,7 @@ maxLitSigned = 0x7fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff  minLitSigned :: W256-minLitSigned = 0x1000000000000000000000000000000000000000000000000000000000000000+minLitSigned = 0x8000000000000000000000000000000000000000000000000000000000000000  -- ** Stack Ops ** --------------------------------------------------------------------------------- @@ -278,6 +278,7 @@  -- | Reads the word starting at idx from the given buf readWord :: Expr EWord -> Expr Buf -> Expr EWord+readWord idx buf@(AbstractBuf _) = ReadWord idx buf readWord idx b@(WriteWord idx' val buf)   -- the word we are trying to read exactly matches a WriteWord   | idx == idx' = val@@ -291,9 +292,11 @@     -- we do not have enough information to statically determine whether or not     -- the region we want to read overlaps the WriteWord     _ -> readWordFromBytes idx b+readWord i@(Lit idx) (WriteByte (Lit idx') _ buf)+  | idx' < idx || (idx' >= idx + 32 && idx <= (maxBound :: W256) - 32) = readWord i buf -- reading a Word that is lower than the dstOffset-32 of a CopySlice, so it's just reading from dst-readWord i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst) | dstOffset >= x+32 =-  readWord i dst+readWord i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst) | dstOffset >= x+32 = readWord i dst+readWord i@(Lit x) (CopySlice _ (Lit dstOffset) (Lit size) _ dst) | x >= dstOffset + size = readWord i dst readWord (Lit idx) b@(CopySlice (Lit srcOff) (Lit dstOff) (Lit size) src dst)   -- the region we are trying to read is enclosed in the sliced region   | (idx - dstOff) < size && 32 <= size - (idx - dstOff) = readWord (Lit $ srcOff + (idx - dstOff)) src@@ -310,6 +313,7 @@   case tryInto idx of     Left _ -> Lit 0     Right i -> Lit $ word $ padRight 32 $ BS.take 32 $ BS.drop i bs+readWordFromBytes idx buf@(AbstractBuf _) = ReadWord idx buf readWordFromBytes i@(Lit idx) buf = let     bytes = [readByte (Lit i') buf | i' <- [idx .. idx + 31]]   in if all isLitByte bytes@@ -579,41 +583,10 @@ -- | Removes any irrelevant writes when reading from a buffer simplifyReads :: Expr a -> Expr a simplifyReads = \case-  ReadWord (Lit idx) b -> readWord (Lit idx) (stripWrites idx 32 b)-  ReadByte (Lit idx) b -> readByte (Lit idx) (stripWrites idx 1 b)+  ReadWord (Lit idx) b -> readWord (Lit idx) b+  ReadByte (Lit idx) b -> readByte (Lit idx) b   a -> a --- | Strips writes from the buffer that can be statically determined to be out of range--- TODO: are the bounds here correct? I think there might be some off by one mistakes...-stripWrites :: W256 -> W256 -> Expr Buf -> Expr Buf-stripWrites off size = \case-  AbstractBuf s -> AbstractBuf s-  ConcreteBuf b -> ConcreteBuf $ case off <= off + size of-                                    True -> case tryFrom @W256 (off + size) of-                                      Right n -> BS.take n b-                                      Left _ -> b-                                    False -> b-  WriteByte (Lit idx) v prev-    -> if idx - off >= size-       then stripWrites off size prev-       else WriteByte (Lit idx) v (stripWrites off size prev)-  -- TODO: handle partial overlaps-  WriteWord (Lit idx) v prev-    -> if idx - off >= size && idx - off <= (maxBound :: W256) - 31-       then stripWrites off size prev-       else WriteWord (Lit idx) v (stripWrites off size prev)-  CopySlice (Lit srcOff) (Lit dstOff) (Lit size') src dst-    -> if dstOff - off >= size && dstOff - off <= (maxBound :: W256) - size' - 1-       then stripWrites off size dst-       else CopySlice (Lit srcOff) (Lit dstOff) (Lit size')-                      (stripWrites srcOff size' src)-                      (stripWrites off size dst)-  WriteByte i v prev -> WriteByte i v (stripWrites off size prev)-  WriteWord i v prev -> WriteWord i v (stripWrites off size prev)-  CopySlice srcOff dstOff size' src dst -> CopySlice srcOff dstOff size' src dst-  GVar _ ->  internalError "Unexpected GVar in stripWrites"-- -- ** Storage ** -----------------------------------------------------------------------------------  @@ -753,7 +726,7 @@        y32 = BS.take 32 $ BS.drop 32 y  slotPos :: Word8 -> ByteString-slotPos pos = BS.pack ((replicate 31 (0::Word8))++[pos])+slotPos pos = BS.replicate 31 0 <> BS.singleton pos  -- Optimized litToArrayPreimage using the pre-computed map litToArrayPreimage :: W256 -> Maybe (Word8, W256)@@ -810,6 +783,15 @@               _ -> SStore key val store writeStorage key val store = SStore key val store +-- Used to check if the underlying concrete store contains a key. Used to decide+-- if we need to fetch a storage slot from RPC or not+concStoreContains :: Expr EWord -> Expr Storage -> Bool+concStoreContains k@(Lit key) store = case store of+  ConcreteStore s -> Map.member key s+  SStore _ _ s -> concStoreContains k s+  AbstractStore _ _ -> internalError "cannot read deeply into an AbstractStore"+  GVar _ -> internalError "cannot read to a GVar"+concStoreContains _ _ = internalError "readDeepStorage only supports concrete keys"  getAddr :: Expr Storage -> Maybe (Expr EAddr) getAddr (SStore _ _ p) = getAddr p@@ -1022,13 +1004,17 @@     -- We can zero out any bytes in a base ConcreteBuf that we know will be overwritten by a later write     -- TODO: make this fully general for entire write chains, not just a single write.     go o@(WriteWord (Lit idx) val (ConcreteBuf b))-      | idx < maxBytes-        = (writeWord (Lit idx) val (-            ConcreteBuf $-              (BS.take (unsafeInto idx) (padRight (unsafeInto idx) b))-              <> (BS.replicate 32 0)-              <> (BS.drop (unsafeInto idx + 32) b)))-      | otherwise = o+      | idx >= maxBytes = o+      | BS.length b >= (unsafeInto idx + 32) =+          let+            slot = BS.take 32 (BS.drop (unsafeInto idx) b)+            isSlotZero = BS.all (== 0) slot+            content = if isSlotZero+              then b+              else (BS.take (unsafeInto idx) b)+                <> (BS.replicate 32 0)+                <> (BS.drop (unsafeInto idx + 32) b)+          in writeWord (Lit idx) val (ConcreteBuf content)     go (WriteWord a b c) = writeWord a b c      go (WriteByte a b c) = writeByte a b c@@ -1367,6 +1353,7 @@     go (PLEq a (Max b _)) | a == b = PBool True     go (PLEq a (Max _ b)) | a == b = PBool True     go (PLEq (Sub a b) c) | a == c = PLEq b a+    go (PLEq a (Lit 0)) = peq (Lit 0) a     go (PLT (Max (Lit a) b) (Lit c)) | a < c = PLT b (Lit c)     go (PLT (Lit 0) (Eq a b)) = peq a b     go (PLEq a b) = pleq a b@@ -1393,13 +1380,13 @@      -- Empty buf     go (PEq (Lit 0) (BufLength k)) = peq k (ConcreteBuf "")-    go (PEq (Lit 0) (Or a b)) = peq a (Lit 0) `PAnd` peq b (Lit 0)+    go (PEq (Lit 0) (Or a b)) = peq (Lit 0) a `PAnd` peq (Lit 0) b      -- PEq rewrites (notice -- GT/GEq is always rewritten to LT by simplify)     go (PEq (Lit 1) (IsZero (LT a b))) = PLT a b     go (PEq (Lit 1) (IsZero (LEq a b))) = PLEq a b     go (PEq (Lit 0) (IsZero a)) = PLT (Lit 0) a-    go (PEq a1 (Add a2 y)) | a1 == a2 = peq y (Lit 0)+    go (PEq a1 (Add a2 y)) | a1 == a2 = peq (Lit 0) y      -- solc specific stuff     go (PLT (Lit 0) (IsZero (Eq a b))) = PNeg (peq a b)@@ -1703,9 +1690,6 @@  inRange :: Int -> Expr EWord -> Prop inRange sz e = if sz == 256 then PBool True else PLEq e (Lit $ 2 ^ sz - 1)--inRangeSigned :: Int -> Expr EWord -> Prop-inRangeSigned sz e = ((PLEq e (Lit $ 2 ^ (sz - 1) - 1)) `POr` (PGEq e $ Lit $ ((2 ^ sz) - 2 ^ (sz -  1))))  -- | images of keccak(bytes32(x)) where 0 <= x < 256 preImages :: [(W256, Word8)]

@@ -1,5 +1,26 @@-module EVM.Fetch where +module EVM.Fetch+  ( fetchContractWithSession+  , fetchBlockWithSession+  , fetchSlotWithSession+  , fetchWithSession+  , fetchQuery+  , oracle+  , Fetcher+  , RpcInfo (..)+  , RpcQuery (..)+  , EVM.Fetch.zero+  , readMockData+  , BlockNumber (..)+  , mkRpcInfo+  , mkSession+  , Session (..)+  , FetchCache (..)+  , addFetchCache+  ) where++import Prelude hiding (Foldable(..))+ import EVM (initialContract, unknownContract) import EVM.ABI import EVM.FeeSchedule (feeSchedule)@@ -12,17 +33,19 @@ import Optics.Core  import Control.Monad.Trans.Maybe+import Control.Applicative (Alternative(..)) import Data.Aeson hiding (Error) import Data.Aeson.Optics import Data.ByteString qualified as BS import Data.Text (Text, unpack, pack)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Foldable (Foldable(..)) import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe)-import Data.List (foldl')+import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Vector qualified as RegularVector import Network.Wreq-import Network.Wreq.Session (Session)-import Network.Wreq.Session qualified as Session+import Network.Wreq.Session qualified as NetSession import Numeric.Natural (Natural) import System.Environment (lookupEnv, getEnvironment) import System.Process@@ -30,7 +53,31 @@ import Control.Monad (when) import EVM.Effects import qualified EVM.Expr as Expr+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.ByteString.Base16 qualified as BS16+import qualified Data.ByteString.Lazy as BSL+import Data.ByteString.Char8 qualified as Char8+import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_) +type Fetcher t m s = App m => Query t s -> m (EVM t s ())++data Session = Session+  { sess           :: NetSession.Session+  , latestBlockNum :: MVar (Maybe W256)+  , sharedCache    :: MVar FetchCache+  }++data FetchCache = FetchCache+  { contractCache :: Map.Map Addr Contract+  , slotCache     :: Map.Map (Addr, W256) W256+  , blockCache    :: Map.Map W256 Block+  }+instance Show FetchCache where+  show (FetchCache c s b) =+    "FetchCache { contractCache: " ++ show (Map.keys c) +++    ", slotCache: " ++ show (Map.keys s) +++    ", blockCache: " ++ show (Map.keys b) ++ " }"+ -- | Abstract representation of an RPC fetch request data RpcQuery a where   QueryCode    :: Addr         -> RpcQuery BS.ByteString@@ -45,8 +92,29 @@  deriving instance Show (RpcQuery a) -type RpcInfo = Maybe (BlockNumber, Text)+data RPCContract = RPCContract+  { mcCode    :: BS.ByteString+  , mcNonce   :: W64+  , mcBalance :: W256+  }+  deriving (Eq, Show) +data RpcInfo = RpcInfo+  { blockNumURL  :: Maybe (BlockNumber, Text) -- ^ (block number, RPC url)+  , mockContract :: Maybe (Map.Map Addr RPCContract) -- ^ mock contracts (addr -> contract)+  , mockSlot     :: Maybe (Map.Map (Addr, W256) W256) -- ^ mock storage slots (addr, slot) -> value+  , mockBlock    :: Maybe (Map.Map W256 Block) -- ^ mock blocks (block number -> block)+  }+  deriving (Show)+instance Semigroup RpcInfo where+  RpcInfo a1 a2 a3 a4 <> RpcInfo b1 b2 b3 b4 =+    RpcInfo (a1 <|> b1) (a2 <|> b2) (a3 <|> b3) (a4 <|> b4)+instance Monoid RpcInfo where+  mempty = RpcInfo Nothing Nothing Nothing Nothing++mkRpcInfo :: Maybe (BlockNumber, Text) -> MockData -> RpcInfo+mkRpcInfo blockNumURL (MockData {..}) = RpcInfo blockNumURL mockContract mockSlot mockBlock+ rpc :: String -> [Value] -> Value rpc method args = object   [ "jsonrpc" .= ("2.0" :: String)@@ -74,6 +142,11 @@ readText :: Read a => Text -> a readText = read . unpack +addFetchCache :: Session -> Addr -> Contract -> IO ()+addFetchCache sess address ctrct = do+  cache <- readMVar sess.sharedCache+  liftIO $ modifyMVar_ sess.sharedCache $ \c -> pure $ c { contractCache = (Map.insert address ctrct cache.contractCache) }+ fetchQuery   :: Show a   => BlockNumber@@ -133,67 +206,200 @@   -- default codesize, default gas limit, default feescedule   pure $ Block coinbase timestamp number prd gasLimit (fromMaybe 0 baseFee) 0xffffffff feeSchedule -fetchWithSession :: Text -> Session -> Value -> IO (Maybe Value)+instance ToJSON Block where+  toJSON (Block coinbase timestamp number prevRandao gaslimit baseFee maxCodeSize _) =+    object+      [ "coinbase" .= unExpr coinbase+      , "timestamp" .= unExpr2 timestamp+      , "number" .= unExpr2 number+      , "prevRandao" .= prevRandao+      , "gaslimit" .= gaslimit+      , "baseFee" .= baseFee+      , "maxCodeSize" .= maxCodeSize+      ]+    where+      unExpr2 :: Expr EWord -> W256+      unExpr2 (Lit n)     = n+      unExpr2 _           = internalError "Block fields must be concrete"+      unExpr :: Expr EAddr -> Addr+      unExpr (LitAddr a) = a+      unExpr _           = internalError "Block fields must be concrete"++instance FromJSON Block where+  parseJSON = withObject "Block" $ \v ->+    Block+      <$> (LitAddr <$> v .: "coinbase")+      <*> (Lit <$> v .: "timestamp")+      <*> (Lit <$> v .: "number")+      <*> v .: "prevRandao"+      <*> v .: "gaslimit"+      <*> v .: "baseFee"+      <*> v .: "maxCodeSize"+      <*> pure feeSchedule++data MockData = MockData+  { mockContract :: Maybe (Map.Map Addr RPCContract) -- ^ mock contracts (addr -> contract)+  , mockSlot     :: Maybe (Map.Map (Addr, W256) W256) -- ^ mock storage slots (addr, slot) -> value+  , mockBlock    :: Maybe (Map.Map W256 Block) -- ^ mock blocks (block number -> block)+  }+instance Semigroup MockData where+  MockData a1 a2 a3 <> MockData b1 b2 b3 =+    MockData (a1 <|> b1) (a2 <|> b2) (a3 <|> b3)+instance Monoid MockData where+  mempty = MockData Nothing Nothing Nothing+instance ToJSON RPCContract where+  toJSON (RPCContract code nonce balance) = object+    [ "mcCode" .= (T.pack $ "0x" ++ (concatMap (paddedShowHex 2) . BS.unpack $ code))+    , "mcNonce" .= nonce+    , "mcBalance" .= balance+    ]++instance FromJSON RPCContract where+  parseJSON = withObject "RPCContract" $ \v -> do+    codeHex <- v .: "mcCode"+    case (BS16.decodeBase16Untyped . strip0x . T.encodeUtf8) codeHex of+       Left _ -> fail "Invalid hex encoding for mcCode"+       Right bs -> RPCContract bs <$> v .: "mcNonce" <*> v .: "mcBalance"+    where+      strip0x :: BS.ByteString -> BS.ByteString+      strip0x bs = if "0x" `Char8.isPrefixOf` bs then Char8.drop 2 bs else bs++instance ToJSON MockData where+  toJSON (MockData contracts slots blocks) = object+    [ "mockContract" .= contracts+    , "mockSlot" .= slots+    , "mockBlock" .= blocks+    ]++instance FromJSON MockData where+  parseJSON = withObject "MockData" $ \v ->+    MockData <$> v .:? "mockContract" <*> v .:? "mockSlot" <*> v .:? "mockBlock"++readMockData :: FilePath -> IO (Either String MockData)+readMockData filePath = do+  jsonData <- BSL.readFile filePath+  pure $ eitherDecode jsonData++writeMockDataToFile :: FilePath -> MockData -> IO ()+writeMockDataToFile filePath mockData = do+  let jsonData = encodePretty mockData+  BSL.writeFile filePath jsonData+  putStrLn $ "Successfully wrote JSON to: " ++ filePath++fetchWithSession :: Text -> NetSession.Session -> Value -> IO (Maybe Value) fetchWithSession url sess x = do-  r <- asValue =<< Session.post sess (unpack url) x+  r <- asValue =<< NetSession.post sess (unpack url) x   pure (r ^? (lensVL responseBody) % key "result") -fetchContractWithSession-  :: BlockNumber -> Text -> Addr -> Session -> IO (Maybe Contract)-fetchContractWithSession n url addr sess = runMaybeT $ do-  let-    fetch :: Show a => RpcQuery a -> IO (Maybe a)-    fetch = fetchQuery n (fetchWithSession url sess)+fetchContractWithSession :: Config -> Session -> BlockNumber -> Text -> Addr -> IO (Maybe Contract)+fetchContractWithSession conf sess nPre url addr = do+  n <- getLatestBlockNum conf sess nPre url+  cache <- readMVar sess.sharedCache+  case Map.lookup addr cache.contractCache of+    Just c -> do+      when (conf.debug) $ putStrLn $ "-> Using cached contract at " ++ show addr+      pure $ Just c+    Nothing -> runMaybeT $ do+      let fetch :: Show a => RpcQuery a -> IO (Maybe a)+          fetch = fetchQuery n (fetchWithSession url sess.sess)+          fname  = "fetched_contract_" ++ show addr ++ ".json"+      code    <- MaybeT $ fetch (QueryCode addr)+      nonce   <- MaybeT $ fetch (QueryNonce addr)+      balance <- MaybeT $ fetch (QueryBalance addr)+      when (conf.debug) $ liftIO $ writeMockDataToFile fname (MockData (Just (Map.singleton addr (RPCContract code nonce balance))) Nothing Nothing)+      let contr = makeContractFromRPC (RPCContract code nonce balance)+      liftIO $ modifyMVar_ sess.sharedCache $ \c -> pure $ c { contractCache = (Map.insert addr contr cache.contractCache) }+      pure contr -  code    <- MaybeT $ fetch (QueryCode addr)-  nonce   <- MaybeT $ fetch (QueryNonce addr)-  balance <- MaybeT $ fetch (QueryBalance addr)+-- In case the user asks for Latest, and we have not yet established what Latest is,+-- we fetch the block to find out. Otherwise, we update Latest to the value we have stored+getLatestBlockNum :: Config -> Session -> BlockNumber -> Text -> IO BlockNumber+getLatestBlockNum conf sess n url =+  case n of+   Latest -> do+     val <- readMVar sess.latestBlockNum+     case val of+        Nothing -> do+          blk <- internalBlockFetch conf sess Latest url+          case blk of+            Nothing -> pure Latest+            Just b -> do+              when (conf.debug) $ putStrLn $ "Setting latest block number to " ++ show b.number+              let m = forceLit b.number+              modifyMVar_ sess.latestBlockNum $ \_ -> pure $ Just m+              pure $ EVM.Fetch.BlockNumber m+        Just v -> pure $ EVM.Fetch.BlockNumber v+   _ -> pure n -  pure $+makeContractFromRPC :: RPCContract -> Contract+makeContractFromRPC (RPCContract code nonce balance) =     initialContract (RuntimeCode (ConcreteRuntimeCode code))       & set #nonce    (Just nonce)       & set #balance  (Lit balance)       & set #external True -fetchSlotWithSession-  :: BlockNumber -> Text -> Session -> Addr -> W256 -> IO (Maybe W256)-fetchSlotWithSession n url sess addr slot =+fetchSlotWithSession :: NetSession.Session -> BlockNumber -> Text -> Addr -> W256 -> IO (Maybe W256)+fetchSlotWithSession sess n url addr slot =   fetchQuery n (fetchWithSession url sess) (QuerySlot addr slot) -fetchBlockWithSession-  :: BlockNumber -> Text -> Session -> IO (Maybe Block)-fetchBlockWithSession n url sess =-  fetchQuery n (fetchWithSession url sess) QueryBlock--fetchBlockFrom :: BlockNumber -> Text -> IO (Maybe Block)-fetchBlockFrom n url = do-  sess <- Session.newAPISession-  fetchBlockWithSession n url sess+fetchBlockWithSession :: Config -> Session  -> BlockNumber -> Text -> IO (Maybe Block)+fetchBlockWithSession conf sess nPre url = do+  n <- getLatestBlockNum conf sess nPre url+  internalBlockFetch conf sess n url -fetchContractFrom :: BlockNumber -> Text -> Addr -> IO (Maybe Contract)-fetchContractFrom n url addr = do-  sess <- Session.newAPISession-  fetchContractWithSession n url addr sess+internalBlockFetch :: Config -> Session -> BlockNumber -> Text -> IO (Maybe Block)+internalBlockFetch conf sess n url = do+  when (conf.debug) $ putStrLn $ "Fetching block " ++ show n ++ " from " ++ unpack url+  ret <- fetchQuery n (fetchWithSession url sess.sess) QueryBlock+  case ret of+    Nothing -> pure ret+    Just b -> do+      let bn = forceLit b.number+      cache <- readMVar sess.sharedCache+      liftIO $ modifyMVar_ sess.sharedCache $ \c -> pure $ c { blockCache = (Map.insert bn b cache.blockCache) }+      when (conf.debug) $ do+        let fname = "fetched_block_" ++ show bn ++ ".json"+        writeMockDataToFile fname (MockData Nothing Nothing (Just (Map.singleton bn b)))+      pure ret -fetchSlotFrom :: BlockNumber -> Text -> Addr -> W256 -> IO (Maybe W256)-fetchSlotFrom n url addr slot = do-  sess <- Session.newAPISession-  fetchSlotWithSession n url sess addr slot+fetchSlotFrom :: App m => Session -> BlockNumber -> Text -> Addr -> W256 -> m (Maybe W256)+fetchSlotFrom sess nPre url addr slot = do+  conf <- readConfig+  n <- liftIO $ getLatestBlockNum conf sess nPre url+  cache <- liftIO $ readMVar sess.sharedCache+  case Map.lookup (addr, slot) cache.slotCache of+    Just s -> do+      when (conf.debug) $ liftIO $ putStrLn $ "-> Using cached slot value for slot " <> show slot <> " at " <> show addr+      pure $ Just s+    Nothing -> do+      ret <- liftIO $ fetchSlotWithSession sess.sess n url addr slot+      when (isJust ret) $ let val = fromJust ret in+        liftIO $ modifyMVar_ sess.sharedCache $ \c -> pure $ c { slotCache = (Map.insert (addr,slot) val cache.slotCache) }+      when (conf.debug) $ liftIO $ do+        let fname = "fetched_slot_" ++ show addr ++ "_" ++ show slot ++ ".json"+        case ret of+          Just v -> writeMockDataToFile fname (MockData Nothing (Just (Map.singleton (addr, slot) v)) Nothing)+          Nothing -> pure ()+      pure ret -fetchChainIdFrom :: Text -> IO (Maybe W256)-fetchChainIdFrom url = do-  sess <- Session.newAPISession-  fetchQuery Latest (fetchWithSession url sess) QueryChainId+mkSession :: App m => m Session+mkSession = do+  sess <- liftIO NetSession.newAPISession+  let emptyCache = FetchCache Map.empty Map.empty Map.empty+  cache <- liftIO $ newMVar emptyCache+  latestBlockNum <- liftIO $ newMVar Nothing+  pure $ Session sess latestBlockNum cache  -- Only used for testing (test.hs, BlockchainTests.hs) zero :: Natural -> Maybe Natural -> Fetcher t m s-zero smtjobs smttimeout q =+zero smtjobs smttimeout q = do+  sess <- mkSession   withSolvers Z3 smtjobs 1 smttimeout $ \s ->-    oracle s Nothing q+    oracle s (Just sess) mempty q --- smtsolving + (http or zero)-oracle :: SolverGroup -> RpcInfo -> Fetcher t m s-oracle solvers info q = do+-- SMT solving + RPC data fetching + reading from environment+oracle :: forall t m s . App m => SolverGroup -> Maybe Session -> RpcInfo -> Fetcher t m s+oracle solvers preSess rpcInfo q = do   case q of     PleaseDoFFI vals envs continue -> case vals of        cmd : args -> do@@ -214,38 +420,53 @@          let pathconds = foldl' PAnd (PBool True) pathconditions          continue <$> getSolutions solvers symExpr numBytes pathconds -    PleaseFetchContract addr base continue -> do+    PleaseFetchContract addr base continue -> withSession addr (continue (nothingContract base addr)) $ \sess -> do       conf <- readConfig       when (conf.debug) $ liftIO $ putStrLn $ "Fetching contract at " ++ show addr       when (addr == 0 && conf.verb > 0) $ liftIO $ putStrLn "Warning: fetching contract at address 0"-      contract <- case info of-        Nothing -> let-          c = case base of-            AbstractBase -> unknownContract (LitAddr addr)-            EmptyBase -> emptyContract-          in pure $ Just c-        Just (n, url) -> liftIO $ fetchContractFrom n url addr+      contract <- case rpcInfo.mockContract >>= Map.lookup addr of+        Just c  -> do+          when (conf.debug) $ liftIO $ putStrLn $ "Using mocked contract at " ++ show addr+          pure $ Just (makeContractFromRPC c)+        Nothing -> case rpcInfo.blockNumURL of+            Nothing -> pure $ Just $ nothingContract base addr+            Just (block, url) -> liftIO $ fetchContractWithSession conf sess block url addr       case contract of         Just x -> pure $ continue x         Nothing -> internalError $ "oracle error: " ++ show q -    PleaseFetchSlot addr slot continue -> do+    PleaseFetchSlot addr slot continue -> withSession addr (continue 0)$ \sess -> do       conf <- readConfig       when (conf.debug) $ liftIO $ putStrLn $ "Fetching slot " <> (show slot) <> " at " <> (show addr)       when (addr == 0 && conf.verb > 0) $ liftIO $ putStrLn "Warning: fetching slot from a contract at address 0"-      case info of-        Nothing -> pure (continue 0)-        Just (n, url) ->-         liftIO $ fetchSlotFrom n url addr slot >>= \case-           Just x  -> pure (continue x)-           Nothing ->-             internalError $ "oracle error: " ++ show q+      case rpcInfo.mockSlot >>= Map.lookup (addr, slot) of+        Just v  -> do+          when (conf.debug) $ liftIO $ putStrLn $ "Using mocked slot value for slot " <> show slot <> " at " <> show addr+          pure $ continue v+        Nothing -> case rpcInfo.blockNumURL of+            Nothing -> pure $ continue 0+            Just (block, url) -> fetchSlotFrom sess block url addr slot >>= \case+               Just x  -> pure $ continue x+               Nothing -> internalError $ "oracle error: " ++ show q      PleaseReadEnv variable continue -> do       value <- liftIO $ lookupEnv variable       pure . continue $ fromMaybe "" value -type Fetcher t m s = App m => Query t s -> m (EVM t s ())+    where+      nothingContract base addr =+        case base of+          AbstractBase -> unknownContract (LitAddr addr)+          EmptyBase -> emptyContract+      withSession addr def f =+        case addr of+          -- special values such as 0, 0xdeadbeef, 0xacab, hevm cheatcodes, and the precompile addresses+          -- do not require a session, there is nothing deployed there, it's way too small or special, RPC would be pointless+          a | a <= 0xdeadbeef -> pure def+          0x7109709ECfa91a80626fF3989D68f67F5b1DD12D -> pure def+          _ -> case preSess of+            Just sess  -> f sess+            Nothing -> internalError $ "oracle: no session provided for fetch addr: " ++ show addr  getSolutions :: forall m . App m => SolverGroup -> Expr EWord -> Int -> Prop -> m (Maybe [W256]) getSolutions solvers symExprPreSimp numBytes pathconditions = do@@ -275,16 +496,16 @@   let props = [pathconditions .&& branchcondition]   checkSatWithProps solvers props >>= \case     -- the condition is unsatisfiable-    (Qed, _) -> -- if pathconditions are consistent then the condition must be false+    Qed -> -- if pathconditions are consistent then the condition must be false       pure $ Case False     -- Sat means its possible for condition to hold-    (Cex {}, _) -> do -- is its negation also possible?+    Cex {} -> do -- is its negation also possible?       let propsNeg = [pathconditions .&& (PNeg branchcondition)]       checkSatWithProps solvers propsNeg >>= \case         -- No. The condition must hold-        (Qed, _) -> pure $ Case True+        Qed -> pure $ Case True         -- Yes. Both branches possible-        (Cex {}, _) -> pure UnknownBranch+        Cex {} -> pure UnknownBranch         -- If the query times out, or can't be executed (e.g. symbolic copyslice) we simply explore both paths         _ -> pure UnknownBranch     -- If the query times out, or can't be executed (e.g. symbolic copyslice) we simply explore both paths

@@ -4,7 +4,7 @@   ( formatExpr   , formatSomeExpr   , formatPartial-  , formatPartialShort+  , formatPartialDetailed   , formatProp   , formatState   , formatError@@ -40,7 +40,7 @@ import EVM.ABI (getAbiSeq, parseTypeName, AbiValue(..), AbiType(..), SolError(..), Indexed(..), Event(..)) import EVM.Dapp (DappContext(..), DappInfo(..), findSrc, showTraceLocation) import EVM.Expr qualified as Expr-import EVM.Solidity (SolcContract(..), Method(..))+import EVM.Solidity (SolcContract(..), Method(..), SrcMap (..), WarningData (..), SourceCache(..)) import EVM.Types import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp) @@ -68,6 +68,8 @@ import Hexdump (prettyHex) import Numeric (showHex) import Witch (into, unsafeInto, tryFrom)+import Data.Vector.Storable qualified as VS+import Data.Sequence qualified as Seq  data Signedness = Signed | Unsigned   deriving (Show)@@ -433,6 +435,7 @@   MaxInitCodeSizeExceeded a b -> "Max init code size exceeded: max: " <> show a <> " actual: " <> show b   InvalidFormat -> "Invalid Format"   PrecompileFailure -> "Precompile failure"+  NonexistentPrecompile a -> "Precompile at address " <> show a <> " does not exist"   ReturnDataOutOfBounds -> "Return data out of bounds"   NonceOverflow -> "Nonce overflow"   BadCheatCode reason a -> "Bad cheat code: " <>  reason <> " sig: " <> show a@@ -467,32 +470,80 @@  formatPartial :: PartialExec -> Text formatPartial = \case-  UnexpectedSymbolicArg pc opcode msg args -> T.unlines-    [ "Unexpected Symbolic Arguments to Opcode"+  UnexpectedSymbolicArg pc addr opcode msg args -> T.unlines+    [ "Unexpected symbolic arguments to opcode."     , indent 2 $ T.unlines       [ "msg: " <> T.pack (show msg)-      , "opcode: " <> T.pack opcode+      , "contract addr: " <> pack (show addr)       , "program counter: " <> T.pack (show pc)+      , "opcode: " <> T.pack opcode       , "arguments: "       , indent 2 $ T.unlines . fmap formatSomeExpr $ args       ]     ]-  MaxIterationsReached pc addr -> "Max Iterations Reached in contract: " <> formatAddr addr <> " pc: " <> pack (show pc) <> " To increase the maximum, set a fixed large (or negative) value for `--max-iterations` on the command line"-  JumpIntoSymbolicCode pc idx -> "Encountered a jump into a potentially symbolic code region while executing initcode. pc: " <> pack (show pc) <> " jump dst: " <> pack (show idx)-  CheatCodeMissing pc selector ->T.unlines-    [ "Cheat code not recognized"-    , "program counter: " <> T.pack (show pc)-    , "function selector: " <> T.pack (show selector)+  MaxIterationsReached pc addr -> T.unlines+    ["Max iterations reached."+    , indent 2 $ T.unlines+      [ "contract addr: " <> T.pack (show addr)+      , "program counter: " <> T.pack (show pc)+      ]     ]-  BranchTooDeep pc -> T.unlines ["Branches too deep at program counter: " <> pack (show pc)]+  JumpIntoSymbolicCode pc addr idx -> T.unlines+    ["Encountered a jump into a symbolic code region."+    , indent 2 $ T.unlines+      [ "contract addr: " <> T.pack (show addr)+      , "program counter: " <> T.pack (show pc)+      , "jump dst: " <> pack (show idx)+      ]+    ]+  CheatCodeMissing pc addr selector -> T.unlines+    [ "Cheat code not recognized."+    , indent 2 $ T.unlines+      [ "contract addr: " <> T.pack (show addr)+      , "program counter: " <> T.pack (show pc)+      , "function selector: " <> T.pack (show selector)+      ]+    ]+  BranchTooDeep pc addr -> T.unlines+    ["Branch too deep."+    , indent 2 $ T.unlines+      [ "contract addr: " <> pack (show addr)+      , "program counter: " <> pack (show pc)]+    ] -formatPartialShort :: PartialExec -> Text-formatPartialShort = \case-  UnexpectedSymbolicArg _ opcode _ _ -> "Unexpected symbolic arguments to opcode: " <> T.pack opcode-  MaxIterationsReached {}            -> "Max iterations reached"-  JumpIntoSymbolicCode {}            -> "Encountered a jump into a potentially symbolic code region while executing initcode"-  CheatCodeMissing _ selector        -> "Cheat code not recognized: " <> T.pack (show selector)-  BranchTooDeep pc                   -> "Branches too deep at program counter: " <> pack (show pc)+  PrecompileMissing pc addr preAddr -> T.unlines+    ["Precompile does not exist"+    , indent 2 $ T.unlines+      [ "precompile addr: " <> pack (show preAddr)+      , "contract addr: " <> pack (show addr)+      , "program counter: " <> pack (show pc)]+    ]+++formatPartialDetailed :: Maybe (WarningData s t) -> PartialExec -> Text+formatPartialDetailed warnData p =+  let toTxt addr pc = pack $ getSrcInfo warnData addr pc+  in case p of+    UnexpectedSymbolicArg {..} -> "Unexpected symbolic arguments to opcode: " <> T.pack opcode <> toTxt addr pc+    MaxIterationsReached {..}  -> "Max iterations reached" <> toTxt addr pc+    JumpIntoSymbolicCode {..}  -> "Encountered a jump into a symbolic code" <> toTxt addr pc+    CheatCodeMissing {..}      -> "Cheat code not recognized: " <> T.pack (show selector) <> toTxt addr pc+    PrecompileMissing {..}     -> "Precompile at address " <> pack (show preAddr) <> " does not exist, called from" <> toTxt addr pc+    BranchTooDeep {..}         -> "Branches too deep" <> toTxt addr pc++getSrcInfo :: Maybe (WarningData s t) -> Expr EAddr -> Int -> String+getSrcInfo Nothing addr pc = " at addr: " <> show addr <> " at pc: " <> show pc+getSrcInfo (Just dat) addr pc = fromMaybe (getSrcInfo Nothing addr pc) $ do+  contr <- Map.lookup addr dat.vm.env.contracts+  pcOp <- contr.opIxMap VS.!? pc+  sMap <- Seq.lookup pcOp dat.solcContr.runtimeSrcmap+  (fname, fcontent) <- Map.lookup sMap.file dat.sourceCache.files+  let eols = BS.count 10 $ BS.take sMap.offset fcontent  -- 10 is \n+  let str = " in file \"" <> fname <> "\" on line " <> show (eols+1)+  case (BS.length fcontent > (sMap.offset + sMap.length)) of+    False -> pure str+    True  -> let relevant = BS.take sMap.length $ BS.drop sMap.offset fcontent+      in pure $ str <> " : " <> show relevant  formatSomeExpr :: SomeExpr -> Text formatSomeExpr (SomeExpr e) = formatExpr $ Expr.simplify e

@@ -1,262 +0,0 @@-{- |-    Module: EVM.Fuzz-    Description: Concrete Fuzzer of Exprs--}--module EVM.Fuzz where--import Control.Monad (replicateM)-import Control.Monad.State (State, get, put, execState)-import Data.Map.Strict as Map (fromList, Map, (!), (!?), insert)-import Data.Maybe (fromMaybe)-import Data.Set as Set (insert, Set, empty, toList, fromList)-import Data.ByteString qualified as BS-import Data.Word (Word8)--import EVM.Expr qualified as Expr-import EVM.Expr (bytesToW256)-import EVM.Types qualified as SMT-import EVM.Traversals-import EVM.Types (Prop(..), W256, Expr(..), EType(..), internalError, keccak')--import Test.QuickCheck (Arbitrary(arbitrary))-import Test.QuickCheck.Gen-import Test.QuickCheck.Random (mkQCGen)---- TODO: Extract Var X = Lit Z, and set it-tryCexFuzz :: [Prop] -> Integer -> (Maybe (SMT.SMTCex))-tryCexFuzz prePs tries = unGen (testVals tries) (mkQCGen 0) 1337-  where-    ps = Expr.concKeccakSimpProps prePs-    vars = extractVars ps-    bufs = extractBufs ps-    stores = extractStorage ps-    testVals :: Integer -> Gen (Maybe SMT.SMTCex)-    testVals 0 = pure Nothing-    testVals todo = do-      varvals <- getvals vars-      bufVals <- getBufs bufs-      storeVals <- getStores stores-      let-        ret = filterCorrectKeccak $ map (substituteEWord varvals . substituteBuf bufVals . substituteStores storeVals) ps-        retSimp = Expr.concKeccakSimpProps ret-      if null retSimp then pure $ Just (SMT.SMTCex {-                                    vars = varvals-                                    , addrs = mempty-                                    , buffers = bufVals-                                    , store = storeVals-                                    , blockContext = mempty-                                    , txContext = mempty-                                    })-                                    else testVals (todo-1)---- Filter out PEq (Lit X) (keccak (ConcreteBuf Y)) if it's correct-filterCorrectKeccak :: [Prop] -> [Prop]-filterCorrectKeccak ps = filter checkKecc ps-  where-    checkKecc (PEq (Lit x) (Keccak (ConcreteBuf y))) = keccak' y /= x-    checkKecc _ = True--substituteEWord :: Map (Expr EWord) W256 -> Prop -> Prop-substituteEWord valMap p = mapProp go p-  where-    go :: Expr a -> Expr a-    go orig@(Var _) = Lit (valMap ! orig)-    go orig@(TxValue) = Lit (valMap ! orig)-    go a = a---substituteBuf :: Map (Expr Buf) SMT.BufModel -> Prop -> Prop-substituteBuf valMap p = mapProp go p-  where-    go :: Expr a -> Expr a-    go orig@(AbstractBuf _) = case (valMap !? orig) of-                                Just (SMT.Flat x) -> ConcreteBuf x-                                Just (SMT.Comp _) -> internalError "No compressed allowed in fuzz"-                                Nothing -> orig-    go a = a--substituteStores ::  Map (Expr 'EAddr) (Map W256 W256) -> Prop -> Prop-substituteStores valMap p = mapProp go p-  where-    go :: Expr a -> Expr a-    -- TODO: Is this OK??-    go (AbstractStore a _) = case valMap !? a of-                                  Just m -> ConcreteStore m-                                  Nothing -> ConcreteStore mempty-    go a = a---- Var extraction-data CollectVars = CollectVars {vars :: Set.Set (Expr EWord)-                               ,vals :: Set.Set W256-                               }-  deriving (Show)--initVarsState :: CollectVars-initVarsState = CollectVars {vars = Set.empty-                            ,vals =  Set.empty-                            }--findVarProp :: Prop -> State CollectVars Prop-findVarProp p = mapPropM go p-  where-    go :: forall a. Expr a -> State CollectVars (Expr a)-    go = \case-      e@(Var a) -> do-        s <- get-        put s {vars = Set.insert (Var a) s.vars}-        pure e-      e@(Lit a) -> do-        s <- get-        put (s {vals=Set.insert a s.vals} ::CollectVars)-        pure e-      e -> pure e---extractVars :: [Prop] -> CollectVars-extractVars ps = execState (mapM_ findVarProp ps) initVarsState------ Buf extraction-newtype CollectBufs = CollectBufs { bufs :: Set.Set (Expr Buf) }-  deriving (Show)--initBufsState :: CollectBufs-initBufsState = CollectBufs { bufs = Set.empty }--extractBufs :: [Prop] -> [Expr Buf]-extractBufs ps = Set.toList bufs- where-  CollectBufs bufs = execState (mapM_ findBufProp ps) initBufsState--findBufProp :: Prop -> State CollectBufs Prop-findBufProp p = mapPropM go p-  where-    go :: forall a. Expr a -> State CollectBufs (Expr a)-    go = \case-      e@(AbstractBuf a) -> do-        s <- get-        put s {bufs=Set.insert (AbstractBuf a) s.bufs}-        pure e-      e -> pure e----- Store extraction-data CollectStorage = CollectStorage { addrs :: Set.Set (Expr EAddr, Maybe W256)-                                     , keys :: Set.Set W256-                                     , vals :: Set.Set W256-                                     }-  deriving (Show)--instance Semigroup (CollectStorage) where-  (CollectStorage a b c) <> (CollectStorage a2 b2 c2) = CollectStorage (a <> a2) (b <> b2) (c <> c2)--initStorageState :: CollectStorage-initStorageState = CollectStorage { addrs = Set.empty, keys = Set.empty, vals = Set.fromList [0x0, 0x1, Expr.maxLit] }--extractStorage :: [Prop] -> CollectStorage-extractStorage ps = execState (mapM_ findStoragePropInner ps) initStorageState <>-    execState (mapM_ findStoragePropComp ps) initStorageState--findStoragePropComp :: Prop -> State CollectStorage Prop-findStoragePropComp p = go2 p-  where-    go2 :: Prop -> State CollectStorage (Prop)-    go2 = \case-      PNeg x -> go2 x-      e@(PEq (Lit val) (SLoad {})) -> do-        s <- get-        put (s {vals=Set.insert val s.vals} :: CollectStorage)-        pure e-      e@(PLT (Lit val) (SLoad {})) -> do-        s <- get-        put (s {vals=Set.insert val s.vals} :: CollectStorage)-        pure e-      (PGT a@(Lit _) b@(SLoad {})) -> go2 (PLT a b)-      (PGEq a@(Lit _) b@(SLoad {})) -> go2 (PLT a b)-      (PLEq a@(Lit _) b@(SLoad {})) -> go2 (PLT a b)-      e -> pure e--findStoragePropInner :: Prop -> State CollectStorage Prop-findStoragePropInner p = mapPropM go p-  where-    go :: forall a. Expr a -> State CollectStorage (Expr a)-    go = \case-      e@(AbstractStore a idx) -> do-        s <- get-        put s {addrs=Set.insert (a, idx) s.addrs}-        pure e-      e@(SLoad (Lit val) _) -> do-        s <- get-        put s {keys=Set.insert val s.keys}-        pure e-      e@(SStore _ (Lit val) _) -> do-        s <- get-        put (s {vals=Set.insert val s.vals} :: CollectStorage)-        pure e-      e -> pure e---- Var value and TX value generation-getvals :: CollectVars -> Gen (Map (Expr EWord) W256)-getvals vars = do-    bufs <- go (Set.toList vars.vars) mempty-    addTxStuff bufs-  where-    addTxStuff :: Map (Expr EWord) W256 -> Gen (Map (Expr EWord) W256)-    addTxStuff a = do-      val <- frequency [ (20, pure 0)-                       , (1, getRndW256)-                       ]-      pure $ Map.insert TxValue val a-    go :: [Expr EWord] -> Map (Expr EWord) W256 -> Gen (Map (Expr EWord) W256)-    go [] valMap = pure valMap-    go (a:ax) valMap = do-      pickKnown :: Bool <- arbitrary-      val <- if (not pickKnown) || (null vars.vals) then do getRndW256-                                                    else elements $ Set.toList (vars.vals)-      go ax (Map.insert a val valMap)---- Storage value generation-getStores :: CollectStorage -> Gen (Map (Expr EAddr) (Map W256 W256))-getStores storesLoads = go (Set.toList storesLoads.addrs) mempty-  where-    go :: [(Expr EAddr, Maybe W256)] -> Map (Expr EAddr) (Map W256 W256) -> Gen (Map (Expr EAddr) (Map W256 W256))-    go [] addrToValsMap = pure addrToValsMap-    go ((addr, _):ax) addrToValsMap = do-      -- number of elements inserted into storage-      numElems :: Int <- frequency [(1, pure 0)-                                   ,(10, choose (1, 10))-                                   ,(1, choose (11, 100))-                                   ]-      l <- replicateM numElems oneWrite-      go ax (Map.insert addr (Map.fromList l) addrToValsMap)-        where-          oneWrite :: Gen (W256, W256)-          oneWrite = do-                    a <- getRndElem storesLoads.keys-                    b <- frequency [(1, getRndW256)-                                   ,(3, elements $ Set.toList storesLoads.vals)-                                   ]-                    pure (fromMaybe (0::W256) a, b)-    getRndElem :: Set W256 -> Gen (Maybe W256)-    getRndElem choices = if null choices then pure Nothing-                         else do fmap Just $ elements $ Set.toList choices---- Buf value generation-getBufs :: [Expr Buf] -> Gen (Map (Expr Buf) SMT.BufModel)-getBufs bufs = go bufs mempty-  where-    go :: [Expr Buf] -> Map (Expr Buf) SMT.BufModel -> Gen (Map (Expr Buf) SMT.BufModel)-    go [] valMap = pure valMap-    go (a:ax) valMap = do-      bytes :: [Word8] <- frequency [-              (1, do-                x :: Int <- choose (1, 100)-                replicateM x arbitrary)-            , (1, replicateM 0 arbitrary)-       ]-      go ax (Map.insert a (SMT.Flat $ BS.pack bytes) valMap)--getRndW256 :: Gen W256-getRndW256 = do-      val <- replicateM 32 arbitrary-      pure $ bytesToW256 val

@@ -2,7 +2,7 @@     Module: EVM.Keccak     Description: Expr passes to determine Keccak assumptions -}-module EVM.Keccak (keccakAssumptions, keccakCompute) where+module EVM.Keccak (keccakAssumptions, concreteKeccaks, findKeccakPropsExprs) where  import Control.Monad.State import Data.Set (Set)@@ -18,9 +18,6 @@   { keccakExprs :: Set (Expr EWord) }   deriving (Show) -initState :: KeccakStore-initState = KeccakStore { keccakExprs = Set.empty }- keccakFinder :: forall a. Expr a -> State KeccakStore () keccakFinder = \case   e@(Keccak _) -> modify (\s -> s{keccakExprs=Set.insert e s.keccakExprs})@@ -32,20 +29,18 @@ findKeccakProp :: Prop -> State KeccakStore () findKeccakProp p = mapPropM_ keccakFinder p -findKeccakPropsExprs :: [Prop] -> [Expr Buf]  -> [Expr Storage]-> State KeccakStore ()-findKeccakPropsExprs ps bufs stores = do-  mapM_ findKeccakProp ps-  mapM_ findKeccakExpr bufs-  mapM_ findKeccakExpr stores+findKeccakPropsExprs :: [Prop] -> [Expr Buf] -> [Expr Storage] -> Set (Expr EWord)+findKeccakPropsExprs ps bufs stores = (execState action (KeccakStore mempty)).keccakExprs+  where+    action = do+      mapM_ findKeccakProp ps+      mapM_ findKeccakExpr bufs+      mapM_ findKeccakExpr stores   uniquePairs :: [a] -> [(a,a)] uniquePairs xs = [(x,y) | (x:ys) <- Data.List.tails xs, y <- ys] -minProp :: Expr EWord -> Prop-minProp k@(Keccak _) = PGT k (Lit 256)-minProp _ = internalError "expected keccak expression"- injProp :: (Expr EWord, Expr EWord) -> Prop injProp (k1@(Keccak b1), k2@(Keccak b2)) =   PImpl (PEq k1 k2) ((b1 .== b2) .&& (bufLength b1 .== bufLength b2))@@ -59,14 +54,17 @@ --   2. Injectivity: That keccak is an injective function (we avoid quantifiers --      here by making this claim for each unique pair of keccak invocations --      discovered in the input expressions)-keccakAssumptions :: [Prop] -> [Expr Buf] -> [Expr Storage] -> [Prop]-keccakAssumptions ps bufs stores = injectivity <> minValue <> minDiffOfPairs+keccakAssumptions :: [Expr EWord] -> [Prop]+keccakAssumptions keccaks = injectivity <> minValue <> minDiffOfPairs   where-    (_, st) = runState (findKeccakPropsExprs ps bufs stores) initState-    ks = Set.toList $ Set.map concretizeKeccakParam st.keccakExprs+    ks = map concretizeKeccakParam keccaks     keccakPairs = uniquePairs ks     injectivity = map injProp keccakPairs     minValue = map minProp ks+      where+        minProp :: Expr EWord -> Prop+        minProp k@(Keccak _) = PGT k (Lit 256)+        minProp _ = internalError "expected keccak expression"     minDiffOfPairs = map minDistance keccakPairs      where       minDistance :: (Expr EWord, Expr EWord) -> Prop@@ -80,24 +78,20 @@ concretizeKeccakParam (Keccak buf) = Keccak (concKeccakSimpExpr buf) concretizeKeccakParam _ = internalError "Cannot happen" -compute :: forall a. Expr a -> Set Prop-compute = \case-  e@(Keccak buf) -> do-    let b = simplify buf-    case keccak b of-      lit@(Lit _) -> Set.singleton (PEq lit (concretizeKeccakParam e))-      _ -> Set.empty-  _ -> Set.empty -computeKeccakExpr :: forall a. Expr a -> Set Prop-computeKeccakExpr e = foldExpr compute Set.empty e+type KeccakValue = (Expr Buf, W256)+concreteKeccaks :: [Prop] -> Set KeccakValue+concreteKeccaks ps = foldMap concreteKeccakProp ps+  where+  concreteKeccakProp :: Prop -> Set KeccakValue+  concreteKeccakProp p = foldProp compute Set.empty p -computeKeccakProp :: Prop -> Set Prop-computeKeccakProp p = foldProp compute Set.empty p+  compute :: forall a. Expr a -> Set KeccakValue+  compute = \case+    Keccak buf -> do+      let b = concKeccakSimpExpr buf+      case b of+        buff@(ConcreteBuf bs) -> Set.singleton (buff, keccak' bs)+        _ -> Set.empty+    _ -> Set.empty -keccakCompute :: [Prop] -> [Expr Buf] -> [Expr Storage] -> [Prop]-keccakCompute ps buf stores =-  Set.toList $-    (foldMap computeKeccakProp ps) <>-    (foldMap computeKeccakExpr buf) <>-    (foldMap computeKeccakExpr stores)

@@ -1,24 +1,45 @@-{-# LANGUAGE QuasiQuotes #-}- {- |     Module: EVM.SMT     Description: Utilities for building and executing SMT queries from Expr instances -}-module EVM.SMT where+module EVM.SMT+(+  module EVM.SMT.Types,+  module EVM.SMT.SMTLIB, -import Prelude hiding (LT, GT)+  collapse,+  getVar,+  formatSMT2,+  declareIntermediates,+  assertProps,+  exprToSMT,+  encodeConcreteStore,+  zero,+  one,+  propToSMT,+  parseVar,+  parseEAddr,+  parseBlockCtx,+  parseTxCtx,+  getAddrs,+  getVars,+  queryMaxReads,+  getBufs,+  getStore+) where +import Prelude hiding (LT, GT, Foldable(..))+ import Control.Monad import Data.Containers.ListUtils (nubOrd, nubInt) import Data.ByteString (ByteString) import Data.ByteString qualified as BS+import Data.Foldable (Foldable(..)) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty-import Data.String.Here import Data.Maybe (fromJust, fromMaybe, isJust, listToMaybe) import Data.Either.Extra (fromRight')-import Data.Foldable (fold) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set)@@ -28,56 +49,27 @@ import Data.Text qualified as TS import Data.Text.Lazy qualified as T import Data.Text.Lazy.Builder-import Data.Text.Read (decimal)-import Language.SMT2.Parser (getValueRes, parseCommentFreeFileMsg)+import qualified Data.Text.Lazy.Builder.Int (decimal)+import Language.SMT2.Parser (getValueRes, parseCommentFreeFileMsg, parseString, specConstant) import Language.SMT2.Syntax (Symbol, SpecConstant(..), GeneralRes(..), Term(..), QualIdentifier(..), Identifier(..), Sort(..), Index(..), VarBinding(..)) import Numeric (readHex, readBin) import Witch (into, unsafeInto) import EVM.Format (formatProp)  import EVM.CSE-import EVM.Expr (writeByte, bufLengthEnv, containsNode, bufLength, minLength, inRange)+import EVM.Expr (writeByte, bufLengthEnv, bufLength, minLength, inRange) import EVM.Expr qualified as Expr-import EVM.Keccak (keccakAssumptions, keccakCompute)+import EVM.Keccak (keccakAssumptions, concreteKeccaks, findKeccakPropsExprs) import EVM.Traversals import EVM.Types import EVM.Effects+import EVM.SMT.Types+import EVM.SMT.SMTLIB   -- ** Encoding ** ----------------------------------------------------------------------------------  --- | Data that we need to construct a nice counterexample-data CexVars = CexVars-  { -- | variable names that we need models for to reconstruct calldata-    calldata     :: [Text]-    -- | symbolic address names-  , addrs        :: [Text]-    -- | buffer names and guesses at their maximum size-  , buffers      :: Map Text (Expr EWord)-    -- | reads from abstract storage-  , storeReads   :: Map (Expr EAddr, Maybe W256) (Set (Expr EWord))-    -- | the names of any block context variables-  , blockContext :: [Text]-    -- | the names of any tx context variables-  , txContext    :: [Text]-  }-  deriving (Eq, Show)--instance Semigroup CexVars where-  (CexVars a b c d e f) <> (CexVars a2 b2 c2 d2 e2 f2) = CexVars (a <> a2) (b <> b2) (c <> c2) (d <> d2) (e <> e2) (f <> f2)--instance Monoid CexVars where-    mempty = CexVars-      { calldata = mempty-      , addrs = mempty-      , buffers = mempty-      , storeReads = mempty-      , blockContext = mempty-      , txContext = mempty-      }-- -- | Attempts to collapse a compressed buffer representation down to a flattened one collapse :: BufModel -> Maybe BufModel collapse model = case toBuf model of@@ -92,46 +84,31 @@ getVar :: SMTCex -> TS.Text -> W256 getVar cex name = fromJust $ Map.lookup (Var name) cex.vars --- Props are ONLY for pretty printing the query Props-data SMT2 = SMT2 [Builder] CexVars [Prop]-  deriving (Eq, Show)--instance Semigroup SMT2 where-  (SMT2 a c d) <> (SMT2 a2 c2 d2) = SMT2 (a <> a2) (c <> c2) (d <> d2)--instance Monoid SMT2 where-  mempty = SMT2 mempty mempty mempty- formatSMT2 :: SMT2 -> Text-formatSMT2 (SMT2 ls _ ps) = expr <> smt2+formatSMT2 (SMT2 (SMTScript entries) _ ps) = expr <> smt2  where  expr = T.concat [T.singleton ';', T.replace "\n" "\n;" $ T.pack . TS.unpack $  TS.unlines (fmap formatProp ps)]- smt2 = T.unlines (fmap toLazyText ls)+ smt2 = T.unlines (fmap toText entries)  -- | Reads all intermediate variables from the builder state and produces SMT declaring them as constants-declareIntermediates :: BufEnv -> StoreEnv -> Err SMT2+declareIntermediates :: BufEnv -> StoreEnv -> Err [SMTEntry] declareIntermediates bufs stores = do   let encSs = Map.mapWithKey encodeStore stores       encBs = Map.mapWithKey encodeBuf bufs-      sorted = List.sortBy compareFst $ Map.toList $ encSs <> encBs-  decls <- mapM snd sorted-  let smt2 = (SMT2 [fromText "; intermediate buffers & stores"] mempty mempty):decls-  pure $ fold smt2+  snippets <- sequence $ Map.elems $ encSs <> encBs+  let decls = concat snippets+  pure $ (SMTComment "intermediate buffers & stores") : decls   where-    compareFst (l, _) (r, _) = compare l r     encodeBuf n expr = do       buf <- exprToSMT expr       bufLen <- encodeBufLen n expr-      pure $ SMT2 ["(define-fun buf" <> (fromString . show $ n) <> "() Buf " <> buf <> ")\n"]  mempty mempty <> bufLen+      pure [SMTCommand ("(define-fun buf" <> (Data.Text.Lazy.Builder.Int.decimal n) <> "() Buf " <> buf <> ")\n"), bufLen]     encodeBufLen n expr = do       bufLen <- exprToSMT (bufLengthEnv bufs True expr)-      pure $ SMT2 ["(define-fun buf" <> (fromString . show $ n) <>"_length () (_ BitVec 256) " <> bufLen <> ")"] mempty mempty+      pure $ SMTCommand ("(define-fun buf" <> (Data.Text.Lazy.Builder.Int.decimal n) <>"_length () (_ BitVec 256) " <> bufLen <> ")")     encodeStore n expr = do       storage <- exprToSMT expr-      pure $ SMT2 ["(define-fun store" <> (fromString . show $ n) <> " () Storage " <> storage <> ")"] mempty mempty--smt2Line :: Builder -> SMT2-smt2Line txt = SMT2 [txt] mempty mempty+      pure [SMTCommand ("(define-fun store" <> (Data.Text.Lazy.Builder.Int.decimal n) <> " () Storage " <> storage <> ")")]  -- simplify to rewrite sload/sstore combos -- notice: it is VERY important not to concretize early, because Keccak assumptions@@ -139,7 +116,7 @@ assertProps :: Config -> [Prop] -> Err SMT2 assertProps conf ps =   if not conf.simp then assertPropsHelper False ps-  else assertPropsHelper True (decompose . Expr.simplifyProps $ ps)+  else assertPropsHelper True (decompose ps)   where     decompose :: [Prop] -> [Prop]     decompose props = if conf.decomposeStorage && safeExprs && safeProps@@ -160,28 +137,20 @@  intermediates <- declareIntermediates bufs stores  readAssumes' <- readAssumes  keccakAssertions' <- keccakAssertions- frameCtxs <- (declareFrameContext . nubOrd $ foldl (<>) [] frameCtx)- blockCtxs <- (declareBlockContext . nubOrd $ foldl (<>) [] blockCtx)+ frameCtxs <- (declareFrameContext . nubOrd $ foldl' (<>) [] frameCtx)+ blockCtxs <- (declareBlockContext . nubOrd $ foldl' (<>) [] blockCtx)  pure $ prelude-  <> (declareAbstractStores abstractStores)-  <> smt2Line ""+  <> SMT2 (SMTScript (declareAbstractStores abstractStores)) mempty mempty   <> declareConstrainAddrs addresses-  <> smt2Line ""   <> (declareBufs toDeclarePsElim bufs stores)-  <> smt2Line ""-  <> (declareVars . nubOrd $ foldl (<>) [] allVars)-  <> smt2Line ""+  <> (declareVars . nubOrd $ foldl' (<>) [] allVars)   <> frameCtxs-  <> smt2Line ""   <> blockCtxs-  <> smt2Line ""-  <> intermediates-  <> smt2Line ""-  <> keccakAssertions'-  <> readAssumes'-  <> gasOrder-  <> smt2Line ""-  <> SMT2 (fmap (\p -> "(assert " <> p <> ")") encs) (cexInfo storageReads) ps+  <> SMT2 (SMTScript intermediates) mempty mempty+  <> SMT2 (SMTScript keccakAssertions') mempty mempty+  <> SMT2 (SMTScript readAssumes') mempty mempty+  <> SMT2 (SMTScript gasOrder) mempty mempty+  <> SMT2 (SMTScript (fmap (\p -> SMTCommand("(assert " <> p <> ")")) encs)) (cexInfo storageReads) ps    where     ps = if simp then Expr.concKeccakSimpProps psPreConc else Expr.concKeccakProps psPreConc@@ -200,28 +169,27 @@     -- Buf, Storage, etc. declarations needed     bufVals = Map.elems bufs     storeVals = Map.elems stores-    storageReads = Map.unionsWith (<>) $ fmap findStorageReads toDeclarePs+    storageReads = mconcat $ fmap findStorageReads toDeclarePs     abstractStores = Set.toList $ Set.unions (fmap referencedAbstractStores toDeclarePs)     addresses = Set.toList $ Set.unions (fmap referencedAddrs toDeclarePs)      -- Keccak assertions: concrete values, distance between pairs, injectivity, etc.     --      This will make sure concrete values of Keccak are asserted, if they can be computed (i.e. can be concretized)-    keccAssump = keccakAssumptions psPreConc bufVals storeVals-    keccComp = keccakCompute psPreConc bufVals storeVals+    concreteKecc = concreteKeccaks psPreConc+    allKeccaks = (findKeccakPropsExprs psElim bufVals storeVals) <> Set.map (Keccak . fst) concreteKecc+    keccAssump = keccakAssumptions $ Set.toList allKeccaks+    keccComp = [(PEq (Lit l) (Keccak buf)) | (buf, l) <- Set.toList concreteKecc]     keccakAssertions = do       assumps <- mapM assertSMT keccAssump       comps <- mapM assertSMT keccComp-      pure $ smt2Line "; keccak assumptions"-        <> SMT2 assumps mempty mempty-        <> smt2Line "; keccak computations"-        <> SMT2 comps mempty mempty+      pure $ ((SMTComment "keccak assumptions") : assumps) <> ((SMTComment "keccak computations") : comps)      -- assert that reads beyond size of buffer & storage is zero     readAssumes = do       assumps <- mapM assertSMT $ assertReads psElim bufs stores-      pure $ smt2Line "; read assumptions" <> SMT2 assumps mempty mempty+      pure (SMTComment "read assumptions" : assumps) -    cexInfo :: Map (Expr 'EAddr, Maybe W256) (Set (Expr 'EWord)) -> CexVars+    cexInfo :: StorageReads -> CexVars     cexInfo a = mempty { storeReads = a }  @@ -287,20 +255,24 @@ -- the store (e.g, SLoad addr idx (SStore addr idx val AbstractStore)). -- However, we expect that most of such reads will have been -- simplified away.-findStorageReads :: Prop -> Map (Expr EAddr, Maybe W256) (Set (Expr EWord))-findStorageReads p = Map.fromListWith (<>) $ foldProp go mempty p+findStorageReads :: Prop -> StorageReads+findStorageReads p = foldProp go mempty p   where-    go :: Expr a -> [((Expr EAddr, Maybe W256), Set (Expr EWord))]+    go :: Expr a -> StorageReads     go = \case-      SLoad slot store ->-        [((fromMaybe (internalError $ "could not extract address from: " <> show store) (Expr.getAddr store), Expr.getLogicalIdx store), Set.singleton slot) | containsNode isAbstractStore store]-      _ -> []+      SLoad slot store | baseIsAbstractStore store -> case Expr.getAddr store of+          Nothing -> internalError $ "could not extract address from: " <> show store+          Just address -> StorageReads $ Map.singleton (address, Expr.getLogicalIdx store) (Set.singleton slot)+      _ -> mempty -    isAbstractStore (AbstractStore _ _) = True-    isAbstractStore _ = False+    baseIsAbstractStore :: Expr 'Storage -> Bool+    baseIsAbstractStore (AbstractStore _ _) = True+    baseIsAbstractStore (ConcreteStore _) = False+    baseIsAbstractStore (SStore _ _ base) = baseIsAbstractStore base+    baseIsAbstractStore (GVar _) = internalError "Unexpected GVar"  findBufferAccess :: TraversableTerm a => [a] -> [(Expr EWord, Expr EWord, Expr Buf)]-findBufferAccess = foldl (foldTerm go) mempty+findBufferAccess = foldl' (foldTerm go) mempty   where     go :: Expr a -> [(Expr EWord, Expr EWord, Expr Buf)]     go = \case@@ -338,7 +310,7 @@     -- we assign a default read hint of 4 to start with in these cases (since in most cases we will need at least 4 bytes to produce a counterexample)     allBufs = Map.fromList . fmap (, Lit 4) . fmap toLazyText . nubOrd . concat $ fmap referencedBufs props <> fmap referencedBufs (Map.elems benv) <> fmap referencedBufs (Map.elems senv) -    bufMap = Map.unionWith Expr.max (foldl addBound mempty allReads) allBufs+    bufMap = Map.unionWith Expr.max (foldl' addBound mempty allReads) allBufs      addBound m (idx, size, buf) =       case baseBuf buf of@@ -358,39 +330,39 @@  -- | Returns an SMT2 object with all buffers referenced from the input props declared, and with the appropriate cex extraction metadata attached declareBufs :: [Prop] -> BufEnv -> StoreEnv -> SMT2-declareBufs props bufEnv storeEnv = SMT2 ("; buffers" : fmap declareBuf allBufs <> ("; buffer lengths" : fmap declareLength allBufs)) cexvars mempty+declareBufs props bufEnv storeEnv = SMT2 (SMTScript ((SMTComment "buffers") : fmap declareBuf allBufs <> ((SMTComment "buffer lengths") : fmap declareLength allBufs))) cexvars mempty   where     cexvars = (mempty :: CexVars){ buffers = discoverMaxReads props bufEnv storeEnv }     allBufs = fmap fromLazyText $ Map.keys cexvars.buffers-    declareBuf n = "(declare-fun " <> n <> " () (Array (_ BitVec 256) (_ BitVec 8)))"-    declareLength n = "(declare-fun " <> n <> "_length" <> " () (_ BitVec 256))"+    declareBuf n = SMTCommand $ "(declare-fun " <> n <> " () (Array (_ BitVec 256) (_ BitVec 8)))"+    declareLength n = SMTCommand $ "(declare-fun " <> n <> "_length" <> " () (_ BitVec 256))"  -- Given a list of variable names, create an SMT2 object with the variables declared declareVars :: [Builder] -> SMT2-declareVars names = SMT2 (["; variables"] <> fmap declare names) cexvars mempty+declareVars names = SMT2 (SMTScript ([SMTComment "variables"] <> fmap declare names)) cexvars mempty   where-    declare n = "(declare-fun " <> n <> " () (_ BitVec 256))"+    declare n = SMTCommand $ "(declare-fun " <> n <> " () (_ BitVec 256))"     cexvars = (mempty :: CexVars){ calldata = fmap toLazyText names }  -- Given a list of variable names, create an SMT2 object with the variables declared declareConstrainAddrs :: [Builder] -> SMT2-declareConstrainAddrs names = SMT2 (["; concrete and symbolic addresses"] <> fmap declare names <> fmap assume names) cexvars mempty+declareConstrainAddrs names = SMT2 (SMTScript ([SMTComment "concrete and symbolic addresses"] <> fmap declare names <> fmap assume names)) cexvars mempty   where-    declare n = "(declare-fun " <> n <> " () Addr)"+    declare n = SMTCommand $ "(declare-fun " <> n <> " () Addr)"     -- assume that symbolic addresses do not collide with the zero address or precompiles-    assume n = "(assert (bvugt " <> n <> " (_ bv9 160)))"+    assume n = SMTCommand $ "(assert (bvugt " <> n <> " (_ bv9 160)))"     cexvars = (mempty :: CexVars){ addrs = fmap toLazyText names }  -- The gas is a tuple of (prefix, index). Within each prefix, the gas is strictly decreasing as the -- index increases. This function gets a map of Prefix -> [Int], and for each prefix, -- enforces the order-enforceGasOrder :: [Prop] -> SMT2-enforceGasOrder ps = SMT2 (["; gas ordering"] <> (concatMap (uncurry order) indices)) mempty mempty+enforceGasOrder :: [Prop] -> [SMTEntry]+enforceGasOrder ps = [SMTComment "gas ordering"] <> (concatMap (uncurry order) indices)   where-    order :: TS.Text -> [Int] -> [Builder]+    order :: TS.Text -> [Int] -> [SMTEntry]     order prefix n = consecutivePairs (nubInt n) >>= \(x, y)->       -- The GAS instruction itself costs gas, so it's strictly decreasing-      ["(assert (bvugt " <> fromRight' (exprToSMT (Gas prefix x)) <> " " <>+      [SMTCommand $ "(assert (bvugt " <> fromRight' (exprToSMT (Gas prefix x)) <> " " <>         fromRight' ((exprToSMT (Gas prefix y))) <> "))"]     consecutivePairs :: [Int] -> [(Int, Int)]     consecutivePairs [] = []@@ -406,253 +378,42 @@ declareFrameContext :: [(Builder, [Prop])] -> Err SMT2 declareFrameContext names = do   decls <- concatMapM declare names-  pure $ SMT2 (["; frame context"] <> decls) cexvars mempty+  pure $ SMT2 (SMTScript ([SMTComment "frame context"] <> decls)) cexvars mempty   where     declare (n,props) = do       asserts <- mapM assertSMT props-      pure $ [ "(declare-fun " <> n <> " () (_ BitVec 256))" ] <> asserts+      pure $ (SMTCommand $ "(declare-fun " <> n <> " () (_ BitVec 256))") : asserts     cexvars = (mempty :: CexVars){ txContext = fmap (toLazyText . fst) names } -declareAbstractStores :: [Builder] -> SMT2-declareAbstractStores names = SMT2 (["; abstract base stores"] <> fmap declare names) mempty mempty+declareAbstractStores :: [Builder] -> [SMTEntry]+declareAbstractStores names = [SMTComment "abstract base stores"] <> fmap declare names   where-    declare n = "(declare-fun " <> n <> " () Storage)"+    declare n = SMTCommand $ "(declare-fun " <> n <> " () Storage)"  declareBlockContext :: [(Builder, [Prop])] -> Err SMT2 declareBlockContext names = do   decls <- concatMapM declare names-  pure $ SMT2 (["; block context"] <> decls) cexvars mempty+  pure $ SMT2 (SMTScript ([SMTComment "block context"] <> decls)) cexvars mempty   where     declare (n, props) = do       asserts <- mapM assertSMT props-      pure $ [ "(declare-fun " <> n <> " () (_ BitVec 256))" ] <> asserts+      pure $ [ SMTCommand $ "(declare-fun " <> n <> " () (_ BitVec 256))" ] <> asserts     cexvars = (mempty :: CexVars){ blockContext = fmap (toLazyText . fst) names } -assertSMT :: Prop -> Either String Builder+assertSMT :: Prop -> Either String SMTEntry assertSMT p = do   p' <- propToSMT p-  pure $ "(assert " <> p' <> ")"--prelude :: SMT2-prelude =  SMT2 src mempty mempty-  where-  src = fmap (fromLazyText . T.drop 2) . T.lines $ [i|-  ; logic-  (set-info :smt-lib-version 2.6)-  ;(set-logic QF_AUFBV)-  (set-logic ALL)-  (set-info :source |-  Generator: hevm-  Application: hevm symbolic execution system-  |)-  (set-info :category "industrial")--  ; types-  (define-sort Byte () (_ BitVec 8))-  (define-sort Word () (_ BitVec 256))-  (define-sort Addr () (_ BitVec 160))-  (define-sort Buf () (Array Word Byte))--  ; slot -> value-  (define-sort Storage () (Array Word Word))--  ; hash functions. They take buffer and a buffer size, and return a Word-  (declare-fun keccak (Buf Word) Word)-  (declare-fun sha256 (Buf Word) Word)--  ; helper functions-  (define-fun max ((a (_ BitVec 256)) (b (_ BitVec 256))) (_ BitVec 256) (ite (bvult a b) b a))--  ; word indexing-  (define-fun indexWord31 ((w Word)) Byte ((_ extract 7 0) w))-  (define-fun indexWord30 ((w Word)) Byte ((_ extract 15 8) w))-  (define-fun indexWord29 ((w Word)) Byte ((_ extract 23 16) w))-  (define-fun indexWord28 ((w Word)) Byte ((_ extract 31 24) w))-  (define-fun indexWord27 ((w Word)) Byte ((_ extract 39 32) w))-  (define-fun indexWord26 ((w Word)) Byte ((_ extract 47 40) w))-  (define-fun indexWord25 ((w Word)) Byte ((_ extract 55 48) w))-  (define-fun indexWord24 ((w Word)) Byte ((_ extract 63 56) w))-  (define-fun indexWord23 ((w Word)) Byte ((_ extract 71 64) w))-  (define-fun indexWord22 ((w Word)) Byte ((_ extract 79 72) w))-  (define-fun indexWord21 ((w Word)) Byte ((_ extract 87 80) w))-  (define-fun indexWord20 ((w Word)) Byte ((_ extract 95 88) w))-  (define-fun indexWord19 ((w Word)) Byte ((_ extract 103 96) w))-  (define-fun indexWord18 ((w Word)) Byte ((_ extract 111 104) w))-  (define-fun indexWord17 ((w Word)) Byte ((_ extract 119 112) w))-  (define-fun indexWord16 ((w Word)) Byte ((_ extract 127 120) w))-  (define-fun indexWord15 ((w Word)) Byte ((_ extract 135 128) w))-  (define-fun indexWord14 ((w Word)) Byte ((_ extract 143 136) w))-  (define-fun indexWord13 ((w Word)) Byte ((_ extract 151 144) w))-  (define-fun indexWord12 ((w Word)) Byte ((_ extract 159 152) w))-  (define-fun indexWord11 ((w Word)) Byte ((_ extract 167 160) w))-  (define-fun indexWord10 ((w Word)) Byte ((_ extract 175 168) w))-  (define-fun indexWord9 ((w Word)) Byte ((_ extract 183 176) w))-  (define-fun indexWord8 ((w Word)) Byte ((_ extract 191 184) w))-  (define-fun indexWord7 ((w Word)) Byte ((_ extract 199 192) w))-  (define-fun indexWord6 ((w Word)) Byte ((_ extract 207 200) w))-  (define-fun indexWord5 ((w Word)) Byte ((_ extract 215 208) w))-  (define-fun indexWord4 ((w Word)) Byte ((_ extract 223 216) w))-  (define-fun indexWord3 ((w Word)) Byte ((_ extract 231 224) w))-  (define-fun indexWord2 ((w Word)) Byte ((_ extract 239 232) w))-  (define-fun indexWord1 ((w Word)) Byte ((_ extract 247 240) w))-  (define-fun indexWord0 ((w Word)) Byte ((_ extract 255 248) w))--  ; symbolic word indexing-  ; a bitshift based version might be more performant here...-  (define-fun indexWord ((idx Word) (w Word)) Byte-    (ite (bvuge idx (_ bv32 256)) (_ bv0 8)-    (ite (= idx (_ bv31 256)) (indexWord31 w)-    (ite (= idx (_ bv30 256)) (indexWord30 w)-    (ite (= idx (_ bv29 256)) (indexWord29 w)-    (ite (= idx (_ bv28 256)) (indexWord28 w)-    (ite (= idx (_ bv27 256)) (indexWord27 w)-    (ite (= idx (_ bv26 256)) (indexWord26 w)-    (ite (= idx (_ bv25 256)) (indexWord25 w)-    (ite (= idx (_ bv24 256)) (indexWord24 w)-    (ite (= idx (_ bv23 256)) (indexWord23 w)-    (ite (= idx (_ bv22 256)) (indexWord22 w)-    (ite (= idx (_ bv21 256)) (indexWord21 w)-    (ite (= idx (_ bv20 256)) (indexWord20 w)-    (ite (= idx (_ bv19 256)) (indexWord19 w)-    (ite (= idx (_ bv18 256)) (indexWord18 w)-    (ite (= idx (_ bv17 256)) (indexWord17 w)-    (ite (= idx (_ bv16 256)) (indexWord16 w)-    (ite (= idx (_ bv15 256)) (indexWord15 w)-    (ite (= idx (_ bv14 256)) (indexWord14 w)-    (ite (= idx (_ bv13 256)) (indexWord13 w)-    (ite (= idx (_ bv12 256)) (indexWord12 w)-    (ite (= idx (_ bv11 256)) (indexWord11 w)-    (ite (= idx (_ bv10 256)) (indexWord10 w)-    (ite (= idx (_ bv9 256)) (indexWord9 w)-    (ite (= idx (_ bv8 256)) (indexWord8 w)-    (ite (= idx (_ bv7 256)) (indexWord7 w)-    (ite (= idx (_ bv6 256)) (indexWord6 w)-    (ite (= idx (_ bv5 256)) (indexWord5 w)-    (ite (= idx (_ bv4 256)) (indexWord4 w)-    (ite (= idx (_ bv3 256)) (indexWord3 w)-    (ite (= idx (_ bv2 256)) (indexWord2 w)-    (ite (= idx (_ bv1 256)) (indexWord1 w)-    (indexWord0 w)-    ))))))))))))))))))))))))))))))))-  )--  (define-fun readWord ((idx Word) (buf Buf)) Word-    (concat-      (select buf idx)-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000001))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000002))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000003))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000004))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000005))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000006))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000007))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000008))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000009))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000a))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000b))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000c))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000d))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000e))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000f))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000010))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000011))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000012))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000013))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000014))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000015))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000016))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000017))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000018))-      (concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000019))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001a))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001b))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001c))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001d))-      (concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001e))-      (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001f))-      ))))))))))))))))))))))))))))))-    )-  )--  (define-fun writeWord ((idx Word) (val Word) (buf Buf)) Buf-      (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store-      (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store buf-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001f) (indexWord31 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001e) (indexWord30 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001d) (indexWord29 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001c) (indexWord28 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001b) (indexWord27 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001a) (indexWord26 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000019) (indexWord25 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000018) (indexWord24 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000017) (indexWord23 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000016) (indexWord22 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000015) (indexWord21 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000014) (indexWord20 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000013) (indexWord19 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000012) (indexWord18 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000011) (indexWord17 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000010) (indexWord16 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000f) (indexWord15 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000e) (indexWord14 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000d) (indexWord13 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000c) (indexWord12 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000b) (indexWord11 val))-      (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000a) (indexWord10 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000009) (indexWord9 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000008) (indexWord8 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000007) (indexWord7 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000006) (indexWord6 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000005) (indexWord5 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000004) (indexWord4 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000003) (indexWord3 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000002) (indexWord2 val))-      (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000001) (indexWord1 val))-      idx (indexWord0 val))-  )+  pure $ SMTCommand ("(assert " <> p' <> ")") -  ; block context-  (declare-fun blockhash (Word) Word)-  (declare-fun codesize (Addr) Word)+wordAsBV :: forall a. Integral a => a -> Builder+wordAsBV w = "(_ bv" <> Data.Text.Lazy.Builder.Int.decimal w <> " 256)" -  ; macros-  (define-fun signext ( (b Word) (val Word)) Word-    (ite (= b (_ bv0  256)) ((_ sign_extend 248) ((_ extract 7    0) val))-    (ite (= b (_ bv1  256)) ((_ sign_extend 240) ((_ extract 15   0) val))-    (ite (= b (_ bv2  256)) ((_ sign_extend 232) ((_ extract 23   0) val))-    (ite (= b (_ bv3  256)) ((_ sign_extend 224) ((_ extract 31   0) val))-    (ite (= b (_ bv4  256)) ((_ sign_extend 216) ((_ extract 39   0) val))-    (ite (= b (_ bv5  256)) ((_ sign_extend 208) ((_ extract 47   0) val))-    (ite (= b (_ bv6  256)) ((_ sign_extend 200) ((_ extract 55   0) val))-    (ite (= b (_ bv7  256)) ((_ sign_extend 192) ((_ extract 63   0) val))-    (ite (= b (_ bv8  256)) ((_ sign_extend 184) ((_ extract 71   0) val))-    (ite (= b (_ bv9  256)) ((_ sign_extend 176) ((_ extract 79   0) val))-    (ite (= b (_ bv10 256)) ((_ sign_extend 168) ((_ extract 87   0) val))-    (ite (= b (_ bv11 256)) ((_ sign_extend 160) ((_ extract 95   0) val))-    (ite (= b (_ bv12 256)) ((_ sign_extend 152) ((_ extract 103  0) val))-    (ite (= b (_ bv13 256)) ((_ sign_extend 144) ((_ extract 111  0) val))-    (ite (= b (_ bv14 256)) ((_ sign_extend 136) ((_ extract 119  0) val))-    (ite (= b (_ bv15 256)) ((_ sign_extend 128) ((_ extract 127  0) val))-    (ite (= b (_ bv16 256)) ((_ sign_extend 120) ((_ extract 135  0) val))-    (ite (= b (_ bv17 256)) ((_ sign_extend 112) ((_ extract 143  0) val))-    (ite (= b (_ bv18 256)) ((_ sign_extend 104) ((_ extract 151  0) val))-    (ite (= b (_ bv19 256)) ((_ sign_extend 96 ) ((_ extract 159  0) val))-    (ite (= b (_ bv20 256)) ((_ sign_extend 88 ) ((_ extract 167  0) val))-    (ite (= b (_ bv21 256)) ((_ sign_extend 80 ) ((_ extract 175  0) val))-    (ite (= b (_ bv22 256)) ((_ sign_extend 72 ) ((_ extract 183  0) val))-    (ite (= b (_ bv23 256)) ((_ sign_extend 64 ) ((_ extract 191  0) val))-    (ite (= b (_ bv24 256)) ((_ sign_extend 56 ) ((_ extract 199  0) val))-    (ite (= b (_ bv25 256)) ((_ sign_extend 48 ) ((_ extract 207  0) val))-    (ite (= b (_ bv26 256)) ((_ sign_extend 40 ) ((_ extract 215  0) val))-    (ite (= b (_ bv27 256)) ((_ sign_extend 32 ) ((_ extract 223  0) val))-    (ite (= b (_ bv28 256)) ((_ sign_extend 24 ) ((_ extract 231  0) val))-    (ite (= b (_ bv29 256)) ((_ sign_extend 16 ) ((_ extract 239  0) val))-    (ite (= b (_ bv30 256)) ((_ sign_extend 8  ) ((_ extract 247  0) val)) val))))))))))))))))))))))))))))))))-  |]+byteAsBV :: Word8 -> Builder+byteAsBV b = "(_ bv" <> Data.Text.Lazy.Builder.Int.decimal b <> " 8)"  exprToSMT :: Expr a -> Err Builder exprToSMT = \case-  Lit w -> pure $ fromLazyText $ "(_ bv" <> (T.pack $ show (into w :: Integer)) <> " 256)"+  Lit w -> pure $ wordAsBV w   Var s -> pure $ fromText s   GVar (BufVar n) -> pure $ fromString $ "buf" <> (show n)   GVar (StoreVar n) -> pure $ fromString $ "store" <> (show n)@@ -774,7 +535,7 @@     wa <- exprToSMT a     pure $ "((_ zero_extend 96)" `sp` wa `sp` ")" -  LitByte b -> pure $ fromLazyText $ "(_ bv" <> T.pack (show (into b :: Integer)) <> " 8)"+  LitByte b -> pure $ byteAsBV b   IndexWord idx w -> case idx of     Lit n -> if n >= 0 && n < 32              then do@@ -878,17 +639,20 @@  -- | Stores a region of src into dst copySlice :: Expr EWord -> Expr EWord -> Expr EWord -> Builder -> Builder -> Err Builder-copySlice srcOffset dstOffset size0@(Lit _) src dst = do-  sz <- internal size0+copySlice srcOffset dstOffset (Lit size) src dst = do+  sz <- internal size   pure $ "(let ((src " <> src <> ")) " <> sz <> ")"   where-    internal (Lit 0) = pure dst-    internal size = do-      let size' = (Expr.sub size (Lit 1))-      encDstOff <- exprToSMT (Expr.add dstOffset size')-      encSrcOff <- exprToSMT (Expr.add srcOffset size')-      child <- internal size'+    internal 0 = pure dst+    internal idx = do+      let idx' = idx - 1+      encDstOff <- offset idx' dstOffset+      encSrcOff <- offset idx' srcOffset+      child <- internal idx'       pure $ "(store " <> child `sp` encDstOff `sp` "(select src " <> encSrcOff <> "))"+    offset :: W256 -> Expr EWord -> Err Builder+    offset o (Lit b) = pure $ wordAsBV $ o + b+    offset o e = exprToSMT $ Expr.add (Lit o) e copySlice _ _ _ _ _ = Left "CopySlice with a symbolically sized region not currently implemented, cannot execute SMT solver on this query"  -- | Unrolls an exponentiation into a series of multiplications@@ -919,20 +683,19 @@ -- | Concatenates a list of bytes into a larger bitvector writeBytes :: ByteString -> Expr Buf -> Err Builder writeBytes bytes buf =  do-  buf' <- exprToSMT buf-  ret <- foldM wrap (0, buf') $ BS.unpack bytes+  smtText <- exprToSMT buf+  let ret = BS.foldl wrap (0, smtText) bytes   pure $ snd ret   where     -- we don't need to store zeros if the base buffer is empty     skipZeros = buf == mempty-    wrap :: (Int, Builder) -> Word8 -> Err (Int, Builder)-    wrap (idx, inner) byte =+    wrap :: (Int, Builder) -> Word8 -> (Int, Builder)+    wrap (idx, acc) byte =       if skipZeros && byte == 0-      then pure (idx + 1, inner)-      else do-          byteSMT <- exprToSMT (LitByte byte)-          idxSMT <- exprToSMT . Lit . unsafeInto $ idx-          pure (idx + 1, "(store " <> inner `sp` idxSMT `sp` byteSMT <> ")")+      then (idx', acc)+      else (idx', "(store " <> acc `sp` (wordAsBV idx) `sp` (byteAsBV byte) <> ")")+      where+        !idx' = idx + 1  encodeConcreteStore :: Map W256 W256 -> Err Builder encodeConcreteStore s = foldM encodeWrite ("((as const Storage) #x0000000000000000000000000000000000000000000000000000000000000000)") (Map.toList s)@@ -962,9 +725,6 @@ parseW256 :: SpecConstant -> W256 parseW256 = parseSC -parseInteger :: SpecConstant -> Integer-parseInteger = parseSC- parseW8 :: SpecConstant -> Word8 parseW8 = parseSC @@ -990,11 +750,6 @@   | Just a <- TS.stripPrefix "symaddr_" name = SymAddr a   | otherwise = internalError $ "cannot parse: " <> show name -textToInt :: TS.Text -> Int-textToInt text = case decimal text of-  Right (value, _) -> value-  Left _ -> internalError $ "cannot parse '" <> (TS.unpack text) <> "' into an Int"- parseBlockCtx :: TS.Text -> Expr EWord parseBlockCtx "origin" = Origin parseBlockCtx "coinbase" = Coinbase@@ -1114,10 +869,10 @@ -- concretized storage getStore   :: (Text -> IO Text)-  -> Map (Expr EAddr, Maybe W256) (Set (Expr EWord))+  -> StorageReads   -> IO (Map (Expr EAddr) (Map W256 W256))-getStore getVal abstractReads =-  fmap Map.fromList $ forM (Map.toList abstractReads) $ \((addr, idx), slots) -> do+getStore getVal (StorageReads innerMap) =+  fmap Map.fromList $ forM (Map.toList innerMap) $ \((addr, idx), slots) -> do     let name = toLazyText (storeName addr idx)     raw <- getVal name     let parsed = case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of@@ -1144,12 +899,12 @@   -- this exprToSMT should never fail, since we have already ran the solver   let expr = toLazyText $ fromRight' $ exprToSMT w   raw <- getVal expr-  case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of-    Right (ResSpecific (valParsed :| [])) ->-      case valParsed of-        (_, TermSpecConstant sc) -> pure $ parseW256 sc-        _ -> internalError $ "cannot parse model for: " <> show w+  let valTxt = fromMaybe (internalError $ "failed to parse value from get-val response: " <> show raw) $ extractValue raw+  case parseString specConstant (T.toStrict valTxt) of+    Right sc -> pure $ parseW256 sc     r -> parseErr r+  where+    extractValue getValResponse = (T.stripSuffix "))") $ snd $ T.breakOnEnd " " $ T.stripEnd getValResponse  -- | Interpret an N-dimensional array as a value of type a. -- Parameterized by an interpretation function for array values.

@@ -0,0 +1,217 @@++module EVM.SMT.SMTLIB (+  prelude,+  toText,+  hasDuplicateCommands+) where++import Data.Containers.ListUtils (nubOrd)+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Builder++import EVM.SMT.Types++prelude :: SMT2+prelude =  SMT2 src mempty mempty+  where+  src = SMTScript $ header <> types <> macros+  header = fmap SMTCommand [+    "(set-info :smt-lib-version 2.6)",+    "(set-logic ALL)",+    "(set-info :source |\n Generator: hevm\n Application: hevm symbolic execution system\n |)",+    "(set-info :category \"industrial\")"+    ]+  types = (SMTComment "types") : (fmap SMTCommand [+    "(define-sort Byte () (_ BitVec 8))",+    "(define-sort Word () (_ BitVec 256))",+    "(define-sort Addr () (_ BitVec 160))",+    "(define-sort Buf () (Array Word Byte))"+    ]) <> [(SMTComment "slot -> value"), SMTCommand "(define-sort Storage () (Array Word Word))"]+    <> (fmap SMTCommand [+        "(declare-fun keccak (Buf Word) Word)",+        "(declare-fun sha256 (Buf Word) Word)"+    ])+  macros = fmap SMTCommand [+    "(define-fun max ((a (_ BitVec 256)) (b (_ BitVec 256))) (_ BitVec 256) (ite (bvult a b) b a))",+    "(define-fun indexWord31 ((w Word)) Byte ((_ extract 7 0) w))",+    "(define-fun indexWord30 ((w Word)) Byte ((_ extract 15 8) w))",+    "(define-fun indexWord29 ((w Word)) Byte ((_ extract 23 16) w))",+    "(define-fun indexWord28 ((w Word)) Byte ((_ extract 31 24) w))",+    "(define-fun indexWord27 ((w Word)) Byte ((_ extract 39 32) w))",+    "(define-fun indexWord26 ((w Word)) Byte ((_ extract 47 40) w))",+    "(define-fun indexWord25 ((w Word)) Byte ((_ extract 55 48) w))",+    "(define-fun indexWord24 ((w Word)) Byte ((_ extract 63 56) w))",+    "(define-fun indexWord23 ((w Word)) Byte ((_ extract 71 64) w))",+    "(define-fun indexWord22 ((w Word)) Byte ((_ extract 79 72) w))",+    "(define-fun indexWord21 ((w Word)) Byte ((_ extract 87 80) w))",+    "(define-fun indexWord20 ((w Word)) Byte ((_ extract 95 88) w))",+    "(define-fun indexWord19 ((w Word)) Byte ((_ extract 103 96) w))",+    "(define-fun indexWord18 ((w Word)) Byte ((_ extract 111 104) w))",+    "(define-fun indexWord17 ((w Word)) Byte ((_ extract 119 112) w))",+    "(define-fun indexWord16 ((w Word)) Byte ((_ extract 127 120) w))",+    "(define-fun indexWord15 ((w Word)) Byte ((_ extract 135 128) w))",+    "(define-fun indexWord14 ((w Word)) Byte ((_ extract 143 136) w))",+    "(define-fun indexWord13 ((w Word)) Byte ((_ extract 151 144) w))",+    "(define-fun indexWord12 ((w Word)) Byte ((_ extract 159 152) w))",+    "(define-fun indexWord11 ((w Word)) Byte ((_ extract 167 160) w))",+    "(define-fun indexWord10 ((w Word)) Byte ((_ extract 175 168) w))",+    "(define-fun indexWord9 ((w Word)) Byte ((_ extract 183 176) w))",+    "(define-fun indexWord8 ((w Word)) Byte ((_ extract 191 184) w))",+    "(define-fun indexWord7 ((w Word)) Byte ((_ extract 199 192) w))",+    "(define-fun indexWord6 ((w Word)) Byte ((_ extract 207 200) w))",+    "(define-fun indexWord5 ((w Word)) Byte ((_ extract 215 208) w))",+    "(define-fun indexWord4 ((w Word)) Byte ((_ extract 223 216) w))",+    "(define-fun indexWord3 ((w Word)) Byte ((_ extract 231 224) w))",+    "(define-fun indexWord2 ((w Word)) Byte ((_ extract 239 232) w))",+    "(define-fun indexWord1 ((w Word)) Byte ((_ extract 247 240) w))",+    "(define-fun indexWord0 ((w Word)) Byte ((_ extract 255 248) w))",+    "(define-fun indexWord ((idx Word) (w Word)) Byte\+      \(ite (bvuge idx (_ bv32 256)) (_ bv0 8)\+      \(ite (= idx (_ bv31 256)) (indexWord31 w)\+      \(ite (= idx (_ bv30 256)) (indexWord30 w)\+      \(ite (= idx (_ bv29 256)) (indexWord29 w)\+      \(ite (= idx (_ bv28 256)) (indexWord28 w)\+      \(ite (= idx (_ bv27 256)) (indexWord27 w)\+      \(ite (= idx (_ bv26 256)) (indexWord26 w)\+      \(ite (= idx (_ bv25 256)) (indexWord25 w)\+      \(ite (= idx (_ bv24 256)) (indexWord24 w)\+      \(ite (= idx (_ bv23 256)) (indexWord23 w)\+      \(ite (= idx (_ bv22 256)) (indexWord22 w)\+      \(ite (= idx (_ bv21 256)) (indexWord21 w)\+      \(ite (= idx (_ bv20 256)) (indexWord20 w)\+      \(ite (= idx (_ bv19 256)) (indexWord19 w)\+      \(ite (= idx (_ bv18 256)) (indexWord18 w)\+      \(ite (= idx (_ bv17 256)) (indexWord17 w)\+      \(ite (= idx (_ bv16 256)) (indexWord16 w)\+      \(ite (= idx (_ bv15 256)) (indexWord15 w)\+      \(ite (= idx (_ bv14 256)) (indexWord14 w)\+      \(ite (= idx (_ bv13 256)) (indexWord13 w)\+      \(ite (= idx (_ bv12 256)) (indexWord12 w)\+      \(ite (= idx (_ bv11 256)) (indexWord11 w)\+      \(ite (= idx (_ bv10 256)) (indexWord10 w)\+      \(ite (= idx (_ bv9 256)) (indexWord9 w)\+      \(ite (= idx (_ bv8 256)) (indexWord8 w)\+      \(ite (= idx (_ bv7 256)) (indexWord7 w)\+      \(ite (= idx (_ bv6 256)) (indexWord6 w)\+      \(ite (= idx (_ bv5 256)) (indexWord5 w)\+      \(ite (= idx (_ bv4 256)) (indexWord4 w)\+      \(ite (= idx (_ bv3 256)) (indexWord3 w)\+      \(ite (= idx (_ bv2 256)) (indexWord2 w)\+      \(ite (= idx (_ bv1 256)) (indexWord1 w)\+      \(indexWord0 w)\+      \)))))))))))))))))))))))))))))))))",+    "(define-fun readWord ((idx Word) (buf Buf)) Word\+      \(concat (select buf idx)\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000001))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000002))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000003))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000004))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000005))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000006))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000007))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000008))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000009))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000a))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000b))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000c))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000d))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000e))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000000f))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000010))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000011))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000012))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000013))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000014))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000015))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000016))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000017))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000018))\+      \(concat (select buf (bvadd idx #x0000000000000000000000000000000000000000000000000000000000000019))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001a))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001b))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001c))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001d))\+      \(concat (select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001e))\+      \(select buf (bvadd idx #x000000000000000000000000000000000000000000000000000000000000001f)\+      \)))))))))))))))))))))))))))))))))",+    "(define-fun writeWord ((idx Word) (val Word) (buf Buf)) Buf\+      \(store (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store (store\+      \(store (store (store (store (store (store (store (store (store (store (store (store (store (store (store buf\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000001f) (indexWord31 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000001e) (indexWord30 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000001d) (indexWord29 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000001c) (indexWord28 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000001b) (indexWord27 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000001a) (indexWord26 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000019) (indexWord25 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000018) (indexWord24 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000017) (indexWord23 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000016) (indexWord22 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000015) (indexWord21 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000014) (indexWord20 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000013) (indexWord19 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000012) (indexWord18 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000011) (indexWord17 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000010) (indexWord16 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000000f) (indexWord15 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000000e) (indexWord14 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000000d) (indexWord13 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000000c) (indexWord12 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000000b) (indexWord11 val))\+      \(bvadd idx #x000000000000000000000000000000000000000000000000000000000000000a) (indexWord10 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000009) (indexWord9 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000008) (indexWord8 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000007) (indexWord7 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000006) (indexWord6 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000005) (indexWord5 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000004) (indexWord4 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000003) (indexWord3 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000002) (indexWord2 val))\+      \(bvadd idx #x0000000000000000000000000000000000000000000000000000000000000001) (indexWord1 val))\+      \idx (indexWord0 val)))",+    "(declare-fun blockhash (Word) Word)",+    "(declare-fun codesize (Addr) Word)",+    "(define-fun signext ( (b Word) (val Word)) Word\+      \(ite (= b (_ bv0  256)) ((_ sign_extend 248) ((_ extract 7    0) val))\+      \(ite (= b (_ bv1  256)) ((_ sign_extend 240) ((_ extract 15   0) val))\+      \(ite (= b (_ bv2  256)) ((_ sign_extend 232) ((_ extract 23   0) val))\+      \(ite (= b (_ bv3  256)) ((_ sign_extend 224) ((_ extract 31   0) val))\+      \(ite (= b (_ bv4  256)) ((_ sign_extend 216) ((_ extract 39   0) val))\+      \(ite (= b (_ bv5  256)) ((_ sign_extend 208) ((_ extract 47   0) val))\+      \(ite (= b (_ bv6  256)) ((_ sign_extend 200) ((_ extract 55   0) val))\+      \(ite (= b (_ bv7  256)) ((_ sign_extend 192) ((_ extract 63   0) val))\+      \(ite (= b (_ bv8  256)) ((_ sign_extend 184) ((_ extract 71   0) val))\+      \(ite (= b (_ bv9  256)) ((_ sign_extend 176) ((_ extract 79   0) val))\+      \(ite (= b (_ bv10 256)) ((_ sign_extend 168) ((_ extract 87   0) val))\+      \(ite (= b (_ bv11 256)) ((_ sign_extend 160) ((_ extract 95   0) val))\+      \(ite (= b (_ bv12 256)) ((_ sign_extend 152) ((_ extract 103  0) val))\+      \(ite (= b (_ bv13 256)) ((_ sign_extend 144) ((_ extract 111  0) val))\+      \(ite (= b (_ bv14 256)) ((_ sign_extend 136) ((_ extract 119  0) val))\+      \(ite (= b (_ bv15 256)) ((_ sign_extend 128) ((_ extract 127  0) val))\+      \(ite (= b (_ bv16 256)) ((_ sign_extend 120) ((_ extract 135  0) val))\+      \(ite (= b (_ bv17 256)) ((_ sign_extend 112) ((_ extract 143  0) val))\+      \(ite (= b (_ bv18 256)) ((_ sign_extend 104) ((_ extract 151  0) val))\+      \(ite (= b (_ bv19 256)) ((_ sign_extend 96 ) ((_ extract 159  0) val))\+      \(ite (= b (_ bv20 256)) ((_ sign_extend 88 ) ((_ extract 167  0) val))\+      \(ite (= b (_ bv21 256)) ((_ sign_extend 80 ) ((_ extract 175  0) val))\+      \(ite (= b (_ bv22 256)) ((_ sign_extend 72 ) ((_ extract 183  0) val))\+      \(ite (= b (_ bv23 256)) ((_ sign_extend 64 ) ((_ extract 191  0) val))\+      \(ite (= b (_ bv24 256)) ((_ sign_extend 56 ) ((_ extract 199  0) val))\+      \(ite (= b (_ bv25 256)) ((_ sign_extend 48 ) ((_ extract 207  0) val))\+      \(ite (= b (_ bv26 256)) ((_ sign_extend 40 ) ((_ extract 215  0) val))\+      \(ite (= b (_ bv27 256)) ((_ sign_extend 32 ) ((_ extract 223  0) val))\+      \(ite (= b (_ bv28 256)) ((_ sign_extend 24 ) ((_ extract 231  0) val))\+      \(ite (= b (_ bv29 256)) ((_ sign_extend 16 ) ((_ extract 239  0) val))\+      \(ite (= b (_ bv30 256)) ((_ sign_extend 8  ) ((_ extract 247  0) val)) val)\+      \)))))))))))))))))))))))))))))))"+    ]+++toText :: SMTEntry -> Text+toText (SMTCommand b) = toLazyText b+toText (SMTComment b) = "; " <> toLazyText b++hasDuplicateCommands :: SMTScript -> Bool+hasDuplicateCommands (SMTScript entries) = length cmdTexts /= length (nubOrd cmdTexts)+  where+    cmdTexts = [toText c | c@(SMTCommand _) <- entries]

@@ -0,0 +1,67 @@+module EVM.SMT.Types where++import Data.Text.Lazy (Text)+import Data.Text.Lazy.Builder+import Data.Map (Map)+import Data.Map qualified as Map (unionWith)+import Data.Set (Set)++import EVM.Types++data SMTEntry = SMTCommand Builder | SMTComment Builder+  deriving (Eq)++newtype SMTScript = SMTScript [SMTEntry]+  deriving (Eq, Monoid, Semigroup)++-- Props are ONLY for pretty printing the query Props+data SMT2 = SMT2 SMTScript CexVars [Prop]+  deriving (Eq)++instance Semigroup SMT2 where+  (SMT2 a c d) <> (SMT2 a2 c2 d2) = SMT2 (a <> a2) (c <> c2) (d <> d2)++instance Monoid SMT2 where+  mempty = SMT2 mempty mempty mempty+++newtype StorageReads = StorageReads (Map (Expr EAddr, Maybe W256) (Set (Expr EWord)))+  deriving (Eq, Show)++instance Semigroup StorageReads where+  StorageReads m1 <> StorageReads m2 =+    StorageReads (Map.unionWith (<>) m1 m2)++instance Monoid StorageReads where+  mempty = StorageReads mempty+++-- | Data that we need to construct a nice counterexample+data CexVars = CexVars+  { -- | variable names that we need models for to reconstruct calldata+    calldata     :: [Text]+    -- | symbolic address names+  , addrs        :: [Text]+    -- | buffer names and guesses at their maximum size+  , buffers      :: Map Text (Expr EWord)+    -- | reads from abstract storage+  , storeReads   :: StorageReads+    -- | the names of any block context variables+  , blockContext :: [Text]+    -- | the names of any tx context variables+  , txContext    :: [Text]+  }+  deriving (Eq, Show)++instance Semigroup CexVars where+  (CexVars a b c d e f) <> (CexVars a2 b2 c2 d2 e2 f2) = CexVars (a <> a2) (b <> b2) (c <> c2) (d <> d2) (e <> e2) (f <> f2)++instance Monoid CexVars where+    mempty = CexVars+      { calldata = mempty+      , addrs = mempty+      , buffers = mempty+      , storeReads = mempty+      , blockContext = mempty+      , txContext = mempty+      }

@@ -39,6 +39,8 @@   , astSrcMap   , containsLinkerHole   , makeSourceCache+  , getContractsMap+  , WarningData(..) ) where  import EVM.ABI@@ -66,8 +68,7 @@ import Data.Foldable import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map-import Data.HashMap.Strict qualified as HMap-import Data.List (sort, isPrefixOf, isInfixOf, isSuffixOf, elemIndex, tails, findIndex)+import Data.List (isPrefixOf, isInfixOf, isSuffixOf, elemIndex, tails, findIndex) import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NonEmpty import Data.Maybe@@ -87,7 +88,8 @@ import System.Process import Text.Read (readMaybe) import Witch (unsafeInto)-import Data.Either.Extra (maybeToEither)+import Data.Either.Extra (maybeToEither, fromRight)+import qualified Data.Bifunctor as Bifunctor (first)  data StorageItem = StorageItem   { slotType :: SlotType@@ -161,6 +163,9 @@ newtype Contracts = Contracts (Map Text SolcContract)   deriving newtype (Show, Eq, Semigroup, Monoid) +getContractsMap :: Contracts -> Map Text SolcContract+getContractsMap (Contracts m) = m+ -- | A mapping from contract identifiers (filepath:name) to their ast json newtype Asts = Asts (Map Text Value)   deriving newtype (Show, Eq, Semigroup, Monoid)@@ -176,6 +181,7 @@ newtype Sources = Sources (Map SrcFile (Maybe ByteString))   deriving newtype (Show, Eq, Semigroup, Monoid) +-- THIS contains id -> (filepath, contents) in `sources` data BuildOutput = BuildOutput   { contracts :: Contracts   , sources   :: SourceCache@@ -192,7 +198,7 @@   deriving (Eq, Show, Read, ParseField)  data SourceCache = SourceCache-  { files  :: Map Int (FilePath, ByteString)+  { files  :: Map Int (FilePath, ByteString) -- ^ map from src id to (filepath, contents)   , lines  :: Map Int (Vector ByteString)   , asts   :: Map Text Value   } deriving (Show, Eq, Generic)@@ -226,6 +232,12 @@   modifierDepth :: {-# UNPACK #-} !Int } deriving (Show, Eq, Ord, Generic) +data WarningData s t = WarningData+  {solcContr :: SolcContract,+   sourceCache :: SourceCache,+   vm :: VM s t+  }+ data SrcMapParseState   = F1 String Int   | F2 Int String Int@@ -358,36 +370,35 @@   let contractName = T.pack $ takeBaseName fp   case readJSON pt contractName fileContents of       Left err -> pure . Left $ "unable to parse " <> show pt <> " project JSON: " <> fp-        <> " Contract: " <> show contractName <> "\nError: " <> err+        <> " Contract: " <> show contractName <> "\nError: " <> show err       Right (contracts, asts, sources) -> do         conf <- readConfig         when (conf.debug) $ liftIO $ putStrLn $ "Parsed contract: " <> show contractName <> " file: " <> fp         sourceCache <- liftIO $ makeSourceCache root sources asts         pure (Right (BuildOutput contracts sourceCache)) -yul :: Text -> Text -> IO (Maybe ByteString)-yul contractName src = do-  json <- solc Yul src False-  let f = (json ^?! key "contracts") ^?! key (Key.fromText "hevm.sol")-      c = f ^?! key (Key.fromText $ if T.null contractName then "object" else contractName)-      bytecode = c ^?! key "evm" ^?! key "bytecode" ^?! key "object" % _String-  pure $ (toCode contractName) <$> (Just bytecode)+yul :: Text -> Text -> IO (Either BytecodeReadingError ByteString)+yul contractName src = yul' contractName src False -yulRuntime :: Text -> Text -> IO (Maybe ByteString)-yulRuntime contractName src = do+yulRuntime :: Text -> Text -> IO (Either BytecodeReadingError ByteString)+yulRuntime contractName src = yul' contractName src True++yul' :: Text -> Text -> Bool -> IO (Either BytecodeReadingError ByteString)+yul' contractName src deployed = do   json <- solc Yul src False-  let f = (json ^?! key "contracts") ^?! key (Key.fromText "hevm.sol")+  let f = (json ^?! key "contracts") ^?! key "hevm.sol"       c = f ^?! key (Key.fromText $ if T.null contractName then "object" else contractName)-      bytecode = c ^?! key "evm" ^?! key "deployedBytecode" ^?! key "object" % _String-  pure $ (toCode contractName) <$> (Just bytecode)+      bytecode = c ^?! key "evm" ^?! key (if deployed then "deployedBytecode" else "bytecode") ^?! key "object" % _String+  pure $ toCode contractName bytecode  solidity   :: (MonadUnliftIO m)   => Text -> Text -> m (Maybe ByteString) solidity contract src = liftIO $ do   json <- solc Solidity src False-  let (Contracts sol, _, _) = fromJust $ readStdJSON json-  pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.creationCode)+  case readStdJSON json of+      Right (Contracts sol) -> pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.creationCode)+      Left e -> internalError $ "unable to parse solidity output:\n" <> (T.unpack json) <> "\n" <> show e  solcRuntime'   :: App m@@ -398,8 +409,8 @@     json <- solc Solidity src viaIR     when conf.dumpExprs $ liftIO $ Data.Text.IO.writeFile "compiled_code.json" json     case readStdJSON json of-      Just (Contracts sol, _, _) -> pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.runtimeCode)-      Nothing -> internalError $ "unable to parse solidity output:\n" <> (T.unpack json)+      Right (Contracts sol) -> pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.runtimeCode)+      Left _ -> internalError $ "unable to parse solidity output:\n" <> (T.unpack json)  solcRuntime   :: App m@@ -409,7 +420,7 @@ functionAbi :: Text -> IO Method functionAbi f = do   json <- solc Solidity ("contract ABI { function " <> f <> " public {}}") False-  let (Contracts sol, _, _) = fromMaybe+  let Contracts sol = fromRight         (internalError . T.unpack $ "while trying to parse function signature `"           <> f <> "`, unable to parse solc output:\n" <> json)         (readStdJSON json)@@ -420,31 +431,51 @@ force :: String -> Maybe a -> a force s = fromMaybe (internalError s) -readJSON :: ProjectType -> Text -> Text -> Err (Contracts, Asts, Sources)+data BytecodeReadingError+  = MissingJsonField Text+  | MissingOrInvalidJsonField Text+  | AesonParsingError Text+  | InvalidSourceMap+  | UnlinkedLibrary Text+  | OtherError Text Text++instance Show BytecodeReadingError where+  show (MissingJsonField field) = case field of+      _ | field == "ast" || field == "sources" -> "missing field " <> (T.unpack field) <> ". Recompile with `forge clean && forge build --ast"+        | otherwise -> "missing " <> (T.unpack field) <> " field"+  show (MissingOrInvalidJsonField field) = "missing or invalid " <> (T.unpack field) <> " field"+  show (AesonParsingError errMsg) = "Error when parsing JSON: " <> (T.unpack errMsg)+  show (InvalidSourceMap) = "invalid sourceMap format"+  show (UnlinkedLibrary contract) = "Unlinked libraries detected in bytecode of contract " <> (T.unpack contract)+  show (OtherError contract errMsg) = "Error when reading bytecode of " <> (T.unpack contract) <> ": " <> T.unpack errMsg++type BuildArtifacts = (Contracts, Asts, Sources)++readJSON :: ProjectType -> Text -> Text -> Either BytecodeReadingError BuildArtifacts readJSON CombinedJSON _ json = readCombinedJSON json-readJSON _ contractName json = readFoundryJSON contractName json+readJSON Foundry contractName json = readFoundryJSON contractName json ++ -- | Reads a foundry json output-readFoundryJSON :: Text -> Text -> Err (Contracts, Asts, Sources)+readFoundryJSON :: Text -> Text -> Either BytecodeReadingError BuildArtifacts readFoundryJSON contractName json = do-  runtime <- maybeToEither "missing 'deployedBytecode' field" $ json ^? key "deployedBytecode"-  runtimeCode <- maybeToEither "missing 'deployedBytecode.object' field" $-    (toCode contractName) . strip0x'' <$> runtime ^? key "object" % _String+  runtime <- maybeToEither (MissingJsonField "deployedBytecode") $ json ^? key "deployedBytecode"+  runtimeCode <- (maybeToEither (MissingJsonField "deployedBytecode.object") $ runtime ^? key "object" % _String) >>= (toCode contractName) . strip0x''   runtimeSrcMap <- case runtime ^? key "sourceMap" % _String of-    Nothing -> Right $ force "Source map creation error" $ makeSrcMaps ""  -- sourceMap is optional-    Just smap -> maybeToEither "invalid sourceMap format" $ makeSrcMaps smap+    Nothing -> pure mempty  -- sourceMap is optional+    Just smap -> maybeToEither InvalidSourceMap $ makeSrcMaps smap -  creation <- maybeToEither "missing 'bytecode' field" $ json ^? key "bytecode"-  creationCode <- maybeToEither "missing 'bytecode.object' field" $-    (toCode contractName) . strip0x'' <$> creation ^? key "object" % _String+  creation <- maybeToEither (MissingJsonField "bytecode") $ json ^? key "bytecode"+  creationCode <- (maybeToEither (MissingJsonField "bytecode.object") $ creation ^? key "object" % _String) >>= (toCode contractName) . strip0x''   creationSrcMap <- case creation ^? key "sourceMap" % _String of-    Nothing -> Right $ force "Source map creation error" $ makeSrcMaps ""  -- sourceMap is optional-    Just smap -> maybeToEither "invalid sourceMap format" $ makeSrcMaps smap+    Nothing -> pure mempty  -- sourceMap is optional+    Just smap -> maybeToEither InvalidSourceMap $ makeSrcMaps smap -  ast <- maybeToEither "missing 'ast' field. Recompile with `forge clean && forge build --ast`" $ json ^? key "ast"-  path <- maybeToEither "missing 'ast.absolutePath' field" $ ast ^? key "absolutePath" % _String-  abi <- maybeToEither "missing or invalid 'abi' array" $ toList <$> json ^? key "abi" % _Array-  id' <- maybeToEither "missing or invalid 'id' field" $ unsafeInto <$> json ^? key "id" % _Integer+  ast <- maybeToEither (MissingJsonField "ast") $ json ^? key "ast"+  path <- maybeToEither (MissingJsonField "ast.absolutePath") $ ast ^? key "absolutePath" % _String+  abi <- maybeToEither (MissingOrInvalidJsonField "abi") $ toList <$> json ^? key "abi" % _Array+  id' <- maybeToEither (MissingOrInvalidJsonField "id") $ unsafeInto <$> json ^? key "id" % _Integer    let contract = SolcContract         { runtimeCodehash     = keccak' (stripBytecodeMetadata runtimeCode)@@ -466,97 +497,121 @@         , Sources   $ Map.singleton (SrcFile id' (T.unpack path)) Nothing         ) ++-- Contract schema in solc's Standard JSON, based on https://docs.soliditylang.org/en/latest/using-the-compiler.html#output-description+data ContractJSON = ContractJSON+  { abi                 :: Value+  , metadata            :: Maybe T.Text+  , storageLayout       :: Maybe Value+  , evm                 :: EvmSection+  } deriving (Show, Generic)++-- EVM Section+data EvmSection = EvmSection+  { bytecode            :: BytecodeSection+  , deployedBytecode    :: BytecodeSection+  } deriving (Show, Generic)++-- Bytecode Section+data BytecodeSection = BytecodeSection+  { object              :: Maybe T.Text+  , sourceMap           :: Maybe T.Text+  , immutableReferences :: Maybe Value+  } deriving (Show, Generic)++instance FromJSON ContractJSON+instance FromJSON EvmSection+instance FromJSON BytecodeSection+ -- | Parses the standard json output from solc-readStdJSON :: Text -> Maybe (Contracts, Asts, Sources)+readStdJSON :: Text -> Either BytecodeReadingError Contracts readStdJSON json = do-  contracts <- KeyMap.toHashMapText <$> json ^? key "contracts" % _Object-  -- TODO: support the general case of "urls" and "content" in the standard json-  sources <- KeyMap.toHashMapText <$>  json ^? key "sources" % _Object-  let asts = force "JSON lacks abstract syntax trees." . preview (key "ast") <$> sources-      contractMap = f contracts-      getId src = unsafeInto $ (force "" $ HMap.lookup src sources) ^?! key "id" % _Integer-      contents src = (SrcFile (getId src) (T.unpack src), encodeUtf8 <$> HMap.lookup src (mconcat $ Map.elems $ snd <$> contractMap))-  pure ( Contracts $ fst <$> contractMap-         , Asts      $ Map.fromList (HMap.toList asts)-         , Sources   $ Map.fromList $ contents <$> (sort $ HMap.keys sources)-         )+  let parseContracts :: KeyMap.KeyMap Value -> Either BytecodeReadingError (Map.Map Text (Map.Map Text ContractJSON))+      parseContracts km = traverse (Bifunctor.first (AesonParsingError . T.pack) . parseEither parseJSON) (KeyMap.toMapText km)++      flattenContracts :: Map Text (Map Text ContractJSON) -> Map Text ContractJSON+      flattenContracts = Map.foldMapWithKey flattenOne+        where+          flattenOne :: Text -> Map Text ContractJSON -> Map Text ContractJSON+          flattenOne fileName contractsInFile = Map.mapKeys (\contractName -> fileName <> ":" <> contractName) contractsInFile++  contractsObject <- maybeToEither (MissingJsonField "contracts") $ json ^? key "contracts" % _Object+  contracts <- translate =<< flattenContracts <$> (parseContracts contractsObject)+  pure (Contracts contracts)   where-    f :: (AsValue s) => HMap.HashMap Text s -> (Map Text (SolcContract, (HMap.HashMap Text Text)))-    f x = Map.fromList . (concatMap g) . HMap.toList $ x-    g (s, x) = h s <$> HMap.toList (KeyMap.toHashMapText (fromMaybe (internalError "Could not parse json object") (preview _Object x)))-    h :: Text -> (Text, Value) -> (Text, (SolcContract, HMap.HashMap Text Text))-    h s (c, x) =-      let-        evmstuff = x ^?! key "evm"-        sc = s <> ":" <> c-        runtime = evmstuff ^?! key "deployedBytecode"-        creation =  evmstuff ^?! key "bytecode"-        theRuntimeCode = (toCode sc) $ fromMaybe "" $ runtime ^? key "object" % _String-        theCreationCode = (toCode sc) $ fromMaybe "" $ creation ^? key "object" % _String-        srcContents :: Maybe (HMap.HashMap Text Text)-        srcContents = do metadata <- x ^? key "metadata" % _String-                         srcs <- KeyMap.toHashMapText <$> metadata ^? key "sources" % _Object-                         pure $ fmap-                           (fromMaybe (internalError "could not parse contents field into a string") . preview (key "content" % _String))-                           (HMap.filter (isJust . preview (key "content")) srcs)-        abis = force ("abi key not found in " <> show x) $-          toList <$> x ^? key "abi" % _Array-      in (sc, (SolcContract {-        runtimeCode      = theRuntimeCode,-        creationCode     = theCreationCode,-        runtimeCodehash  = keccak' (stripBytecodeMetadata theRuntimeCode),-        creationCodehash = keccak' (stripBytecodeMetadata theCreationCode),-        runtimeSrcmap    = force "srcmap-runtime" (makeSrcMaps (runtime ^?! key "sourceMap" % _String)),-        creationSrcmap   = force "srcmap" (makeSrcMaps (creation ^?! key "sourceMap" % _String)),-        contractName = sc,+    translate :: Map Text ContractJSON -> Either BytecodeReadingError (Map Text SolcContract)+    translate m = Map.traverseWithKey translateOne m++    translateOne :: Text -> ContractJSON -> Either BytecodeReadingError SolcContract+    translateOne contractName contractData = do+      runtimeCode <- toCode contractName (fromMaybe "" contractData.evm.deployedBytecode.object)+      creationCode <- toCode contractName (fromMaybe "" contractData.evm.bytecode.object)+      runtimeSrcMap <- case contractData.evm.deployedBytecode.sourceMap of+        Nothing -> pure mempty+        Just smap -> maybeToEither InvalidSourceMap $ makeSrcMaps smap+      creationSrcMap <- case contractData.evm.bytecode.sourceMap of+        Nothing -> pure mempty+        Just smap -> maybeToEither InvalidSourceMap $ makeSrcMaps smap+      abis <- maybeToEither (MissingJsonField "abi") (contractData.abi ^? _Array <&> toList)++      pure SolcContract {+        runtimeCode = runtimeCode,+        creationCode = creationCode,+        runtimeCodehash = keccak' (stripBytecodeMetadata runtimeCode),+        creationCodehash = keccak' (stripBytecodeMetadata creationCode),+        runtimeSrcmap = runtimeSrcMap,+        creationSrcmap = creationSrcMap,+        contractName = contractName,         constructorInputs = mkConstructor abis,-        abiMap        = mkAbiMap abis,-        eventMap      = mkEventMap abis,-        errorMap      = mkErrorMap abis,-        storageLayout = mkStorageLayout $ x ^? key "storageLayout",-        immutableReferences = fromMaybe mempty $-          do x' <- runtime ^? key "immutableReferences"-             case fromJSON x' of-               Success a -> pure a-               _ -> Nothing-      }, fromMaybe mempty srcContents))+        abiMap = mkAbiMap abis,+        eventMap = mkEventMap abis,+        errorMap = mkErrorMap abis,+        storageLayout = mkStorageLayout contractData.storageLayout,+        immutableReferences = fromMaybe mempty $ do+          x' <- contractData.evm.deployedBytecode.immutableReferences+          case fromJSON x' of+            Success a -> pure a+            _ -> Nothing+      } --- deprecate me soon-readCombinedJSON :: Text -> Err (Contracts, Asts, Sources)+-- TODO: deprecate me soon+readCombinedJSON :: Text -> Either BytecodeReadingError BuildArtifacts readCombinedJSON json = do-  contracts <- maybeToEither "missing or invalid 'contracts' field" $ f . KeyMap.toHashMapText <$> (json ^? key "contracts" % _Object)-  sources <- maybeToEither "missing or invalid 'sourceList' field" $ toList . fmap (preview _String) <$> json ^? key "sourceList" % _Array-  astsPre <- maybeToEither "JSON lacks abstract syntax trees (ast). Recompile with `forge clean && forge build --ast`" $ json ^? key "sources" % _Object+  rawContracts <- maybeToEither (MissingOrInvalidJsonField "contracts") (json ^? key "contracts" % _Object)+  contracts <- Map.traverseWithKey extractContract $ KeyMap.toMapText rawContracts+  sources <- maybeToEither (MissingOrInvalidJsonField "sourceList") $ toList . fmap (preview _String) <$> json ^? key "sourceList" % _Array+  astsPre <- maybeToEither (MissingJsonField "sources") $ json ^? key "sources" % _Object   pure ( Contracts contracts-       , Asts (Map.fromList (HMap.toList (KeyMap.toHashMapText astsPre)))+       , Asts (KeyMap.toMapText astsPre)        , Sources $ Map.fromList $            (\(path, id') -> (SrcFile id' (T.unpack path), Nothing)) <$>              zip (catMaybes sources) [0..]        )   where-    f x = Map.fromList . HMap.toList $ HMap.mapWithKey g x-    g s x =+    extractContract :: Text -> Value -> Either BytecodeReadingError SolcContract+    extractContract contractName x = do+      runtimeCode <- (toCode contractName) =<< maybeToEither (MissingJsonField "bin-runtime") (x ^? key "bin-runtime" % _String)+      creationCode <- (toCode contractName) =<< maybeToEither (MissingJsonField "bin") (x ^? key "bin" % _String)       let-        theRuntimeCode = (toCode s) (x ^?! key "bin-runtime" % _String)-        theCreationCode = (toCode s) (x ^?! key "bin" % _String)         abis = toList $ case (x ^?! key "abi") ^? _Array of                  Just v -> v                                       -- solc >= 0.8                  Nothing -> (x ^?! key "abi" % _String) ^?! _Array -- solc <  0.8-      in SolcContract {-        runtimeCode      = theRuntimeCode,-        creationCode     = theCreationCode,-        runtimeCodehash  = keccak' (stripBytecodeMetadata theRuntimeCode),-        creationCodehash = keccak' (stripBytecodeMetadata theCreationCode),-        runtimeSrcmap    = force "internal error: srcmap-runtime" (makeSrcMaps (x ^?! key "srcmap-runtime" % _String)),-        creationSrcmap   = force "internal error: srcmap" (makeSrcMaps (x ^?! key "srcmap" % _String)),-        contractName = s,-        constructorInputs = mkConstructor abis,-        abiMap       = mkAbiMap abis,-        eventMap     = mkEventMap abis,-        errorMap     = mkErrorMap abis,-        storageLayout = mkStorageLayout $ x ^? key "storage-layout",-        immutableReferences = mempty -- TODO: deprecate combined-json-      }+        contract = SolcContract {+          runtimeCode      = runtimeCode,+          creationCode     = creationCode,+          runtimeCodehash  = keccak' (stripBytecodeMetadata runtimeCode),+          creationCodehash = keccak' (stripBytecodeMetadata creationCode),+          runtimeSrcmap    = force "internal error: srcmap-runtime" (makeSrcMaps (x ^?! key "srcmap-runtime" % _String)),+          creationSrcmap   = force "internal error: srcmap" (makeSrcMaps (x ^?! key "srcmap" % _String)),+          contractName = contractName,+          constructorInputs = mkConstructor abis,+          abiMap       = mkAbiMap abis,+          eventMap     = mkEventMap abis,+          errorMap     = mkErrorMap abis,+          storageLayout = mkStorageLayout $ x ^? key "storage-layout",+          immutableReferences = mempty+        }+      pure contract  mkAbiMap :: [Value] -> Map FunctionSelector Method mkAbiMap abis = Map.fromList $@@ -675,12 +730,12 @@ containsLinkerHole :: Text -> Bool containsLinkerHole = regexMatches "__\\$[a-z0-9]{34}\\$__" -toCode :: Text -> Text -> ByteString+toCode :: Text -> Text -> Either BytecodeReadingError ByteString toCode contractName t = case BS16.decodeBase16Untyped (encodeUtf8 t) of-  Right d -> d+  Right d -> Right d   Left e -> if containsLinkerHole t-            then error $ T.unpack ("Error toCode: unlinked libraries detected in bytecode, in " <> contractName)-            else error $ T.unpack ("Error toCode:" <> e <> ", in " <> contractName)+            then Left $ UnlinkedLibrary contractName+            else Left $ OtherError contractName e  solc :: Language -> Text -> Bool -> IO Text solc lang src viaIR = T.pack <$> readProcess "solc" ["--standard-json"] (T.unpack $ stdjson lang src viaIR)

@@ -14,10 +14,9 @@ import Control.Monad import Control.Monad.State.Strict import Control.Monad.IO.Unlift-import Data.Char (isSpace) import Data.Map (Map) import Data.Map qualified as Map-import Data.Set (Set, isSubsetOf, fromList)+import Data.Set (Set, isSubsetOf, fromList, toList) import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Either (isLeft) import Data.Text qualified as TStrict@@ -25,14 +24,15 @@ import Data.Text.Lazy qualified as T import Data.Text.Lazy.IO qualified as T import Data.Text.Lazy.Builder+import qualified Data.Text.Lazy.Builder.Int (decimal) import System.Process (createProcess, cleanupProcess, proc, ProcessHandle, std_in, std_out, std_err, StdStream(..), createPipe)-import Witch (into)+import System.FilePath ((</>)) import EVM.Effects-import EVM.Fuzz (tryCexFuzz) import Data.Bits ((.&.)) import Numeric (showHex) import EVM.Expr (simplifyProps) +import EVM.Keccak qualified as Keccak (concreteKeccaks) import EVM.SMT import EVM.Types @@ -41,12 +41,14 @@   = Z3   | CVC5   | Bitwuzla+  | EmptySolver   | Custom Text  instance Show Solver where   show Z3 = "z3"   show CVC5 = "cvc5"   show Bitwuzla = "bitwuzla"+  show EmptySolver = "empty-smt-solver"   show (Custom s) = T.unpack s  @@ -100,18 +102,16 @@     -- collect result     readChan resChan -checkSatWithProps :: App m => SolverGroup -> [Prop] -> m (SMTResult, Err SMT2)+checkSatWithProps :: App m => SolverGroup -> [Prop] -> m (SMTResult) checkSatWithProps sg props = do   conf <- readConfig   let psSimp = if conf.simp then simplifyProps props else props-  if psSimp == [PBool False] then pure (Qed, Right mempty)+  if psSimp == [PBool False] then pure Qed   else do-    let smt2 = assertProps conf psSimp-    if isLeft smt2 then-      let err = getError smt2 in pure (Error err, Left err)-    else do-      res <- liftIO $ checkSat sg (Just props) smt2-      pure (res, Right (getNonError smt2))+    let concreteKeccaks = fmap (\(buf,val) -> PEq (Lit val) (Keccak buf)) (toList $ Keccak.concreteKeccaks props)+    let smt2 = assertProps conf (if conf.simp then psSimp <> concreteKeccaks else psSimp)+    if isLeft smt2 then pure $ Error $ getError smt2+    else liftIO $ checkSat sg (Just props) smt2  -- When props is Nothing, the cache will not be filled or used checkSat :: SolverGroup -> Maybe [Prop] -> Err SMT2 -> IO SMTResult@@ -125,10 +125,11 @@     -- collect result     readChan resChan -writeSMT2File :: SMT2 -> String -> IO ()-writeSMT2File smt2 postfix = do+writeSMT2File :: SMT2 -> FilePath -> String -> IO ()+writeSMT2File smt2 path postfix = do     let content = formatSMT2 smt2 <> "\n\n(check-sat)"-    T.writeFile ("query-" <> postfix <> ".smt2") content+        fullPath = path </> "query-" <> postfix <> ".smt2"+    T.writeFile fullPath content  withSolvers :: App m => Solver -> Natural -> Natural -> Maybe Natural -> (SolverGroup -> m a) -> m a withSolvers solver count threads timeout cont = do@@ -177,16 +178,20 @@ getMultiSol :: forall m. (MonadIO m, ReadConfig m) => SMT2 -> MultiSol -> (Chan (Maybe [W256])) -> SolverInstance -> Chan SolverInstance -> Int -> m () getMultiSol smt2@(SMT2 cmds cexvars _) multiSol r inst availableInstances fileCounter = do   conf <- readConfig-  when conf.dumpQueries $ liftIO $ writeSMT2File smt2 (show fileCounter)+  when conf.dumpQueries $ liftIO $ writeSMT2File smt2 "." (show fileCounter)   -- reset solver and send all lines of provided script-  out <- liftIO $ sendScript inst ("(reset)" : cmds)+  out <- liftIO $ do+    resetRes <- sendScript inst $ SMTScript [SMTCommand "(reset)"]+    case resetRes of+      e@(Left _) -> pure e+      _ -> sendScript inst cmds   case out of     Left err -> liftIO $ do       when conf.debug $ putStrLn $ "Unable to write SMT to solver: " <> (T.unpack err)       writeChan r Nothing     Right _ -> do-      sat <- liftIO $ sendLine inst "(check-sat)"-      when conf.dumpQueries $ liftIO $ writeSMT2File smt2 (show fileCounter <> "-origquery")+      sat <- liftIO $ sendCommand inst $ SMTCommand "(check-sat)"+      when conf.dumpQueries $ liftIO $ writeSMT2File smt2 "." (show fileCounter <> "-origquery")       subRun [] smt2 sat   -- put the instance back in the list of available instances   liftIO $ writeChan availableInstances inst@@ -206,6 +211,7 @@            writeChan r Nothing         "unknown" -> liftIO $ do            when conf.debug $ putStrLn "Unknown result by SMT solver."+           dumpUnsolved fullSmt fileCounter conf.dumpUnsolved            writeChan r Nothing         "sat" -> do           if length vals >= multiSol.maxSols then liftIO $ do@@ -217,17 +223,17 @@               Just v -> do                 let hexMask = maskFromBytesCount multiSol.numBytes                     maskedVal = v .&. hexMask-                    toSMT n = show (into n :: Integer)-                    maskedVar = "(bvand " <> multiSol.var <> " (_ bv" <> toSMT hexMask <> " 256))"-                    restrict = "(assert (not (= " <> maskedVar <> " (_ bv" <> toSMT maskedVal <> " 256))))"-                    newSmt = fullSmt <> SMT2 [(fromString restrict)] mempty mempty+                    toSMT n = Data.Text.Lazy.Builder.Int.decimal n+                    maskedVar = "(bvand " <> fromString multiSol.var <> " (_ bv" <> toSMT hexMask <> " 256))"+                    restrict = SMTCommand $ "(assert (not (= " <> maskedVar <> " (_ bv" <> toSMT maskedVal <> " 256))))"+                    newSmt = fullSmt <> SMT2 (SMTScript [restrict]) mempty mempty                 when conf.debug $ liftIO $ putStrLn $ "Got one solution to symbolic query, val: 0x" <> (showHex maskedVal "") <>                   " now have " <> show (length vals + 1) <> " solution(s), max is: " <> show multiSol.maxSols-                when conf.dumpQueries $ liftIO $ writeSMT2File newSmt (show fileCounter <> "-sol" <> show (length vals))-                out <- liftIO $ sendLine inst (T.pack restrict)+                when conf.dumpQueries $ liftIO $ writeSMT2File newSmt "." (show fileCounter <> "-sol" <> show (length vals))+                out <- liftIO $ sendCommand inst restrict                 case out of                   "success" -> do-                    out2 <- liftIO $ sendLine inst  (T.pack "(check-sat)")+                    out2 <- liftIO $ sendCommand inst  (SMTCommand "(check-sat)")                     subRun (maskedVal:vals) newSmt out2                   err -> liftIO $ do                     when conf.debug $ putStrLn $ "Unable to write SMT to solver: " <> (T.unpack err)@@ -238,41 +244,44 @@           writeChan r Nothing  getOneSol :: (MonadIO m, ReadConfig m) => SMT2 -> Maybe [Prop] -> Chan SMTResult -> TChan CacheEntry -> SolverInstance -> Chan SolverInstance -> Int -> m ()-getOneSol smt2@(SMT2 cmds cexvars ps) props r cacheq inst availableInstances fileCounter = do+getOneSol smt2@(SMT2 cmds cexvars _) props r cacheq inst availableInstances fileCounter = do   conf <- readConfig-  let fuzzResult = tryCexFuzz ps conf.numCexFuzz   liftIO $ do-    when (conf.dumpQueries) $ writeSMT2File smt2 (show fileCounter)-    if (isJust fuzzResult)-      then do-        when (conf.debug) $ putStrLn $ "   Cex found via fuzzing:" <> (show fuzzResult)-        writeChan r (Cex $ fromJust fuzzResult)-      else if Prelude.not conf.onlyCexFuzz then do-        -- reset solver and send all lines of provided script-        out <- sendScript inst ("(reset)" : cmds)-        case out of-          -- if we got an error then return it-          Left e -> writeChan r (Error $ "Error while writing SMT to solver: " <> T.unpack e)-          -- otherwise call (check-sat), parse the result, and send it down the result channel-          Right () -> do-            sat <- sendLine inst "(check-sat)"-            res <- do-                case sat of-                  "unsat" -> do-                    when (isJust props) $ liftIO . atomically $ writeTChan cacheq (CacheEntry (fromJust props))-                    pure Qed-                  "timeout" -> pure $ Unknown "Result timeout by SMT solver"-                  "unknown" -> pure $ Unknown "Result unknown by SMT solver"-                  "sat" -> Cex <$> getModel inst cexvars-                  _ -> pure . Error $ "Unable to parse SMT solver output: " <> T.unpack sat-            writeChan r res-      else do-        when (conf.debug) $ putStrLn "Fuzzing failed to find a Cex, not trying SMT due to onlyCexFuzz"-        writeChan r $ Error "Option onlyCexFuzz enabled, not running SMT"+    when (conf.dumpQueries) $ writeSMT2File smt2 "." (show fileCounter)+    -- reset solver and send all lines of provided script+    out <- do+      resetRes <- sendScript inst $ SMTScript [SMTCommand "(reset)"]+      case resetRes of+        e@(Left _) -> pure e+        _ -> sendScript inst cmds+    case out of+      -- if we got an error then return it+      Left e -> writeChan r (Error $ "Error while writing SMT to solver: " <> T.unpack e)+      -- otherwise call (check-sat), parse the result, and send it down the result channel+      Right () -> do+        sat <- sendCommand inst $ SMTCommand "(check-sat)"+        res <- do+            case sat of+              "unsat" -> do+                when (isJust props) $ liftIO . atomically $ writeTChan cacheq (CacheEntry (fromJust props))+                pure Qed+              "timeout" -> pure $ Unknown "Result timeout by SMT solver"+              "unknown" -> do+                dumpUnsolved smt2 fileCounter conf.dumpUnsolved+                pure $ Unknown "Result unknown by SMT solver"+              "sat" -> Cex <$> getModel inst cexvars+              _ -> pure . Error $ "Unable to parse SMT solver output: " <> T.unpack sat+        writeChan r res      -- put the instance back in the list of available instances     writeChan availableInstances inst +dumpUnsolved :: SMT2 -> Int -> Maybe FilePath -> IO ()+dumpUnsolved fullSmt fileCounter dump = do+   case dump of+     Just path -> writeSMT2File fullSmt path $ "unsolved-" <> show fileCounter+     Nothing -> pure ()+ getModel :: SolverInstance -> CexVars -> IO SMTCex getModel inst cexvars = do   -- get an initial version of the model from the solver@@ -322,35 +331,35 @@     -- and try again.     shrinkBuf :: Text -> W256 -> StateT SMTCex IO ()     shrinkBuf buf hint = do-      let encBound = "(_ bv" <> (T.pack $ show (into hint :: Integer)) <> " 256)"+      let encBound = "(_ bv" <> Data.Text.Lazy.Builder.Int.decimal hint <> " 256)"       answer <- liftIO $ do-        checkCommand inst "(push 1)"-        checkCommand inst $ "(assert (bvule " <> buf <> "_length " <> encBound <> "))"-        sendLine inst "(check-sat)"+        checkCommand inst $ SMTCommand "(push 1)"+        checkCommand inst $ SMTCommand ("(assert (bvule " <> (fromLazyText buf) <> "_length " <> encBound <> "))")+        sendCommand inst $ SMTCommand "(check-sat)"       case answer of         "sat" -> do           model <- liftIO getRaw           put model         "unsat" -> do-          liftIO $ checkCommand inst "(pop 1)"+          liftIO $ checkCommand inst $ SMTCommand "(pop 1)"           let nextHint = if hint == 0 then 1 else hint * 2           if nextHint < hint || nextHint > 1_073_741_824             then pure () -- overflow or over 1GB             else shrinkBuf buf nextHint         _ -> do -- unexpected answer -> clean up and do not change the model-          liftIO $ checkCommand inst "(pop 1)"+          liftIO $ checkCommand inst $ SMTCommand "(pop 1)"           pure ()  -    -- we set a pretty arbitrary upper limit (of 1024) to decide if we need to do some shrinking+    -- we set a pretty arbitrary upper limit (of 32) to decide if we need to do some shrinking     bufsUsable :: SMTCex -> Bool     bufsUsable model = any (go . snd) (Map.toList model.buffers)       where         go (Flat _) = True         go (Comp c) = case c of-          (Base _ sz) -> sz <= 1024+          (Base _ sz) -> sz <= 32           -- TODO: do I need to check the write idx here?-          (Write _ idx next) -> idx <= 1024 && go (Comp next)+          (Write _ idx next) -> idx <= 32 && go (Comp next)  mkTimeout :: Maybe Natural -> Text mkTimeout t = T.pack $ show $ (1000 *)$ case t of@@ -365,6 +374,7 @@     , "--produce-models"     , "--time-limit-per=" <> mkTimeout timeout     , "--bv-solver=preprop"+    , "--bv-output-format=16"     ]   Z3 ->     [ "-st"@@ -379,6 +389,7 @@     , "--tlimit-per=" <> mkTimeout timeout     , "--arrays-exp"     ]+  EmptySolver -> []   Custom _ -> []  -- | Spawns a solver instance, and sets the various global config options that we use for our queries@@ -398,11 +409,12 @@   case solver of     CVC5 -> pure solverInstance     Bitwuzla -> do-      _ <- sendLine solverInstance "(set-option :print-success true)"+      _ <- sendCommand solverInstance $ SMTCommand "(set-option :print-success true)"       pure solverInstance+    EmptySolver -> pure solverInstance     Z3 -> do-      _ <- sendLine' solverInstance $ "(set-option :timeout " <> mkTimeout timeout <> ")"-      _ <- sendLine solverInstance "(set-option :print-success true)"+      _ <- sendCommand solverInstance $ SMTCommand "(set-option :print-success true)"+      _ <- sendCommand solverInstance $ SMTCommand ("(set-option :timeout " <> (fromLazyText $ mkTimeout timeout) <> ")")       pure solverInstance     Custom _ -> pure solverInstance @@ -411,52 +423,38 @@ stopSolver (SolverInstance _ stdin stdout process) = cleanupProcess (Just stdin, Just stdout, Nothing, process)  -- | Sends a list of commands to the solver. Returns the first error, if there was one.-sendScript :: SolverInstance -> [Builder] -> IO (Either Text ())-sendScript solver cmds = do-  let sexprs = splitSExpr $ fmap toLazyText cmds-  go sexprs+sendScript :: SolverInstance -> SMTScript -> IO (Either Text ())+sendScript solver (SMTScript entries) = do+  go entries   where     go [] = pure $ Right ()-    go (c:cs) = do+    go (SMTComment _ : rest) = go rest+    go (c@(SMTCommand command):cs) = do       out <- sendCommand solver c       case out of         "success" -> go cs-        e -> pure $ Left $ "Solver returned an error:\n" <> e <> "\nwhile sending the following line: " <> c+        e -> pure $ Left $ "Solver returned an error:\n" <> e <> "\nwhile sending the following command: " <> toLazyText command -checkCommand :: SolverInstance -> Text -> IO ()+checkCommand :: SolverInstance -> SMTEntry -> IO () checkCommand inst cmd = do   res <- sendCommand inst cmd   case res of     "success" -> pure ()     _ -> internalError $ "Unexpected solver output: " <> T.unpack res --- | Sends a single command to the solver, returns the first available line from the output buffer-sendCommand :: SolverInstance -> Text -> IO Text-sendCommand inst cmd = do-  -- trim leading whitespace-  let cmd' = T.dropWhile isSpace cmd-  case T.unpack cmd' of-    "" -> pure "success"      -- ignore blank lines-    ';' : _ -> pure "success" -- ignore comments-    _ -> sendLine inst cmd'  -- | Strips trailing \r, if present stripCarriageReturn :: Text -> Text stripCarriageReturn t = fromMaybe t $ T.stripSuffix "\r" t  -- | Sends a string to the solver and appends a newline, returns the first available line from the output buffer-sendLine :: SolverInstance -> Text -> IO Text-sendLine (SolverInstance _ stdin stdout _) cmd = do-  T.hPutStrLn stdin cmd+sendCommand :: SolverInstance -> SMTEntry -> IO Text+sendCommand _ (SMTComment _) = internalError "Attempting to send a comment as a command to SMT solver"+sendCommand (SolverInstance _ stdin stdout _) (SMTCommand cmd) = do+  T.hPutStrLn stdin $ toLazyText cmd   hFlush stdin   stripCarriageReturn <$> (T.hGetLine stdout) --- | Sends a string to the solver and appends a newline, doesn't return stdout-sendLine' :: SolverInstance -> Text -> IO ()-sendLine' (SolverInstance _ stdin _ _) cmd = do-  T.hPutStrLn stdin cmd-  hFlush stdin- -- | Returns a string representation of the model for the requested variable getValue :: SolverInstance -> Text -> IO Text getValue (SolverInstance _ stdin stdout _) var = do@@ -484,37 +482,3 @@       if (ls + ls') == (rs + rs')          then pure $ cleanLine : prev          else go (ls + ls') (rs + rs') (cleanLine : prev)---- From a list of lines, take each separate SExpression and put it in--- its own list, after removing comments.-splitSExpr :: [Text] -> [Text]-splitSExpr ls =-  -- split lines, strip comments, and append everything to a single line-  let text = T.intercalate " " $ T.takeWhile (/= ';') <$> concatMap T.lines ls in-  filter (/= "") $ go text []-  where-    go "" acc = reverse acc-    go text acc =-      let (sexpr, text') = getSExpr text in-      let (sexpr', rest) = T.breakOnEnd ")" sexpr in-      go text' ((T.strip rest):(T.strip sexpr'):acc)--data Par = LPar | RPar---- take the first SExpression and return the rest of the text-getSExpr :: Text -> (Text, Text)-getSExpr l = go LPar l 0 []-  where-    go _ text 0 prev@(_:_) = (T.intercalate "" (reverse prev), text)-    go _ _ r _ | r < 0 = internalError $ "Unbalanced SExpression: " <> show l-    go _ "" _ _  = internalError $ "Unbalanced SExpression: " <> show l-    -- find the next left parenthesis-    go LPar line r prev = -- r is how many right parentheses we are missing-      let (before, after) = T.breakOn "(" line in-      let rp = T.length $ T.filter (== ')') before in-      go RPar after (r - rp) (if before == "" then prev else before : prev)-    -- find the next right parenthesis-    go RPar line r prev =-      let (before, after) = T.breakOn ")" line in-      let lp = T.length $ T.filter (== '(') before in-      go LPar after (r + lp) (if before == "" then prev else before : prev)

@@ -24,7 +24,7 @@ import Control.Monad.IO.Class import Control.Monad.Operational (Program, ProgramViewT(..), ProgramView, singleton, view) import Control.Monad.ST (stToIO, RealWorld)-import Control.Monad.State.Strict (execStateT, runStateT, get)+import Control.Monad.State.Strict (execStateT, get, StateT(..)) import Data.Text (Text)  import EVM qualified@@ -121,3 +121,4 @@         EVM m -> do           (r, vm') <- liftIO $ stToIO $ runStateT m vm           interpret fetcher vm' (k r)+

@@ -3,6 +3,9 @@  module EVM.SymExec where +import Prelude hiding (Foldable(..))++import Control.Arrow ((>>>)) import Control.Concurrent.Async (concurrently, mapConcurrently) import Control.Concurrent.Spawn (parMapIO, pool) import Control.Monad (when, forM_, forM)@@ -10,12 +13,12 @@ import Control.Monad.Operational qualified as Operational import Control.Monad.ST (RealWorld, stToIO, ST) import Control.Monad.State.Strict (runStateT)-import Data.Bifunctor (second) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Containers.ListUtils (nubOrd) import Data.DoubleWord (Word256)-import Data.List (foldl', sortBy, sort)+import Data.Foldable (Foldable(..))+import Data.List (sortBy, sort) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Map.Strict (Map)@@ -31,6 +34,7 @@ import Data.Vector qualified as V import Data.Vector.Storable qualified as VS import Data.Vector.Storable.ByteString (vectorToByteString)+ import EVM (makeVm, abstractContract, initialContract, getCodeLocation, isValidJumpDest) import EVM.Exec import EVM.Fetch qualified as Fetch@@ -38,7 +42,7 @@ import EVM.Effects import EVM.Expr qualified as Expr import EVM.FeeSchedule (feeSchedule)-import EVM.Format (formatExpr, formatPartial, formatPartialShort, showVal, indent, formatBinary, formatProp, formatState, formatError)+import EVM.Format (formatExpr, formatPartial, formatPartialDetailed, showVal, indent, formatBinary, formatProp, formatState, formatError) import EVM.SMT qualified as SMT import EVM.Solvers import EVM.Stepper (Stepper)@@ -53,6 +57,8 @@ import Options.Generic (ParseField, ParseFields, ParseRecord) import Text.Printf (printf) import Witch (into, unsafeInto)+import Data.Text.Encoding (encodeUtf8)+import EVM.Solidity (WarningData (..))  data LoopHeuristic   = Naive@@ -68,11 +74,11 @@     getIssue _ = Nothing     grouped = NE.group $ sort $ mapMaybe getIssue results -groupPartials :: [Expr End] -> [(Integer, String)]-groupPartials e = map (\g -> (into (length g), NE.head g)) grouped+groupPartials :: Maybe (WarningData s t) -> [Expr End] -> [(Integer, String)]+groupPartials warnData e = map (\g -> (into (length g), NE.head g)) grouped   where     getPartial :: Expr End -> Maybe String-    getPartial (Partial _ _ reason) = Just $ T.unpack $ formatPartialShort reason+    getPartial (Partial _ _ reason) = Just $ T.unpack $ formatPartialDetailed warnData reason     getPartial _ = Nothing     grouped = NE.group $ sort $ mapMaybe getPartial e @@ -94,41 +100,38 @@   { iterConf :: IterConfig   , rpcInfo :: Fetch.RpcInfo   }-  deriving (Eq, Show)+  deriving (Show)  defaultVeriOpts :: VeriOpts defaultVeriOpts = VeriOpts   { iterConf = defaultIterConf-  , rpcInfo = Nothing+  , rpcInfo = mempty   }  rpcVeriOpts :: (Fetch.BlockNumber, Text) -> VeriOpts-rpcVeriOpts info = defaultVeriOpts { rpcInfo = Just info }+rpcVeriOpts info = defaultVeriOpts { rpcInfo  = mempty { Fetch.blockNumURL = Just info }}  extractCex :: VerifyResult -> Maybe (Expr End, SMTCex) extractCex (Cex c) = Just c extractCex _ = Nothing -bool :: Expr EWord -> Prop-bool e = POr (PEq (Lit 1) e) (PEq (Lit 0) e)  -- | Abstract calldata argument generation symAbiArg :: Text -> AbiType -> CalldataFragment symAbiArg name = \case   AbiUIntType n ->     if n `mod` 8 == 0 && n <= 256-    then St [Expr.inRange n v] v+    then St [] v     else internalError "bad type"   AbiIntType n ->     if n `mod` 8 == 0 && n <= 256-    -- TODO: is this correct?-    then St [Expr.inRangeSigned n v] v+    then St [] v     else internalError "bad type"-  AbiBoolType -> St [bool v] v+  AbiBoolType -> St [] v   AbiAddressType -> St [] (WAddr (SymAddr name))   AbiBytesType n ->     if n > 0 && n <= 32-    then St [Expr.inRange (n * 8) v] v+    then St [] v     else internalError "bad type"   AbiArrayType sz tps -> do     Comp . V.toList . V.imap (\(T.pack . show -> i) tp -> symAbiArg (name <> "-a-" <> i) tp) $ (V.replicate sz tps)@@ -344,11 +347,11 @@         ends <- withRunInIO $ \runInIO -> mapConcurrently (runInIO . runOne frozen newDepth) vals         pure $ goITE (zip vals ends)         where-          goITE :: [(W256, Expr End)] -> Expr End+          goITE :: [(Expr EWord, Expr End)] -> Expr End           goITE [] = internalError "goITE: empty list"           goITE [(_, end)] = end-          goITE ((val,end):ps) = ITE (Eq expr (Lit val)) end (goITE ps)-          runOne :: App m => VM 'Symbolic RealWorld -> Int -> W256 -> m (Expr 'End)+          goITE ((val,end):ps) = ITE (Eq expr val) end (goITE ps)+          runOne :: App m => VM 'Symbolic RealWorld -> Int -> Expr EWord -> m (Expr 'End)           runOne frozen newDepth v = do             (ra, vma) <- liftIO $ stToIO $ runStateT (continue v) frozen { result = Nothing, exploreDepth = newDepth }             interpret fetcher iterConf vma (k ra)@@ -404,7 +407,7 @@                     (r, vm') <- case simpProps of                       [PBool False] -> liftIO $ stToIO $ runStateT (continue (Case False)) vm                       [] -> liftIO $ stToIO $ runStateT (continue (Case True)) vm-                      _ -> liftIO $ stToIO $ runStateT (continue UnknownBranch) vm {exploreDepth = vm.exploreDepth+1}+                      _ -> liftIO $ stToIO $ runStateT (continue UnknownBranch) vm                     interpret fetcher iterConf vm' (k r)           _ -> performQuery @@ -414,7 +417,7 @@   let codelocation = getCodeLocation vm       (iters, _) = view (at codelocation % non (0, [])) vm.iterations   in if unsafeInto maxIter <= iters-     then Map.lookup (codelocation, iters - 1) vm.cache.path+     then Map.lookup (codelocation, iters - 1) vm.pathsVisited      else Nothing  askSmtItersReached :: VM Symbolic s -> Integer -> Bool@@ -445,6 +448,7 @@ type Precondition s = VM Symbolic s -> Prop type Postcondition s = VM Symbolic s -> Expr End -> Prop +-- Used only in testing checkAssert   :: App m   => SolverGroup@@ -454,9 +458,24 @@   -> [String]   -> VeriOpts   -> m (Expr End, [VerifyResult])-checkAssert solvers errs c signature' concreteArgs opts =-  verifyContract solvers c signature' concreteArgs opts Nothing (Just $ checkAssertions errs)+checkAssert solvers errs c signature' concreteArgs opts = do+  checkAssertWithSession solvers Nothing errs c signature' concreteArgs opts +-- Used only in testing+checkAssertWithSession+  :: App m+  => SolverGroup+  -> Maybe Fetch.Session+  -> [Word256]+  -> ByteString+  -> Maybe Sig+  -> [String]+  -> VeriOpts+  -> m (Expr End, [VerifyResult])+checkAssertWithSession solvers sess errs c signature' concreteArgs opts = do+  verifyContractWithSession solvers sess c signature' concreteArgs opts Nothing (Just $ checkAssertions errs)++-- Used only in testing getExprEmptyStore   :: App m   => SolverGroup@@ -469,9 +488,10 @@   conf <- readConfig   calldata <- mkCalldata signature' concreteArgs   preState <- liftIO $ stToIO $ loadEmptySymVM (RuntimeCode (ConcreteRuntimeCode c)) (Lit 0) calldata-  exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.iterConf preState runExpr+  exprInter <- interpret (Fetch.oracle solvers Nothing opts.rpcInfo) opts.iterConf preState runExpr   if conf.simp then (pure $ Expr.simplify exprInter) else pure exprInter +-- Used only in testing getExpr   :: App m   => SolverGroup@@ -484,7 +504,7 @@   conf <- readConfig   calldata <- mkCalldata signature' concreteArgs   preState <- liftIO $ stToIO $ abstractVM calldata c Nothing False-  exprInter <- interpret (Fetch.oracle solvers opts.rpcInfo) opts.iterConf preState runExpr+  exprInter <- interpret (Fetch.oracle solvers Nothing opts.rpcInfo) opts.iterConf preState runExpr   if conf.simp then (pure $ Expr.simplify exprInter) else pure exprInter  {- | Checks if an assertion violation has been encountered@@ -509,6 +529,7 @@ -} checkAssertions :: [Word256] -> Postcondition s checkAssertions errs _ = \case+  Failure _ _ (UnrecognizedOpcode 0xfe)  -> PBool False   Failure _ _ (Revert (ConcreteBuf msg)) -> PBool $ msg `notElem` (fmap panicMsg errs)   Failure _ _ (Revert b) -> foldl' PAnd (PBool True) (fmap (PNeg . PEq b . ConcreteBuf . panicMsg) errs)   _ -> PBool True@@ -539,8 +560,8 @@ mkCalldata (Just (Sig name types)) args =   symCalldata name types args (AbstractBuf "txdata") -verifyContract-  :: App m+-- Used only in testing+verifyContract :: forall m . App m   => SolverGroup   -> ByteString   -> Maybe Sig@@ -550,9 +571,24 @@   -> Maybe (Postcondition RealWorld)   -> m (Expr End, [VerifyResult]) verifyContract solvers theCode signature' concreteArgs opts maybepre maybepost = do+  verifyContractWithSession solvers Nothing theCode signature' concreteArgs opts maybepre maybepost++-- Used only in testing+verifyContractWithSession :: forall m . App m+  => SolverGroup+  -> Maybe Fetch.Session+  -> ByteString+  -> Maybe Sig+  -> [String]+  -> VeriOpts+  -> Maybe (Precondition RealWorld)+  -> Maybe (Postcondition RealWorld)+  -> m (Expr End, [VerifyResult])+verifyContractWithSession solvers sess theCode signature' concreteArgs opts maybepre maybepost = do   calldata <- mkCalldata signature' concreteArgs   preState <- liftIO $ stToIO $ abstractVM calldata theCode maybepre False-  verify solvers opts preState maybepost+  let fetcher = Fetch.oracle solvers sess opts.rpcInfo+  verify solvers fetcher opts preState maybepost  -- | Stepper that parses the result of Stepper.runFully into an Expr End runExpr :: Stepper.Stepper Symbolic RealWorld (Expr End)@@ -590,10 +626,10 @@ -- the incremental nature of the task at hand. Introducing support for -- incremental queries might let us go even faster here. -- TODO: handle errors properly-reachable :: App m => SolverGroup -> Expr End -> m ([SMT.SMT2], Expr End)+reachable :: App m => SolverGroup -> Expr End -> m (Expr End) reachable solvers e = do   res <- go [] e-  pure $ second (fromMaybe (internalError "no reachable paths found")) res+  pure $ fromMaybe (internalError "no reachable paths found") res   where     {-        Walk down the tree and collect pcs.@@ -601,26 +637,26 @@        If reachable return the expr wrapped in a Just. If not return Nothing.        When walking back up the tree drop unreachable subbranches.     -}-    go :: (App m, MonadUnliftIO m) => [Prop] -> Expr End -> m ([SMT.SMT2], Maybe (Expr End))+    go :: (App m, MonadUnliftIO m) => [Prop] -> Expr End -> m (Maybe (Expr End))     go pcs = \case       ITE c t f -> do         (tres, fres) <- withRunInIO $ \env -> concurrently           (env $ go (PEq (Lit 1) c : pcs) t)           (env $ go (PEq (Lit 0) c : pcs) f)-        let subexpr = case (snd tres, snd fres) of+        let subexpr = case (tres, fres) of               (Just t', Just f') -> Just $ ITE c t' f'               (Just t', Nothing) -> Just t'               (Nothing, Just f') -> Just f'               (Nothing, Nothing) -> Nothing-        pure (fst tres <> fst fres, subexpr)+        pure subexpr       leaf -> do-        (res, smt2) <- checkSatWithProps solvers pcs+        res <- checkSatWithProps solvers pcs         case res of-          Qed -> pure ([getNonError smt2], Nothing)-          Cex _ -> pure ([getNonError smt2], Just leaf)+          Qed -> pure Nothing+          Cex _ -> pure (Just leaf)           -- if we get an error, we don't know if the leaf is reachable or not, so           -- we assume it could be reachable-          _ -> pure ([], Just leaf)+          _ -> pure (Just leaf)  -- | Extract constraints stored in Expr End nodes extractProps :: Expr End -> [Prop]@@ -648,31 +684,31 @@   when (any isPartial flattened) $ do     T.putStrLn $ indent 3 "\x1b[33m[WARNING]\x1b[0m: hevm was only able to partially explore "                 <> T.pack call <> " due to the following issue(s):"-    T.putStr . T.unlines . fmap (indent 5 . ("- " <>)) . fmap formatPartial . getPartials $ flattened+    T.putStr . T.unlines . fmap (indent 5 . ("- " <>)) . fmap formatPartial . (map fst) . getPartials $ flattened -getPartials :: [Expr End] -> [PartialExec]+getPartials :: [Expr End] -> [(PartialExec, Expr End)] getPartials = mapMaybe go   where-    go :: Expr End -> Maybe PartialExec+    go :: Expr End -> Maybe (PartialExec, Expr End)     go = \case-      Partial _ _ p -> Just p+      e@(Partial _ _ p) -> Just (p, e)       _ -> Nothing  -- | Symbolically execute the VM and check all endstates against the -- postcondition, if available.-verify-  :: App m+verify :: App m   => SolverGroup+  -> Fetch.Fetcher Symbolic m RealWorld   -> VeriOpts   -> VM Symbolic RealWorld   -> Maybe (Postcondition RealWorld)   -> m (Expr End, [VerifyResult])-verify solvers opts preState maybepost = do-  (expr, res, _) <- verifyInputs solvers opts (Fetch.oracle solvers opts.rpcInfo) preState maybepost+verify solvers fetcher opts preState maybepost = do+  (expr, res, _) <- verifyInputs solvers opts fetcher preState maybepost   pure $ verifyResults preState expr res  verifyResults :: VM Symbolic RealWorld -> Expr End -> [(SMTResult, Expr End)] -> (Expr End, [VerifyResult])-verifyResults preState expr cexs = if Prelude.null cexs then (expr, [Qed]) else (expr, fmap toVRes cexs)+verifyResults preState expr cexs = if null cexs then (expr, [Qed]) else (expr, fmap toVRes cexs)   where     toVRes :: (SMTResult, Expr End) -> VerifyResult     toVRes (res, leaf) = case res of@@ -690,32 +726,32 @@   -> Fetch.Fetcher Symbolic m RealWorld   -> VM Symbolic RealWorld   -> Maybe (Postcondition RealWorld)-  -> m (Expr End, [(SMTResult, Expr End)], [PartialExec])+  -> m (Expr End, [(SMTResult, Expr End)], [(PartialExec, Expr End)]) verifyInputs solvers opts fetcher preState maybepost = do   conf <- readConfig   let call = mconcat ["prefix 0x", getCallPrefix preState.state.calldata]   when conf.debug $ liftIO $ putStrLn $ "   Exploring call " <> call -  exprInter <- interpret fetcher opts.iterConf preState runExpr-  when conf.dumpExprs $ liftIO $ T.writeFile "unsimplified.expr" (formatExpr exprInter)-  let expr = if conf.simp then (Expr.simplify exprInter) else exprInter-      flattened = flattenExpr expr-  when conf.dumpExprs $ liftIO $ do-    T.writeFile "simplified.expr" (formatExpr expr)-    T.writeFile "simplified-conc.expr" (formatExpr $ Expr.simplify $ mapExpr Expr.concKeccakOnePass expr)+  expr <- interpret fetcher opts.iterConf preState runExpr+  when conf.dumpExprs $ liftIO $ T.writeFile "unsimplified.expr" (formatExpr expr)+  let flattened = flattenExpr expr+  when (conf.dumpExprs && conf.simp) $ liftIO $ do+    let exprSimplified = Expr.simplify expr+    T.writeFile "simplified.expr" (formatExpr exprSimplified)+    T.writeFile "simplified-conc.expr" (formatExpr $ Expr.simplify $ mapExpr Expr.concKeccakOnePass exprSimplified)    let partials = getPartials flattened   when conf.debug $ liftIO $ do     putStrLn "   Flattening expression"     printPartialIssues flattened ("the call " <> call)     putStrLn $ "   Exploration finished, " <> show (Expr.numBranches expr) <> " branch(es) to check in call " <> call-+    putStrLn $ "   Keccak preimages in state: " <> (show $ length preState.keccakPreImgs)   case maybepost of     Nothing -> pure (expr, [(Qed, expr)], partials)     Just post -> do       let         -- Filter out any leaves from `flattened` that can be statically shown to be safe-        tocheck = flip map flattened $ \leaf -> (toPropsFinal conf leaf preState.constraints post, leaf)+        tocheck = flip map flattened $ \leaf -> (toProps leaf preState post, leaf)         withQueries = filter canBeSat tocheck       when conf.debug $ liftIO $ putStrLn $ "   Checking for reachability of " <> show (length withQueries)         <> " potential property violation(s) in call " <> call@@ -723,8 +759,8 @@       -- Dispatch the remaining branches to the solver to check for violations       results <- withRunInIO $ \env -> flip mapConcurrently withQueries $ \(query, leaf) -> do         res <- env $ checkSatWithProps solvers query-        when conf.debug $ putStrLn $ "   SMT result: " <> show (fst res)-        pure (fst res, leaf)+        when conf.debug $ putStrLn $ "   SMT result: " <> show res+        pure (res, leaf)       let cexs = filter (\(res, _) -> not . isQed $ res) results       when conf.debug $ liftIO $         putStrLn $ "   Found " <> show (length cexs) <> " potential counterexample(s) in call " <> call@@ -733,9 +769,13 @@     getCallPrefix :: Expr Buf -> String     getCallPrefix (WriteByte (Lit 0) (LitByte a) (WriteByte (Lit 1) (LitByte b) (WriteByte (Lit 2) (LitByte c) (WriteByte (Lit 3) (LitByte d) _)))) = mconcat $ map (printf "%02x") [a,b,c,d]     getCallPrefix _ = "unknown"-    toProps leaf constr post = PNeg (post preState leaf) : constr <> extractProps leaf-    toPropsFinal conf leaf constr post = if conf.simp then Expr.simplifyProps $ toProps leaf constr post-                                                 else toProps leaf constr post+    toProps leaf vm post = let+      postCondition = post preState leaf+      keccakConstraints = map (\(bs, k)-> PEq (Keccak (ConcreteBuf bs)) (Lit k)) (Set.toList vm.keccakPreImgs)+     in case postCondition of+      PBool True -> [PBool False]+      _ -> PNeg postCondition : vm.constraints <> extractProps leaf <> keccakConstraints+     canBeSat (a, _) = case a of         [PBool False] -> False         _ -> True@@ -809,7 +849,7 @@       conf <- readConfig       let bytecode = if BS.null bs then BS.pack [0] else bs       prestate <- liftIO $ stToIO $ abstractVM calldata bytecode Nothing create-      expr <- interpret (Fetch.oracle solvers Nothing) opts.iterConf prestate runExpr+      expr <- interpret (Fetch.oracle solvers Nothing mempty) opts.iterConf prestate runExpr       let simpl = if conf.simp then Expr.simplify expr else expr       pure $ flattenExpr simpl     oneQedOrNoQed :: EqIssues -> EqIssues@@ -873,7 +913,7 @@        parMapIO (runOne env wrap) input        where          runOne env wrap (props, meaning) = do-           res <- wrap (env $ fst <$> checkSatWithProps solvers (Set.toList props))+           res <- wrap (env $ checkSatWithProps solvers (Set.toList props))            pure (res, meaning)      -- Takes two branches and returns a set of props that will need to be@@ -1000,7 +1040,7 @@   let flattened = flattenExpr expr       withQueries = fmap (\e -> (extractProps e, e)) flattened   results <- withRunInIO $ \runInIO -> (flip mapConcurrently) withQueries $ \(query, leaf) -> do-    (res, _) <- runInIO $ checkSatWithProps solvers query+    res <- runInIO $ checkSatWithProps solvers query     pure (res, leaf)   pure $ fmap swap $ filter (\(res, _) -> not . isQed $ res) results @@ -1116,30 +1156,48 @@ prettyBuf (ConcreteBuf bs) = formatBinary bs prettyBuf b = internalError $ "Unexpected symbolic buffer:\n" <> T.unpack (formatExpr b) +calldataFromCex :: App m => SMTCex -> Expr Buf -> Sig -> m (Err ByteString)+calldataFromCex cex buf sig = do+  let sigKeccak = keccakSig $ encodeUtf8 (callSig sig)+  pure $ (sigKeccak <>) <$> body+  where+    cd = defaultSymbolicValues $ subModel cex buf+    argdata = case cd of+      Right cd' -> Right $ Expr.drop 4 (Expr.simplify cd')+      Left e -> Left e+    body = forceConcrete =<< argdata+    forceConcrete :: (Expr Buf) -> Err ByteString+    forceConcrete (ConcreteBuf k) = Right k+    forceConcrete _ = Left "Symbolic buffer in calldata, cannot produce concrete model"+    keccakSig :: ByteString -> ByteString+    keccakSig = keccakBytes >>> BS.take 4+ prettyCalldata :: SMTCex -> Expr Buf -> Text -> [AbiType] -> Text-prettyCalldata cex buf sig types = headErr errSig (T.splitOn "(" sig) <> "(" <> body <> ")"+prettyCalldata cex buf sig types = headErr errSig (T.splitOn "(" sig) <> "(" <> body <> ")" <> T.pack finalErr   where     cd = defaultSymbolicValues $ subModel cex buf     argdata :: Err (Expr Buf) = case cd of       Right cd' -> Right $ Expr.drop 4 (Expr.simplify cd')       Left e -> Left e-    body = case argdata of+    (body, finalErr) = case argdata of       Right argdata' -> case decodeBuf types argdata' of-        CAbi v -> T.intercalate "," (fmap showVal v)-        NoVals -> case argdata' of-            ConcreteBuf c -> T.pack (bsToHex c)-            _ -> T.pack err-        SAbi _ -> T.pack err-      Left e -> T.pack e+        (CAbi v, "") -> (T.intercalate "," (fmap showVal v), "")+        (CAbi v, err) -> (T.intercalate "," (fmap showVal v), dash <> err)+        (NoVals, err) -> case argdata' of+            ConcreteBuf c -> (T.pack $ "ABI decode failed. hex calldata: 0x" <> (bsToHex c), dash <> err)+            _ -> (T.pack defaultText, dash <> err)+        (SAbi _, err) -> (T.pack defaultText, dash <> err)+      Left err -> (T.pack err, "")     headErr e l = fromMaybe (T.pack e) $ listToMaybe l-    err = "Error: unable to produce a concrete model for calldata: " <> show buf+    dash = " -- "+    defaultText = "Error: unable to produce a concrete model for calldata: " <> show buf     errSig = "Error unable to split sig: " <> show sig  -- | If the expression contains any symbolic values, default them to some -- concrete value The intuition here is that if we still have symbolic values -- in our calldata expression after substituting in our cex, then they can have -- any value and we can safely pick a random value. This is a bit unsatisfying,--- we should really be doing smth like: https://github.com/ethereum/hevm/issues/334+-- we should really be doing smth like: https://github.com/argotorg/hevm/issues/334 -- but it's probably good enough for now defaultSymbolicValues :: Err (Expr a) -> Err (Expr a) defaultSymbolicValues = \case

@@ -0,0 +1,161 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}++module EVM.Tracing+  ( interpretWithTrace+  , execWithTrace+  , vmTraceStep+  , VMTraceStep (..)+  , VMTraceStepResult (..)+  )+where++-- This module allows stepping with tracing of the EVM.+import Optics.Core+import Optics.State++import Control.Monad.IO.Class+import Control.Monad.ST (stToIO, RealWorld)+import Data.Aeson qualified as JSON+import Data.Word (Word8, Word64)+import GHC.Generics (Generic)+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Operational qualified as Operational+import Control.Monad.Reader (lift)+import Control.Monad.State.Strict qualified as State+import Data.Maybe (fromJust)+import EVM (exec1)+import EVM.Op (intToOpName)+import Witch (into)+import Data.ByteString qualified as BS++import EVM.Effects+import EVM.Fetch qualified as Fetch+import EVM.Types+import EVM.Stepper++data VMTraceStep =+  VMTraceStep+  { pc      :: Int+  , op      :: Int+  , gas     :: Data.Word.Word64+  , memSize :: Data.Word.Word64+  , depth   :: Int+  , stack   :: [W256]+  , error   :: Maybe String+  } deriving (Generic)++instance Show VMTraceStep where+  show (VMTraceStep pc op gas memSize depth stack err) =+    "VMTraceStep { "+    ++ "tracePc = " ++ show pc+    ++ ", Op = " ++ show (intToOpName op)+    ++ ", Gas = " ++ show gas+    ++ ", MemSize = " ++ show memSize+    ++ ", Depth = " ++ show depth+    ++ ", Stack = " ++ show stack+    ++ ", Error = " ++ show err+    ++ " }"++instance JSON.ToJSON VMTraceStep where+  toEncoding = JSON.genericToEncoding JSON.defaultOptions+instance JSON.FromJSON VMTraceStep++data VMTraceStepResult =+  VMTraceStepResult+  { out  :: ByteStringS+  , gasUsed :: Data.Word.Word64+  } deriving (Generic, Show)++instance JSON.ToJSON VMTraceStepResult where+  toEncoding = JSON.genericToEncoding JSON.defaultOptions++type TraceState s = (VM Concrete s, [VMTraceStep])++execWithTrace :: App m => StateT (TraceState RealWorld) m (VMResult Concrete RealWorld)+execWithTrace = do+  _ <- runWithTrace+  fromJust <$> use (_1 % #result)++runWithTrace :: App m => StateT (TraceState RealWorld) m (VM Concrete RealWorld)+runWithTrace = do+  -- This is just like `exec` except for every instruction evaluated,+  -- we also increment a counter indexed by the current code location.+  conf <- lift readConfig+  vm0 <- use _1+  case vm0.result of+    Nothing -> do+      State.modify' (\(a, b) -> (a, b ++ [vmTraceStep vm0]))+      vm' <- liftIO $ stToIO $ State.execStateT (exec1 conf) vm0+      assign _1 vm'+      runWithTrace+    Just (VMFailure _) -> do+      -- Update error text for last trace element+      (a, b) <- State.get+      let updatedElem = (last b) {error = (vmTraceStep vm0).error}+          updatedTraces = take (length b - 1) b ++ [updatedElem]+      State.put (a, updatedTraces)+      pure vm0+    Just _ -> pure vm0++interpretWithTrace+  :: forall m a . App m+  => Fetch.Fetcher Concrete m RealWorld+  -> Stepper Concrete RealWorld a+  -> StateT (TraceState RealWorld) m a+interpretWithTrace fetcher =+  eval . Operational.view+  where+    eval+      :: App m+      => Operational.ProgramView (Action Concrete RealWorld) a+      -> StateT (TraceState RealWorld) m a+    eval (Operational.Return x) = pure x+    eval (action Operational.:>>= k) =+      case action of+        Exec ->+          execWithTrace >>= interpretWithTrace fetcher . k+        Wait q -> do+          m <- State.lift $ fetcher q+          vm <- use _1+          vm' <- liftIO $ stToIO $ State.execStateT m vm+          assign _1 vm'+          interpretWithTrace fetcher (k ())+        EVM m -> do+          vm <- use _1+          (r, vm') <- liftIO $ stToIO $ State.runStateT m vm+          assign _1 vm'+          interpretWithTrace fetcher (k r)++vmTraceStep :: VM Concrete s -> VMTraceStep+vmTraceStep vm =+  let+    memsize = vm.state.memorySize+  in VMTraceStep+    { pc = vm.state.pc+    , op = into $ getOpFromVM vm+    , gas = vm.state.gas+    , memSize = memsize+    -- increment to match geth format+    , depth = 1 + length (vm.frames)+    -- reverse to match geth format+    , stack = reverse $ forceLit <$> vm.state.stack+    , error = readoutError vm.result+    }+  where+    readoutError :: Maybe (VMResult t s) -> Maybe String+    readoutError (Just (VMFailure e)) = Just $ evmErrToString e+    readoutError _ = Nothing++getOpFromVM :: VM t s -> Word8+getOpFromVM vm =+  let pcpos  = vm ^. #state % #pc+      code' = vm ^. #state % #code+      xs = case code' of+        UnknownCode _ -> internalError "UnknownCode instead of RuntimeCode"+        InitCode bs _ -> BS.drop pcpos bs+        RuntimeCode (ConcreteRuntimeCode xs') -> BS.drop pcpos xs'+        RuntimeCode (SymbolicRuntimeCode _) -> internalError "RuntimeCode is symbolic"+  in if xs == BS.empty then 0+                       else BS.head xs+

@@ -4,12 +4,12 @@ -} module EVM.Traversals where -import Prelude hiding (LT, GT)+import Prelude hiding (LT, GT, Foldable(..))  import Control.Monad (forM, void) import Control.Monad.Identity (Identity(Identity), runIdentity)+import Data.Foldable (Foldable(..)) import Data.Map.Strict qualified as Map-import Data.List (foldl')  import EVM.Types @@ -89,13 +89,13 @@       -- control flow        e@(Success a _ c d) -> f e-                          <> foldl (foldProp f) mempty a+                          <> foldl' (foldProp f) mempty a                           <> go c                           <> foldl' (foldExpr f) mempty (Map.keys d)                           <> foldl' (foldEContract f) mempty d-      e@(Failure a _ (Revert c)) -> f e <> (foldl (foldProp f) mempty a) <> go c-      e@(Failure a _ _) -> f e <> (foldl (foldProp f) mempty a)-      e@(Partial a _ _) -> f e <> (foldl (foldProp f) mempty a)+      e@(Failure a _ (Revert c)) -> f e <> (foldl' (foldProp f) mempty a) <> go c+      e@(Failure a _ _) -> f e <> (foldl' (foldProp f) mempty a)+      e@(Partial a _ _) -> f e <> (foldl' (foldProp f) mempty a)       e@(ITE a b c) -> f e <> (go a) <> (go b) <> (go c)        -- integers@@ -168,7 +168,7 @@        -- logs -      e@(LogEntry a b c) -> f e <> (go a) <> (go b) <> (foldl (<>) mempty (fmap f c))+      e@(LogEntry a b c) -> f e <> (go a) <> (go b) <> (foldl' (<>) mempty (fmap f c))        -- storage 

@@ -11,7 +11,10 @@  module EVM.Types where +import Prelude hiding (Foldable(..))+ import GHC.Stack (HasCallStack, prettyCallStack, callStack)+import GHC.ByteOrder (targetByteOrder, ByteOrder(..)) import Control.Arrow ((>>>)) import Control.Monad (mzero) import Control.Monad.ST (ST)@@ -24,20 +27,20 @@ import Data.Binary qualified as Binary import Data.ByteArray qualified as BA import Data.Char-import Data.List (foldl') import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as BS16 import Data.ByteString.Builder (byteStringHex, toLazyByteString) import Data.ByteString.Char8 qualified as Char8+import Data.ByteString.Internal (unsafeCreate) import Data.ByteString.Lazy (toStrict) import Data.Data import Data.Int (Int64)-import Data.Word (Word8, Word32, Word64)+import Data.Word (Word8, Word32, Word64, byteSwap32, byteSwap64) import Data.DoubleWord import Data.DoubleWord.TH+import Data.Foldable (Foldable(..)) import Data.Map (Map)-import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Set (Set) import Data.Sequence (Seq)@@ -50,6 +53,8 @@ import Data.Vector qualified as V import Data.Vector.Storable qualified as VS import Data.Vector.Storable.Mutable (STVector)+import Foreign.Ptr (castPtr, plusPtr)+import Foreign.Storable (poke) import Numeric (readHex, showHex) import Options.Generic import Optics.TH@@ -549,6 +554,7 @@   | MaxInitCodeSizeExceeded W256 (Expr EWord)   | InvalidFormat   | PrecompileFailure+  | NonexistentPrecompile Addr   | ReturnDataOutOfBounds   | NonceOverflow   | BadCheatCode String FunctionSelector@@ -583,11 +589,12 @@  -- | Sometimes we can only partially execute a given program data PartialExec-  = UnexpectedSymbolicArg { pc :: Int, opcode :: String, msg  :: String, args  :: [SomeExpr] }+  = UnexpectedSymbolicArg { pc :: Int, addr :: Expr EAddr, opcode :: String, msg  :: String, args  :: [SomeExpr] }   | MaxIterationsReached  { pc :: Int, addr :: Expr EAddr }-  | JumpIntoSymbolicCode  { pc :: Int, jumpDst :: Int }-  | CheatCodeMissing      { pc :: Int, selector :: FunctionSelector }-  | BranchTooDeep         { pc :: Int}+  | JumpIntoSymbolicCode  { pc :: Int, addr :: Expr EAddr, jumpDst :: Int }+  | PrecompileMissing     { pc :: Int, addr :: Expr EAddr, preAddr :: Addr }+  | CheatCodeMissing      { pc :: Int, addr :: Expr EAddr, selector :: FunctionSelector }+  | BranchTooDeep         { pc :: Int, addr :: Expr EAddr}   deriving (Show, Eq, Ord)  -- | Effect types used by the vm implementation for side effects & control flow@@ -612,7 +619,7 @@  -- | Execution could proceed down one of several branches data RunAll s where-  PleaseRunAll    :: Expr EWord -> [W256] -> (W256 -> EVM Symbolic s ()) -> RunAll s+  PleaseRunAll    :: Expr EWord -> [Expr EWord] -> (Expr EWord -> EVM Symbolic s ()) -> RunAll s  -- | The possible return values of a SMT query data BranchCondition = Case Bool | UnknownBranch@@ -649,7 +656,7 @@ instance Show (RunAll s) where   showsPrec _ = \case     PleaseRunAll _ _ _ ->-      (("<EVM.RunAll: system running all paths") ++)+      (("<EVM.RunAll: system running all paths for Expr EWord-s") ++)  -- | The possible result states of a VM data VMResult (t :: VMType) s where@@ -679,7 +686,7 @@   , tx             :: TxState   , logs           :: [Expr Log]   , traces         :: Zipper.TreePos Zipper.Empty Trace-  , cache          :: Cache+  , pathsVisited   :: PathsVisited   , burned         :: !(Gas t)   , iterations     :: Map CodeLocation (Int, [Expr EWord])   -- ^ how many times we've visited a loc, and what the contents of the stack were when we were there last@@ -692,14 +699,15 @@   , freshVar       :: Int   -- ^ used to generate fresh symbolic variable names for overapproximations   --   during symbolic execution. See e.g. OpStaticcall-  , exploreDepth    :: Int+  , exploreDepth   :: Int+  , keccakPreImgs  :: Set (ByteString, W256)   }   deriving (Generic)  data ForkState = ForkState   { env :: Env   , block :: Block-  , cache :: Cache+  , pathsVisited :: PathsVisited   , urlOrAlias :: String   }   deriving (Show, Generic)@@ -770,7 +778,7 @@   { contract     :: Expr EAddr   , codeContract :: Expr EAddr   , code         :: ContractCode-  , pc           :: {-# UNPACK #-} !Int+  , pc           :: {-# UNPACK #-} !Int -- program counter in BYTES (not ops). PUSH ops will increment pc by more than 1   , stack        :: [Expr EWord]   , memory       :: Memory s   , memorySize   :: Word64@@ -842,7 +850,7 @@   , balance     :: Expr EWord   , nonce       :: Maybe W64   , codehash    :: Expr EWord-  , opIxMap     :: VS.Vector Int+  , opIxMap     :: VS.Vector Int -- ^ map from byte index to op index   , codeOps     :: V.Vector (Int, Op)   , external    :: Bool   }@@ -889,33 +897,7 @@  -- | A unique id for a given pc type CodeLocation = (Expr EAddr, Int)---- | The cache is data that can be persisted for efficiency:--- any expensive query that is constant at least within a block.-data Cache = Cache-  { fetched :: Map Addr Contract-  , path    :: Map (CodeLocation, Int) Bool-  } deriving (Show, Generic)--instance Semigroup Cache where-  a <> b = Cache-    { fetched = Map.unionWith unifyCachedContract a.fetched b.fetched-    , path = mappend a.path b.path-    }--instance Monoid Cache where-  mempty = Cache { fetched = mempty-                 , path = mempty-                 }---- only intended for use in Cache merges, where we expect--- everything to be Concrete-unifyCachedContract :: Contract -> Contract -> Contract-unifyCachedContract a b = a { storage = merged }-  where merged = case (a.storage, b.storage) of-                   (ConcreteStore sa, ConcreteStore sb) ->-                     ConcreteStore (mappend sa sb)-                   _ -> a.storage+type PathsVisited = Map (CodeLocation, Int) Bool   -- Bytecode Representations ------------------------------------------------------------------------@@ -1166,6 +1148,16 @@     , txContext = mempty     } +data ReproducibleCex = ReproducibleCex+  { testName :: Text+  , callData :: ByteString+  }+  deriving (Eq)+instance Show ReproducibleCex where+  show (ReproducibleCex name data') =+    "ReproducibleCex { testName = " <> show name <>+    ", callData = 0x" <> bsToHex data' <> " }"+ class GetUnknownStr a where     getUnknownStr :: a -> String @@ -1277,6 +1269,12 @@       cutshow = drop 2 $ show x       pad = replicate (64 - length (cutshow)) '0' +instance JSON.ToJSONKey W256 where+  toJSONKey = JSON.toJSONKeyText $ \x ->+    let cutshow = drop 2 $ show x+        pad = replicate (64 - length cutshow) '0'+    in T.pack ("0x" ++ pad ++ cutshow)+ instance JSON.FromJSON W256 where   parseJSON v = do     s <- T.unpack <$> JSON.parseJSON v@@ -1435,12 +1433,41 @@  word256Bytes :: W256 -> ByteString word256Bytes (W256 (Word256 (Word128 a b) (Word128 c d))) =+  unsafeCreate 32 $ \ptr -> do+    let ptr' = castPtr ptr+    poke (ptr' `plusPtr`  0) $ hton64 a+    poke (ptr' `plusPtr`  8) $ hton64 b+    poke (ptr' `plusPtr` 16) $ hton64 c+    poke (ptr' `plusPtr` 24) $ hton64 d++-- old, slower word256Bytes implementation, kept for differential fuzzing+slow_word256Bytes :: W256 -> ByteString+slow_word256Bytes (W256 (Word256 (Word128 a b) (Word128 c d))) =   Cereal.encode (a, b, c, d)  word160Bytes :: Addr -> ByteString word160Bytes (Addr (Word160 a (Word128 b c))) =+  unsafeCreate 20 $ \ptr -> do+    let ptr' = castPtr ptr+    poke (ptr' `plusPtr`  0) $ hton32 a+    poke (ptr' `plusPtr`  4) $ hton64 b+    poke (ptr' `plusPtr` 12) $ hton64 c++-- old, slower word160Bytes implementation, kept for differential fuzzing+slow_word160Bytes :: Addr -> ByteString+slow_word160Bytes (Addr (Word160 a (Word128 b c))) =   Cereal.encode (a, b, c) +hton32 :: Word32 -> Word32+hton32 | targetByteOrder == LittleEndian = byteSwap32+       | otherwise = id+{-# INLINE hton32 #-}++hton64 :: Word64 -> Word64+hton64 | targetByteOrder == LittleEndian = byteSwap64+       | otherwise = id+{-# INLINE hton64 #-}+ -- Get first and second Nibble from byte hi, lo :: Word8 -> Nibble hi b = Nibble $ b `shiftR` 4@@ -1480,7 +1507,7 @@     w256m0 = word8sToWord64 (take 8 (drop 16 bytes))     w256lo = word8sToWord64 (take 8 (drop 24 bytes))     word8sToWord64 :: [Word8] -> Word64-    word8sToWord64 = foldl (\acc byte -> (acc `shiftL` 8) .|. fromIntegral byte) 0+    word8sToWord64 = foldl' (\acc byte -> (acc `shiftL` 8) .|. fromIntegral byte) 0   -- Keccak hashing ----------------------------------------------------------------------------------@@ -1571,6 +1598,23 @@ bsToHex :: ByteString -> String bsToHex bs = concatMap (paddedShowHex 2) (BS.unpack bs) +-- Used during forceAddr to deal with symbolic addresses+forceEAddrToEWord :: Expr EAddr -> Expr EWord+forceEAddrToEWord = \case+  LitAddr a -> Lit (into a)+  SymAddr a ->  WAddr (SymAddr a)+  _ -> internalError "Unexpected address type forced to EWord"++forceEWordToEAddr :: Expr 'EWord -> Expr 'EAddr+forceEWordToEAddr = \case+  Lit a -> LitAddr (truncateToAddr a)+  WAddr (SymAddr a) -> SymAddr a+  _ -> internalError "Unexpected EWord type forced to address"++forceLit :: Expr EWord -> W256+forceLit (Lit x) = x+forceLit x = internalError $ "concrete vm, shouldn't ever happen: " <> show x+ -- Optics ------------------------------------------------------------------------------------------  @@ -1578,7 +1622,6 @@ makeFieldLabelsNoPrefix ''FrameState makeFieldLabelsNoPrefix ''TxState makeFieldLabelsNoPrefix ''SubState-makeFieldLabelsNoPrefix ''Cache makeFieldLabelsNoPrefix ''Trace makeFieldLabelsNoPrefix ''VMOpts makeFieldLabelsNoPrefix ''Frame

@@ -2,6 +2,8 @@  module EVM.UnitTest where +import Prelude hiding (Foldable(..))+ import EVM import EVM.ABI import EVM.Solvers@@ -13,17 +15,17 @@ import EVM.Fetch qualified as Fetch import EVM.Format import EVM.Solidity-import EVM.SymExec (defaultVeriOpts, symCalldata, verify, extractCex, prettyCalldata, panicMsg, VeriOpts(..), flattenExpr, groupIssues, groupPartials, IterConfig(..), defaultIterConf)+import EVM.SymExec (defaultVeriOpts, symCalldata, verify, extractCex, prettyCalldata, calldataFromCex, panicMsg, VeriOpts(..), flattenExpr, groupIssues, groupPartials, IterConfig(..), defaultIterConf, LoopHeuristic) import EVM.Types import EVM.Transaction (initTx) import EVM.Stepper (Stepper) import EVM.Stepper qualified as Stepper+import EVM.Tracing qualified as Tracing import EVM.Expr (maybeLitWordSimp)-import Data.List (foldl')  import Control.Monad (void, when, forM, forM_) import Control.Monad.ST (RealWorld, ST, stToIO)-import Control.Monad.State.Strict (execState, get, put, liftIO)+import Control.Monad.State.Strict (execState, get, put, liftIO, runStateT) import Optics.Core import Optics.State import Optics.State.Operators@@ -33,7 +35,7 @@ import Data.ByteString.Internal (c2w) import Data.ByteString.Lazy qualified as BSLazy import Data.Decimal (DecimalRaw(..))-import Data.Foldable (toList)+import Data.Foldable (Foldable(..), toList) import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe@@ -49,17 +51,19 @@ import Data.Char (ord)  data UnitTestOptions s = UnitTestOptions-  { rpcInfo     :: Fetch.RpcInfo-  , solvers     :: SolverGroup-  , maxIter     :: Maybe Integer-  , askSmtIters :: Integer-  , smtTimeout  :: Maybe Natural-  , match       :: Text-  , prefix      :: Text-  , dapp        :: DappInfo-  , testParams  :: TestVMParams-  , ffiAllowed  :: Bool-  , checkFailBit:: Bool+  { rpcInfo       :: Fetch.RpcInfo+  , solvers       :: SolverGroup+  , sess          :: Fetch.Session+  , maxIter       :: Maybe Integer+  , askSmtIters   :: Integer+  , smtTimeout    :: Maybe Natural+  , match         :: Text+  , prefix        :: Text+  , dapp          :: DappInfo+  , testParams    :: TestVMParams+  , ffiAllowed    :: Bool+  , checkFailBit  :: Bool+  , loopHeuristic :: LoopHeuristic   }  data TestVMParams = TestVMParams@@ -109,21 +113,21 @@ -- | Generate VeriOpts from UnitTestOptions makeVeriOpts :: UnitTestOptions s -> VeriOpts makeVeriOpts opts =-   defaultVeriOpts { iterConf = defaultIterConf {maxIter = opts.maxIter, askSmtIters = opts.askSmtIters }+   defaultVeriOpts { iterConf = defaultIterConf {maxIter = opts.maxIter, askSmtIters = opts.askSmtIters, loopHeuristic = opts.loopHeuristic}                    , rpcInfo = opts.rpcInfo                    }  -- | Top level CLI endpoint for hevm test -- | Returns tuple of (No Cex, No warnings)-unitTest :: App m => UnitTestOptions RealWorld -> Contracts -> m (Bool, Bool)-unitTest opts (Contracts cs) = do+unitTest :: App m => UnitTestOptions RealWorld -> BuildOutput -> m (Bool, Bool)+unitTest opts bo@(BuildOutput (Contracts cs) _) = do   let unitTestContrs = findUnitTests opts.prefix opts.match $ Map.elems cs   conf <- readConfig   when conf.debug $ liftIO $ do     putStrLn $ "Found " ++ show (length unitTestContrs) ++ " unit test contract(s) to test:"     let x = map (\(a,b) -> "  --> " <> a <> "  ---  functions: " <> (Text.pack $ show b)) unitTestContrs     putStrLn $ unlines $ map Text.unpack x-  results <- concatMapM (runUnitTestContract opts cs) unitTestContrs+  results <- concatMapM (runUnitTestContract opts bo) unitTestContrs   when conf.debug $ liftIO $ putStrLn $ "unitTest individual results: " <> show results   let (firsts, seconds) = unzip results   pure (and firsts, and seconds)@@ -159,26 +163,63 @@     Left e -> pushTrace (ErrorTrace e)     _ -> popTrace +validateCex :: forall m . App m+  => UnitTestOptions RealWorld+  -> Fetch.Fetcher Concrete m RealWorld+  -> VM Concrete RealWorld+  -> ReproducibleCex+  -> m Bool+validateCex uTestOpts fetcher vm repCex = do+  let utoConc = uTestOpts { testParams = uTestOpts.testParams { caller = LitAddr 0xdeadbeef}}+  conf <- readConfig+  when conf.debug $ liftIO $ putStrLn $ "Repro running function: " <> show utoConc.testParams.address <>+    " with caller: " <> show utoConc.testParams.caller <> ", gas: " <> show utoConc.testParams.gasCall <>+    ", and calldata: " <> show (bsToHex repCex.callData)++  -- Note, we should not need solvers to execute this code+  vm2 <- Stepper.interpret fetcher vm $ do+    Stepper.evm $ do+      pushTrace (EntryTrace $ "checking cex for function " <> repCex.testName <> " with calldata: " <> (Text.pack $ bsToHex repCex.callData))+      makeTxCall utoConc.testParams (ConcreteBuf repCex.callData, [])+    Stepper.evm get++  (res, (vm3, vmtrace)) <- runStateT (Tracing.interpretWithTrace fetcher Stepper.execFully) (vm2, [])+  when (conf.debug && (conf.verb > 2)) $ liftIO $ do+    putStrLn $ "vm step trace: " <> unlines (map show vmtrace)+    putStrLn $ "vm res: " <> show res+    putStrLn $ "vm res: " <> show vm3.result+  let shouldFail = "proveFail" `isPrefixOf` repCex.testName+  let ret = case res of+              Left err -> case err of+                (UnrecognizedOpcode 0xfe) -> True+                (Revert (ConcreteBuf msg)) ->+                   msg == panicMsg 0x01 ||+                     let sel = selector "Error(string)"+                     in (sel `BS.isPrefixOf` msg) && ("assertion failed" `BS.isPrefixOf` (BS.drop (4+32+32) msg))+                _ -> False+              Right _ -> utoConc.checkFailBit && (dsTestFailedConc vm3.env.contracts)+  pure (ret /= shouldFail)+ -- Returns tuple of (No Cex, No warnings) runUnitTestContract   :: App m   => UnitTestOptions RealWorld-  -> Map Text SolcContract+  -> BuildOutput   -> (Text, [Sig])   -> m [(Bool, Bool)] runUnitTestContract-  opts@(UnitTestOptions {..}) contractMap (name, testSigs) = do+  opts@(UnitTestOptions {..}) buildOut (name, testSigs) = do   liftIO $ putStrLn $ "Checking " ++ show (length testSigs) ++ " function(s) in contract " ++ unpack name    -- Look for the wanted contract by name from the Solidity info-  case Map.lookup name contractMap of+  case Map.lookup name (getContractsMap buildOut.contracts) of     Nothing -> internalError $ "Contract " ++ unpack name ++ " not found"-    Just theContract -> do+    Just solcContr -> do       -- Construct the initial VM and begin the contract's constructor-      vm0 :: VM Concrete RealWorld <- liftIO $ stToIO $ initialUnitTestVm opts theContract-      vm1 <- Stepper.interpret (Fetch.oracle solvers rpcInfo) vm0 $ do+      vm0 :: VM Concrete RealWorld <- liftIO $ stToIO $ initialUnitTestVm opts solcContr+      vm1 <- Stepper.interpret (Fetch.oracle solvers (Just sess) rpcInfo) vm0 $ do         Stepper.enter name-        initializeUnitTest opts theContract+        initializeUnitTest opts solcContr         Stepper.evm get        writeTraceDapp dapp vm1@@ -189,29 +230,38 @@           tick $ indentLines 3 failOut           pure [(True, False)]         Just (VMSuccess _) -> do-          forM testSigs $ \s -> symRun opts vm1 s+          forM testSigs $ \s -> symRun opts vm1 s solcContr buildOut.sources         _ -> internalError "setUp() did not end with a result" +dsTestFailedSym :: Map (Expr 'EAddr) (Expr EContract) -> VM s t -> Prop+dsTestFailedSym store vm =+  let testContract = fromMaybe (internalError "test contract not found in state") (Map.lookup vm.state.contract store)+  in case Map.lookup cheatCode store of+    Just cheatContract -> Expr.readStorage' (Lit 0x6661696c65640000000000000000000000000000000000000000000000000000) cheatContract.storage .== Lit 1+    Nothing -> And (Expr.readStorage' (Lit 0) testContract.storage) (Lit 2) .== Lit 2++dsTestFailedConc :: Map (Expr 'EAddr) Contract -> Bool+dsTestFailedConc store = case Map.lookup cheatCode store of+  Just cheatContract -> Expr.readStorage' (Lit 0x6661696c65640000000000000000000000000000000000000000000000000000) cheatContract.storage == Lit 1+  Nothing -> internalError "dsTestFailedConc: expected a cheatCode in the store"+ -- Define the thread spawner for symbolic tests -- Returns tuple of (No Cex, No warnings)-symRun :: App m => UnitTestOptions RealWorld -> VM Concrete RealWorld -> Sig -> m (Bool, Bool)-symRun opts@UnitTestOptions{..} vm (Sig testName types) = do-    let callSig = testName <> "(" <> (Text.intercalate "," (map abiTypeSolidity types)) <> ")"-    liftIO $ putStrLn $ "\x1b[96m[RUNNING]\x1b[0m " <> Text.unpack callSig-    cd <- symCalldata callSig types [] (AbstractBuf "txdata")-    let shouldFail = "proveFail" `isPrefixOf` callSig+symRun :: App m => UnitTestOptions RealWorld -> VM Concrete RealWorld -> Sig -> SolcContract -> SourceCache -> m (Bool, Bool)+symRun opts@UnitTestOptions{..} vm sig@(Sig testName types) solcContr sourceCache = do+    let cs = callSig sig+    liftIO $ putStrLn $ "\x1b[96m[RUNNING]\x1b[0m " <> Text.unpack cs+    cd <- symCalldata cs types [] (AbstractBuf "txdata")+    let shouldFail = "proveFail" `isPrefixOf` cs      -- define postcondition depending on `shouldFail`-    let testContract store = fromMaybe (internalError "test contract not found in state") (Map.lookup vm.state.contract store)-        failed store = case Map.lookup cheatCode store of-          Just cheatContract -> Expr.readStorage' (Lit 0x6661696c65640000000000000000000000000000000000000000000000000000) cheatContract.storage .== Lit 1-          Nothing -> And (Expr.readStorage' (Lit 0) (testContract store).storage) (Lit 2) .== Lit 2+    let         postcondition = curry $ case shouldFail of           True -> \(_, post) -> case post of-            Success _ _ _ store -> if opts.checkFailBit then failed store else PBool False+            Success _ _ _ store -> if opts.checkFailBit then (dsTestFailedSym store vm) else PBool False             _ -> PBool True           False -> \(_, post) -> case post of-            Success _ _ _ store -> if opts.checkFailBit then PNeg (failed store) else PBool True+            Success _ _ _ store -> if opts.checkFailBit then PNeg (dsTestFailedSym store vm) else PBool True             Failure _ _ (UnrecognizedOpcode 0xfe) -> PBool False             Failure _ _ (Revert msg) -> case msg of               ConcreteBuf b ->@@ -225,7 +275,8 @@             Partial _ _ _ -> PBool True             _ -> internalError "Invalid leaf node" -    vm' <- Stepper.interpret (Fetch.oracle solvers rpcInfo) vm $+    let fetcherConc = Fetch.oracle solvers (Just sess) rpcInfo+    vm' <- Stepper.interpret fetcherConc vm $       Stepper.evm $ do         pushTrace (EntryTrace testName)         makeTxCall testParams cd@@ -233,7 +284,8 @@     writeTraceDapp dapp vm'      -- check postconditions against vm-    (end, results) <- verify solvers (makeVeriOpts opts) (symbolify vm') (Just postcondition)+    let fetcherSym = Fetch.oracle solvers (Just sess) rpcInfo+    (end, results) <- verify solvers fetcherSym (makeVeriOpts opts) (symbolify vm') (Just postcondition)     let ends = flattenExpr end     conf <- readConfig     when conf.debug $ liftIO $ forM_ (filter Expr.isFailure ends) $ \case@@ -241,7 +293,6 @@       _ -> internalError "cannot be, filtered for failure"      -- display results-    let t = "the test " <> Text.unpack testName     let warnings = any Expr.isPartial ends || any isUnknown results || any isError results     let allReverts = not . (any Expr.isSuccess) $ ends     let unexpectedAllRevert = allReverts && not shouldFail@@ -253,8 +304,14 @@       (True, _, _) -> do         -- there are counterexamples (and maybe other things, but Cex is most important)         let x = mapMaybe extractCex results-        y <- symFailure opts testName (fst cd) types x-        pure $ "   \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n" <> Text.unpack y+        failsToRepro <- getReproFailures (Sig testName types) (fst cd) (map snd x)+++        validation <- mapM (traverse $ validateCex opts fetcherConc vm) failsToRepro+        when conf.debug $ liftIO $ putStrLn $ "Cex reproduction runs' results are: " <> show validation+        let toPrintData = zipWith (\(a, b) c -> (a, b, c)) x validation+        txtFails <- symFailure opts testName (fst cd) types toPrintData+        pure $ "   \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n" <> Text.unpack txtFails       (_, True, _) -> do         -- There are errors/unknowns/partials, we fail them         pure $ "   \x1b[31m[FAIL]\x1b[0m " <> Text.unpack testName <> "\n"@@ -266,7 +323,8 @@     when (unexpectedAllRevert && (warnings || (any isCex results))) $ do       -- if we display a FAILED due to Cex/warnings, we should also mention everything reverted       liftIO $ putStrLn $ "   \x1b[33m[WARNING]\x1b[0m " <> Text.unpack testName <> " all branches reverted\n"-    liftIO $ printWarnings ends results t+    let warnData = Just $ WarningData solcContr sourceCache vm'+    liftIO $ printWarnings warnData ends results $ "the test " <> Text.unpack testName     pure (not (any isCex results), not (warnings || unexpectedAllRevert))     where       -- The offset of the text is: the selector (4B), the offset value (aligned to 32B), and the length of the string (aligned to 32B)@@ -294,19 +352,29 @@               lhs = LitByte (c2w a)               rhs = Expr.readByte (Lit (fromIntegral n)) b ---printWarnings :: GetUnknownStr b => [Expr 'End] -> [ProofResult a b] -> String -> IO ()-printWarnings e results testName = do+printWarnings :: Maybe (WarningData s t) -> GetUnknownStr b => [Expr 'End] -> [ProofResult a b] -> String -> IO ()+printWarnings warnData e results testName = do   when (any isUnknown results || any isError results || any Expr.isPartial e) $ do     putStrLn $ "   \x1b[33m[WARNING]\x1b[0m hevm was only able to partially explore " <> testName <> " due to: ";     forM_ (groupIssues (filter isError results)) $ \(num, str) -> putStrLn $ "      " <> show num <> "x -> " <> str     forM_ (groupIssues (filter isUnknown results)) $ \(num, str) -> putStrLn $ "      " <> show num <> "x -> " <> str-    forM_ (groupPartials e) $ \(num, str) -> putStrLn $ "      " <> show num <> "x -> " <> str+    forM_ (groupPartials warnData e) $ \(num, str) -> putStrLn $ "      " <> show num <> "x -> " <> str   putStrLn "" -symFailure :: App m => UnitTestOptions RealWorld -> Text -> Expr Buf -> [AbiType] -> [(Expr End, SMTCex)] -> m Text-symFailure UnitTestOptions {..} testName cd types failures' = do+getReproFailures :: App m => Sig -> Expr Buf -> [SMTCex] -> m [Err ReproducibleCex]+getReproFailures sig@(Sig testName _) cd cexes = do+  fullCDs <- mapM (\cex -> calldataFromCex cex cd sig) cexes+  pure $ map (\case+    Left err -> Left err+    Right fullCD -> Right $ ReproducibleCex { testName = testName, callData = fullCD}) fullCDs++symFailure :: App m =>+  UnitTestOptions RealWorld -> Text -> Expr Buf -> [AbiType] ->+  [(Expr End, SMTCex, Err Bool)] ->+  m Text+symFailure UnitTestOptions {..} testName cd types fails = do   conf <- readConfig-  pure $ mconcat [ Text.concat $ indentLines 3 . mkMsg conf <$> failures' ]+  pure $ mconcat [ Text.concat $ indentLines 3 . mkMsg conf <$> fails ]   where       showRes = \case         Success _ _ _ _ -> if "proveFail" `isPrefixOf` testName@@ -315,8 +383,8 @@         res ->           let ?context = dappContext (traceContext res)           in Text.pack $ prettyvmresult res-      mkMsg conf (leaf, cex) = intercalate "\n" $-        ["Counterexample:"+      mkMsg conf (leaf, cex, repro) = intercalate "\n" $+        ["Counterexample:   " <> reproToText repro         ,"  calldata: " <> let ?context = dappContext (traceContext leaf)                            in prettyCalldata cex cd testName types         ,"  result:   " <> showRes leaf@@ -326,6 +394,10 @@       dappContext TraceContext { contracts, labels } =         DappContext { info = dapp, contracts, labels } +      reproToText :: Err Bool -> Text+      reproToText (Left err) = "\x1b[33m[error attempting to reproduce: " <> pack err <> "]\x1b[0m"+      reproToText (Right repro) = if repro then "\x1b[90m[validated]\x1b[0m" else "\x1b[31m[not reproducible]\x1b[0m"+ indentLines :: Int -> Text -> Text indentLines n s =   let p = Text.replicate n " "@@ -476,19 +548,20 @@           & set #balance (Lit testParams.balanceCreate)   pure $ vm & set (#env % #contracts % at (LitAddr ethrunAddress)) (Just creator) -paramsFromRpc :: Fetch.RpcInfo -> IO TestVMParams-paramsFromRpc rpcinfo = do-  (miner,ts,blockNum,ran,limit,base) <- case rpcinfo of+paramsFromRpc :: forall m . App m => Fetch.RpcInfo -> Fetch.Session -> m TestVMParams+paramsFromRpc rpcInfo sess = do+  (miner,ts,blockNum,ran,limit,base) <- case rpcInfo.blockNumURL of     Nothing -> pure (SymAddr "miner", Lit 0, Lit 0, 0, 0, 0)-    Just (block, url) -> Fetch.fetchBlockFrom block url >>= \case-      Nothing -> internalError "Could not fetch block"-      Just Block{..} -> pure ( coinbase-                             , timestamp-                             , number-                             , prevRandao-                             , gaslimit-                             , baseFee-                             )+    Just (Fetch.Latest, url) -> fetch Fetch.Latest url+    Just (Fetch.BlockNumber block, url) -> case rpcInfo.mockBlock >>= Map.lookup block of+        Nothing -> fetch (Fetch.BlockNumber block) url+        Just b ->pure (b.coinbase+                      , b.timestamp+                      , b.number+                      , b.prevRandao+                      , b.gaslimit+                      , b.baseFee+                      )   let ts' = fromMaybe (internalError "received unexpected symbolic timestamp via rpc") (maybeLitWordSimp ts)   pure $ TestVMParams     -- TODO: make this symbolic! It needs some tweaking to the way that our@@ -510,6 +583,19 @@     , prevrandao = ran     , chainId = 99     }+  where+    fetch block url = do+      conf <- readConfig+      liftIO $ Fetch.fetchBlockWithSession conf sess block url >>= \case+        Nothing -> internalError "Could not fetch block"+        Just Block{..} -> pure ( coinbase+                               , timestamp+                               , number+                               , prevRandao+                               , gaslimit+                               , baseFee+                               )+  tick :: Text -> IO () tick x = Text.putStr x >> hFlush stdout

@@ -9,8 +9,9 @@ import EVM.Transaction import EVM.UnitTest (writeTrace) import EVM.Types hiding (Block, Case, Env)-import EVM.Test.Tracing (interpretWithTrace, VMTrace, compareTraces, EVMToolTraceOutput(..), decodeTraceOutputHelper) import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp)+import EVM.Tracing qualified as Tracing+import EVM.Test.FuzzSymExec (compareTraces, EVMToolTraceOutput(..), decodeTraceOutputHelper)  import Optics.Core import Control.Arrow ((***), (&&&))@@ -188,10 +189,10 @@   -- | Run a vm test and output a geth style per opcode trace-traceVMTest :: App m => Case -> m [VMTrace]+traceVMTest :: App m => Case -> m [Tracing.VMTraceStep] traceVMTest x = do   vm0 <- liftIO $ vmForCase x-  (_, (_, ts)) <- runStateT (interpretWithTrace (EVM.Fetch.zero 0 (Just 0)) EVM.Stepper.runFully) (vm0, [])+  (_, (_, ts)) <- runStateT (Tracing.interpretWithTrace (EVM.Fetch.zero 0 (Just 0)) EVM.Stepper.runFully) (vm0, [])   pure ts  -- | given a path to a test file, a test case from within that file, and a trace from geth from running that test, compare the traces and show where we differ

@@ -0,0 +1,829 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-|+Module      : Tracing+Description : Tests to fuzz concrete tracing, and symbolic execution++Functions here are used to generate traces for the concrete+execution of HEVM and check that against evmtool from go-ethereum. Re-using some+of this code, we also generate a symbolic expression then evaluate it+concretely through Expr.simplify, then check that against evmtool's output.+-}+module EVM.Test.FuzzSymExec where++import Control.Monad (when)+import Control.Monad.ST (ST, stToIO)+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Reader (ReaderT)+import Data.Aeson ((.:), (.:?))+import Data.Aeson qualified as JSON+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as Char8+import Data.Maybe (fromJust, isJust, isNothing)+import Data.Map.Strict qualified as Map+import Data.Text.IO qualified as T+import Data.Vector qualified as Vector+import Data.Word (Word8, Word64)+import GHC.Generics (Generic)+import GHC.IO.Exception (ExitCode(ExitSuccess))+import Numeric (showHex)+import System.Directory (removeDirectoryRecursive)+import System.FilePath ((</>))+import System.IO.Temp (getCanonicalTemporaryDirectory, createTempDirectory)+import System.Process (readCreateProcessWithExitCode, proc, CreateProcess(..))+import Test.QuickCheck (elements)+import Test.QuickCheck.Instances.Text()+import Test.QuickCheck.Instances.Natural()+import Test.QuickCheck.Instances.ByteString()+import Test.Tasty (testGroup, after, TestTree, TestName, DependencyType(..))+import Test.Tasty.HUnit (assertEqual, testCase)+import Test.Tasty.QuickCheck hiding (Failure, Success)+import Witch (into, unsafeInto)++import Optics.Core hiding (pre)++import EVM (makeVm, initialContract, symbolify)+import EVM.Assembler (assemble)+import EVM.Expr qualified as Expr+import EVM.Exec (ethrunAddress)+import EVM.Fetch qualified as Fetch+import EVM.Format (formatBinary)+import EVM.FeeSchedule+import EVM.Op (intToOpName)+import EVM.Sign (deriveAddr)+import EVM.Solvers+import EVM.Stepper qualified as Stepper+import EVM.SymExec+import EVM.Traversals (mapExpr)+import EVM.Transaction qualified+import EVM.Types hiding (Env)+import EVM.Effects+import Control.Monad.IO.Unlift+import EVM.Tracing (interpretWithTrace, VMTraceStep(..), VMTraceStepResult(..))++data EVMToolTrace =+  EVMToolTrace+    { pc :: Int+    , op :: Int+    , gas :: W256+    , memSize :: Integer+    , depth :: Int+    , refund :: Int+    , opName :: String+    , stack :: [W256]+    , error :: Maybe String+    , gasCost :: Maybe W256+    } deriving (Generic, Show)++instance JSON.FromJSON EVMToolTrace where+  parseJSON = JSON.withObject "EVMToolTrace" $ \v -> EVMToolTrace+    <$> v .: "pc"+    <*> v .: "op"+    <*> v .: "gas"+    <*> v .: "memSize"+    <*> v .: "depth"+    <*> v .: "refund"+    <*> v .: "opName"+    <*> v .: "stack"+    <*> v .:? "error"+    <*> v .:? "gasCost"++mkBlockHash:: Int -> Expr 'EWord+mkBlockHash x = (into x :: Integer) & show & Char8.pack & EVM.Types.keccak' & Lit++blockHashesDefault :: Map.Map Int W256+blockHashesDefault = Map.fromList [(x, forceLit $ mkBlockHash x) | x<- [1..256]]++data EVMToolOutput =+  EVMToolOutput+    { output :: ByteStringS+    , gasUsed :: W256+    , time :: Maybe Integer+    , error :: Maybe String+    } deriving (Generic, Show)++instance JSON.FromJSON EVMToolOutput++data EVMToolTraceOutput =+  EVMToolTraceOutput+    { trace :: [EVMToolTrace]+    , output :: EVMToolOutput+    } deriving (Generic, Show)++instance JSON.FromJSON EVMToolTraceOutput++data EVMToolEnv = EVMToolEnv+  { coinbase    :: Addr+  , timestamp   :: Expr EWord+  , number      :: Expr EWord+  , gasLimit    :: Data.Word.Word64+  , baseFee     :: W256+  , maxCodeSize :: W256+  , schedule    :: FeeSchedule Data.Word.Word64+  , blockHashes :: Map.Map Int W256+  , withdrawals :: [Addr]+  , currentRandom :: W256+  , parentBeaconBlockRoot :: W256+  } deriving (Show, Generic)++instance JSON.ToJSON EVMToolEnv where+  toJSON b = JSON.object [ ("currentCoinBase"  , (JSON.toJSON b.coinbase))+                         , ("currentGasLimit"  , (JSON.toJSON ("0x" ++ showHex (into @Integer b.gasLimit) "")))+                         , ("currentNumber"    , (JSON.toJSON number))+                         , ("currentTimestamp" , (JSON.toJSON tstamp))+                         , ("currentBaseFee"   , (JSON.toJSON b.baseFee))+                         , ("blockHashes"      , (JSON.toJSON b.blockHashes))+                         , ("withdrawals"      , (JSON.toJSON b.withdrawals))+                         , ("currentRandom"    , (JSON.toJSON b.currentRandom))+                         , ("parentBeaconBlockRoot" , (JSON.toJSON b.parentBeaconBlockRoot))+                         ]+              where+                tstamp :: W256+                tstamp = case (b.timestamp) of+                              Lit a -> a+                              _ -> internalError "Timestamp needs to be a Lit"+                number :: W256+                number = case (b.number) of+                              Lit a -> a+                              _ -> internalError "Timestamp needs to be a Lit"++emptyEvmToolEnv :: EVMToolEnv+emptyEvmToolEnv = EVMToolEnv { coinbase = 0+                             , timestamp = Lit 0+                             , number     = Lit 0+                             , gasLimit   = 0xffffffffffffffff+                             , baseFee    = 0+                             , maxCodeSize= 0xffffffff+                             , schedule   = feeSchedule+                             , blockHashes = mempty+                             , withdrawals = mempty+                             , currentRandom = 42+                             , parentBeaconBlockRoot = 5+                             }++data EVMToolReceipt =+  EVMToolReceipt+    { _type :: String+    , root :: String+    , status :: String+    , cumulativeGasUsed :: String+    , logsBloom :: String+    , logs :: Maybe String+    , transactionHash :: String+    , contractAddress :: String+    , gasUsed :: String+    , effectiveGasPrice :: Maybe String+    , blockHash :: String+    , transactionIndex :: String+    } deriving (Generic, Show)++instance JSON.FromJSON EVMToolReceipt where+    parseJSON = JSON.withObject "EVMReceipt" $ \v -> EVMToolReceipt+        <$> v .: "type"+        <*> v .: "root"+        <*> v .: "status"+        <*> v .: "cumulativeGasUsed"+        <*> v .: "logsBloom"+        <*> v .: "logs"+        <*> v .: "transactionHash"+        <*> v .: "contractAddress"+        <*> v .: "gasUsed"+        <*> v .: "effectiveGasPrice"+        <*> v .: "blockHash"+        <*> v .: "transactionIndex"++data EVMToolResult =+  EVMToolResult+  { stateRoot :: String+  , txRoot :: String+  , receiptsRoot :: String+  , logsHash :: String+  , logsBloom :: String+  , receipts :: [EVMToolReceipt]+  , currentDifficulty :: Maybe String+  , gasUsed :: String+  , currentBaseFee :: String+  , withdrawalsRoot :: String+  } deriving (Generic, Show)++instance JSON.FromJSON EVMToolResult+++data EVMToolAlloc =+  EVMToolAlloc+  { balance :: W256+  , code :: ByteString+  , nonce :: W64+  } deriving (Generic)++instance JSON.ToJSON EVMToolAlloc where+  toJSON b = JSON.object [ ("balance" , (JSON.toJSON $ show b.balance))+                         , ("code", (JSON.toJSON $ ByteStringS b.code))+                         , ("nonce", (JSON.toJSON b.nonce))+                         ]++emptyEVMToolAlloc :: EVMToolAlloc+emptyEVMToolAlloc = EVMToolAlloc { balance = 0+                                 , code = mempty+                                 , nonce = 0+                                 }+-- Sets up common parts such as TX, origin contract, and environment that can+-- later be used to create & execute either an evmtool (from go-ethereum) or an+-- HEVM transaction. Some elements here are hard-coded such as the secret key,+-- which are currently not being fuzzed.+evmSetup :: OpContract -> ByteString -> Int -> (EVM.Transaction.Transaction, EVMToolEnv, EVMToolAlloc, Addr, Addr, Integer)+evmSetup contr txData gaslimitExec = (txn, evmEnv, contrAlloc, fromAddress, toAddress, sk)+  where+    contrLits = assemble $ getOpData contr+    toW8fromLitB :: Expr 'Byte -> Word8+    toW8fromLitB (LitByte a) = a+    toW8fromLitB _ = internalError "Cannot convert non-litB"++    bitcode = BS.pack . Vector.toList $ toW8fromLitB <$> contrLits+    contrAlloc = EVMToolAlloc{ balance = 0xa493d65e20984bc+                             , code = bitcode+                             , nonce = 0x48+                             }+    txn = EVM.Transaction.Transaction+      { txdata     = txData+      , gasLimit = unsafeInto gaslimitExec+      , gasPrice = Just 1+      , nonce    = 172+      , toAddr   = Just 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192+      , r        = 0 -- will be fixed when we sign+      , s        = 0 -- will be fixed when we sign+      , v        = 0 -- will be fixed when we sign+      , value    = 0 -- setting this > 0 fails because HEVM doesn't handle value sent in toplevel transaction+      , txtype     = EVM.Transaction.EIP1559Transaction+      , accessList = []+      , maxPriorityFeeGas =  Just 1+      , maxFeePerGas = Just 1+      , chainId = 1+      }+    evmEnv = EVMToolEnv { coinbase      = 0xff+                        , timestamp     = Lit 0x3e8+                        , number        = Lit 0+                        , gasLimit      = unsafeInto gaslimitExec+                        , baseFee       = 0x0+                        , maxCodeSize   = 0xfffff+                        , schedule      = feeSchedule+                        , blockHashes   = blockHashesDefault+                        , withdrawals   = mempty+                        , currentRandom = 42+                        , parentBeaconBlockRoot = 5+                        }+    sk = 0xDC38EE117CAE37750EB1ECC5CFD3DE8E85963B481B93E732C5D0CB66EE6B0C9D+    fromAddress = fromJust $ deriveAddr sk+    toAddress = 0x8A8eAFb1cf62BfBeb1741769DAE1a9dd47996192++getHEVMRet+  :: App m+  => OpContract -> ByteString -> Int -> m (Either (EvmError, [VMTraceStep]) (Expr 'End, [VMTraceStep], VMTraceStepResult))+getHEVMRet contr txData gaslimitExec = do+  let (txn, evmEnv, contrAlloc, fromAddress, toAddress, _) = evmSetup contr txData gaslimitExec+  runCodeWithTrace mempty evmEnv contrAlloc txn (LitAddr fromAddress) (LitAddr toAddress)++getEVMToolRet :: FilePath -> OpContract -> ByteString -> Int -> IO (Maybe EVMToolResult)+getEVMToolRet evmDir contr txData gaslimitExec = do+  let (txn, evmEnv, contrAlloc, fromAddress, toAddress, sk) = evmSetup contr txData gaslimitExec+      txs = [EVM.Transaction.sign sk txn]+      walletAlloc = EVMToolAlloc{ balance = 0x5ffd4878be161d74+                                , code = BS.empty+                                , nonce = 0xac+                                }+      alloc :: Map.Map Addr EVMToolAlloc+      alloc = Map.fromList ([ (fromAddress, walletAlloc), (toAddress, contrAlloc)])+  JSON.encodeFile (evmDir </> "txs.json") txs+  JSON.encodeFile (evmDir </> "alloc.json") alloc+  JSON.encodeFile (evmDir </> "env.json") evmEnv+  let cmd = (proc "evm" [ "transition"+                        , "--state.fork", "Cancun"+                        , "--input.alloc", "alloc.json"+                        , "--input.env", "env.json"+                        , "--input.txs", "txs.json"+                        , "--output.alloc", "alloc-out.json"+                        , "--trace.returndata=true"+                        , "--trace", "trace.json"+                        , "--output.result", "result.json"+                        ]) { cwd = Just evmDir }+  (exitCode, evmtoolStdout, evmtoolStderr) <- readCreateProcessWithExitCode cmd ""+  when (exitCode /= ExitSuccess) $ do+    putStrLn $ "evmtool exited with code " <> show exitCode+    putStrLn $ "evmtool stderr output:" <> show evmtoolStderr+    putStrLn $ "evmtool stdout output:" <> show evmtoolStdout+  JSON.decodeFileStrict (evmDir </> "result.json") :: IO (Maybe EVMToolResult)++-- Compares traces of evmtool (from go-ethereum) and HEVM+compareTraces :: [VMTraceStep] -> [EVMToolTrace] -> IO (Bool)+compareTraces hevmTrace evmTrace = go hevmTrace evmTrace+  where+    go :: [VMTraceStep] -> [EVMToolTrace] -> IO (Bool)+    go [] [] = pure True+    go (a:ax) (b:bx) = do+      let aOp = a.op+          bOp = b.op+          aPc = a.pc+          bPc = b.pc+          aStack = a.stack+          bStack = b.stack+          aGas = into a.gas+          bGas = b.gas+      -- putStrLn $ "hevm: " <> intToOpName aOp <> " pc: " <> show aPc <> " gas: " <> show aGas <> " stack: " <> show aStack+      -- putStrLn $ "geth: " <> intToOpName bOp <> " pc: " <> show bPc <> " gas: " <> show bGas <> " stack: " <> show bStack++      when (aGas /= bGas) $ do+        putStrLn "GAS doesn't match:"+        putStrLn $ "HEVM's gas   : " <> (show aGas)+        putStrLn $ "evmtool's gas: " <> (show bGas)+        putStrLn $ "executing opcode: " <> (intToOpName aOp)+      when (aOp /= bOp || aPc /= bPc) $ do+        putStrLn $ "HEVM: " <> (intToOpName aOp) <> " (pc " <> (show aPc) <> ") --- evmtool " <> (intToOpName bOp) <> " (pc " <> (show bPc) <> ")"++      when (isJust b.error) $ do+        putStrLn $ "Error by evmtool: " <> (show b.error)+        putStrLn $ "Error by HEVM   : " <> (show a.error)++      when (aStack /= bStack) $ do+        putStrLn "stacks don't match:"+        putStrLn $ "HEVM's stack   : " <> (show aStack)+        putStrLn $ "evmtool's stack: " <> (show bStack)+      if aOp == bOp && aStack == bStack && aPc == bPc && aGas == bGas then go ax bx+      else pure False+++    go a@(_:_) [] = do+      putStrLn $ "Traces don't match. HEVM's trace is longer by:" <> (show a)+      pure False+    go [] [b] = do+      -- evmtool produces ONE more trace element of the error+      -- hevm on the other hand stops and doesn't produce one more+      if isJust b.error then pure True+                           else do+                             putStrLn $ "Traces don't match. HEVM's trace is longer by:" <> (show b)+                             pure False+    go [] b@(_:_) = do+      putStrLn $ "Traces don't match. evmtool's trace is longer by:" <> (show b)+      pure False++getTraceFileName :: FilePath -> EVMToolResult -> String+getTraceFileName evmDir evmtoolResult = evmDir </> traceFileName+  where+    txName = ((evmtoolResult.receipts) !! 0).transactionHash+    traceFileName = "trace-0-" ++ txName ++ ".jsonl"++getTraceOutput :: FilePath -> Maybe EVMToolResult -> IO (Maybe EVMToolTraceOutput)+getTraceOutput evmDir evmtoolResult =+  case evmtoolResult of+    Nothing -> pure Nothing+    Just res -> do+      let traceFileName = getTraceFileName evmDir res+      decodeTraceOutputHelper traceFileName++decodeTraceOutputHelper :: String -> IO (Maybe EVMToolTraceOutput)+decodeTraceOutputHelper traceFileName = do+  traceContents <- readFile traceFileName+  let traceLines = lines traceContents+  let (traces, outputLines) = splitAt (length traceLines - 1) traceLines+  let parsedTraces = map decodeString traces :: [Maybe EVMToolTrace]+  let parsedOutput = decodeString (outputLines !! 0) :: Maybe EVMToolOutput+  if all isJust parsedTraces && isJust parsedOutput then+    pure $ Just $ EVMToolTraceOutput (map fromJust parsedTraces) (fromJust parsedOutput)+  else+    pure Nothing+  where+    decodeString :: (JSON.FromJSON a) => String -> Maybe a+    decodeString = JSON.decodeStrict . Char8.pack++-- | Takes a runtime code and calls it with the provided calldata+--   Uses evmtool's alloc and transaction to set up the VM correctly+runCodeWithTrace+  :: App m+  => Fetch.RpcInfo -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction+  -> Expr EAddr -> Expr EAddr -> m (Either (EvmError, [VMTraceStep]) ((Expr 'End, [VMTraceStep], VMTraceStepResult)))+runCodeWithTrace rpcinfo evmEnv alloc txn fromAddr toAddress = withSolvers Z3 0 1 Nothing $ \solvers -> do+  let calldata' = ConcreteBuf txn.txdata+      code' = alloc.code+      iterConf = IterConfig { maxIter = Nothing, askSmtIters = 1, loopHeuristic = Naive }+      fetcherSym = Fetch.oracle solvers Nothing rpcinfo+      buildExpr vm = interpret fetcherSym iterConf vm runExpr+  origVM <- liftIO $ stToIO $ vmForRuntimeCode code' calldata' evmEnv alloc txn fromAddr toAddress+  expr <- buildExpr $ symbolify origVM++  let fetcherConc = Fetch.oracle solvers Nothing rpcinfo+  (res, (vm, trace)) <- runStateT (interpretWithTrace fetcherConc Stepper.execFully) (origVM, [])+  case res of+    Left x -> pure $ Left (x, trace)+    Right _ -> pure $ Right (expr, trace, vmres vm)++vmForRuntimeCode :: ByteString -> Expr Buf -> EVMToolEnv -> EVMToolAlloc -> EVM.Transaction.Transaction -> Expr EAddr -> Expr EAddr -> ST s (VM Concrete s)+vmForRuntimeCode runtimecode calldata' evmToolEnv alloc txn fromAddr toAddress =+  let contract = initialContract (RuntimeCode (ConcreteRuntimeCode runtimecode))+                 & set #balance (Lit alloc.balance)+  in (makeVm $ VMOpts+    { contract = contract+    , otherContracts = []+    , calldata = (calldata', [])+    , value = Lit txn.value+    , baseState = EmptyBase+    , address =  toAddress+    , caller = fromAddr+    , origin = fromAddr+    , coinbase = LitAddr evmToolEnv.coinbase+    , number = evmToolEnv.number+    , timestamp = evmToolEnv.timestamp+    , gasprice = fromJust txn.gasPrice+    , gas = txn.gasLimit - (EVM.Transaction.txGasCost evmToolEnv.schedule txn)+    , gaslimit = txn.gasLimit+    , blockGaslimit = evmToolEnv.gasLimit+    , prevRandao = evmToolEnv.currentRandom+    , baseFee = evmToolEnv.baseFee+    , priorityFee = fromJust txn.maxPriorityFeeGas+    , maxCodeSize = evmToolEnv.maxCodeSize+    , schedule = evmToolEnv.schedule+    , chainId = txn.chainId+    , create = False+    , txAccessList = mempty+    , allowFFI = False+    , freshAddresses = 0+    , beaconRoot = 0+    }) <&> set (#env % #contracts % at (LitAddr ethrunAddress))+             (Just (initialContract (RuntimeCode (ConcreteRuntimeCode BS.empty))))+       <&> set (#state % #calldata) calldata'++vmres :: VM Concrete s -> VMTraceStepResult+vmres vm =+  let+    gasUsed' = vm.tx.gaslimit - vm.state.gas+    res = case vm.result of+      Just (VMSuccess (ConcreteBuf b)) -> (ByteStringS b)+      Just (VMSuccess x) -> internalError $ "unhandled: " <> (show x)+      Just (VMFailure (Revert (ConcreteBuf b))) -> (ByteStringS b)+      Just (VMFailure _) -> ByteStringS mempty+      _ -> ByteStringS mempty+  in VMTraceStepResult+     { out = res+     , gasUsed = gasUsed'+     }+++newtype OpContract = OpContract [Op]+instance Show OpContract where+  show (OpContract a) = "OpContract " ++ (show a)++getOpData :: OpContract-> [Op]+getOpData (OpContract x) = x++instance Arbitrary OpContract where+  arbitrary = fmap OpContract (sized genContract)++removeExtcalls :: OpContract -> OpContract+removeExtcalls (OpContract ops) = OpContract (filter (noStorageNoExtcalls) ops)+  where+    noStorageNoExtcalls :: Op -> Bool+    noStorageNoExtcalls o = case o of+                               -- External info functions+                               OpExtcodecopy -> False+                               OpExtcodehash -> False+                               OpExtcodesize -> False+                               OpAddress -> False+                               OpOrigin -> False+                               OpCaller -> False+                               OpCoinbase -> False+                               OpCreate -> False+                               OpCreate2 -> False+                               -- External call functions+                               OpDelegatecall -> False+                               OpStaticcall -> False+                               OpCall -> False+                               OpCallcode -> False+                               -- Not interesting+                               OpBalance -> False+                               OpSelfdestruct -> False+                               _ -> True++getJumpDests :: [Op] -> [Int]+getJumpDests ops = go ops 0 []+    where+      go :: [Op] -> Int -> [Int] -> [Int]+      go [] _ dests = dests+      go (a:ax) pos dests = case a of+                       OpJumpdest -> go ax (pos+1) (pos:dests)+                       OpPush _ -> go ax (pos+33) dests+                       -- We'll fix these up later to add a Push in between, hence they are 34 bytes+                       OpJump -> go ax (pos+34) dests+                       OpJumpi -> go ax (pos+34) dests+                       -- everything else is 1 byte+                       _ -> go ax (pos+1) dests++fixContractJumps :: OpContract -> IO OpContract+fixContractJumps (OpContract ops) = do+  let+    addedOps = ops++[OpJumpdest]+    jumpDests = getJumpDests addedOps+    -- always end on an OpJumpdest so we don't have an issue with a "later" position+    ops2 = fixup addedOps 0 []+    -- original set of operations, the set of jumpDests NOW valid, current position, return value+    fixup :: [Op] -> Int -> [Op] -> IO [Op]+    fixup [] _ ret = pure ret+    fixup (a:ax) pos ret = case a of+      OpJumpi -> do+        let filtDests = (filter (> pos) jumpDests)+        rndPos <- randItem filtDests+        fixup ax (pos+34) (ret++[(OpPush (Lit (unsafeInto rndPos))), (OpJumpi)])+      OpJump -> do+        let filtDests = (filter (> pos) jumpDests)+        rndPos <- randItem filtDests+        fixup ax (pos+34) (ret++[(OpPush (Lit (unsafeInto rndPos))), (OpJump)])+      myop@(OpPush _) -> fixup ax (pos+33) (ret++[myop])+      myop -> fixup ax (pos+1) (ret++[myop])+  fmap OpContract ops2++genPush :: Int -> Gen [Op]+genPush n = vectorOf n onePush+  where+    onePush :: Gen Op+    onePush  = do+      p <- chooseInt (1, 10)+      pure $ OpPush (Lit (unsafeInto p))++genContract :: Int -> Gen [Op]+genContract n = do+    y <- chooseInt (3, 6)+    pushes <- genPush y+    normalOps <- vectorOf (3*n+40) genOne+    large :: Bool <- chooseAny+    extra <- if large then vectorOf (100) genOne+                      else pure []+    addReturn <- chooseInt (0, 10)+    let contr = pushes ++ normalOps ++ extra+    if addReturn < 10 then pure $ contr++[OpPush (Lit 0x40), OpPush (Lit 0x0), OpReturn]+                      else pure contr+  where+    genOne :: Gen Op+    genOne = frequency [+      -- math ops+      (20, frequency [+          (2, pure OpAdd)+        , (2, pure OpMul)+        , (1, pure OpSub)+        , (2, pure OpDiv)+        , (1, pure OpSdiv)+        , (2, pure OpMod)+        , (1, pure OpSmod)+        , (1, pure OpAddmod)+        , (2, pure OpMulmod)+        , (1, pure OpExp)+        , (1, pure OpSignextend)+        , (2, pure OpLt)+        , (2, pure OpGt)+        , (2, pure OpSlt)+        , (2, pure OpSgt)+        , (1, pure OpSha3)+      ])+      -- Comparison & binary ops+      , (200, frequency [+          (1, pure OpEq)+        , (1, pure OpIszero)+        , (1, pure OpAnd)+        , (1, pure OpOr)+        , (1, pure OpXor)+        , (1, pure OpNot)+        , (1, pure OpByte)+        , (1, pure OpShl)+        , (1, pure OpShr)+        , (1, pure OpSar)+      ])+      -- calldata+      , (200, pure OpCalldataload)+      , (800, pure OpCalldatacopy)+      -- Get some info+      , (100, frequency [+          (10, pure OpAddress)+        , (10, pure OpBalance)+        , (10, pure OpOrigin)+        , (10, pure OpCaller)+        , (10, pure OpCallvalue)+        , (10, pure OpCalldatasize)+        , (10, pure OpCodesize)+        , (10, pure OpGasprice)+        , (10, pure OpReturndatasize)+        , (10, pure OpReturndatacopy)+        , (10, pure OpExtcodehash)+        , (10, pure OpBlockhash)+        , (10, pure OpCoinbase)+        , (10, pure OpTimestamp)+        , (10, pure OpNumber)+        , (10, pure OpPrevRandao)+        , (10, pure OpGaslimit)+        , (10, pure OpChainid)+        , (10, pure OpSelfbalance)+        , (10, pure OpBaseFee)+        , (10, pure OpPc)+        , (10, pure OpMsize)+        , (10, pure OpGas)+        , (10, pure OpExtcodesize)+        , (10, pure OpCodecopy)+        , (10, pure OpExtcodecopy)+      ])+      -- memory manip+      , (1200, frequency [+          (10, pure OpMcopy)+        , (50, pure OpMload)+        , (1, pure OpMstore)+        , (300, pure OpMstore8)+      ])+      -- storage manip+      , (100, frequency [+          (1, pure OpSload)+        , (1, pure OpSstore)+        , (1, pure OpTstore)+        , (1, pure OpTload)+      ])+      -- Jumping around+      , (50, frequency [+            (1, pure OpJump)+          , (10, pure OpJumpi)+      ])+      -- calling out+      , (1, frequency [+          (1, pure OpStaticcall)+        , (1, pure OpCall)+        , (1, pure OpCallcode)+        , (1, pure OpDelegatecall)+        , (1, pure OpCreate)+        , (1, pure OpCreate2)+        , (1, pure OpSelfdestruct)+      ])+      -- manipulate stack+      , (13000, frequency [+          (1, pure OpPop)+        , (400, do+            -- x <- arbitrary+            large <- chooseInt (0, 2000)+            x <- if large == 0 then chooseBoundedIntegral (0::W256, (2::W256)^(256::W256)-1)+                               else chooseBoundedIntegral (0, 10)+            pure $ OpPush (Lit x))+        , (10, do+            x <- chooseInt (1, 10)+            pure $ OpDup (unsafeInto x))+        , (10, do+            x <- chooseInt (1, 10)+            pure $ OpSwap (unsafeInto x))+      ])]+      -- End states+      -- , (1, frequency [+      --    (1, pure OpStop)+      --  , (10, pure OpReturn)+      --  , (10, pure OpRevert)+      -- ])++randItem :: [a] -> IO a+randItem = generate . Test.QuickCheck.elements++getOpFromVM :: VM t s -> Word8+getOpFromVM vm =+  let pcpos  = vm ^. #state % #pc+      code' = vm ^. #state % #code+      xs = case code' of+        UnknownCode _ -> internalError "UnknownCode instead of RuntimeCode"+        InitCode bs _ -> BS.drop pcpos bs+        RuntimeCode (ConcreteRuntimeCode xs') -> BS.drop pcpos xs'+        RuntimeCode (SymbolicRuntimeCode _) -> internalError "RuntimeCode is symbolic"+  in if xs == BS.empty then 0+                       else BS.head xs++testEnv :: Env+testEnv = Env { config = defaultConfig }++test :: TestName -> ReaderT Env IO () -> TestTree+test a b = testCase a $ runEnv testEnv b++prop:: Testable prop => ReaderT Env IO prop -> Property+prop a = ioProperty $ runEnv testEnv a++tests :: TestTree+tests = testGroup "contract-quickcheck-run"+    [ testProperty "random-contract-concrete-call" $ \(contr :: OpContract, GasLimitInt gasLimit, TxDataRaw txDataRaw) -> prop $ do+        let txData = BS.pack $ toEnum <$> txDataRaw+        -- TODO: By removing external calls, we fuzz less+        --       It should work also when we external calls. Removing for now.+        contrFixed <- liftIO $ fixContractJumps $ removeExtcalls contr+        checkTraceAndOutputs contrFixed gasLimit txData+      , after AllFinish "random-contract-concrete-call" $ test "calldata-wraparound-1" $ do+        let contract = OpContract $ concat+              [ [OpPush (Lit 0xff),OpPush (Lit 31),OpMstore8] -- value, offs+              , [OpPush (Lit 0x3),OpPush (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff),OpPush (Lit 0x0),OpCalldatacopy] -- size, offs, destOffs+              , [OpPush (Lit 0x20),OpPush (Lit 0),OpReturn] -- datasize, offs+              ]+        checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5])+      , after AllFinish "calldata-wraparound-1" $ test "calldata-wraparound-2" $ do+        let contract = OpContract $ concat+              [ [OpPush (Lit 0xff),OpPush (Lit 0),OpMstore8] -- value, offs+              , [OpPush (Lit 0x10),OpPush (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff),OpPush (Lit 0x0),OpCalldatacopy] -- size, offs, destOffs+              , [OpPush (Lit 0x20),OpPush (Lit 0),OpReturn] -- datasize, offs+              ]+        checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5])+      , after AllFinish "calldata-wraparound-2" $ test "calldata-overwrite-with-0-if-oversized" $ do+        -- supposed to copy 1...6 and then 0s, overwriting the 0xff with 0+        let contract = OpContract $ concat+              [ [OpPush (Lit 0xff),OpPush (Lit 1),OpMstore8] -- value, offs+              , [OpPush (Lit 10),OpPush (Lit 0),OpPush (Lit 0), OpCalldatacopy] -- size, offs, destOffs+              , [OpPush (Lit 10),OpPush (Lit 0x0),OpReturn] -- datasize, offset+              ]+        checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5, 6])+      , after AllFinish "calldata-overwrite-with-0-if-oversized" $ test "calldata-overwrite-correct-size" $ do+        let contract = OpContract $ concat+              [ [OpPush (Lit 0xff),OpPush (Lit 8),OpMstore8] -- value, offs+              , [OpPush (Lit 10),OpPush (Lit 0),OpPush (Lit 0), OpCalldatacopy] -- size, offs, destOffs+              , [OpPush (Lit 10),OpPush (Lit 0x0),OpReturn] -- datasize, offset+              ]+        checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5, 6])+      , after AllFinish "calldata-overwrite-correct-size" $ test "calldata-offset-copy" $ do+        let contract = OpContract $ concat+              [ [OpPush (Lit 0xff),OpPush (Lit 8),OpMstore8] -- value, offs+              , [OpPush (Lit 0xff),OpPush (Lit 1),OpMstore8] -- value, offs+              , [OpPush (Lit 10),OpPush (Lit 4),OpPush (Lit 0), OpCalldatacopy] -- size, offs, destOffs+              , [OpPush (Lit 10),OpPush (Lit 0x0),OpReturn] -- datasize, offset+              ]+        checkTraceAndOutputs contract 40000 (BS.pack [1, 2, 3, 4, 5, 6])+    ]++checkTraceAndOutputs :: App m => OpContract -> Int -> ByteString -> m ()+checkTraceAndOutputs contract gasLimit txData = do+  tmpDir <- liftIO getCanonicalTemporaryDirectory+  evmDir <- liftIO $ createTempDirectory tmpDir "evm-trace"+  evmtoolResult <- liftIO $ getEVMToolRet evmDir contract txData gasLimit+  hevmRun <- getHEVMRet contract txData gasLimit+  evmtoolTraceOutput <- fmap fromJust $ liftIO $ getTraceOutput evmDir evmtoolResult+  case hevmRun of+    (Right (expr, hevmTrace, hevmTraceResult)) -> liftIO $ do+      let+        concretize :: Expr a -> Expr Buf -> Expr a+        concretize a c = mapExpr go a+          where+            go :: Expr a -> Expr a+            go = \case+                       AbstractBuf "calldata" -> c+                       y -> y+        concretizedExpr = concretize expr (ConcreteBuf txData)+        simplConcExpr = Expr.simplify concretizedExpr+        getReturnVal :: Expr End -> Maybe ByteString+        getReturnVal (Success _ _ (ConcreteBuf bs) _) = Just bs+        getReturnVal _ = Nothing+        simplConcrExprRetval = getReturnVal simplConcExpr+      traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace)+      -- putStrLn $ "HEVM trace   : " <> show hevmTrace+      -- putStrLn $ "evmtool trace: " <> show (evmtoolTraceOutput.trace)+      assertEqual "Traces and gas must match" traceOK True+      let resultOK = evmtoolTraceOutput.output.output == hevmTraceResult.out+      if resultOK then liftIO $ do+        putStrLn $ "HEVM & evmtool's outputs match: '" <> (bsToHex $ bssToBs evmtoolTraceOutput.output.output) <> "'"+        if isNothing simplConcrExprRetval || (fromJust simplConcrExprRetval) == (bssToBs hevmTraceResult.out)+           then do+             putStr "OK, symbolic interpretation -> concrete calldata -> Expr.simplify gives the same answer."+             if isNothing simplConcrExprRetval then putStrLn ", but it was a Nothing, so not strong equivalence"+                                               else putStrLn ""+           else do+             putStrLn $ "original expr                    : " <> (show expr)+             putStrLn $ "concretized expr                 : " <> (show concretizedExpr)+             putStrLn $ "simplified concretized expr      : " <> (show simplConcExpr)+             putStrLn $ "evmtoolTraceOutput.output.output : " <> (show (evmtoolTraceOutput.output.output))+             putStrLn $ "HEVM trace result output         : " <> (bsToHex (bssToBs hevmTraceResult.out))+             putStrLn $ "ret value computed via symb+conc : " <> (bsToHex (fromJust simplConcrExprRetval))+             assertEqual "Simplified, concretized expression must match evmtool's output." True False+      else do+        putStrLn $ "Name of trace file: " <> (getTraceFileName evmDir $ fromJust evmtoolResult)+        putStrLn $ "HEVM result  :" <> (show hevmTraceResult)+        T.putStrLn $ "HEVM result: " <> (formatBinary $ bssToBs hevmTraceResult.out)+        T.putStrLn $ "evm result : " <> (formatBinary $ bssToBs evmtoolTraceOutput.output.output)+        putStrLn $ "HEVM result len: " <> (show (BS.length $ bssToBs hevmTraceResult.out))+        putStrLn $ "evm result  len: " <> (show (BS.length $ bssToBs evmtoolTraceOutput.output.output))+      assertEqual "Contract exec successful. HEVM & evmtool's outputs must match" resultOK True+    Left (evmerr, hevmTrace) -> liftIO $ do+      putStrLn $ "HEVM contract exec issue: " <> (show evmerr)+      -- putStrLn $ "evmtool result was: " <> show (fromJust evmtoolResult)+      -- putStrLn $ "output by evmtool is: '" <> bsToHex evmtoolTraceOutput.toOutput.output <> "'"+      traceOK <- compareTraces hevmTrace (evmtoolTraceOutput.trace)+      assertEqual "Traces and gas must match" traceOK True+  liftIO $ removeDirectoryRecursive evmDir++-- GasLimitInt+newtype GasLimitInt = GasLimitInt (Int)+  deriving (Show, Eq)++instance Arbitrary GasLimitInt where+  arbitrary = do+    let mkLimit = chooseInt (50000, 0xfffff)+    fmap GasLimitInt mkLimit++-- GenTxDataRaw+newtype TxDataRaw = TxDataRaw ([Int])+  deriving (Show, Eq)++instance Arbitrary TxDataRaw where+  arbitrary = do+    let+      txDataRaw = sized $ \n -> vectorOf (10*n+5) $ chooseInt (0,255)+    fmap TxDataRaw txDataRaw