hevm 0.57.0 → 0.58.0

raw patch · 41 files changed

+11157/−7460 lines, 41 filesdep +cryptondep +randomdep −cryptonitedep ~QuickCheckdep ~timedep ~vectorPVP ok

version bump matches the API change (PVP)

Dependencies added: crypton, random

Dependencies removed: cryptonite

Dependency ranges changed: QuickCheck, time, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +47/−0
• bench/bench-perf.hs +5/−31
• bench/bench.hs +3/−4
• cli/cli.hs +38/−41
• hevm.cabal +23/−13
• src/EVM.hs +695/−83
• src/EVM/ABI.hs +149/−40
• src/EVM/Assembler.hs +1/−0
• src/EVM/ConsoleLog.hs +189/−0
• src/EVM/Dapp.hs +49/−29
• src/EVM/Effects.hs +6/−0
• src/EVM/Exec.hs +1/−22
• src/EVM/Expr.hs +301/−35
• src/EVM/FeeSchedule.hs +2/−0
• src/EVM/Fetch.hs +75/−9
• src/EVM/Format.hs +17/−21
• src/EVM/Merge.hs +142/−0
• src/EVM/Op.hs +4/−0
• src/EVM/SMT.hs +74/−84
• src/EVM/SMT/SMTLIB.hs +39/−6
• src/EVM/SMT/Types.hs +5/−2
• src/EVM/Sign.hs +1/−1
• src/EVM/Solidity.hs +18/−30
• src/EVM/Solvers.hs +242/−163
• src/EVM/SymExec.hs +184/−119
• src/EVM/Transaction.hs +71/−10
• src/EVM/Traversals.hs +10/−5
• src/EVM/Types.hs +69/−1
• src/EVM/UnitTest.hs +76/−53
• test/EVM/ConcreteExecution/ConcreteExecutionTests.hs +198/−0
• test/EVM/Equivalence/EquivalenceTests.hs +566/−0
• test/EVM/Expr/ExprTests.hs +1621/−0
• test/EVM/Expr/Generator.hs +573/−0
• test/EVM/SymExec/SymExecTests.hs +1401/−0
• test/EVM/Test/BlockchainTests.hs +159/−74
• test/EVM/Test/FoundryTests.hs +181/−0
• test/EVM/Test/FuzzSymExec.hs +19/−54
• test/EVM/Test/Utils.hs +17/−17
• test/clitest.hs +34/−1
• test/rpc.hs +35/−30
• test/test.hs +3817/−6482

@@ -5,6 +5,53 @@ 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). +## [Unreleased]++## [0.58.0] - 2026-06-26++## Added+- RPC retry with exponential backoff and a shared cooldown across workers, so transient+  network errors and rate limits (e.g. HTTP 429) no longer abort symbolic execution+- Support for a subset of the [`expectRevert`](https://www.getfoundry.sh/reference/cheatcodes/expect-revert#expectrevert) family of foundry cheatcodes:+  - `expectRevert()`+  - `expectRevert(bytes)`+  - `expectRevert(bytes4)`+  - `expectRevert(address)`+  - `expectRevert(bytes4,address)`+  - `expectRevert(bytes,address)`+  - `expectPartialRevert(bytes4)`+  - `expectPartialRevert(bytes4,address)`+- Support for Foundry/Hardhat `console.log` — calls to the console address are intercepted and decoded in traces+- Source location info (file, line, code snippet) is now shown in state merge debug messages+- New opcode: CLZ+- New POr/PAnd/PImpl/Or/And simplification rules+- Support for `--early-abort` flag that aborts symbolic execution as soon as a counterexample is found+- Support for `vm.etch(address, bytecode)` cheatcode to set the code of a contract at a given address+- State merging via speculative execution of both branches of a JUMPI, joining the+  resulting states whenever possible. Amount of speculative execution is+  controlled via `merge-max-budget`+- Missing simplifications for Eq, Mod, SMod, XOR, SHL, SHR, and Or+- A few more simplification rules around Eq, SHL/SHR, Sub+Add combos, and Xor+- Symbolic execution now supports dynamic `bytes`/`string` calldata arguments,+  with their length bounded by `--max-dyn-size` (default 64). When such a bound+  is applied the result carries a program-wide `[CAVEAT]` noting that+  counterexamples requiring longer inputs may be missed (rather than a per-path+  `Partial`)+- `readWord` disjointness rule for `WriteWord (Add (Lit c) X) …` with bounded `X`.++## Changed+- Simplifier now rewrites `Mul(-1, x)` and `~x + 1` to `Sub(0, x)`+- `AbiFunction` and `AbiBytes` parser is now more strict+- We now check length of AbiArrayDynamic and don't crash in case it's too large+- SMT queries now run in separate processes, which allows us to better manage+  timeouts and memory usage by the SMT solver.+- We now allow limiting the SMT solver's memory usage via `--smt-memory` (in MB).+- The option `--smttimeout` is now called `--smt-timeout` for consistency with other+  options.+- We now abort VM run on a failed `assume`.+- Removed SHA256 from the Expr since it was not being used+- When doing CopySlice of exactly one concrete byte, we now correctly simplify+ ## [0.57.0] - 2026-01-08  ## Added

@@ -20,7 +20,6 @@ import EVM.UnitTest import Test.Tasty.Bench import Control.Monad.ST-import EVM.FeeSchedule (feeSchedule)  -- benchmark hevm using tasty-bench @@ -38,35 +37,10 @@ vm0 c = makeVm $ vm0Opts c  vm0Opts :: Contract -> VMOpts Concrete-vm0Opts c =-  VMOpts-    { contract = c,-      calldata = (ConcreteBuf "", []),-      value = Lit 0xfffffffffffff, -- balance-      baseState = EmptyBase,-      address = LitAddr 0xacab,-      caller = LitAddr 0,-      origin = LitAddr 0,-      gas = 0xffffffffffffffff,-      baseFee = 0,-      priorityFee = 0,-      gaslimit = 0xffffffffffffffff,-      coinbase = LitAddr 0,-      number = Lit 0,-      timestamp = Lit 0,-      blockGaslimit = 0xffffffffffffffff,-      gasprice = 0,-      maxCodeSize = 0xffffffff,-      prevRandao = 0,-      schedule = feeSchedule,-      chainId = 1,-      create = False,-      txAccessList = mempty, -- TODO: support me soon-      allowFFI = False,-      otherContracts = [],-      freshAddresses = 0,-      beaconRoot = 0-    }+vm0Opts c = defaultVMOpts+  { contract = c,+    value = Lit 0xfffffffffffff -- balance+  }  vmOptsToTestVMParams :: VMOpts Concrete -> TestVMParams vmOptsToTestVMParams v =@@ -98,7 +72,7 @@ callMainForBytecode :: App m => ByteString -> m (Either EvmError (Expr 'Buf)) callMainForBytecode bs = do   vm <- vmFromRawByteString bs-  Stepper.interpret (Fetch.zero 0 Nothing) vm (Stepper.evm (abiCall (vmOptsToTestVMParams (vm0Opts (initialContract (RuntimeCode (ConcreteRuntimeCode bs))))) (Left ("main()", emptyAbi))) >> Stepper.execFully)+  Stepper.interpret (Fetch.zero 0 Nothing 1024) vm (Stepper.evm (abiCall (vmOptsToTestVMParams (vm0Opts (initialContract (RuntimeCode (ConcreteRuntimeCode bs))))) (Left ("main()", emptyAbi))) >> Stepper.execFully)  benchMain :: (String, ByteString) -> Benchmark benchMain (name, bs) = bench name $ nfIO $ runApp $ (\x -> if isRight x then () else internalError "failed") <$> callMainForBytecode bs

@@ -43,9 +43,8 @@   tests <- ts   putStrLn "    executing blockchain tests"   let cases = concat . Map.elems . (fmap Map.toList) $ tests-      ignored = Map.keys BCTests.problematicTests   foldM (\acc (n, c) ->-      if n `elem` ignored+      if isJust (BCTests.findIgnoreReason n)       then pure True       else do         res <- runApp $ runBCTest c@@ -57,7 +56,7 @@ runBCTest x =  do   vm0 <- liftIO $ BCTests.vmForCase x-  result <- Stepper.interpret (Fetch.zero 0 Nothing) vm0 Stepper.runFully+  result <- Stepper.interpret (Fetch.zero 0 Nothing 1024) vm0 Stepper.runFully   writeTrace vm0   pure $ isNothing $ BCTests.checkExpectation x result @@ -67,7 +66,7 @@  findPanics :: App m => Solver -> Natural -> Integer -> ByteString -> m () findPanics solver count iters c = do-  _ <- withSolvers solver count 1 Nothing $ \s -> do+  _ <- withSolvers solver count Nothing 1024 $ \s -> do     let opts = (defaultVeriOpts :: VeriOpts) { iterConf = defaultIterConf {maxIter = Just iters, askSmtIters = iters + 1 }}     checkAssert s allPanicCodes c Nothing [] opts   liftIO $ putStrLn "done"

@@ -39,12 +39,11 @@ import Text.Read (readMaybe) import JSONL (jsonlBuilder, jsonLine) -import EVM (initialContract, abstractContract, makeVm)+import EVM (initialContract, abstractContract, makeVm, defaultVMOpts) import EVM.ABI (Sig(..))-import EVM.Dapp (dappInfo, DappInfo, emptyDapp)+import EVM.Dapp (dappInfo, DappInfo, emptyDapp, TestMethodInfo(..)) import EVM.Expr qualified as Expr import EVM.Concrete qualified as Concrete-import EVM.FeeSchedule (feeSchedule) import EVM.Fetch qualified as Fetch import EVM.Format (hexByteString, strip0x, formatExpr, indent) import EVM.Solidity@@ -88,9 +87,9 @@   , verb          ::Int   , root          ::Maybe String   , assertionType ::AssertionType-  , solverThreads ::Natural-  , smttimeout    ::Natural-  , smtdebug      ::Bool+  , smtTimeout    ::Natural+  , smtMemory     ::Natural+  , smtDebug      ::Bool   , dumpUnsolved  ::Maybe String   , numSolvers    ::Maybe Natural   , maxIterations ::Integer@@ -101,6 +100,9 @@   , noSimplify    ::Bool   , onlyDeployed  ::Bool   , cacheDir      ::Maybe String+  , earlyAbort    ::Bool+  , mergeMaxBudget :: Int+  , maxDynSize    ::Int   }  commonOptions :: Parser CommonOptions@@ -117,9 +119,9 @@   <*> (option auto $ long "verb"            <> showDefault <> value 1 <> help "Append call trace: {1} failures {2} all")   <*> (optional $ strOption $ long "root"   <> help "Path to  project root directory")   <*> (option auto $ long "assertion-type"  <> showDefault <> value Forge <> help "Assertions as per Forge or DSTest")-  <*> (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")+  <*> (option auto $ long "smt-timeout"     <> value 300 <> help "Timeout given to SMT solver in seconds. Not available on Windows")+  <*> (option auto $ long "smt-memory"      <> value defMemLimit <> help "Maximum memory limit for SMT solver in MB. Only available on Linux")+  <*> (switch $ long "smt-debug"            <> 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 "max-iterations"  <> showDefault <> value 5 <> help "Number of times we may revisit a particular branching point. For no bound, set -1")@@ -130,6 +132,9 @@   <*> (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")   <*> (optional $ strOption $ long "cache-dir" <> help "Directory to save and load RPC cache")+  <*> (switch $  long "early-abort" <> help "Stop exploration immediately upon finding the first counterexample")+  <*> (option auto $ long "merge-max-budget" <> showDefault <> value 100 <> help "Max instructions for speculative merge exploration during path merging")+  <*> (option auto $ long "max-dyn-size" <> showDefault <> value 64 <> help "Max byte length for concretized dynamic types (bytes, string) in symbolic arguments")  data CommonExecOptions = CommonExecOptions   { address       ::Maybe Addr@@ -188,8 +193,8 @@   , rpc           ::Maybe URL   , number        ::Maybe W256   , coverage      ::Bool-  , match         ::Maybe String-  , prefix        ::String+  , match         ::Maybe Text+  , prefix        ::Text   , ffi           ::Bool   } @@ -330,7 +335,7 @@       solver <- getSolver cOpts.solver       cores <- liftIO $ unsafeInto <$> getNumProcessors       let solverCount = fromMaybe cores cOpts.numSolvers-      runEnv env $ withSolvers solver solverCount cOpts.solverThreads (Just cOpts.smttimeout) $ \solvers -> do+      runEnv env $ withSolvers solver solverCount (Just cOpts.smtTimeout) cOpts.smtMemory $ \solvers -> do         buildOut <- readBuildOutput root testOpts.projectType         case buildOut of           Left e -> liftIO $ do@@ -358,7 +363,7 @@         putStrLn "Error: maxBufSize must be at least 0. Negative values do not make sense. A value of zero means at most 1 byte long buffers"         exitFailure       pure Env { config = defaultConfig-        { dumpQueries = cOpts.smtdebug+        { dumpQueries = cOpts.smtDebug         , dumpUnsolved = cOpts.dumpUnsolved         , debug = cOpts.debug         , dumpEndStates = cOpts.debug@@ -372,6 +377,9 @@         , verb = cOpts.verb         , simp = Prelude.not cOpts.noSimplify         , onlyDeployed = cOpts.onlyDeployed+        , earlyAbort = cOpts.earlyAbort+        , mergeMaxBudget = cOpts.mergeMaxBudget+        , maxDynSize = cOpts.maxDynSize         } }  @@ -411,11 +419,11 @@                             , loopHeuristic = cOpts.loopDetectionHeuristic                             }                           }-  calldata <- buildCalldata cOpts eqOpts.sig eqOpts.arg+  (calldata, _caveats) <- buildCalldata cOpts eqOpts.sig eqOpts.arg   solver <- liftIO $ getSolver cOpts.solver   cores <- liftIO $ unsafeInto <$> getNumProcessors   let solverCount = fromMaybe cores cOpts.numSolvers-  withSolvers solver solverCount cOpts.solverThreads (Just cOpts.smttimeout) $ \s -> do+  withSolvers solver solverCount (Just cOpts.smtTimeout) cOpts.smtMemory $ \s -> do     sess <- Fetch.mkSession cOpts.cacheDir Nothing     eq <- equivalenceCheck s (Just sess) (fromJust bytecodeA) (fromJust bytecodeB) veriOpts calldata eqOpts.create     let anyIssues =  not (null eq.partials) || any (isUnknown . fst) eq.res  || any (isError . fst) eq.res@@ -423,7 +431,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 Nothing eq.partials (map fst eq.res) "the contracts under test"+    liftIO $ printWarnings Nothing mempty eq.partials (map fst eq.res) "the contracts under test"     case any (isCex . fst) eq.res of       False -> liftIO $ do         when anyIssues exitFailure@@ -472,8 +480,9 @@ parseMaxIters :: Integer -> Maybe Integer parseMaxIters num = if num < 0 then Nothing else Just num --- | Builds a buffer representing calldata based on the given cli arguments-buildCalldata :: App m => CommonOptions -> Maybe Text -> [String] -> m (Expr Buf, [Prop])+-- | Builds a buffer representing calldata based on the given cli arguments,+-- together with any program-wide soundness caveats incurred (see 'Caveat').+buildCalldata :: App m => CommonOptions -> Maybe Text -> [String] -> m ((Expr Buf, [Prop]), [Caveat]) buildCalldata cOpts sig arg = case (cOpts.calldata, sig) of   -- fully abstract calldata   (Nothing, Nothing) -> mkCalldata Nothing []@@ -483,7 +492,7 @@     if (isNothing val) then liftIO $ do       putStrLn $ "Error, invalid calldata: " <>  show c       exitFailure-    else pure (ConcreteBuf (fromJust val), [])+    else pure ((ConcreteBuf (fromJust val), []), [])   -- calldata according to given abi with possible specializations from the `arg` list   (Nothing, Just sig') -> do     method' <- liftIO $ functionAbi sig'@@ -500,7 +509,7 @@   let block' = maybe Fetch.Latest Fetch.BlockNumber cExecOpts.block       blockUrlInfo = (,) block' <$> cExecOpts.rpc   sess <- Fetch.mkSession cOpts.cacheDir cExecOpts.block-  calldata <- buildCalldata cOpts sOpts.sig sOpts.arg+  (calldata, caveats) <- buildCalldata cOpts sOpts.sig sOpts.arg   preState <- symvmFromCommand cExecOpts sOpts cFileOpts sess calldata   errCodes <- case sOpts.assertions of     Nothing -> pure defaultPanicCodes@@ -513,7 +522,7 @@   cores <- liftIO $ unsafeInto <$> getNumProcessors   let solverCount = fromMaybe cores cOpts.numSolvers   solver <- liftIO $ getSolver cOpts.solver-  withSolvers solver solverCount cOpts.solverThreads (Just cOpts.smttimeout) $ \solvers -> do+  withSolvers solver solverCount (Just cOpts.smtTimeout) cOpts.smtMemory $ \solvers -> do     let veriOpts = VeriOpts { iterConf = IterConfig {                               maxIter = parseMaxIters cOpts.maxIterations                               , askSmtIters = cOpts.askSmtIterations@@ -529,6 +538,7 @@     case res of       [] -> do         liftIO $ putStrLn "\nQED: No reachable property violations discovered\n"+        liftIO $ printCaveats caveats         showExtras solvers sOpts calldata expr       _ -> do         let cexs = snd <$> mapMaybe getCex res@@ -540,7 +550,8 @@                  , ""                  ] <> fmap (formatCex (fst calldata) Nothing) cexs         liftIO $ T.putStrLn $ T.unlines counterexamples-        liftIO $ printWarnings Nothing expr res "symbolically"+        liftIO $ printWarnings Nothing mempty expr res "symbolically"+        liftIO $ printCaveats caveats         showExtras solvers sOpts calldata expr         liftIO exitFailure @@ -581,7 +592,7 @@     rpcDat :: Fetch.RpcInfo = Fetch.RpcInfo blockUrlInfo    -- TODO: we shouldn't need solvers to execute this code-  withSolvers Z3 0 1 Nothing $ \solvers -> do+  withSolvers Z3 0 Nothing cOpts.smtMemory $ \solvers -> do     let fetcher = Fetch.oracle solvers (Just sess) rpcDat     vm' <- if execOpts.jsonTrace            then do@@ -705,9 +716,8 @@                   then addr (.address) (Concrete.createAddress (fromJust $ maybeLitAddrSimp origin) (W64 $ word64 (.nonce) 0))                   else addr (.address) (LitAddr 0xacab) -        vm0 baseFee miner ts blockNum prevRan c = makeVm $ VMOpts+        vm0 baseFee miner ts blockNum prevRan c = makeVm $ (defaultVMOpts @Concrete)           { contract       = c-          , otherContracts = []           , calldata       = (calldata, [])           , value          = Lit val           , address        = address@@ -724,14 +734,8 @@           , gasprice       = word (.gasprice) 0           , maxCodeSize    = word (.maxcodesize) 0xffffffff           , prevRandao     = word (.prevRandao) prevRan-          , schedule       = feeSchedule           , chainId        = word (.chainid) 1           , create         = (.create) execOpts-          , baseState      = EmptyBase-          , txAccessList   = mempty -- TODO: support me soon-          , allowFFI       = False-          , freshAddresses = 0-          , beaconRoot     = 0           }         word f def = fromMaybe def (f cExecOpts)         word64 f def = fromMaybe def (f cExecOpts)@@ -811,7 +815,7 @@     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+    vm0 baseFee miner ts blockNum prevRan cd callvalue caller c baseState = makeVm $ defaultVMOpts       { contract       = c       , otherContracts = [(originAddr, originContr)]       , calldata       = cd@@ -819,7 +823,6 @@       , address        = address       , caller         = caller       , origin         = origin-      , gas            = ()       , gaslimit       = word64 (.gaslimit) 0xffffffffffffffff       , baseFee        = baseFee       , priorityFee    = word (.priorityFee) 0@@ -830,14 +833,9 @@       , gasprice       = word (.gasprice) 0       , maxCodeSize    = word (.maxcodesize) 0xffffffff       , prevRandao     = word (.prevRandao) prevRan-      , schedule       = feeSchedule       , chainId        = word (.chainid) 1       , create         = (.create) sOpts       , baseState      = baseState-      , txAccessList   = mempty-      , allowFFI       = False-      , freshAddresses = 0-      , beaconRoot     = 0       }     word f def = fromMaybe def (f cExecOpts)     word64 f def = fromMaybe def (f cExecOpts)@@ -868,9 +866,8 @@                 in rpcDat { Fetch.blockNumURL = i }     , maxIter = parseMaxIters cOpts.maxIterations     , askSmtIters = cOpts.askSmtIterations-    , smtTimeout = Just cOpts.smttimeout-    , match = T.pack $ fromMaybe ".*" testOpts.match-    , prefix = T.pack testOpts.prefix+    , smtTimeout = Just cOpts.smtTimeout+    , methodFilter = \(TestMethodInfo _ (Sig name _)) -> testOpts.prefix `T.isPrefixOf` name && maybe True (\match -> regexMatches match name) testOpts.match     , testParams = params     , dapp = srcInfo     , ffiAllowed = testOpts.ffi

@@ -2,7 +2,7 @@ name:   hevm version:-  0.57.0+  0.58.0 synopsis:   Symbolic EVM Evaluator description:@@ -101,6 +101,7 @@     EVM.Solvers,     EVM.Exec,     EVM.Format,+    EVM.ConsoleLog,     EVM.Fetch,     EVM.FeeSchedule,     EVM.Op,@@ -113,6 +114,7 @@     EVM.Traversals,     EVM.CSE,     EVM.Keccak,+    EVM.Merge,     EVM.Transaction,     EVM.Types,     EVM.UnitTest,@@ -161,7 +163,7 @@     mtl                               >= 2.2 && < 2.4,     filepath                          >= 1.4.2 && < 1.6,     cereal                            >= 0.5.8 && < 0.6,-    cryptonite                        >= 0.30 && < 0.31,+    crypton                           >= 0.32 && < 1.1,     memory                            >= 0.16.0 && < 0.20,     data-dword                        >= 0.3.1 && < 0.4,     process                           >= 1.6.5 && < 1.7,@@ -175,8 +177,10 @@     pretty-hex                        >= 1.1 && < 1.2,     rosezipper                        >= 0.2 && < 0.3,     wreq                              >= 0.5.3 && < 0.6,+    random                            >= 1.2 && < 1.3,     regex-tdfa                        >= 1.2.3 && < 1.4,     base                              >= 4.9 && < 5,+    time                              >= 1.9 && < 1.15,     smt2-parser                       >= 0.1.0 && < 0.2,     spool                             >= 0.1 && < 0.2,     stm                               >= 2.5.0 && < 2.6.0,@@ -199,7 +203,7 @@     cli   main-is:     cli.hs-  ghc-options: -threaded -with-rtsopts=-N+  ghc-options: -threaded "-with-rtsopts=-N -A32m"   other-modules:     Paths_hevm   autogen-modules:@@ -234,8 +238,6 @@   autogen-modules:     Paths_hevm   build-depends:-    QuickCheck,-    quickcheck-instances,     aeson,     base,     containers,@@ -248,11 +250,9 @@     process,     tasty,     tasty-hunit,-    tasty-quickcheck,     tasty-expected-failure,     temporary,     text,-    vector,     witherable,     optics-core,     witch,@@ -264,19 +264,18 @@   default-language: GHC2021   exposed-modules:     EVM.Test.Utils-    EVM.Test.FuzzSymExec     EVM.Test.BlockchainTests  common test-common   import: test-base   default-language: GHC2021   if flag(devel)-    ghc-options: -threaded -with-rtsopts=-N+    ghc-options: -threaded "-with-rtsopts=-N -A32m"   build-depends:-    test-utils+    test-utils,+    vector,   other-modules:     EVM.Test.Utils-    EVM.Test.FuzzSymExec     EVM.Test.BlockchainTests  --- Test Suites ---@@ -288,6 +287,14 @@     exitcode-stdio-1.0   main-is:     test.hs+  other-modules:+    EVM.Equivalence.EquivalenceTests+    EVM.Expr.ExprTests+    EVM.Expr.Generator+    EVM.ConcreteExecution.ConcreteExecutionTests+    EVM.SymExec.SymExecTests+    EVM.Test.FuzzSymExec+    EVM.Test.FoundryTests   build-depends:     base16,     binary,@@ -296,7 +303,10 @@     here,     time,     optics-extra,-    regex+    QuickCheck,+    quickcheck-instances,+    regex,+    tasty-quickcheck,  -- these tests require network access so we split them into a separate test -- suite to make it easy to skip them when running nix-build@@ -374,7 +384,7 @@   hs-source-dirs:     bench   ghc-options:-    -O2 -threaded -with-rtsopts=-N -fproc-alignment=64+    -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A32m" -fproc-alignment=64   other-modules:     Paths_hevm   autogen-modules:

@@ -15,6 +15,8 @@   writeByte, bufLength, indexWord, readBytes, copySlice, wordToAddr, maybeLitByteSimp, maybeLitWordSimp, maybeLitAddrSimp) import EVM.Expr qualified as Expr import EVM.FeeSchedule (FeeSchedule (..))+import EVM.FeeSchedule qualified as Fees (feeSchedule)+import EVM.Merge qualified as Merge import EVM.Op import EVM.Precompiled qualified import EVM.Solidity@@ -58,7 +60,7 @@ import Data.Vector.Storable qualified as VS import Data.Vector.Storable.Mutable qualified as VS.Mutable import Data.Vector.Storable.ByteString (vectorToByteString, byteStringToVector)-import Data.Word (Word8, Word32, Word64)+import Data.Word (Word8, Word64) import Text.Read (readMaybe) import Witch (into, tryFrom, unsafeInto, tryInto) @@ -66,6 +68,38 @@ import Crypto.Hash qualified as Crypto import Crypto.Number.ModArithmetic (expFast) +defaultVMOpts :: VMOps t => VMOpts t+defaultVMOpts = VMOpts+  { contract       = emptyContract+  , otherContracts = []+  , calldata       = mempty+  , value          = Lit 0+  , address        = LitAddr 0xacab+  , caller         = LitAddr 0+  , origin         = LitAddr 0+  , gas            = toGas maxBound+  , gaslimit       = maxBound+  , baseFee        = 0+  , priorityFee    = 0+  , coinbase       = LitAddr 0+  , number         = Lit 0+  , timestamp      = Lit 0+  , blockGaslimit  = maxBound+  , gasprice       = 0+  , maxCodeSize    = 0xffffffff+  , prevRandao     = 0+  , schedule       = Fees.feeSchedule+  , chainId        = 1+  , create         = False+  , baseState      = EmptyBase+  , txAccessList   = mempty+  , allowFFI       = False+  , freshAddresses = 0+  , beaconRoot     = 0+  , parentHash     = 0+  , txdataFloorGas = Fees.feeSchedule.g_transaction+  }+ blankState :: VMOps t => ST RealWorld (FrameState t) blankState = do   memory <- ConcreteMemory <$> VS.Mutable.new 0@@ -116,7 +150,7 @@       initialAccessedStorageKeys = fromList $ foldMap (uncurry (map . (,))) (Map.toList txaccessList)       touched = if o.create then [txorigin] else [txorigin, txtoAddr]   memory <- ConcreteMemory <$> VS.Mutable.new 0-  pure $ setEIP4788Storage o $ VM+  pure $ setEIP2935Storage o $ setEIP4788Storage o $ VM     { result = Nothing     , frames = mempty     , tx = TxState@@ -129,6 +163,7 @@       , subState = SubState mempty touched initialAccessedAddrs initialAccessedStorageKeys mempty mempty       , isCreate = o.create       , txReversion = Map.fromList ((o.address,o.contract):o.otherContracts)+      , txdataFloorGas = o.txdataFloorGas       }     , logs = []     , traces = Zipper.fromForest []@@ -160,12 +195,15 @@       }     , forks = Seq.singleton (ForkState env block mempty "")     , currentFork = 0+    , srcLookup = Nothing     , labels = mempty     , osEnv = mempty     , freshVar = 0     , exploreDepth = 0     , keccakPreImgs = fromList []     , pathsVisited = mempty+    , mergeState = defaultMergeState+    , expectedRevert = Nothing     }     where     env = Env@@ -214,6 +252,25 @@       }     Nothing -> vm +-- https://eips.ethereum.org/EIPS/eip-2935+setEIP2935Storage :: VMOpts t -> VM t -> VM t+setEIP2935Storage o vm = do+  let historyStorageAddress = LitAddr 0x0000F90827F1C53a10cb7A02335B175320002935+  case Map.lookup historyStorageAddress vm.env.contracts of+    Just historyContract -> do+      let+        historyBufferLength = 8191+        slotIdx = Expr.mod (Expr.sub o.number (Lit 1)) (Lit historyBufferLength)+        storage = Expr.writeStorage slotIdx (Lit o.parentHash) historyContract.storage+      vm {+        env = vm.env {+          contracts = Map.insert historyStorageAddress+                                 (historyContract { storage } :: Contract)+                                 vm.env.contracts+        }+      }+    Nothing -> vm+ -- | Initialize an abstract contract with unknown code unknownContract :: Expr EAddr -> Contract unknownContract addr = Contract@@ -301,7 +358,7 @@     doStop = finishFrame (FrameReturned mempty)     litSelf = maybeLitAddrSimp self -  if isJust litSelf && (fromJust litSelf) > 0x0 && (fromJust litSelf) <= 0xa then do+  if isJust litSelf && isPrecompileAddr' (fromJust litSelf) then do     -- call to precompile     let ?op = 0x00 -- dummy value     let calldatasize = bufLength vm.state.calldata@@ -361,16 +418,13 @@                   pushSym y          OpSwap i -> {-# SCC "OpSwap" #-}-          case (stk ^? ix_i, stk ^? ix_0) of-            (Just ei, Just e0) ->-              burn g_verylow $ do-                next-                zoom (#state % #stack) $ do-                  ix_i .= e0-                  ix_0 .= ei-            _ -> underrun-          where-            (ix_i, ix_0) = (ix (into i), ix 0)+          let idx = into i in+          case splitAt idx stk of+          (e0:middle, ei:after) ->+            burn g_verylow $ do+              next+              assign' (#state % #stack) $ ei : middle ++ (e0 : after)+          _ -> underrun          OpLog n -> {-# SCC "OpLog" #-}           notStatic $@@ -425,6 +479,7 @@         OpShl -> {-# SCC "OpShl" #-} stackOp2 g_verylow Expr.shl         OpShr -> {-# SCC "OpShr" #-} stackOp2 g_verylow Expr.shr         OpSar -> {-# SCC "OpSar" #-} stackOp2 g_verylow Expr.sar+        OpClz -> {-# SCC "OpClz" #-} stackOp1 g_low Expr.clz          -- more accurately referred to as KECCAK         OpSha3 -> {-# SCC "OpSha3" #-}@@ -473,7 +528,11 @@             next >> pushSym vm.state.callvalue          OpCalldataload -> {-# SCC "OpCalldataload" #-} stackOp1 g_verylow $-          \ind -> Expr.readWord ind vm.state.calldata+        -- Reading past call data length should always return 0. We force this in the concrete case.+        -- However, symbolic mode relies on `Expr.readWord` which has wrap-around semantics+          \ind -> case (ind, vm.state.calldata) of+            (Lit i, ConcreteBuf bs) | i > (fromIntegral $ BS.length bs) -> Lit 0+            _ -> Expr.readWord ind vm.state.calldata          OpCalldatasize -> {-# SCC "OpCalldatasize" #-}           limitStack 1 . burn g_base $@@ -520,7 +579,7 @@                                Just b -> pushSym (bufLength b)                                Nothing -> pushSym $ CodeSize x               case x of-                a@(LitAddr _) -> if a == cheatCode+                a@(LitAddr _) -> if a == cheatCode || a == consoleAddr                   then do                     next                     assign' (#state % #stack) xs@@ -651,14 +710,14 @@                 accessMemoryWord x $ do                   next                   buf <- readMemory x (Lit 32)-                  let w = Expr.readWordFromBytes (Lit 0) buf+                  let w = Expr.readWord (Lit 0) buf                   assign' (#state % #stack) (w : xs)             _ -> underrun           OpMcopy -> {-# SCC "OpMcopy" #-}           case stk of-            dstOff:srcOff:sz:xs ->  do+            dstOff:srcOff:sz:xs ->               case sz of                 Lit sz' -> do                   let words_copied = (sz' + 31) `div` 32@@ -666,14 +725,16 @@                   burn (g_verylow + (unsafeInto g_mcopy)) $                     accessMemoryRange srcOff sz $ accessMemoryRange dstOff sz $ do                       next+                      assign' (#state % #stack) xs                       mcopy sz srcOff dstOff                 _ -> do                   -- symbolic, ignore gas                   next+                  assign' (#state % #stack) xs                   mcopy sz srcOff dstOff-              assign' (#state % #stack) xs             _ -> underrun             where+            mcopy (Lit 0) _ _ = pure ()             mcopy sz srcOff dstOff = do                   m <- gets (.state.memory)                   case m of@@ -813,14 +874,39 @@          OpJumpi -> {-# SCC "OpJumpi" #-}           case stk of-            x:y:xs -> forceConcreteLimitSz x 2 "JUMPI: symbolic jumpdest" $ \x' ->+            x:cond:xs -> forceConcreteLimitSz x 2 "JUMPI: symbolic jumpdest" $ \maybeTarget ->               burn g_high $                 let jump :: Bool -> EVM t ()                     jump False = assign' (#state % #stack) xs >> next-                    jump _    = case tryInto x' of+                    jump _    = case tryInto maybeTarget of                       Left _ -> vmError BadJumpDestination-                      Right i -> checkJump i xs-                in branch conf.maxDepth y jump+                      Right jumpTarget -> checkJump jumpTarget xs+                    -- For Symbolic execution, try forward-jump merge first+                    symbolicMerge :: EVM Symbolic ()+                    symbolicMerge = case tryInto maybeTarget of+                      Left _ ->+                        -- Invalid destination - but we only error if we try to jump+                        -- Use branch to decide based on condition+                        branch conf.maxDepth cond $ \case+                          False -> assign' (#state % #stack) xs >> next+                          True -> vmError BadJumpDestination+                      Right jumpTarget -> do+                        -- Check if we're already in merge mode (speculative execution)+                        ms <- use #mergeState+                        if ms.msActive then+                          -- Inside speculation: nested branch, bail out+                          -- This will cause speculateLoop to return Nothing+                          assign #result $ Just $ VMFailure BadJumpDestination+                        else do+                          merged <- Merge.tryMergeForwardJump conf (exec1 conf) vm.state.pc jumpTarget cond xs+                          unless merged $ do+                            let jumpSym :: Bool -> EVM Symbolic ()+                                jumpSym False = assign' (#state % #stack) xs >> next+                                jumpSym _    = checkJump jumpTarget xs+                            branch conf.maxDepth cond jumpSym+                in case eqT @t @Symbolic of+                     Just Refl -> symbolicMerge+                     Nothing -> branch conf.maxDepth cond jump             _ -> underrun          OpPc -> {-# SCC "OpPc" #-}@@ -984,7 +1070,7 @@                       touchAddress from'                        let (cost, gas') = costOfCreate fees availableGas xSize True-                      newAddr <- create2Address self xSalt initCode+                      newAddr <- create2Address from' xSalt initCode                       _ <- accessAccountForGas newAddr                       burn' cost $                         create from' this xSize gas' xValue xs newAddr (ConcreteBuf initCode)@@ -1046,6 +1132,10 @@             xOffset:xSize:_ ->               accessMemoryRange xOffset xSize $ do                 output <- readMemory xOffset xSize+                case vm.expectedRevert of+                  Just e | isNothing e.actualReverter ->+                    assign #expectedRevert (Just e { actualReverter = Just self })+                  _ -> pure ()                 finishFrame (FrameReverted output)             _ -> underrun @@ -1252,21 +1342,26 @@         forceConcreteBuf input "MODEXP" $ \input' -> do           let             (lenb, lene, lenm) = parseModexpLength input'--            output = ConcreteBuf $-              if isZero (96 + lenb + lene) lenm input'-              then truncpadlit (unsafeInto lenm) (asBE (0 :: Int))-              else-                let-                  b = asInteger $ lazySlice 96 lenb input'-                  e = asInteger $ lazySlice (96 + lenb) lene input'-                  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 % #returndata) output-          copyBytesToMemory output outSize (Lit 0) outOffset-          next+            -- EIP-7823: ModExp upper bounds - each input limited to 1024 bytes (8192 bits)+            modexpLimit = 1024 :: W256+          if lenb > modexpLimit || lene > modexpLimit || lenm > modexpLimit+          then precompileFail  -- EIP-7823: fail and consume all gas if limits exceeded+          else do+            let+              output = ConcreteBuf $+                if isZero (96 + lenb + lene) lenm input'+                then truncpadlit (unsafeInto lenm) (asBE (0 :: Int))+                else+                  let+                    b = asInteger $ lazySlice 96 lenb input'+                    e = asInteger $ lazySlice (96 + lenb) lene input'+                    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 % #returndata) output+            copyBytesToMemory output outSize (Lit 0) outOffset+            next        -- ECADD       0x6 ->@@ -1337,8 +1432,8 @@ parseModexpLength :: ByteString -> (W256, W256, W256) parseModexpLength input =   let lenb = word $ LS.toStrict $ lazySlice  0 32 input-      lene = word $ LS.toStrict $ lazySlice 32 64 input-      lenm = word $ LS.toStrict $ lazySlice 64 96 input+      lene = word $ LS.toStrict $ lazySlice 32 32 input+      lenm = word $ LS.toStrict $ lazySlice 64 32 input   in (lenb, lene, lenm)  --- checks if a range of ByteString bs starting at offset and length size is all zeros.@@ -1523,8 +1618,20 @@       -- deposit the code from a creation tx       creation <- use (#tx % #isCreate)       createe  <- use (#state % #contract)-      createeExists <- (Map.member createe) <$> use (#env % #contracts)-      when (creation && createeExists) $+      createeContract <- preuse (#env % #contracts % ix createe)+      -- Check if this is a collision case (target has RuntimeCode instead of InitCode)+      let isCollision = creation && case createeContract of+            Just c -> case c.code of+              InitCode _ _ -> False+              RuntimeCode _ -> True   -- collision: existing contract has RuntimeCode+              UnknownCode _ -> internalError "cannot determine collision with unknown code"+            Nothing -> internalError "create transaction but no code found"+      -- For collision: burn all gas (failed CREATE consumes all gas)+      when isCollision $ assign (#state % #gas) initialGas+      -- Only replace code if this is a creation tx, the contract exists,+      -- and it has InitCode (not RuntimeCode from a collision)+      let shouldReplaceCode = creation && not isCollision+      when shouldReplaceCode $         case output of           ConcreteBuf bs -> replaceCode createe (RuntimeCode (ConcreteRuntimeCode bs))           _ ->@@ -1756,6 +1863,11 @@ cheatCode :: Expr EAddr cheatCode = LitAddr $ unsafeInto (keccak' "hevm cheat code") +-- | The address used by Foundry/Hardhat console.log+-- 0x000000000000000000636F6e736F6c652e6c6f67 (ASCII "console.log")+consoleAddr :: Expr EAddr+consoleAddr = LitAddr 0x000000000000000000636F6e736F6c652e6c6f67+ cheat   :: forall t . (?conf :: Config, ?op :: Word8, VMOps t, Typeable t)   => Gas t -> (Expr EWord, Expr EWord) -> (Expr EWord, Expr EWord) -> [Expr EWord]@@ -1833,8 +1945,10 @@   , action "assume(bool)" $       \sig input -> case decodeStaticArgs 0 1 input of         [c] -> do-          modifying #constraints ((:) (PEq (Lit 1) c))-          doStop+          whenSymbolicElse (modifying #constraints ((:) (PEq (Lit 1) c)) >> doStop) $ do+            case c of+              Lit v -> if (v == 0) then (terminateVMWithError AssumeCheatFailed) else doStop+              _ -> internalError "Symbolic value encountered in concrete mode"         _ -> vmError (BadCheatCode "assume(bool) parameter decoding failed." sig)    , action "roll(uint256)" $@@ -1977,6 +2091,58 @@           _ -> vmError (BadCheatCode "setEnv(string,string) address decoding failed" sig)         _ -> vmError (BadCheatCode "setEnv(string,string) parameter decoding failed" sig) +  , action "etch(address,bytes)" $+      \sig input ->  case decodeBuf [AbiAddressType, AbiBytesDynamicType] input of+        (CAbi [AbiAddress addr, AbiBytesDynamic bytes],"") -> fetchAccount (LitAddr addr) $ \_ -> do+            replaceCodeEtch (LitAddr addr) (RuntimeCode (ConcreteRuntimeCode bytes))+            doStop+        _ -> vmError (BadCheatCode "etch(address,bytes) address decoding failed" sig)++  , action "expectRevert()" $+      \_ _ -> setExpectedRevert Nothing False Nothing++  , action "expectRevert(bytes)" $+      \sig input -> case decodeBuf [AbiBytesDynamicType] input of+        (CAbi [AbiBytesDynamic bs],"") ->+          setExpectedRevert (Just (ConcreteBuf bs)) False Nothing+        _ -> vmError (BadCheatCode "expectRevert(bytes) parameter decoding failed" sig)++  , action "expectRevert(bytes4)" $+      \sig input -> case decodeBuf [AbiBytesType 4] input of+        (CAbi [AbiBytes 4 bs],"") ->+          setExpectedRevert (Just (ConcreteBuf bs)) False Nothing+        _ -> vmError (BadCheatCode "expectRevert(bytes4) parameter decoding failed" sig)++  , action "expectRevert(address)" $+      \sig input -> case decodeBuf [AbiAddressType] input of+        (CAbi [AbiAddress addr],"") ->+          setExpectedRevert Nothing False (Just (LitAddr addr))+        _ -> vmError (BadCheatCode "expectRevert(address) parameter decoding failed" sig)++  , action "expectRevert(bytes4,address)" $+      \sig input -> case decodeBuf [AbiBytesType 4, AbiAddressType] input of+        (CAbi [AbiBytes 4 bs, AbiAddress addr],"") ->+          setExpectedRevert (Just (ConcreteBuf bs)) False (Just (LitAddr addr))+        _ -> vmError (BadCheatCode "expectRevert(bytes4,address) parameter decoding failed" sig)++  , action "expectRevert(bytes,address)" $+      \sig input -> case decodeBuf [AbiBytesDynamicType, AbiAddressType] input of+        (CAbi [AbiBytesDynamic bs, AbiAddress addr],"") ->+          setExpectedRevert (Just (ConcreteBuf bs)) False (Just (LitAddr addr))+        _ -> vmError (BadCheatCode "expectRevert(bytes,address) parameter decoding failed" sig)++  , action "expectPartialRevert(bytes4)" $+      \sig input -> case decodeBuf [AbiBytesType 4] input of+        (CAbi [AbiBytes 4 bs],"") ->+          setExpectedRevert (Just (ConcreteBuf bs)) True Nothing+        _ -> vmError (BadCheatCode "expectPartialRevert(bytes4) parameter decoding failed" sig)++  , action "expectPartialRevert(bytes4,address)" $+      \sig input -> case decodeBuf [AbiBytesType 4, AbiAddressType] input of+        (CAbi [AbiBytes 4 bs, AbiAddress addr],"") ->+          setExpectedRevert (Just (ConcreteBuf bs)) True (Just (LitAddr addr))+        _ -> vmError (BadCheatCode "expectPartialRevert(bytes4,address) parameter decoding failed" sig)+   -- Single-value environment read cheat actions   , $(envReadSingleCheat "envBool(string)") AbiBool stringToBool   , $(envReadSingleCheat "envUint(string)") (AbiUInt 256) stringToWord256@@ -2022,6 +2188,7 @@   , action "assertEq(address,address)" $ assertEq AbiAddressType   , action "assertEq(bytes32,bytes32)" $ assertEq (AbiBytesType 32)   , action "assertEq(string,string)"   $ assertEq (AbiStringType)+  , action "assertEq(bytes,bytes)"     $ assertEq AbiBytesDynamicType   --   , action "assertNotEq(bool,bool)"       $ assertNotEq AbiBoolType   , action "assertNotEq(uint256,uint256)" $ assertNotEq (AbiUIntType 256)@@ -2029,6 +2196,7 @@   , action "assertNotEq(address,address)" $ assertNotEq AbiAddressType   , action "assertNotEq(bytes32,bytes32)" $ assertNotEq (AbiBytesType 32)   , action "assertNotEq(string,string)"   $ assertNotEq (AbiStringType)+  , action "assertNotEq(bytes,bytes)"      $ assertNotEq AbiBytesDynamicType   --   , action "assertLt(uint256,uint256)" $ assertLt (AbiUIntType 256)   , action "assertLt(int256,int256)"   $ assertSLt (AbiIntType 256)@@ -2039,6 +2207,45 @@   , action "assertGe(uint256,uint256)" $ assertGe (AbiUIntType 256)   , action "assertGe(int256,int256)"   $ assertSGe (AbiIntType 256)   --+  , action "assertApproxEqAbs(uint256,uint256,uint256)" $ assertApproxEqAbsUint+  , action "assertApproxEqAbs(int256,int256,uint256)"   $ assertApproxEqAbsInt+  --+  , action "assertApproxEqRel(uint256,uint256,uint256)" $ assertApproxEqRelUint+  , action "assertApproxEqRel(int256,int256,uint256)"   $ assertApproxEqRelInt+  --+  -- Variants with a trailing `err` string. The string is decoded away and never+  -- used; each behaves exactly like its non-message counterpart.+  , action "assertEq(bool,bool,string)"       $ withMsg 2 (assertEq AbiBoolType)+  , action "assertEq(uint256,uint256,string)" $ withMsg 2 (assertEq (AbiUIntType 256))+  , action "assertEq(int256,int256,string)"   $ withMsg 2 (assertEq (AbiIntType 256))+  , action "assertEq(address,address,string)" $ withMsg 2 (assertEq AbiAddressType)+  , action "assertEq(bytes32,bytes32,string)" $ withMsg 2 (assertEq (AbiBytesType 32))+  , action "assertEq(string,string,string)"   $ assertEqMsgDyn AbiStringType+  , action "assertEq(bytes,bytes,string)"      $ assertEqMsgDyn AbiBytesDynamicType+  --+  , action "assertNotEq(bool,bool,string)"       $ withMsg 2 (assertNotEq AbiBoolType)+  , action "assertNotEq(uint256,uint256,string)" $ withMsg 2 (assertNotEq (AbiUIntType 256))+  , action "assertNotEq(int256,int256,string)"   $ withMsg 2 (assertNotEq (AbiIntType 256))+  , action "assertNotEq(address,address,string)" $ withMsg 2 (assertNotEq AbiAddressType)+  , action "assertNotEq(bytes32,bytes32,string)" $ withMsg 2 (assertNotEq (AbiBytesType 32))+  , action "assertNotEq(string,string,string)"   $ assertNotEqMsgDyn AbiStringType+  , action "assertNotEq(bytes,bytes,string)"      $ assertNotEqMsgDyn AbiBytesDynamicType+  --+  , action "assertLt(uint256,uint256,string)" $ withMsg 2 (assertLt (AbiUIntType 256))+  , action "assertLt(int256,int256,string)"   $ withMsg 2 (assertSLt (AbiIntType 256))+  , action "assertLe(uint256,uint256,string)" $ withMsg 2 (assertLe (AbiUIntType 256))+  , action "assertLe(int256,int256,string)"   $ withMsg 2 (assertSLe (AbiIntType 256))+  , action "assertGt(uint256,uint256,string)" $ withMsg 2 (assertGt (AbiUIntType 256))+  , action "assertGt(int256,int256,string)"   $ withMsg 2 (assertSGt (AbiIntType 256))+  , action "assertGe(uint256,uint256,string)" $ withMsg 2 (assertGe (AbiUIntType 256))+  , action "assertGe(int256,int256,string)"   $ withMsg 2 (assertSGe (AbiIntType 256))+  --+  , action "assertApproxEqAbs(uint256,uint256,uint256,string)" $ withMsg 3 assertApproxEqAbsUint+  , action "assertApproxEqAbs(int256,int256,uint256,string)"   $ withMsg 3 assertApproxEqAbsInt+  --+  , action "assertApproxEqRel(uint256,uint256,uint256,string)" $ withMsg 3 assertApproxEqRelUint+  , action "assertApproxEqRel(int256,int256,uint256,string)"   $ withMsg 3 assertApproxEqRelInt+  --   , action "toString(address)" $ toStringCheat AbiAddressType   , action "toString(bool)"    $ toStringCheat AbiBoolType   , action "toString(uint256)" $ toStringCheat (AbiUIntType 256)@@ -2057,8 +2264,6 @@     frameReturnExpr e = finishFrame (FrameReturned e)     frameRevert :: VMOps t => ByteString -> EVM t ()     frameRevert err = finishFrame (FrameReverted $ errorMsg err)-    errorMsg :: ByteString -> Expr Buf-    errorMsg err = ConcreteBuf $ selector "Error(string)" <> encodeAbiValue (AbiTuple $ V.fromList [AbiString err])     continueOnce cont = do       assign #result Nothing       cont@@ -2088,17 +2293,47 @@       ")  parameter decoding failed. Error: " <> show abivals     revertErr a b comp = frameRevert $ "assertion failed: " <>       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+    -- 1e18 (100% in foundry's 18-decimal fixed point) as Integer and W256+    scale1e18 :: Integer+    scale1e18 = 10^(18::Int)+    scale1e18W :: W256+    scale1e18W = 10^(18::Int)+    -- largest absDelta with absDelta*1e18 < 2^256 (symbolic overflow guard)+    maxSafeRelDelta :: W256+    maxSafeRelDelta = (maxBound :: W256) `Prelude.div` scale1e18W+    -- shared rel-assertion failure message; realDelta is pre-rendered+    relFailMsg :: Show a => a -> a -> Word256 -> String -> ByteString+    relFailMsg a b maxPercentDelta realDelta = "assertion failed: " <>+      BS8.pack (show a) <> " !~= " <> BS8.pack (show b) <>+      " (max delta: " <> BS8.pack (show maxPercentDelta) <>+      ", real delta: " <> BS8.pack realDelta <> ")"+    genAssert = genAssertN []+    -- like genAssert but ignores `extra` trailing ABI args (the err-string+    -- overloads). Only used directly for string operands; static operands strip+    -- the err arg upstream via withMsg to keep the symbolic path.+    genAssertN extra comp exprComp invComp name abitype sig input = do+      case decodeBuf ([abitype, abitype] ++ extra) 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           Lit 0 -> doStop           Lit _ -> revertErr ew1 ew2 invComp           ew -> branch (?conf).maxDepth ew $ \case             False -> doStop             True -> revertErr ew1 ew2 invComp         abivals -> vmError (BadCheatCode (paramDecodeErr abitype name abivals) sig)+    -- keep the first n 32-byte head words, dropping the trailing err string so+    -- operand-only handlers decode normally (and keep SAbi for symbolic operands)+    keepHeadWords n input =+      foldr (\i acc -> let off = Lit (fromIntegral (i * 32 :: Int))+                       in writeWord off (readWord off input) acc)+            mempty [0 .. n - 1]+    -- Run a no-message handler after stripping the trailing `err` string.+    withMsg n handler sig input = handler sig (keepHeadWords n input)+    -- dynamic operands (string/bytes) can't be sliced: decode [op,op,string] and+    -- compare the first two concretely (no symbolic path), ignoring the err string+    assertEqMsgDyn    op = genAssertN [AbiStringType] (==) Expr.eq "!=" "assertEq" op+    assertNotEqMsgDyn op = genAssertN [AbiStringType] (/=) (\a b -> Expr.iszero $ Expr.eq a b) "==" "assertNotEq" op     assertEq =    genAssert (==) Expr.eq "!=" "assertEq"     assertNotEq = genAssert (/=) (\a b -> Expr.iszero $ Expr.eq a b) "==" "assertNotEq"     assertLt =    genAssert (<)  Expr.lt ">=" "assertLt"@@ -2109,11 +2344,250 @@     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"+    -- | assertApproxEqAbs for uint256: passes when |left - right| <= maxDelta+    assertApproxEqAbsUint sig input = do+      case decodeBuf [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256] input of+        (CAbi [AbiUInt _ a, AbiUInt _ b, AbiUInt _ maxDelta],"") ->+          let delta = if a > b then a - b else b - a+          in if delta <= maxDelta then doStop+             else frameRevert $ "assertion failed: " <>+               BS8.pack (show a) <> " !~= " <> BS8.pack (show b) <>+               " (max delta: " <> BS8.pack (show maxDelta) <>+               ", real delta: " <> BS8.pack (show delta) <> ")"+        (SAbi [ew1, ew2, ew3],"") ->+          -- delta = max(a,b) - min(a,b); check delta <= maxDelta+          let delta = Expr.sub (Expr.max ew1 ew2) (Expr.min ew1 ew2)+          in case Expr.simplify (Expr.iszero $ Expr.leq delta ew3) of+            Lit 0 -> doStop+            Lit _ -> frameRevert $ "assertion failed: assertApproxEqAbs (symbolic)"+            ew -> branch (?conf).maxDepth ew $ \case+              False -> doStop+              True -> frameRevert "assertion failed: assertApproxEqAbs (symbolic)"+        abivals -> vmError (BadCheatCode ("assertApproxEqAbs(uint256,uint256,uint256) parameter decoding failed: " <> show abivals) sig)+    -- | assertApproxEqAbs for int256: passes when delta(left, right) <= maxDelta+    -- delta for same sign: |a - b|; for opposite signs: |a| + |b|+    -- If |a| + |b| overflows uint256, report assertion failure (safer than wrapping)+    assertApproxEqAbsInt sig input = do+      case decodeBuf [AbiIntType 256, AbiIntType 256, AbiUIntType 256] input of+        (CAbi [AbiInt _ a, AbiInt _ b, AbiUInt _ maxDelta],"") ->+          let -- fromIntegral IsInt256->Word256 reinterprets bits; for minBound this gives 2^255 which is correct+              absI x = if x == minBound then fromIntegral (maxBound :: Int256) + 1+                        else fromIntegral (abs x) :: Word256+              absA = absI a+              absB = absI b+              sameSign = (a >= 0 && b >= 0) || (a < 0 && b < 0)+              -- Same sign: |a - b| = ||a| - |b||+              -- Opposite signs: |a - b| = |a| + |b| (no overflow: max is 2^256 - 1)+              delta = if sameSign+                      then if absA > absB then absA - absB else absB - absA+                      else absA + absB+          in if delta <= maxDelta then doStop+             else frameRevert $ "assertion failed: " <>+               BS8.pack (show a) <> " !~= " <> BS8.pack (show b) <>+               " (max delta: " <> BS8.pack (show maxDelta) <>+               ", real delta: " <> BS8.pack (show delta) <> ")"+        (SAbi [ew1, ew2, ew3],"") ->+          -- For symbolic int256, compute unsigned delta via:+          -- if sameSign(a,b) then |a-b| else |a|+|b|+          -- We approximate with unsigned sub of max/min which works for same-sign+          -- but for full correctness with symbolic int256, we use the uint comparison+          let delta = Expr.sub (Expr.max ew1 ew2) (Expr.min ew1 ew2)+          in case Expr.simplify (Expr.iszero $ Expr.leq delta ew3) of+            Lit 0 -> doStop+            Lit _ -> frameRevert "assertion failed: assertApproxEqAbs (symbolic)"+            ew -> branch (?conf).maxDepth ew $ \case+              False -> doStop+              True -> frameRevert "assertion failed: assertApproxEqAbs (symbolic)"+        abivals -> vmError (BadCheatCode ("assertApproxEqAbs(int256,int256,uint256) parameter decoding failed: " <> show abivals) sig)+    -- | assertApproxEqRel(uint256): pass iff |a-b|*1e18/b <= maxPercentDelta+    -- (1e18 == 100%, denominator is the reference b), per forge-std. Special cases:+    -- b==0&&a==0 -> pass; b==0&&a/=0 -> "undefined"; result > uint256 -> overflow.+    assertApproxEqRelUint sig input = do+      case decodeBuf [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256] input of+        (CAbi [AbiUInt _ a, AbiUInt _ b, AbiUInt _ maxPercentDelta],"")+          | b == 0 ->+            if a == 0 then doStop+            else frameRevert $ relFailMsg a b maxPercentDelta "undefined"+          | otherwise ->+            let absDelta = if a > b then a - b else b - a+                -- in Integer to avoid the intermediate overflow (foundry uses U512)+                percentDelta = (toInteger absDelta * scale1e18) `Prelude.div` toInteger b+            in if percentDelta > toInteger (maxBound :: Word256)+               then frameRevert "assertion failed: overflow in delta calculation"+               else if percentDelta <= toInteger maxPercentDelta then doStop+               else frameRevert $ relFailMsg a b maxPercentDelta (show percentDelta)+        (SAbi [ew1, ew2, ew3],"") ->+          -- Sound encoding: Expr.mul truncates mod 2^256, so it's only trustworthy+          -- when absDelta*1e18 can't overflow (absDelta <= maxSafeRelDelta). Pass+          -- only when provably within bound; overflow-possible or b==0&&a/=0 fail+          -- (b==0&&a==0 passes). May give false positives, never an unsound pass.+          let absDelta     = Expr.sub (Expr.max ew1 ew2) (Expr.min ew1 ew2)+              percentDelta = Expr.div (Expr.mul absDelta (Lit scale1e18W)) ew2+              bZero        = Expr.iszero ew2+              aNotZero     = Expr.iszero (Expr.iszero ew1)+              overflow     = Expr.gt absDelta (Lit maxSafeRelDelta)+              pdExceeds    = Expr.gt percentDelta ew3+              -- fail iff (b == 0 && a /= 0) || (b /= 0 && (overflow || pd > max))+              failCond     = Expr.or (Expr.and bZero aNotZero)+                                     (Expr.and (Expr.iszero bZero) (Expr.or overflow pdExceeds))+          in case Expr.simplify failCond of+            Lit 0 -> doStop+            Lit _ -> frameRevert "assertion failed: assertApproxEqRel (symbolic)"+            ew -> branch (?conf).maxDepth ew $ \case+              False -> doStop+              True -> frameRevert "assertion failed: assertApproxEqRel (symbolic)"+        abivals -> vmError (BadCheatCode ("assertApproxEqRel(uint256,uint256,uint256) parameter decoding failed: " <> show abivals) sig)+    -- | assertApproxEqRel(int256): as uint, but signed absDelta (same sign+    -- ||a|-|b||, opposite |a|+|b|) over denominator |b|.+    assertApproxEqRelInt sig input = do+      case decodeBuf [AbiIntType 256, AbiIntType 256, AbiUIntType 256] input of+        (CAbi [AbiInt _ a, AbiInt _ b, AbiUInt _ maxPercentDelta],"") ->+          let -- fromIntegral Int256->Word256 reinterprets bits; for minBound this gives 2^255 which is correct+              absI x = if x == minBound then fromIntegral (maxBound :: Int256) + 1+                        else fromIntegral (abs x) :: Word256+              absA = absI a+              absB = absI b+              sameSign = (a >= 0 && b >= 0) || (a < 0 && b < 0)+              absDelta = if sameSign+                         then if absA > absB then absA - absB else absB - absA+                         else absA + absB+          in if b == 0+             then if a == 0 then doStop+                  else frameRevert $ relFailMsg a b maxPercentDelta "undefined"+             else+               let percentDelta = (toInteger absDelta * scale1e18) `Prelude.div` toInteger absB+               in if percentDelta > toInteger (maxBound :: Word256)+                  then frameRevert "assertion failed: overflow in delta calculation"+                  else if percentDelta <= toInteger maxPercentDelta then doStop+                  else frameRevert $ relFailMsg a b maxPercentDelta (show percentDelta)+        (SAbi [_, _, _],"") ->+          -- A sound signed encoding isn't expressible with hevm's Expr (would need+          -- full-precision signed abs + |b| division), so we conservatively fail+          -- rather than risk an unsound pass. May be a false positive.+          frameRevert "assertion failed: assertApproxEqRel (symbolic int256 operands not supported)"+        abivals -> vmError (BadCheatCode ("assertApproxEqRel(int256,int256,uint256) parameter decoding failed: " <> show abivals) sig)     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) +-- * expectRevert support+--+-- The cheat captures the depth of the call stack so that when the immediately+-- following sub-call returns/reverts at the same depth, finishFrame consumes+-- the expectation and rewrites the result.++setExpectedRevert+  :: VMOps t => Maybe (Expr Buf) -> Bool -> Maybe (Expr EAddr) -> EVM t ()+setExpectedRevert reasonExp isPartial reverterExp = do+  vm <- get+  case vm.expectedRevert of+    Just _ ->+      vmError (BadCheatCode "expectRevert: previous expectation not yet consumed" 0)+    Nothing -> do+      assign #expectedRevert $ Just ExpectedRevert+        { reason         = reasonExp+        , partialMatch   = isPartial+        , reverter       = reverterExp+        , depth          = length vm.frames+        , actualReverter = Nothing+        }+      finishFrame (FrameReturned mempty)++-- | ABI-encode an Error(string) revert payload.+errorMsg :: ByteString -> Expr Buf+errorMsg err = ConcreteBuf $ selector "Error(string)" <> encodeAbiValue (AbiTuple $ V.fromList [AbiString err])++assertionFailedBuf :: ByteString -> Expr Buf+assertionFailedBuf msg = errorMsg ("assertion failed: " <> msg)++-- | If a concrete buffer is an Error(string)-encoded revert, return the inner+-- string bytes. Otherwise Nothing.+stripErrorPrefix :: ByteString -> Maybe ByteString+stripErrorPrefix bs+  | BS.length bs < 4 = Nothing+  | BS.take 4 bs /= selector "Error(string)" = Nothing+  | otherwise = case decodeBuf [AbiStringType] (ConcreteBuf (BS.drop 4 bs)) of+      (CAbi [AbiString inner], _) -> Just inner+      _ -> Nothing++-- | Outcome of matching an expectation against an actual revert.+-- 'Indeterminate' carries the reason a concrete decision could not be made;+-- the caller should bail with an unexpected-symbolic error. A definite+-- 'Mismatch' takes precedence over an 'Indeterminate' on a different axis, so+-- an indeterminate reason check cannot mask a known reverter mismatch (and+-- vice versa).+data RevertMatch+  = Match+  | Mismatch+  | Indeterminate String+  deriving (Eq, Show)++matchExpectedRevert+  :: ExpectedRevert -> Expr Buf -> Expr EAddr -> RevertMatch+matchExpectedRevert e actual reverterAddr = combine reasonMatches reverterMatches+  where+    combine Mismatch     _            = Mismatch+    combine _            Mismatch     = Mismatch+    combine (Indeterminate s) _            = Indeterminate s+    combine _            (Indeterminate s) = Indeterminate s+    combine Match        Match        = Match++    reasonMatches = case e.reason of+      Nothing -> Match+      Just expected+        | e.partialMatch -> matchPartialPrefix expected actual+        | otherwise      -> matchFullReason   expected actual++    reverterMatches = case e.reverter of+      Nothing -> Match+      Just want -> case (want, reverterAddr) of+        (LitAddr a, LitAddr b) -> if a == b then Match else Mismatch+        (SymAddr a, SymAddr b) -> if a == b then Match else Mismatch+        (SymAddr a, LitAddr b) -> Indeterminate $ "cannot compare concrete and symbolic addresses: " ++ (unpack a) ++ " and " ++ (show b)+        (LitAddr a, SymAddr b) -> Indeterminate $ "cannot compare concrete and symbolic addresses: " ++ (show a) ++ " and " ++ (unpack b)+        _ -> internalError "unexpected GVar"++-- | Compare only the first four bytes (selector). Succeeds when both sides have+-- a concrete 4-byte prefix even if the rest of the buffer is symbolic.+matchPartialPrefix :: Expr Buf -> Expr Buf -> RevertMatch+matchPartialPrefix expected actual = case (prefix4 (Expr.simplify expected), prefix4 (Expr.simplify actual)) of+  (Right e, Right a)   -> if e == a then Match else Mismatch+  (Left s, _)          -> Indeterminate s+  (_, Left s)          -> Indeterminate s+  where+    prefix4 :: Expr Buf -> Either String ByteString+    prefix4 buf = BS.pack <$> traverse (toLitByte . Expr.simplify . flip Expr.readByte buf . Lit) [0..3]+    toLitByte :: Expr Byte -> Either String Word8+    toLitByte (LitByte w) = Right w+    toLitByte _           = Left "first 4 bytes of revert data are symbolic"++-- | Full-buffer reason match. Both sides are normalized by stripping an+-- Error(string) wrapper if present, so a wrapped expected matches a raw actual+-- inner string and vice versa.+matchFullReason :: Expr Buf -> Expr Buf -> RevertMatch+matchFullReason expected actual = case (Expr.simplify expected, Expr.simplify actual) of+  (ConcreteBuf eBs, ConcreteBuf aBs) ->+    let normalize bs = fromMaybe bs (stripErrorPrefix bs)+    in if normalize eBs == normalize aBs then Match else Mismatch+  _ -> Indeterminate "revert data is symbolic"++-- | Dummy success returndata used when swallowing a matched revert at a CALL+-- boundary. 8192 zero bytes — large enough to satisfy Solidity's return-data+-- decoders for any reasonable return type. Matches foundry's+-- @DUMMY_CALL_OUTPUT@ in @crates/cheatcodes/src/test/revert_handlers.rs@:+-- https://github.com/foundry-rs/foundry/blob/master/crates/cheatcodes/src/test/revert_handlers.rs+dummySuccessReturn :: Expr Buf+dummySuccessReturn = ConcreteBuf (BS.replicate 8192 0)++-- | Sentinel address pushed on the stack when swallowing a matched CREATE+-- revert. Matches foundry's @DUMMY_CREATE_ADDRESS@ (= 0x01) in+-- @crates/cheatcodes/src/test/revert_handlers.rs@ so tests that inspect the+-- LHS of @new C()@ after expectRevert behave identically across both tools:+-- https://github.com/foundry-rs/foundry/blob/master/crates/cheatcodes/src/test/revert_handlers.rs+dummyCreateAddress :: Expr EAddr+dummyCreateAddress = LitAddr 1+ -- * General call implementation ("delegateCall") -- note that the continuation is ignored in the precompile case delegateCall@@ -2138,6 +2612,12 @@             precompiledContract this gasGiven xTo' xContext' xValue xInOffset xInSize xOutOffset xOutSize xs   | xTo == cheatCode = do       cheat gasGiven (xInOffset, xInSize) (xOutOffset, xOutSize) xs+  | xTo == consoleAddr = do+      calldata <- readMemory xInOffset xInSize+      pushTrace $ ConsoleLog calldata+      assign' (#state % #stack) (Lit 1 : xs)+      assign (#state % #returndata) mempty+      next   | otherwise =       callChecks this gasGiven xContext xTo xValue xInOffset xInSize xOutOffset xOutSize xs $         \xGas -> do@@ -2196,14 +2676,21 @@  -- -- * Contract creation --- EIP 684+-- EIP-684 and EIP-7610: collision if nonce != 0, code is non-empty, or storage is non-empty collision :: Maybe Contract -> Bool collision c' = case c' of-  Just c -> c.nonce /= Just 0 || case c.code of+  Just c -> c.nonce /= Just 0 || not (isStorageEmpty c.storage) || case c.code of     RuntimeCode (ConcreteRuntimeCode "") -> False     RuntimeCode (SymbolicRuntimeCode b) -> not $ null b     _ -> True   Nothing -> False+  where+    isStorageEmpty :: Expr Storage -> Bool+    isStorageEmpty = \case+      ConcreteStore m -> Map.null m+      AbstractStore _ _ -> True -- empty symbolic store+      SStore _ _ _ -> False     -- has writes, so non-empty+      GVar _ -> internalError "unexpected global variable"  create :: forall t. (?op :: Word8, ?conf::Config, VMOps t)   => Expr EAddr -> Contract@@ -2338,6 +2825,7 @@               { balance = now.balance               , nonce = now.nonce               , storage = now.storage+              , tStorage = now.tStorage               }         RuntimeCode _ ->           internalError $ "Can't replace code of deployed contract " <> show target@@ -2346,6 +2834,23 @@       Nothing ->         internalError "Can't replace code of nonexistent contract" +replaceCodeEtch :: Expr EAddr -> ContractCode -> EVM t ()+replaceCodeEtch target newCode =+  zoom (#env % #contracts % at target) $+    get >>= \case+      Just now -> case now.code of+        InitCode _ _ -> internalError "Can't etch code of contract in init code phase"+        RuntimeCode _ -> do+          put . Just $+            ((now :: Contract)+              { code = newCode+              , codehash = hashcode newCode+              , opIxMap = mkOpIxMap newCode+              , codeOps = mkCodeOps newCode+              })+        UnknownCode _ -> internalError "Can't etch unknown code"+      Nothing -> put . Just $ initialContract newCode+ replaceCodeOfSelf :: ContractCode -> EVM t () replaceCodeOfSelf newCode = do   vm <- get@@ -2374,6 +2879,15 @@   | FrameErrored EvmError -- ^ Any other error   deriving Show +terminateVMWithError :: VMOps t => EvmError -> EVM t ()+terminateVMWithError err = do+  vm <- get+  case vm.frames of+    [] -> finishFrame (FrameErrored err)+    _ -> do+      finishFrame (FrameErrored err)+      terminateVMWithError err+ finishAllFramesAndStop :: VMOps t => EVM t () finishAllFramesAndStop = do   vm <- get@@ -2391,7 +2905,73 @@ finishFrame :: VMOps t => FrameResult -> EVM t () finishFrame how = do   oldVm <- get+  case oldVm.expectedRevert of+    Just e+      -- we are back at the start depth (ignoring calls to the cheat address)+      | length oldVm.frames == e.depth+      , not (poppingCheatFrame oldVm.frames)+      -> do+          assign #expectedRevert Nothing+          let isCreate = case oldVm.frames of+                Frame { context = CreationContext {} } : _ -> True+                _ -> False+          case how of+            FrameReverted actual ->+              let reverterAddr =+                    fromMaybe+                      (internalError "expectRevert: missing actualReverter for FrameReverted")+                      e.actualReverter+              in case matchExpectedRevert e actual reverterAddr of+                Match+                  -- if the expected revert occured, then in order to match+                  -- foundry, we need to add some sentinel values to the stack+                  -- and pretend the actual call/create succeeded.+                  | isCreate -> do+                      finishFrameNoExpectation (FrameReverted actual)+                      -- drop the prev return value+                      modifying (#state % #stack) (drop 1)+                      -- add our sentinel+                      pushAddr dummyCreateAddress+                      -- empty returndata+                      assign (#state % #returndata) mempty+                  | otherwise -> do+                      -- process the revert with our dummy returndata+                      finishFrameNoExpectation (FrameReverted dummySuccessReturn)+                      -- drop the prev return value+                      modifying (#state % #stack) (drop 1)+                      -- pretend the call succeeded+                      push 1+                Mismatch ->+                  finishFrameNoExpectation+                    (FrameReverted (assertionFailedBuf "expected revert did not match"))+                Indeterminate reason -> do+                  unexpectedSymArg ("expectRevert: " <> reason) [actual]+                  finishFrameNoExpectation how+            FrameReturned _ ->+              finishFrameNoExpectation+                (FrameReverted (assertionFailedBuf "expected call did not revert"))+            FrameErrored _ -> finishFrameNoExpectation how +      -- we have popped out past the start depth of the expected revert (i.e. returned without a revert occuring)+      | length oldVm.frames < e.depth+      , not (poppingCheatFrame oldVm.frames)+      -> do+          assign #expectedRevert Nothing+          finishFrameNoExpectation $+            FrameReverted (assertionFailedBuf "expected revert never occurred")+    _ -> finishFrameNoExpectation how+  where+    -- | True when the frame being popped is a cheat-call frame. Such frames+    -- must be ignored by the expectRevert interception, as cheatcode calls are+    -- not checked by `expectRevert`+    poppingCheatFrame (Frame { context = CallContext { target } } : _) = target == cheatCode+    poppingCheatFrame _ = False++-- | The non-interception body of finishFrame+finishFrameNoExpectation :: VMOps t => FrameResult -> EVM t ()+finishFrameNoExpectation how = do+  oldVm <- get+   case oldVm.frames of     -- Is the current frame the only one?     [] -> do@@ -2867,27 +3447,45 @@  concreteModexpGasFee :: ByteString -> Word64 concreteModexpGasFee input =-  if lenb < into (maxBound :: Word32) &&-     (lene < into (maxBound :: Word32) || (lenb == 0 && lenm == 0)) &&-     lenm < into (maxBound :: Word64)-  then-    max 200 ((multiplicationComplexity * iterCount) `div` 3)-  else-    maxBound -- TODO: this is not 100% correct, return Nothing on overflow-  where-    (lenb, lene, lenm) = parseModexpLength input-    ez = isZero (96 + lenb) lene input-    e' = word $ LS.toStrict $-      lazySlice (96 + lenb) (min 32 lene) input-    nwords :: Word64-    nwords = ceilDiv (unsafeInto $ max lenb lenm) 8-    multiplicationComplexity = nwords * nwords-    iterCount' :: Word64-    iterCount' | lene <= 32 && ez = 0-               | lene <= 32 = unsafeInto (log2 e')-               | e' == 0 = 8 * (unsafeInto lene - 32)-               | otherwise = unsafeInto (log2 e') + 8 * (unsafeInto lene - 32)-    iterCount = max iterCount' 1+  let (lenb, lene, lenm) = parseModexpLength input+      -- EIP-7823: Cap input lengths at 1024 bytes (8192 bits)+      -- If any length exceeds this, the precompile will fail+      -- and consume all provided gas+      eip7823Limit :: W256+      eip7823Limit = 1024+  in if lenb > eip7823Limit || lene > eip7823Limit || lenm > eip7823Limit+     then 0  -- EIP-7823: limits exceeded, gas cost is 0 (precompileFail will consume all gas)+     else+       let ez = isZero (96 + lenb) lene input+           e' = word $ LS.toStrict $ lazySlice (96 + lenb) (min 32 lene) input+           maxLength :: Word64+           maxLength = unsafeInto $ max lenb lenm+           nwords :: Word64+           nwords = ceilDiv maxLength 8+           -- Check for overflow in nwords * nwords calculation+           multiplicationComplexity :: Word64+           multiplicationComplexity+             | maxLength <= 32 = 16+             | nwords > 0xFFFFFFFF = maxBound  -- nwords^2 would overflow+             | otherwise = let nw2 = nwords * nwords+                           in if nw2 > maxBound `div` 2+                              then maxBound+                              else 2 * nw2+           lene64 :: Word64+           lene64 = unsafeInto lene+           iterCount' :: Word64+           iterCount' | lene <= 32 && ez = 0+                      | lene <= 32 = unsafeInto (log2 e')+                      | e' == 0 = 16 * (lene64 - 32)+                      | otherwise = unsafeInto (log2 e') + 16 * (lene64 - 32)+           iterCount = max iterCount' 1+           -- Check for overflow in final multiplication+           result = if multiplicationComplexity == maxBound+                    then maxBound+                    else if iterCount > maxBound `div` multiplicationComplexity+                         then maxBound+                         else multiplicationComplexity * iterCount+       in max 500 result  -- Gas cost of precompiles costOfPrecompile :: FeeSchedule Word64 -> Addr -> Expr Buf -> Word64@@ -2986,9 +3584,13 @@   n <- use (#env % #freshAddresses)   pure $ SymAddr ("freshSymAddr" <> (pack $ show n)) +isPrecompileAddr' :: Addr -> Bool+isPrecompileAddr' 0x100 = True+isPrecompileAddr' x = 0x0 < x && x <= 0x11+ isPrecompileAddr :: Expr EAddr -> Bool isPrecompileAddr = \case-  LitAddr a -> 0x0 < a && a <= 0x09+  LitAddr a -> isPrecompileAddr' a   SymAddr _ -> False   GVar _ -> internalError "Unexpected GVar" @@ -3074,7 +3676,7 @@         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+      -- Both paths are possible       runBothPaths loc exploreDepth UnknownBranch =         (fork depthLimit exploreDepth ) . PleaseRunBoth $ (runBothPaths loc exploreDepth) . Case @@ -3169,9 +3771,12 @@     else continue    gasTryFrom (forceLit -> w256) =-    case tryFrom w256 of-      Left _ -> Left ()-      Right a -> Right a+    -- EVM spec: gas values larger than Word64 max should be treated as "max gas"+    -- The 63/64 rule will cap it appropriately later+    -- Note: We can't use tryFrom here because TryFrom W256 Word64 always succeeds (truncates)+    if w256 > into (maxBound :: Word64)+    then Right maxBound  -- Cap at Word64 max for overflow+    else Right (unsafeInto w256)    -- Gas cost of create, including hash cost if needed   costOfCreate (FeeSchedule {..}) availableGas size hashNeeded = (createCost, initGas)@@ -3213,10 +3818,17 @@     gasRemaining <- use (#state % #gas)      let-      sumRefunds   = sum (snd <$> tx.subState.refunds)-      gasUsed      = tx.gaslimit - gasRemaining-      cappedRefund = min (quot gasUsed 5) sumRefunds-      originPay    = (into $ gasRemaining + cappedRefund) * tx.gasprice+      gasUsedBeforeRefund = tx.gaslimit - gasRemaining+      sumRefunds          = sum (snd <$> tx.subState.refunds)+      cappedRefund        = min (quot gasUsedBeforeRefund 5) sumRefunds+      gasUsedAfterRefund  = gasUsedBeforeRefund - cappedRefund+      -- EIP-7623: Apply floor cost based on calldata tokens+      gasUsed             = max gasUsedAfterRefund tx.txdataFloorGas+      -- Adjust refund if floor kicks in+      actualRefund        = if gasUsed > gasUsedAfterRefund+                            then cappedRefund - (gasUsed - gasUsedAfterRefund)+                            else cappedRefund+      originPay    = (into $ gasRemaining + actualRefund) * tx.gasprice       minerPay     = tx.priorityFee * (into gasUsed)      modifying (#env % #contracts)

@@ -61,9 +61,9 @@  import Prelude hiding (Foldable(..)) -import EVM.Expr (readWord, isLitWord)+import EVM.Expr (readWord, readByte, isLitWord, simplify) import EVM.Types-import EVM.Expr (maybeLitWordSimp)+import EVM.Expr (maybeLitWordSimp, maybeLitByteSimp)  import Control.Applicative ((<|>)) import Control.Monad (replicateM, replicateM_, forM_, void)@@ -72,6 +72,8 @@ import Data.Bits (shiftL, shiftR, (.&.), testBit, bit, complement, (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS+import Data.DoubleWord (Word160(..), Word128(..))+import Data.Serialize qualified as Cereal import Data.ByteString.Base16 qualified as BS16 import Data.ByteString.Char8 qualified as Char8 import Data.ByteString.Lazy qualified as BSLazy@@ -112,7 +114,7 @@   | AbiArrayDynamic AbiType (Vector AbiValue)   | AbiArray        Int AbiType (Vector AbiValue)   | AbiTuple        (Vector AbiValue)-  | AbiFunction     BS.ByteString+  | AbiFunction     Addr FunctionSelector   deriving (Read, Eq, Ord, Generic)  class ShowAlter a where@@ -133,7 +135,7 @@     "[" ++ intercalate ", " (show <$> Vector.toList v) ++ "]"   show (AbiTuple v) =     "(" ++ intercalate ", " (show <$> Vector.toList v) ++ ")"-  show (AbiFunction b)       = show (ByteStringS b)+  show (AbiFunction addr sel) = show (ByteStringS (word160Bytes addr <> word32Bytes sel))  -- | Pretty-print some 'AbiValue'. instance ShowAlter AbiValue where@@ -151,7 +153,7 @@     "[" ++ intercalate ", " (showAlter <$> Vector.toList v) ++ "]"   showAlter (AbiTuple v) = "AbiTuple" <>     "(" ++ intercalate ", " (show <$> Vector.toList v) ++ ")"-  showAlter (AbiFunction b)       = "AbiFunction " <> show (ByteStringS b)+  showAlter (AbiFunction addr sel) = "AbiFunction " <> show (ByteStringS (word160Bytes addr <> word32Bytes sel))  data AbiType   = AbiUIntType         Int@@ -217,7 +219,7 @@   AbiArrayDynamic t _ -> AbiArrayDynamicType t   AbiArray n t _      -> AbiArrayType n t   AbiTuple v          -> AbiTupleType (abiValueType <$> v)-  AbiFunction _       -> AbiFunctionType+  AbiFunction _ _     -> AbiFunctionType  getAbi :: AbiType -> Get AbiValue getAbi t = label (Text.unpack (abiTypeSolidity t)) $@@ -255,14 +257,20 @@      AbiArrayDynamicType t' -> do       AbiUInt _ n <- label "array length" (getAbi (AbiUIntType 256))-      AbiArrayDynamic t' <$>+      let maxLen = fromIntegral (maxBound :: Int) :: Word256+      if n > maxLen then fail "array length exceeds maximum Int"+      else AbiArrayDynamic t' <$>         label "array body" (getAbiSeq (unsafeInto n) (repeat t'))      AbiTupleType ts ->       AbiTuple <$> getAbiSeq (Vector.length ts) (Vector.toList ts) -    AbiFunctionType ->-      AbiFunction <$> getBytesWith256BitPadding (24 :: Int)+    AbiFunctionType -> do+      addrBytes <- BS.pack <$> replicateM 20 getWord8+      sel <- FunctionSelector <$> getWord32be+      skip 8  -- padding to 32 bytes+      let addr = bytesToAddr addrBytes+      pure (AbiFunction addr sel)  putAbi :: AbiValue -> Put putAbi = \case@@ -296,8 +304,10 @@   AbiTuple v ->     putAbiSeq v -  AbiFunction b -> do-    putAbi (AbiBytes 24 b)+  AbiFunction addr (FunctionSelector sel) -> do+    forM_ (BS.unpack (word160Bytes addr)) putWord8+    putWord32be sel+    replicateM_ 8 (putWord8 0)  -- padding to 32 bytes  -- | Decode a sequence type (e.g. tuple / array). Will fail for non sequence types getAbiSeq :: Int -> [AbiType] -> Get (Vector AbiValue)@@ -351,7 +361,7 @@         AbiBool _    -> 32         AbiTuple v   -> sum (abiHeadSize <$> v)         AbiArray _ _ xs -> sum (abiHeadSize <$> xs)-        AbiFunction _ -> 32+        AbiFunction _ _ -> 32         _ -> internalError "impossible"  putAbiSeq :: Vector AbiValue -> Put@@ -409,20 +419,26 @@     , P.string "bool"    $> AbiBoolType     , P.string "string"  $> AbiStringType -    , sizedType "uint" AbiUIntType-    , sizedType "int"  AbiIntType-    , sizedType "bytes" AbiBytesType+    , sizedType "uint" AbiUIntType (const True)+    , sizedType "int"  AbiIntType (const True)+    , sizedType "bytes" AbiBytesType (\n -> n >= 1 && n <= 32)      , P.string "bytes" $> AbiBytesDynamicType     , P.string "tuple" $> AbiTupleType v     , P.string "function" $> AbiFunctionType++    -- Fallback for user-defined types (e.g. enums like "Order.OrderType").+    -- Solidity libraries emit qualified enum names in their ABI instead of+    -- the underlying uint8. Treat any unrecognized identifier as uint8.+    , P.try (P.some (P.alphaNumChar P.<|> P.char '.') $> AbiUIntType 8)     ]    where-    sizedType :: Text -> (Int -> AbiType) -> P.Parsec () Text AbiType-    sizedType s f = P.try $ do+    sizedType :: Text -> (Int -> AbiType) -> (Int -> Bool) -> P.Parsec () Text AbiType+    sizedType s f valid = P.try $ do       void (P.string s)-      fmap (f . read) (P.some P.digitChar)+      n <- read <$> P.some P.digitChar+      if valid n then pure (f n) else P.empty  pack32 :: Int -> [Word32] -> Word256 pack32 n xs =@@ -440,6 +456,19 @@ roundTo32Bytes :: Integral a => a -> a roundTo32Bytes n = 32 * div (n + 31) 32 +word32Bytes :: FunctionSelector -> ByteString+word32Bytes (FunctionSelector w) = BSLazy.toStrict $ runPut $ putWord32be w++bytesToAddr :: ByteString -> Addr+bytesToAddr bs = case Cereal.runGet m bs of+  Right addr -> addr+  Left _ -> internalError "bytesToAddr: failed to parse 20 bytes"+  where+    m = do a <- Cereal.getWord32be+           b <- Cereal.getWord64be+           c <- Cereal.getWord64be+           pure $ Addr (Word160 a (Word128 b c))+ emptyAbi :: AbiValue emptyAbi = AbiTuple mempty @@ -481,7 +510,9 @@                             <|> (do Boolz b <- readS_to_P reads                                     pure $ AbiBool b) parseAbiValue (AbiBytesType n) = AbiBytes n <$> do ByteStringS bytes <- bytesP-                                                   pure bytes+                                                   if BS.length bytes == n+                                                     then pure bytes+                                                     else pfail parseAbiValue AbiBytesDynamicType = AbiBytesDynamic <$> do ByteStringS bytes <- bytesP                                                            pure bytes parseAbiValue AbiStringType = AbiString <$> do Char8.pack <$> readS_to_P reads@@ -492,8 +523,13 @@   AbiArray n typ <$> do a <- listP (parseAbiValue typ)                         pure $ Vector.fromList a parseAbiValue (AbiTupleType _) = internalError "tuple types not supported"-parseAbiValue AbiFunctionType = AbiFunction <$> do ByteStringS bytes <- bytesP-                                                   pure bytes+parseAbiValue AbiFunctionType = do+  ByteStringS bytes <- bytesP+  if BS.length bytes == 24+    then let addr = bytesToAddr (BS.take 20 bytes)+             sel = FunctionSelector (word32 (BS.unpack (BS.drop 20 bytes)))+         in pure (AbiFunction addr sel)+    else pfail  listP :: ReadP a -> ReadP [a] listP parser = between (char '[') (char ']') ((do skipSpaces@@ -518,18 +554,88 @@     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, "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 decodeBuf tps (ConcreteBuf asBS)-  where-    isDynamic t = abiKind t == Dynamic+decodeBuf tps b = case simplify b of+  ConcreteBuf buf -> decodeBuf tps (ConcreteBuf buf)+  buf -> if any isDynamic tps then tryDecodeDynamic tps buf+    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 decodeBuf tps (ConcreteBuf asBS)+    where+      isDynamic t = abiKind t == Dynamic +-- | Try to decode arguments including dynamic types like bytes/string+-- For dynamic types, reads offset from head, then length and data from that offset+tryDecodeDynamic :: [AbiType] -> Expr Buf -> (AbiVals, String)+tryDecodeDynamic tps buf =+  let headVals = decodeStaticArgs 0 (length tps) buf+      headSimp = map simplify headVals+  in case decodeWithExprs 0 tps headSimp buf of+    Left err -> (NoVals, err)+    Right abiVals -> (CAbi abiVals, "")++-- | Decode types using head expressions+-- For static types, the expression is the value+-- For dynamic types, the expression must be a concrete offset+decodeWithExprs :: Int -> [AbiType] -> [Expr EWord] -> Expr Buf -> Err [AbiValue]+decodeWithExprs _ [] [] _ = Right []+decodeWithExprs _ [] _ _ = Left "mismatched types and values"+decodeWithExprs _ _ [] _ = Left "mismatched types and values"+decodeWithExprs headPos (t:ts) (v:vs) buf = do+  val <- decodeOneArgExpr t v buf+  rest <- decodeWithExprs (headPos + 32) ts vs buf+  pure (val : rest)++-- | Decode a single argument from its head expression+-- For dynamic types, the expression must be a concrete offset+decodeOneArgExpr :: AbiType -> Expr EWord -> Expr Buf -> Err AbiValue+decodeOneArgExpr t expr buf = case abiKind t of+  Static -> maybe (Left $ "static type requires concrete value, got: " ++ show expr)+    (decodeStaticArgConcrete t) simpExpr+  Dynamic -> maybe (Left $ "dynamic type requires concrete offset, got: " ++ show expr)+    (\o -> decodeDynamicArg t (unsafeInto o) buf) simpExpr+  where simpExpr = maybeLitWordSimp expr++-- | Decode a static type from a concrete 32-byte word value+decodeStaticArgConcrete :: AbiType -> W256 -> Err AbiValue+decodeStaticArgConcrete t v = case t of+  AbiUIntType n -> Right $ AbiUInt n (fromIntegral v)+  AbiIntType n -> Right $ AbiInt n (fromIntegral v)+  AbiAddressType -> Right $ AbiAddress $ fromIntegral v+  AbiBoolType -> Right $ AbiBool (v > 0)+  AbiBytesType n ->+    let bs = BS.take n (word256Bytes v)+    in Right $ AbiBytes n bs+  AbiFunctionType ->+    let bs = word256Bytes v+        addr = bytesToAddr (BS.take 20 bs)+        sel = FunctionSelector (word32 (BS.unpack (BS.drop 20 (BS.take 24 bs))))+    in Right $ AbiFunction addr sel+  _ -> Left $ "unexpected static type: " ++ show t++-- | Decode a dynamic type from buffer at given offset+decodeDynamicArg :: AbiType -> Int -> Expr Buf -> Err AbiValue+decodeDynamicArg t offset buf = case t of+  AbiBytesDynamicType -> do+    -- Read length at offset+    let lenExpr = simplify $ readWord (Lit $ unsafeInto offset) buf+    case maybeLitWordSimp lenExpr of+      Nothing -> Left "could not get concrete length for bytes"+      Just len ->+        let dataOffset = offset + 32+            byteCount = unsafeInto len :: Int+            bytes = [simplify $ readByte (Lit $ unsafeInto (dataOffset + i)) buf | i <- [0 .. byteCount - 1]]+            concreteBytes = mapMaybe maybeLitByteSimp bytes+        in if length concreteBytes /= byteCount+           then Left $ "could not get all concrete bytes (got " ++ show (length concreteBytes) ++ " of " ++ show byteCount ++ ")"+           else Right $ AbiBytesDynamic (BS.pack concreteBytes)++  -- String is encoded the same as bytes+  AbiStringType -> decodeDynamicArg AbiBytesDynamicType offset buf+  _ -> Left $ "dynamic type not yet supported: " ++ show t+ decodeStaticArgs :: Int -> Int -> Expr Buf -> [Expr EWord] decodeStaticArgs offset numArgs b =   [readWord (Lit . unsafeInto $ i) b | i <- [offset,(offset+32) .. (offset + (numArgs-1)*32)]]@@ -542,8 +648,7 @@    AbiIntType n -> do      x <- genUInt n      pure $ AbiInt n (signedWord (x - 2^(n-1)))-   AbiAddressType ->-     AbiAddress . fromIntegral <$> genUInt 20+   AbiAddressType -> AbiAddress . fromIntegral <$> genUInt 20    AbiBoolType ->      elements [AbiBool False, AbiBool True]    AbiBytesType n ->@@ -561,9 +666,12 @@        replicateM n (scale (`div` 3) (genAbiValue t))    AbiTupleType ts ->      AbiTuple <$> mapM genAbiValue ts-   AbiFunctionType ->-     do xs <- replicateM 24 arbitrary-        pure (AbiFunction (BS.pack xs))+   AbiFunctionType -> do+     addrBytes <- BS.pack <$> replicateM 20 arbitrary+     selBytes <- replicateM 4 arbitrary+     let addr = bytesToAddr addrBytes+         sel = FunctionSelector (word32 selBytes)+     pure (AbiFunction addr sel)   where     genUInt :: Int -> Gen Word256     genUInt n = arbitraryIntegralWithMax (2^n-1) :: Gen Word256@@ -603,9 +711,10 @@     AbiUInt n a -> AbiUInt n <$> (shrinkIntegral a)     AbiInt n a -> AbiInt n <$> (shrinkIntegral a)     AbiBool b -> AbiBool <$> shrink b-    AbiAddress a -> [AbiAddress 0xacab, AbiAddress 0xdeadbeef, AbiAddress 0xbabeface]-      <> (AbiAddress <$> shrinkIntegral a)-    AbiFunction b -> shrink $ AbiBytes 24 b+    AbiAddress a -> [AbiAddress 0xacab, AbiAddress a, AbiAddress 0xbabeface, AbiAddress 0xdeadbeef]+    AbiFunction addr (FunctionSelector sel) ->+      [AbiFunction a (FunctionSelector s) | a <- shrinkIntegral addr, s <- [sel]]+      ++ [AbiFunction a (FunctionSelector s) | a <- [addr], s <- shrinkIntegral sel]  -- A modification of 'arbitrarySizedBoundedIntegral' quickcheck library -- which takes the maxbound explicitly rather than relying on a Bounded instance.

@@ -42,6 +42,7 @@       OpShl -> [LitByte 0x1B]       OpShr -> [LitByte 0x1C]       OpSar -> [LitByte 0x1D]+      OpClz -> [LitByte 0x1E]       OpSha3 -> [LitByte 0x20]       OpAddress -> [LitByte 0x30]       OpBalance -> [LitByte 0x31]

@@ -0,0 +1,189 @@+module EVM.ConsoleLog+  ( formatConsoleLog+  ) where++import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as Char8+import Data.ByteString.Builder (byteStringHex, toLazyByteString)+import Data.ByteString.Lazy (toStrict)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text, pack, intercalate)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T++import EVM.ABI (AbiType(..), AbiValue(..), decodeBuf, AbiVals(..))+import EVM.Types (Expr(..), EType(..), FunctionSelector(..), abiKeccak, word32)++-- | Try to decode and format a console.log calldata buffer.+-- Returns a human-readable representation of the log message.+formatConsoleLog :: Expr Buf -> Text+formatConsoleLog (ConcreteBuf bs) = formatConsoleLogBS bs+formatConsoleLog _ = "<symbolic console.log>"++formatConsoleLogBS :: ByteString -> Text+formatConsoleLogBS bs+  | BS.length bs < 4 = "console::log()"+  | otherwise =+      let selector = FunctionSelector (word32 (BS.unpack (BS.take 4 bs)))+          payload = BS.drop 4 bs+      in case Map.lookup selector consoleLogSigs of+        Just (_, types) ->+          case decodeBuf types (ConcreteBuf payload) of+            (CAbi vals, _) -> "console::log(" <> intercalate ", " (map showAbiVal vals) <> ")"+            _ -> "console::log(" <> hexBS bs <> ")"+        Nothing -> "console::log(" <> hexBS bs <> ")"+  where+    hexBS b = "0x" <> T.decodeUtf8 (toStrict (toLazyByteString (byteStringHex b)))++-- | Format an ABI value for console output+showAbiVal :: AbiValue -> Text+showAbiVal (AbiString s) = T.pack (show (Char8.unpack s))+showAbiVal (AbiAddress addr) = pack (show addr)+showAbiVal (AbiBool b) = if b then "true" else "false"+showAbiVal v = pack (show v)++-- | Map from 4-byte selector to (display name, parameter types) for all+-- console.log overloads.+consoleLogSigs :: Map FunctionSelector (Text, [AbiType])+consoleLogSigs = Map.fromList+  [ sig "log()"                  []+  -- single param+  , sig "log(bool)"              [AbiBoolType]+  , sig "log(address)"           [AbiAddressType]+  , sig "log(uint256)"           [AbiUIntType 256]+  , sig "log(int256)"            [AbiIntType 256]+  , sig "log(string)"            [AbiStringType]+  , sig "log(bytes)"             [AbiBytesDynamicType]+  -- two params+  , sig "log(bool,bool)"                [AbiBoolType, AbiBoolType]+  , sig "log(bool,address)"             [AbiBoolType, AbiAddressType]+  , sig "log(bool,uint256)"             [AbiBoolType, AbiUIntType 256]+  , sig "log(bool,string)"              [AbiBoolType, AbiStringType]+  , sig "log(address,bool)"             [AbiAddressType, AbiBoolType]+  , sig "log(address,address)"          [AbiAddressType, AbiAddressType]+  , sig "log(address,uint256)"          [AbiAddressType, AbiUIntType 256]+  , sig "log(address,string)"           [AbiAddressType, AbiStringType]+  , sig "log(uint256,bool)"             [AbiUIntType 256, AbiBoolType]+  , sig "log(uint256,address)"          [AbiUIntType 256, AbiAddressType]+  , sig "log(uint256,uint256)"          [AbiUIntType 256, AbiUIntType 256]+  , sig "log(uint256,string)"           [AbiUIntType 256, AbiStringType]+  , sig "log(string,bool)"              [AbiStringType, AbiBoolType]+  , sig "log(string,address)"           [AbiStringType, AbiAddressType]+  , sig "log(string,uint256)"           [AbiStringType, AbiUIntType 256]+  , sig "log(string,string)"            [AbiStringType, AbiStringType]+  , sig "log(string,int256)"            [AbiStringType, AbiIntType 256]+  -- three params+  , sig "log(bool,bool,bool)"                   [AbiBoolType, AbiBoolType, AbiBoolType]+  , sig "log(bool,bool,address)"                [AbiBoolType, AbiBoolType, AbiAddressType]+  , sig "log(bool,bool,uint256)"                [AbiBoolType, AbiBoolType, AbiUIntType 256]+  , sig "log(bool,bool,string)"                 [AbiBoolType, AbiBoolType, AbiStringType]+  , sig "log(bool,address,bool)"                [AbiBoolType, AbiAddressType, AbiBoolType]+  , sig "log(bool,address,address)"             [AbiBoolType, AbiAddressType, AbiAddressType]+  , sig "log(bool,address,uint256)"             [AbiBoolType, AbiAddressType, AbiUIntType 256]+  , sig "log(bool,address,string)"              [AbiBoolType, AbiAddressType, AbiStringType]+  , sig "log(bool,uint256,bool)"                [AbiBoolType, AbiUIntType 256, AbiBoolType]+  , sig "log(bool,uint256,address)"             [AbiBoolType, AbiUIntType 256, AbiAddressType]+  , sig "log(bool,uint256,uint256)"             [AbiBoolType, AbiUIntType 256, AbiUIntType 256]+  , sig "log(bool,uint256,string)"              [AbiBoolType, AbiUIntType 256, AbiStringType]+  , sig "log(bool,string,bool)"                 [AbiBoolType, AbiStringType, AbiBoolType]+  , sig "log(bool,string,address)"              [AbiBoolType, AbiStringType, AbiAddressType]+  , sig "log(bool,string,uint256)"              [AbiBoolType, AbiStringType, AbiUIntType 256]+  , sig "log(bool,string,string)"               [AbiBoolType, AbiStringType, AbiStringType]+  , sig "log(address,bool,bool)"                [AbiAddressType, AbiBoolType, AbiBoolType]+  , sig "log(address,bool,address)"             [AbiAddressType, AbiBoolType, AbiAddressType]+  , sig "log(address,bool,uint256)"             [AbiAddressType, AbiBoolType, AbiUIntType 256]+  , sig "log(address,bool,string)"              [AbiAddressType, AbiBoolType, AbiStringType]+  , sig "log(address,address,bool)"             [AbiAddressType, AbiAddressType, AbiBoolType]+  , sig "log(address,address,address)"          [AbiAddressType, AbiAddressType, AbiAddressType]+  , sig "log(address,address,uint256)"          [AbiAddressType, AbiAddressType, AbiUIntType 256]+  , sig "log(address,address,string)"           [AbiAddressType, AbiAddressType, AbiStringType]+  , sig "log(address,uint256,bool)"             [AbiAddressType, AbiUIntType 256, AbiBoolType]+  , sig "log(address,uint256,address)"          [AbiAddressType, AbiUIntType 256, AbiAddressType]+  , sig "log(address,uint256,uint256)"          [AbiAddressType, AbiUIntType 256, AbiUIntType 256]+  , sig "log(address,uint256,string)"           [AbiAddressType, AbiUIntType 256, AbiStringType]+  , sig "log(address,string,bool)"              [AbiAddressType, AbiStringType, AbiBoolType]+  , sig "log(address,string,address)"           [AbiAddressType, AbiStringType, AbiAddressType]+  , sig "log(address,string,uint256)"           [AbiAddressType, AbiStringType, AbiUIntType 256]+  , sig "log(address,string,string)"            [AbiAddressType, AbiStringType, AbiStringType]+  , sig "log(uint256,bool,bool)"                [AbiUIntType 256, AbiBoolType, AbiBoolType]+  , sig "log(uint256,bool,address)"             [AbiUIntType 256, AbiBoolType, AbiAddressType]+  , sig "log(uint256,bool,uint256)"             [AbiUIntType 256, AbiBoolType, AbiUIntType 256]+  , sig "log(uint256,bool,string)"              [AbiUIntType 256, AbiBoolType, AbiStringType]+  , sig "log(uint256,address,bool)"             [AbiUIntType 256, AbiAddressType, AbiBoolType]+  , sig "log(uint256,address,address)"          [AbiUIntType 256, AbiAddressType, AbiAddressType]+  , sig "log(uint256,address,uint256)"          [AbiUIntType 256, AbiAddressType, AbiUIntType 256]+  , sig "log(uint256,address,string)"           [AbiUIntType 256, AbiAddressType, AbiStringType]+  , sig "log(uint256,uint256,bool)"             [AbiUIntType 256, AbiUIntType 256, AbiBoolType]+  , sig "log(uint256,uint256,address)"          [AbiUIntType 256, AbiUIntType 256, AbiAddressType]+  , sig "log(uint256,uint256,uint256)"          [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]+  , sig "log(uint256,uint256,string)"           [AbiUIntType 256, AbiUIntType 256, AbiStringType]+  , sig "log(uint256,string,bool)"              [AbiUIntType 256, AbiStringType, AbiBoolType]+  , sig "log(uint256,string,address)"           [AbiUIntType 256, AbiStringType, AbiAddressType]+  , sig "log(uint256,string,uint256)"           [AbiUIntType 256, AbiStringType, AbiUIntType 256]+  , sig "log(uint256,string,string)"            [AbiUIntType 256, AbiStringType, AbiStringType]+  , sig "log(string,bool,bool)"                 [AbiStringType, AbiBoolType, AbiBoolType]+  , sig "log(string,bool,address)"              [AbiStringType, AbiBoolType, AbiAddressType]+  , sig "log(string,bool,uint256)"              [AbiStringType, AbiBoolType, AbiUIntType 256]+  , sig "log(string,bool,string)"               [AbiStringType, AbiBoolType, AbiStringType]+  , sig "log(string,address,bool)"              [AbiStringType, AbiAddressType, AbiBoolType]+  , sig "log(string,address,address)"           [AbiStringType, AbiAddressType, AbiAddressType]+  , sig "log(string,address,uint256)"           [AbiStringType, AbiAddressType, AbiUIntType 256]+  , sig "log(string,address,string)"            [AbiStringType, AbiAddressType, AbiStringType]+  , sig "log(string,uint256,bool)"              [AbiStringType, AbiUIntType 256, AbiBoolType]+  , sig "log(string,uint256,address)"           [AbiStringType, AbiUIntType 256, AbiAddressType]+  , sig "log(string,uint256,uint256)"           [AbiStringType, AbiUIntType 256, AbiUIntType 256]+  , sig "log(string,uint256,string)"            [AbiStringType, AbiUIntType 256, AbiStringType]+  , sig "log(string,string,bool)"               [AbiStringType, AbiStringType, AbiBoolType]+  , sig "log(string,string,address)"            [AbiStringType, AbiStringType, AbiAddressType]+  , sig "log(string,string,uint256)"            [AbiStringType, AbiStringType, AbiUIntType 256]+  , sig "log(string,string,string)"             [AbiStringType, AbiStringType, AbiStringType]+  -- four params (most common combinations)+  , sig "log(bool,bool,bool,bool)"                      [AbiBoolType, AbiBoolType, AbiBoolType, AbiBoolType]+  , sig "log(bool,bool,bool,address)"                   [AbiBoolType, AbiBoolType, AbiBoolType, AbiAddressType]+  , sig "log(bool,bool,bool,uint256)"                   [AbiBoolType, AbiBoolType, AbiBoolType, AbiUIntType 256]+  , sig "log(bool,bool,bool,string)"                    [AbiBoolType, AbiBoolType, AbiBoolType, AbiStringType]+  , sig "log(address,address,address,address)"          [AbiAddressType, AbiAddressType, AbiAddressType, AbiAddressType]+  , sig "log(address,address,address,uint256)"          [AbiAddressType, AbiAddressType, AbiAddressType, AbiUIntType 256]+  , sig "log(address,address,address,string)"           [AbiAddressType, AbiAddressType, AbiAddressType, AbiStringType]+  , sig "log(uint256,uint256,uint256,uint256)"          [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]+  , sig "log(uint256,uint256,uint256,string)"           [AbiUIntType 256, AbiUIntType 256, AbiUIntType 256, AbiStringType]+  , sig "log(string,string,string,string)"              [AbiStringType, AbiStringType, AbiStringType, AbiStringType]+  , sig "log(string,string,string,uint256)"             [AbiStringType, AbiStringType, AbiStringType, AbiUIntType 256]+  , sig "log(string,string,string,address)"             [AbiStringType, AbiStringType, AbiStringType, AbiAddressType]+  , sig "log(string,string,string,bool)"                [AbiStringType, AbiStringType, AbiStringType, AbiBoolType]+  , sig "log(string,uint256,uint256,uint256)"           [AbiStringType, AbiUIntType 256, AbiUIntType 256, AbiUIntType 256]+  , sig "log(string,address,address,address)"           [AbiStringType, AbiAddressType, AbiAddressType, AbiAddressType]+  , sig "log(string,bool,bool,bool)"                    [AbiStringType, AbiBoolType, AbiBoolType, AbiBoolType]+  , sig "log(string,string,uint256,uint256)"            [AbiStringType, AbiStringType, AbiUIntType 256, AbiUIntType 256]+  , sig "log(string,uint256,string,uint256)"            [AbiStringType, AbiUIntType 256, AbiStringType, AbiUIntType 256]+  , sig "log(string,address,uint256,uint256)"           [AbiStringType, AbiAddressType, AbiUIntType 256, AbiUIntType 256]+  , sig "log(string,uint256,address,uint256)"           [AbiStringType, AbiUIntType 256, AbiAddressType, AbiUIntType 256]+  , sig "log(string,bool,string,string)"                [AbiStringType, AbiBoolType, AbiStringType, AbiStringType]+  , sig "log(string,string,address,address)"            [AbiStringType, AbiStringType, AbiAddressType, AbiAddressType]+  , sig "log(string,address,string,address)"            [AbiStringType, AbiAddressType, AbiStringType, AbiAddressType]+  , sig "log(string,address,address,string)"            [AbiStringType, AbiAddressType, AbiAddressType, AbiStringType]+  , sig "log(string,uint256,uint256,string)"            [AbiStringType, AbiUIntType 256, AbiUIntType 256, AbiStringType]+  , sig "log(string,uint256,string,string)"             [AbiStringType, AbiUIntType 256, AbiStringType, AbiStringType]+  , sig "log(string,string,uint256,string)"             [AbiStringType, AbiStringType, AbiUIntType 256, AbiStringType]+  , sig "log(string,address,uint256,string)"            [AbiStringType, AbiAddressType, AbiUIntType 256, AbiStringType]+  , sig "log(string,uint256,address,string)"            [AbiStringType, AbiUIntType 256, AbiAddressType, AbiStringType]+  , sig "log(string,address,string,uint256)"            [AbiStringType, AbiAddressType, AbiStringType, AbiUIntType 256]+  , sig "log(string,string,address,uint256)"            [AbiStringType, AbiStringType, AbiAddressType, AbiUIntType 256]+  , sig "log(string,address,string,string)"             [AbiStringType, AbiAddressType, AbiStringType, AbiStringType]+  , sig "log(string,bool,address,address)"              [AbiStringType, AbiBoolType, AbiAddressType, AbiAddressType]+  , sig "log(string,bool,uint256,uint256)"              [AbiStringType, AbiBoolType, AbiUIntType 256, AbiUIntType 256]+  , sig "log(string,bool,string,uint256)"               [AbiStringType, AbiBoolType, AbiStringType, AbiUIntType 256]+  , sig "log(string,bool,uint256,string)"               [AbiStringType, AbiBoolType, AbiUIntType 256, AbiStringType]+  , sig "log(string,bool,address,string)"               [AbiStringType, AbiBoolType, AbiAddressType, AbiStringType]+  , sig "log(string,bool,string,address)"               [AbiStringType, AbiBoolType, AbiStringType, AbiAddressType]+  , sig "log(string,bool,uint256,address)"              [AbiStringType, AbiBoolType, AbiUIntType 256, AbiAddressType]+  , sig "log(string,bool,address,uint256)"              [AbiStringType, AbiBoolType, AbiAddressType, AbiUIntType 256]+  , sig "log(string,bool,bool,string)"                  [AbiStringType, AbiBoolType, AbiBoolType, AbiStringType]+  , sig "log(string,bool,bool,address)"                 [AbiStringType, AbiBoolType, AbiBoolType, AbiAddressType]+  , sig "log(string,bool,bool,uint256)"                 [AbiStringType, AbiBoolType, AbiBoolType, AbiUIntType 256]+  ]+  where+    sig :: ByteString -> [AbiType] -> (FunctionSelector, (Text, [AbiType]))+    sig s types = (abiKeccak s, (pack (Char8.unpack s), types))

@@ -13,9 +13,9 @@ import Data.List (find, sort) import Data.Map (Map) import Data.Map qualified as Map-import Data.Maybe (mapMaybe)+import Data.Maybe (mapMaybe, isJust) import Data.Sequence qualified as Seq-import Data.Text (Text, isPrefixOf, pack)+import Data.Text (Text, pack) import Data.Text.Encoding (encodeUtf8) import Data.Vector qualified as V import Optics.Core@@ -47,6 +47,13 @@   , labels :: Map Addr Text   } +data TestMethodInfo = TestMethodInfo+  { contract :: SolcContract+  , methodSignature :: Sig+  }++type TestMethodFilter = TestMethodInfo -> Bool+ dappInfo :: FilePath -> BuildOutput -> DappInfo dappInfo root (BuildOutput (Contracts cs) sources) =   let@@ -80,43 +87,30 @@ emptyDapp :: DappInfo emptyDapp = dappInfo "" mempty --- Dapp unit tests are detected by searching within abi methods--- that begin with "check" or "prove", that are in a contract with--- the "IS_TEST()" abi marker, for a given regular expression.------ The regex is matched on the full test method name, including path--- and contract, i.e. "path/to/file.sol:TestContract.test_name()".+-- Unit tests are detected by searching within abi methods+-- in a contract with the "IS_TEST()" abi marker.  unitTestMarkerAbi :: FunctionSelector unitTestMarkerAbi = abiKeccak (encodeUtf8 "IS_TEST()") -mkSig :: Text -> Method -> Maybe Sig-mkSig prefix method-  | prefix `isPrefixOf` testname = Just (Sig testname argtypes)-  | otherwise = Nothing+mkSig :: Method -> Sig+mkSig method = Sig method.name argtypes   where-    testname = method.name     argtypes = snd <$> method.inputs -findUnitTests :: Text -> Text -> ([SolcContract] -> [(Text, [Sig])])-findUnitTests prefix match =-  concatMap $ \c ->-    case Map.lookup unitTestMarkerAbi c.abiMap of-      Nothing -> []-      Just _  ->-        let testNames = unitTestMethodsFiltered prefix (regexMatches match) c-        in [(c.contractName, testNames) | not (BS.null c.runtimeCode) && not (null testNames)]+findUnitTests :: TestMethodFilter -> SolcContract -> [Sig]+findUnitTests methodFilter c = if isTestContract c then contractMethodsFiltered methodFilter c else []+  where+    isTestContract c' = not (BS.null c'.runtimeCode) && (isJust $ Map.lookup unitTestMarkerAbi c'.abiMap) -unitTestMethodsFiltered :: Text -> (Text -> Bool) -> (SolcContract -> [Sig])-unitTestMethodsFiltered prefix matcher c =-  let testName (Sig n _) = c.contractName <> "." <> n-  in filter (matcher . testName) (unitTestMethods prefix c)+contractMethodsFiltered :: TestMethodFilter -> SolcContract -> [Sig]+contractMethodsFiltered testMethodFilter c = filter (\sig -> testMethodFilter (TestMethodInfo c sig)) $ contractMethods c -unitTestMethods :: Text -> SolcContract -> [Sig]-unitTestMethods prefix =+contractMethods :: SolcContract -> [Sig]+contractMethods =   (.abiMap)   >>> Map.elems-  >>> mapMaybe (mkSig prefix)+  >>> map mkSig  traceSrcMap :: DappInfo -> Trace -> Maybe SrcMap traceSrcMap dapp trace = srcMap dapp trace.contract trace.opIx@@ -166,9 +160,35 @@     Nothing -> Left "<no source map>"     Just sm ->       case srcMapCodePos dapp.sources sm of-        Nothing -> Left "<source not found>"         Just (fileName, lineIx) ->           Right (pack fileName <> ":" <> pack (show lineIx))+        -- srcmap points to a file not in the source cache (e.g. compiler-+        -- generated panic handler).  Walk backwards through the contract's+        -- srcmap to find the nearest entry with a valid source location —+        -- this typically resolves to the assert/require that triggered the+        -- error.+        Nothing ->+          case fallbackSrcPos dapp trace of+            Just (fileName, lineIx) ->+              Right (pack fileName <> ":" <> pack (show lineIx))+            Nothing -> Left "<source not found>"++-- | Walk backwards from the current opIx to find the nearest srcmap entry+-- whose file index exists in the source cache.+fallbackSrcPos :: DappInfo -> Trace -> Maybe (FilePath, Int)+fallbackSrcPos dapp trace = do+  sol <- findSrc trace.contract dapp+  let srcmaps = case trace.contract.code of+        InitCode _ _ -> sol.creationSrcmap+        RuntimeCode _ -> sol.runtimeSrcmap+        UnknownCode _ -> mempty+  go (trace.opIx - 1) srcmaps+  where+    go i srcmaps+      | i < 0     = Nothing+      | otherwise = case Seq.lookup i srcmaps >>= srcMapCodePos dapp.sources of+          Just pos -> Just pos+          Nothing  -> go (i - 1) srcmaps  srcMapCodePos :: SourceCache -> SrcMap -> Maybe (FilePath, Int) srcMapCodePos cache sm =

@@ -46,6 +46,9 @@   , verb             :: Int   , simp             :: Bool   , onlyDeployed     :: Bool+  , earlyAbort       :: Bool+  , mergeMaxBudget   :: Int        -- ^ Max instructions for speculative merge exploration+  , maxDynSize       :: Int        -- ^ Max byte length for concretized dynamic types (bytes, string)   }   deriving (Show, Eq) @@ -65,6 +68,9 @@   , verb = 0   , simp = True   , onlyDeployed = False+  , earlyAbort = False+  , mergeMaxBudget = 100+  , maxDynSize = 64   }  -- Write to the console

@@ -2,7 +2,6 @@  import EVM hiding (createAddress) import EVM.Concrete (createAddress)-import EVM.FeeSchedule (feeSchedule) import EVM.Types  import Control.Monad.Trans.State.Strict (get, State)@@ -18,33 +17,13 @@  vmForEthrunCreation :: VMOps t => ByteString -> ST RealWorld (VM t) vmForEthrunCreation creationCode =-  (makeVm $ VMOpts+  (makeVm $ defaultVMOpts     { contract = initialContract (InitCode creationCode mempty)-    , otherContracts = []-    , calldata = mempty-    , value = Lit 0-    , baseState = EmptyBase     , address = createAddress ethrunAddress 1     , caller = LitAddr ethrunAddress     , origin = LitAddr ethrunAddress-    , coinbase = LitAddr 0-    , number = Lit 0-    , timestamp = Lit 0     , blockGaslimit = 0-    , gasprice = 0     , prevRandao = 42069-    , gas = toGas 0xffffffffffffffff-    , gaslimit = 0xffffffffffffffff-    , baseFee = 0-    , priorityFee = 0-    , maxCodeSize = 0xffffffff-    , schedule = feeSchedule-    , chainId = 1-    , create = False-    , txAccessList = mempty-    , allowFFI = False-    , freshAddresses = 0-    , beaconRoot = 0     }) <&> set (#env % #contracts % at (LitAddr ethrunAddress))              (Just (initialContract (RuntimeCode (ConcreteRuntimeCode "")))) 

@@ -4,17 +4,146 @@    Helper functions for working with Expr instances.    All functions here will return a concrete result if given a concrete input. -}-module EVM.Expr where+module EVM.Expr+  ( -- * Constants+    maxLit+  , maxLitSigned+  , minLitSigned -import Prelude hiding (LT, GT)+    -- * Stack Ops+  , op1+  , op2+  , op3+  , normArgs++    -- * Arithmetic+  , add+  , sub+  , mul+  , div+  , sdiv+  , mod+  , smod+  , addmod+  , mulmod+  , exp+  , sex++    -- * Comparisons / Booleans+  , lt+  , gt+  , leq+  , geq+  , slt+  , sgt+  , eq+  , iszero++    -- * Bit operations+  , and+  , or+  , xor+  , not+  , shl+  , shr+  , sar+  , clz++    -- * Props+  , peq+  , pleq++    -- * Buffers+  , readByte+  , readBytes+  , readWord+  , maxBytes+  , copySlice+  , writeByte+  , writeWord+  , bufLength+  , bufLengthEnv+  , minLength+  , concretePrefix+  , take+  , drop+  , toList+  , fromList+  , simplifyReads++    -- * Storage+  , readStorage'+  , readStorage+  , writeStorage+  , concStoreContains+  , getAddr+  , getLogicalIdx++    -- * Storage patterns / helpers+  , pattern MappingSlot+  , pattern ArraySlotWithOffs+  , pattern ArraySlotWithOffs2+  , pattern ArraySlotZero+  , idsDontMatch+  , slotPos+  , litToArrayPreimage+  , litToKeccak++    -- * Decomposition+  , safeToDecomposeProp+  , safeToDecompose+  , decomposeStorage++    -- * Simplification+  , simplify+  , simplifyProps+  , simplifyProp++    -- * Conversions+  , litAddr+  , litCode+  , exprToAddr+  , wordToAddr++    -- * Other helpers+  , isLitWord+  , isSuccess+  , isFailure+  , isPartial+  , isSymAddr+  , indexWord+  , padByte+  , joinBytes+  , eqByte+  , min+  , max+  , containsNode+  , inRange+  , preImages+  , constPropagate+  , concKeccakSimpExpr+  , concKeccakProps+  , concKeccakSimpProps+  , concKeccakOnePass+  , checkLHSConstProp+  , checkLHSConst+  , maybeLitByteSimp+  , maybeLitWordSimp+  , maybeLitAddrSimp+  , maybeConcStoreSimp+  ) where++import Prelude hiding (LT, GT, exp, drop, take, not, and, or, div, mod, min, max)+import Prelude qualified (div, mod, not, take, min, max) import Control.Monad (unless, when) import Control.Monad.ST (ST) import Control.Monad.State (put, get, execState, State)-import Data.Bits hiding (And, Xor)+import Data.Bits hiding (And, Xor, xor)+import Data.Bits qualified (xor) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.DoubleWord (Int256, Word256(Word256), Word128(Word128))-import Data.List+import Data.List (sort, find) import Data.Map qualified as LMap import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe, isJust, fromMaybe)@@ -30,8 +159,6 @@ import Witch (unsafeInto, into, tryInto) import Data.Containers.ListUtils (nubOrd) -import Optics.Core- import EVM.Traversals import EVM.Types @@ -202,6 +329,8 @@      else        fromIntegral $ shiftR asSigned (fromIntegral x)) +clz :: Expr EWord -> Expr EWord+clz = op1 CLZ (\x -> if x == 0 then 256 else fromIntegral $ countLeadingZeros x)  -- Props @@ -210,6 +339,7 @@ peq (LitAddr x) (LitAddr y) = PBool (x == y) peq (LitByte x) (LitByte y) = PBool (x == y) peq (ConcreteBuf x) (ConcreteBuf y) = PBool (x == y)+peq (ConcreteStore x) (ConcreteStore y) = PBool (x == y) peq a b   | a == b = PBool True   | otherwise = let args = sort [a, b]@@ -246,15 +376,25 @@   = if x == idx     then val     else readByte i src+readByte i@(Lit x) (WriteByte (And (Lit idx) _) _ src)+  | x > idx = readByte i src readByte i@(Lit x) (WriteWord (Lit idx) val src)   = if x - idx < 32     then case val of            (Lit _) -> indexWord (Lit $ x - idx) val            _ -> IndexWord (Lit $ x - idx) val     else readByte i src--- reading a byte that is lower than the dstOffset of a CopySlice, so it's just reading from dst-readByte i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst) | dstOffset > x =-  readByte i dst+-- reading a byte that is before the CopySlice destination region, so just read from dst+-- We must ensure dstOffset + size does not wrap past maxBound.+-- When size is symbolic, we bound dstOffset to ensure no wrapping is possible.+readByte i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst)+  | dstOffset > x+  , dstOffset <= (maxBound :: W256) - maxBytes+  = readByte i dst+readByte i@(Lit x) (CopySlice _ (Lit dstOffset) (Lit size) _ dst)+  | dstOffset > x+  , dstOffset + size >= dstOffset+  = readByte i dst readByte i@(Lit x) (CopySlice (Lit srcOffset) (Lit dstOffset) (Lit size) src dst)   = if x - dstOffset < size     then readByte (Lit $ x - (dstOffset - srcOffset)) src@@ -276,12 +416,59 @@ readBytes (Prelude.min 32 -> n) idx buf   = joinBytes [readByte (add idx (Lit . unsafeInto $ i)) buf | i <- [0 .. n - 1]] +-- | Static upper bound on a word expression (unsigned, no wrap), or Nothing.+upperBound :: Expr EWord -> Maybe W256+upperBound e = case (simplifyNoLitToKeccak e) of+  Lit n         -> Just n+  And (Lit m) _ -> Just m+  Mod _ (Lit b)+    | b == 0    -> Just 0+    | otherwise -> Just (b - 1)+  Div a (Lit b)+    | b == 0    -> Just 0+    | otherwise -> upperBound a >>= \ua -> Just (ua `Prelude.div` b)+  Mul (Lit a) b -> mulBound a b+  Add (Lit a) b -> addBound a b+  SHR (Lit n) b+    | n >= 256  -> Just 0+    | otherwise -> upperBound b >>= \ub ->+        Just (ub `shiftR` fromIntegral n)+  _ -> Nothing+  where+    mulBound a b+      | a == 0    = Just 0+      | otherwise = upperBound b >>= \ub ->+          if ub == 0 then Just 0+          else if ub <= (maxBound :: W256) `Prelude.div` a then Just (a * ub)+          else Nothing+    addBound a b = upperBound b >>= \ub ->+      if a <= (maxBound :: W256) - ub then Just (a + ub) else Nothing++-- | True if the WriteWord at @wIdx@ is provably disjoint from the 32-byte+--   read at @i@. Sound mod 2^256: requires both windows to fit below 2^256.+writeDisjointFromReadWord :: W256 -> Expr EWord -> Bool+writeDisjointFromReadWord i = \case+  Add (Lit c) x+    | Just ux <- upperBound x ->+        let cI        = toInteger c+            uxI       = toInteger ux+            iI        = toInteger i+            maxI      = toInteger (maxBound :: W256)+            writeMaxI = cI + uxI + 31+            readMaxI  = iI + 31+        in readMaxI <= maxI+           && writeMaxI <= maxI+           && (cI > readMaxI || writeMaxI < iI)+  _ -> False+ -- | 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+  -- WriteWord provably disjoint via interval bounds (Add (Lit c) X, X bounded)+  | Lit i <- idx, writeDisjointFromReadWord i idx' = readWord idx buf   | otherwise = case (idx, idx') of     (Lit i, Lit i') ->       if i' - i >= 32 && i' - i <= (maxBound :: W256) - 31@@ -294,9 +481,28 @@     _ -> 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) (Lit size) _ dst) | x >= dstOffset + size = readWord i dst+-- reading a Word that is before the CopySlice destination region, so just read from dst+-- We must ensure x+32 and dstOffset+size do not wrap past maxBound.+-- When size is symbolic, we bound dstOffset to ensure no wrapping is possible.+readWord i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst)+  | dstOffset >= x + 32+  , x + 32 >= x+  , dstOffset <= (maxBound :: W256) - maxBytes+  = readWord i dst+readWord i@(Lit x) (CopySlice _ (Lit dstOffset) (Lit size) _ dst)+  | dstOffset >= x + 32+  , x + 32 >= x+  , dstOffset + size >= dstOffset+  = readWord i dst+-- reading a Word that is past the end of the CopySlice destination region+readWord i@(Lit x) (CopySlice _ (Lit dstOffset) _ _ dst)+  | x >= dstOffset + maxBytes+  , dstOffset + maxBytes >= dstOffset+  = readWord i dst+readWord i@(Lit x) (CopySlice _ (Lit dstOffset) (Lit size) _ dst)+  | x >= dstOffset + size+  , dstOffset + size >= dstOffset+  = 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@@ -309,12 +515,24 @@ -- Attempts to read a concrete word from a buffer by reading 32 individual bytes and joining them together -- returns an abstract ReadWord expression if a concrete word cannot be constructed readWordFromBytes :: Expr EWord -> Expr Buf -> Expr EWord-readWordFromBytes (Lit idx) (ConcreteBuf bs) =-  case tryInto idx of-    Left _ -> Lit 0-    Right i -> Lit $ word $ padRight 32 $ BS.take 32 $ BS.drop i bs+readWordFromBytes (Lit idx) (ConcreteBuf bs)+  =  case tryInto idx of+      Right i -> Lit $ word $ padRight 32 $ BS.take 32 $ BS.drop i bs+      Left _ -> if noOverflow then Lit 0 else Lit . word $ wrappedBytes+        where+          noOverflow = idx <= (maxBound :: W256) - 31+          wrappedBytes = zeroes <> bytesFromBeginning+          fromEnd :: Int = fromIntegral ((maxBound :: W256) - idx + 1)+          fromBeginning = 32 - fromEnd+          zeroes = BS.replicate fromEnd 0+          bytesFromBeginning = padRight 32 $ BS.take fromBeginning bs++ readWordFromBytes idx buf@(AbstractBuf _) = ReadWord idx buf-readWordFromBytes i@(Lit idx) buf = let+readWordFromBytes i@(Lit idx) buf+  -- idx+31 must not wrap past maxBound (would make [idx..idx+31] empty)+  | idx + 31 < idx = ReadWord i buf+  | otherwise = let     bytes = [readByte (Lit i') buf | i' <- [idx .. idx + 31]]   in if all isLitByte bytes      then Lit (bytesToW256 . mapMaybe maybeLitByteSimp $ bytes)@@ -355,19 +573,20 @@ -- Fully concrete copy copySlice a@(Lit srcOffset) b@(Lit dstOffset) c@(Lit size) d@(ConcreteBuf src) e@(ConcreteBuf dst)   | dstOffset < maxBytes-  , size < maxBytes =-      let hd = padRight (unsafeInto dstOffset) $ BS.take (unsafeInto dstOffset) dst-          sl = if srcOffset > unsafeInto (BS.length src)-            then BS.replicate (unsafeInto size) 0-            else padRight (unsafeInto size) $ BS.take (unsafeInto size) (BS.drop (unsafeInto srcOffset) src)-          tl = BS.drop (unsafeInto dstOffset + unsafeInto size) dst-      in ConcreteBuf $ hd <> sl <> tl+  , size < maxBytes+  , srcOffset + size >= srcOffset -- srcOffset must not wrap+  = let hd = padRight (unsafeInto dstOffset) $ BS.take (unsafeInto dstOffset) dst+        sl = if srcOffset > unsafeInto (BS.length src)+          then BS.replicate (unsafeInto size) 0+          else padRight (unsafeInto size) $ BS.take (unsafeInto size) (BS.drop (unsafeInto srcOffset) src)+        tl = BS.drop (unsafeInto dstOffset + unsafeInto size) dst+    in ConcreteBuf $ hd <> sl <> tl   | otherwise = CopySlice a b c d e  -- concrete indices & abstract src (may produce a concrete result if we are -- copying from a concrete region of src) copySlice s@(Lit srcOffset) d@(Lit dstOffset) sz@(Lit size) src ds@(ConcreteBuf dst)-  | dstOffset < maxBytes, size < maxBytes, srcOffset + (size-1) > srcOffset = let+  | dstOffset < maxBytes, size < maxBytes, srcOffset + (size-1) >= srcOffset = let     hd = padRight (unsafeInto dstOffset) $ BS.take (unsafeInto dstOffset) dst     sl = [readByte (Lit i) src | i <- [srcOffset .. srcOffset + (size - 1)]]     tl = BS.drop (unsafeInto dstOffset + unsafeInto size) dst@@ -376,6 +595,9 @@        else CopySlice s d sz src ds   | otherwise = CopySlice s d sz src ds +copySlice srcOff dstOff (Lit size) (WriteWord srcOff2 val _) dstBuff+  | size < 32 && srcOff == srcOff2 = copySlice (Lit 0) dstOff (Lit size) (WriteWord (Lit 0) val (ConcreteBuf "")) dstBuff+ -- abstract indices copySlice srcOffset dstOffset size src dst = CopySlice srcOffset dstOffset size src dst @@ -521,11 +743,6 @@           _ -> pure (i, v)  -word256At :: Expr EWord -> Lens (Expr Buf) (Expr Buf) (Expr EWord) (Expr EWord)-word256At i = lens getter setter where-  getter = readWord i-  setter m x = writeWord i x m- -- | Returns the first n bytes of buf take :: W256 -> Expr Buf -> Expr Buf take n = slice (Lit 0) (Lit n)@@ -1051,13 +1268,28 @@     go (IsZero (IsZero (Eq x y))) = eq x y     go (IsZero (IsZero a)) = lt (Lit 0) a     go (IsZero (Xor x y)) = eq x y+    go (IsZero (Sub a b)) = eq a b+    go (IsZero (Or a b)) = EVM.Expr.and (iszero a) (iszero b)     go (IsZero a) = iszero a +    -- ITE (if-then-else) simplification for path merging+    go (ITE (Lit 0) _ f) = f+    go (ITE (Lit _) t _) = t+    go (ITE _ t f) | t == f = t+    go (ITE c (ITE c' a _) d) | c == c' = ITE c a d -- nested same condition in then+    go (ITE c a (ITE c' _ d)) | c == c' = ITE c a d -- nested same condition in else+     -- syntactic Eq reduction     go (Eq (Lit a) (Lit b))       | a == b = Lit 1       | otherwise = Lit 0     go (Eq (Lit 0) (Sub a b)) = eq a b+    go (Eq (Lit 0) (Xor a b)) = eq a b+    go (Eq (Add a b) c)+      | a == c = iszero b+      | b == c = iszero a+    go (Eq (Sub a b) c) | a == c = iszero b+     go (Eq (Lit 0) a) = iszero a     go (Eq a b)       | a == b = Lit 1@@ -1096,6 +1328,7 @@      -- LT     go (EVM.Types.LT _ (Lit 0)) = Lit 0+    go (EVM.Types.LT (Lit a) _) | a == maxLit = Lit 0     go (EVM.Types.LT a (Lit 1)) = iszero a     go (EVM.Types.LT a b) = lt a b @@ -1116,7 +1349,9 @@      -- Mod     go (Mod _ (Lit 0)) = Lit 0+    go (Mod _ (Lit 1)) = Lit 0     go (SMod _ (Lit 0)) = Lit 0+    go (SMod _ (Lit 1)) = Lit 0     go (Mod a b) | a == b = Lit 0     go (SMod a b) | a == b = Lit 0     go (Mod (Lit 0) _) = Lit 0@@ -1201,6 +1436,13 @@       | b == c = a       | otherwise = sub (add a b) c +    -- Order sub/add around+    go (Sub (Sub a b) c) = sub a (add b c)+    go (Sub a (Sub b c)) = add (sub a b) c++    -- Negation: ~x + 1 = 0 - x (two's complement)+    go (Add (Lit 1) (Not b)) = Sub (Lit 0) b+     -- add / sub identities     go (Add a b)       | b == (Lit 0) = a@@ -1212,11 +1454,25 @@       | otherwise = sub a b      -- XOR normalization+    go (Xor a b) | a == b = Lit 0+    go (Xor (Lit 0) a) = a+    go (Xor (Lit a) b) | a == maxLit = EVM.Expr.not b     go (Xor a  b) = EVM.Expr.xor a b +    -- Not simplification+    go (EVM.Types.Not (EVM.Types.Not a)) = a+    go (Not a) = EVM.Expr.not a++    -- EqByte     go (EqByte a b) = eqByte a b      -- SHL / SHR / SAR+    go (SHL (Lit a) _) | a >= 256 = Lit 0+    go (SHR (Lit a) _) | a >= 256 = Lit 0+    go (SHL (Lit n) (SHR (Lit m) x)) -- zero out LSB+      | n == m && n < 256 = EVM.Expr.and (Lit (shiftL maxLit (fromIntegral n))) x+    go (SHR (Lit n) (SHL (Lit m) x)) -- zero out MSB+      | n == m && n < 256 = EVM.Expr.and (Lit (shiftR maxLit (fromIntegral n))) x     go (SHL a v)       | a == (Lit 0) = v       | v == (Lit 0) = v@@ -1230,8 +1486,12 @@        | a == (Lit 0) = v        | v == (Lit 0) = v        | otherwise = sar a v+    go (CLZ v) = clz v      -- Bitwise AND & OR. These MUST preserve bitwise equivalence+    go (And a (Or b _)) | a == b = a+    go (And a (Or _ b)) | a == b = a+     go (And a b)       | a == b = a       | b == (Not a) || a == (Not b) = Lit 0@@ -1239,14 +1499,15 @@       | a == (Lit maxLit) = b       | b == (Lit maxLit) = a       | otherwise = EVM.Expr.and a b+    go (Or a (And b _)) | a == b = a+    go (Or a (And _ b)) | a == b = a     go (Or a b)       | a == b = a       | a == (Lit 0) = b       | b == (Lit 0) = a+      | a == (Lit maxLit) || b == (Lit maxLit) = Lit maxLit       | otherwise = EVM.Expr.or a b -    -- Double NOT is a no-op, since it's a bitwise inversion-    go (EVM.Types.Not (EVM.Types.Not a)) = a      -- Some trivial min / max eliminations     go (Max a b) = EVM.Expr.max a b@@ -1259,6 +1520,7 @@     go (Mul a b) = case (a, b) of                      (Lit 0, _) -> Lit 0                      (Lit 1, _) -> b+                     (Lit v, _) | v == maxLit -> Sub (Lit 0) b                      _ -> mul a b      -- Some trivial (s)div eliminations@@ -1396,10 +1658,17 @@     go (POr x (PBool False)) = x     go (POr (PBool False) x) = x +    -- Absoption rules+    go (PAnd a (POr b _)) | a == b = a+    go (PAnd a (POr _ b)) | a == b = a+    go (POr a (PAnd b _)) | a == b = a+    go (POr a (PAnd _ b)) | a == b = a+     -- Imply     go (PImpl _ (PBool True)) = PBool True     go (PImpl (PBool True) b) = b     go (PImpl (PBool False) _) = PBool True+    go (PImpl a b) | a == b = PBool True       go p = p@@ -1636,9 +1905,6 @@ max (Lit 0) y = y max x (Lit 0) = x max x y = normArgs Max Prelude.max x y--allLit :: [Expr Byte] -> Bool-allLit = all isLitByte  -- | True if the given expression contains any node that satisfies the -- input predicate

@@ -51,6 +51,7 @@   , g_warm_storage_read :: n   , g_access_list_address :: n   , g_access_list_storage_key :: n+  , g_txdatafloor :: n   } deriving Show  feeSchedule :: Num n => FeeSchedule n@@ -105,4 +106,5 @@   , g_warm_storage_read = 100   , g_access_list_address = 2400   , g_access_list_storage_key = 1900+  , g_txdatafloor = 10   }

@@ -47,7 +47,7 @@ import Data.Aeson.Encode.Pretty (encodePretty) import qualified Data.ByteString.Lazy as BSL import Data.Bifunctor (first)-import Control.Exception (try, SomeException)+import Control.Exception (SomeException, SomeAsyncException(..), try, catches, Handler(..), throwIO)  import Data.Aeson hiding (Error) import Data.Aeson.Optics@@ -69,7 +69,11 @@ import Control.Monad (when) import EVM.Effects import qualified EVM.Expr as Expr+import Control.Concurrent (threadDelay) import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)+import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef')+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, addUTCTime)+import System.Random (randomRIO)  type Fetcher t m = App m => Query t -> m (EVM t ()) @@ -91,6 +95,9 @@   -- These are NOT persisted to disk   , failedContracts :: MVar (Set Addr)   , failedSlots     :: MVar (Set (Addr, W256))+  -- Shared rate limit cooldown across workers. When any worker hits a+  -- rate limit, it sets a deadline; other workers wait before retrying.+  , rpcThrottle     :: IORef (Maybe UTCTime)   }  data FetchCache = FetchCache@@ -276,6 +283,64 @@       <*> v .: "maxCodeSize"       <*> pure feeSchedule +-- | Wait if there's an active cooldown from a recent rate limit.+waitForCooldown :: IORef (Maybe UTCTime) -> IO ()+waitForCooldown ref = do+  mDeadline <- readIORef ref+  case mDeadline of+    Nothing -> pure ()+    Just deadline -> do+      now <- getCurrentTime+      let diff = diffUTCTime deadline now+      when (diff > 0) $+        threadDelay (ceiling (realToFrac diff * 1_000_000 :: Double))++-- | Set a cooldown deadline. Keeps the longer of existing vs new deadline.+setCooldown :: IORef (Maybe UTCTime) -> Int -> IO ()+setCooldown ref delayUs = do+  now <- getCurrentTime+  let newDeadline = addUTCTime (realToFrac delayUs / 1_000_000) now+  atomicModifyIORef' ref $ \existing ->+    let deadline = case existing of+          Just d | d > newDeadline -> d+          _ -> newDeadline+    in (Just deadline, ())++-- | Retry an IO action on exception with exponential backoff + jitter.+-- Uses a shared cooldown so all workers back off together.+-- Only retries synchronous exceptions (network errors, HTTP 429, etc.).+-- Re-throws all async exceptions (Timeout, ThreadKilled).+-- RPC-level errors (Left) are NOT retried — they pass through.+withRetry :: Bool -> IORef (Maybe UTCTime) -> IO (Either Text a) -> IO (Either Text a)+withRetry debug throttle action = go 1+  where+  maxRetries = 5 :: Int+  go attempt = do+    waitForCooldown throttle+    result <- catches (Right <$> action)+      [ Handler $ \(SomeAsyncException e) -> throwIO e+      , Handler $ \(e :: SomeException) -> pure $ Left e+      ]+    case result of+      Right r -> pure r+      Left e+        | attempt <= maxRetries -> do+            let baseDelayUs = 500_000 * (2 ^ (attempt - 1)) :: Int+            jitter <- randomRIO (0, baseDelayUs)+            let delayUs = baseDelayUs + jitter+            setCooldown throttle delayUs+            when debug $ putStrLn $+              "RPC retry " <> show attempt <> "/" <> show maxRetries+              <> " in " <> show (delayUs `div` 1000) <> "ms"+            threadDelay delayUs+            go (attempt + 1)+        | otherwise ->+            pure $ Left $ pack $ show e++-- | Like fetchWithSession but with retry + shared cooldown from Session.+fetchWithRetry :: Bool -> Text -> Session -> Value -> IO (Either Text Value)+fetchWithRetry debug url session = withRetry debug session.rpcThrottle . fetchWithSession url session.sess+ fetchWithSession :: Text -> NetSession.Session -> Value -> IO (Either Text Value) fetchWithSession url sess x = do   r <- asValue =<< NetSession.post sess (unpack url) x@@ -306,7 +371,7 @@         -- Attempt fetch         when (conf.debug) $ putStrLn $ "-> Fetching contract at " ++ show addr         let fetch :: Show a => RpcQuery a -> IO (Either Text a)-            fetch = fetchQuery n (fetchWithSession url sess.sess)+            fetch = fetchQuery n (fetchWithRetry conf.debug url sess)          codeRes <- fetch (QueryCode addr)         nonceRes <- fetch (QueryNonce addr)@@ -373,7 +438,7 @@       else do         -- Attempt fetch         when (conf.debug) $ putStrLn $ "-> Fetching slot " <> show slot <> " at " <> show addr-        ret <- fetchSlotWithSession sess.sess n url addr slot+        ret <- fetchQuery n (fetchWithRetry conf.debug url sess) (QuerySlot addr slot)         case ret of           Right val -> do             -- Success: cache it@@ -436,7 +501,7 @@ 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+  ret <- fetchQuery n (fetchWithRetry conf.debug url sess) QueryBlock   case ret of     Left _ -> pure Nothing     Right b -> do@@ -489,16 +554,17 @@   -- Initialize ephemeral failure tracking   failedContracts <- liftIO $ newMVar Set.empty   failedSlots <- liftIO $ newMVar Set.empty-  pure $ Session sess latestBlockNum cache cacheDir failedContracts failedSlots+  rpcThrottle <- liftIO $ newIORef Nothing+  pure $ Session sess latestBlockNum cache cacheDir failedContracts failedSlots rpcThrottle  mkSessionWithoutCache :: App m => m Session mkSessionWithoutCache = mkSession Nothing Nothing  -- Only used for testing (test.hs, BlockchainTests.hs)-zero :: Natural -> Maybe Natural -> Fetcher t m-zero smtjobs smttimeout q = do+zero :: Natural -> Maybe Natural -> Natural -> Fetcher t m+zero smtjobs smttimeout maxMemoryMB q = do   sess <- mkSessionWithoutCache-  withSolvers Z3 smtjobs 1 smttimeout $ \s ->+  withSolvers Z3 smtjobs smttimeout maxMemoryMB $ \s ->     oracle s (Just sess) noRpc q  noRpcFetcher :: forall t m . App m => SolverGroup -> Fetcher t m@@ -569,7 +635,7 @@             when (conf.debug) $ liftIO $ putStrLn $ "Fetching slot " <> (show slot) <> " at " <> (show addr)             let (block, url) = fromJust rpcInfo.blockNumURL             n <- liftIO $ getLatestBlockNum conf sess block url-            ret <- liftIO $ fetchSlotWithSession sess.sess n url addr slot+            ret <- liftIO $ fetchQuery n (fetchWithRetry conf.debug url sess) (QuerySlot addr slot)             case ret of               Right val -> do                 liftIO $ modifyMVar_ sess.sharedCache $ \c ->

@@ -5,6 +5,7 @@   , formatSomeExpr   , formatPartial   , formatPartialDetailed+  , formatCaveat   , formatProp   , formatState   , formatError@@ -39,9 +40,10 @@  import EVM (traceForest, traceForest', traceContext, cheatCode) import EVM.ABI (getAbiSeq, parseTypeName, AbiValue(..), AbiType(..), SolError(..), Indexed(..), Event(..))+import EVM.ConsoleLog (formatConsoleLog) import EVM.Dapp (DappContext(..), DappInfo(..), findSrc, showTraceLocation) import EVM.Expr qualified as Expr-import EVM.Solidity (SolcContract(..), Method(..), SrcMap (..), WarningData (..), SourceCache(..))+import EVM.Solidity (SolcContract(..), Method(..)) import EVM.Types import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp) @@ -69,8 +71,6 @@ 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)@@ -330,6 +330,8 @@     ReturnTrace out (CreationContext {}) ->       let l = Expr.bufLength out       in "← " <> formatExpr l <> " bytes of code"+    ConsoleLog buf ->+      "\x1b[36m" <> formatConsoleLog buf <> "\x1b[0m"     EntryTrace t ->       t     FrameTrace (CreationContext { address }) ->@@ -440,6 +442,7 @@   NonceOverflow -> "Nonce overflow"   BadCheatCode reason a -> "Bad cheat code: " <>  reason <> " sig: " <> show a   NonexistentFork a -> "Fork ID does not exist: " <> show a+  AssumeCheatFailed -> "Assume failed"  prettyvmresult :: Expr End -> String prettyvmresult (Failure _ _ (Revert (ConcreteBuf ""))) = "Revert"@@ -523,10 +526,16 @@       , "program counter: " <> pack (show pc)]     ] +-- | Render a program-wide soundness caveat (see 'Caveat').+formatCaveat :: Caveat -> Text+formatCaveat = \case+  DynArgBounded maxSz ->+    "Dynamic (bytes/string) arguments were bounded to " <> pack (show maxSz) <>+    " bytes; counterexamples requiring longer inputs may be missed." -formatPartialDetailed :: Maybe (WarningData t) -> PartialExec -> Text-formatPartialDetailed warnData p =-  let toTxt addr pc = pack $ getSrcInfo warnData addr pc+formatPartialDetailed :: Maybe SrcLookup -> Map.Map (Expr EAddr) Contract -> PartialExec -> Text+formatPartialDetailed srcLookupM contracts p =+  let toTxt addr pc = pack $ runSrcLookup srcLookupM contracts 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@@ -535,20 +544,6 @@     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 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 @@ -654,6 +649,7 @@       Eq a b -> fmt "Eq" [a, b]       EqByte a b -> fmt "EqByte" [a, b]       IsZero a -> fmt "IsZero" [a]+      ITE c t el -> fmt "ITE" [c, t, el]        And a b -> fmt "And" [a, b]       Or a b -> fmt "Or" [a, b]@@ -662,6 +658,7 @@       SHL a b -> fmt "SHL" [a, b]       SHR a b -> fmt "SHR" [a, b]       SAR a b -> fmt "SAR" [a, b]+      CLZ a -> fmt "CLZ" [a]        e@Origin -> T.pack (show e)       e@Coinbase -> T.pack (show e)@@ -837,7 +834,6 @@        -- Hashes       Keccak b -> fmt "Keccak" [b]-      SHA256 b -> fmt "SHA256" [b]       where         fmt nm args = T.unlines           [ "(" <> nm

@@ -0,0 +1,142 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | State merging for symbolic execution+--+-- This module provides functions for merging execution paths during symbolic+-- execution. Instead of forking on every JUMPI, we can speculatively execute+-- both paths and merge them using ITE (If-Then-Else) expressions when:+--+-- 1. Both paths converge to the same PC (forward jump pattern)+-- 2. Neither path has side effects (storage, memory, logs unchanged)+-- 3. Both paths have the same stack depth+--+-- This reduces path explosion from 2^N to linear in many common patterns.++module EVM.Merge+  ( tryMergeForwardJump+  ) where++import Control.Monad (when)+import Control.Monad.State.Strict (get, put)+import Debug.Trace (traceM)+import Optics.Core+import Optics.State++import EVM.Effects (Config(..))+import EVM.Expr qualified as Expr+import EVM.Types++-- | Execute instructions speculatively until target PC is reached or+-- we hit budget limit/SMT query/RPC call/revert/error.+speculateLoopOuter+  :: Config+  -> EVM Symbolic ()  -- ^ Single-step executor+  -> Int              -- ^ Target PC+  -> EVM Symbolic (Maybe (VM Symbolic))+speculateLoopOuter conf exec1Step targetPC = do+    -- Initialize merge state for this speculation+    let budget = conf.mergeMaxBudget+    modifying #mergeState $ \ms -> ms { msActive = True , msRemainingBudget = budget }+    res <- speculateLoop conf exec1Step targetPC+    -- Reset merge state+    assign #mergeState defaultMergeState+    pure res++-- | Inner loop for speculative execution with budget tracking+speculateLoop+  :: Config+  -> EVM Symbolic ()  -- ^ Single-step executor+  -> Int              -- ^ Target PC+  -> EVM Symbolic (Maybe (VM Symbolic))+speculateLoop conf exec1Step targetPC = do+    ms <- use #mergeState+    if ms.msRemainingBudget <= 0+      then pure Nothing  -- Budget exhausted+      else do+        pc <- use (#state % #pc)+        result <- use #result+        case result of+          Just _ -> pure Nothing  -- Hit RPC call/revert/SMT query/etc.+          Nothing+            | pc == targetPC -> Just <$> get  -- Reached target+            | otherwise -> do+                -- Decrement budget and execute one instruction+                modifying #mergeState $ \s -> s { msRemainingBudget = subtract 1 s.msRemainingBudget }+                exec1Step+                speculateLoop conf exec1Step targetPC++-- | Try to merge a forward jump (skip block pattern) for Symbolic execution+-- Returns True if merge succeeded, False if we should fall back to forking+-- SOUNDNESS: Both paths (jump and fall-through) must converge to the same PC,+-- have the same stack depth, and have no side effects. Only then can we merge.+tryMergeForwardJump+  :: Config+  -> EVM Symbolic ()  -- ^ Single-step executor+  -> Int              -- ^ Current PC+  -> Int              -- ^ Jump target PC+  -> Expr EWord       -- ^ Branch condition+  -> [Expr EWord]     -- ^ Stack after popping JUMPI args+  -> EVM Symbolic Bool+tryMergeForwardJump conf exec1Step currentPC jumpTarget cond stackAfterPop = do+  -- Only handle forward jumps (skip block pattern)+  if jumpTarget <= currentPC+  then pure False  -- Not a forward jump+  else do+    vm0 <- get++    -- Skip merge if memory is mutable (ConcreteMemory)+    case vm0.state.memory of+      ConcreteMemory _ -> pure False+      SymbolicMemory _ -> do+        -- True branch (jump taken): Just sets PC to target, no execution needed+        let trueStack = stackAfterPop  -- Stack after popping JUMPI args++        -- False branch (fall through): Execute until we reach jump target+        assign' (#state % #stack) stackAfterPop+        modifying' (#state % #pc) (+ 1)  -- Move past JUMPI+        maybeVmFalse <- speculateLoopOuter conf exec1Step jumpTarget++        case maybeVmFalse of+          Nothing -> put vm0 >> pure False -- can't merge: EVM error, SMT/RPC query, over-budget+          Just vmFalse -> do+            let falseStack = vmFalse.state.stack+                soundnessOK = checkNoSideEffects vm0 vmFalse++            -- Check merge conditions: same stack depth AND no side effects+            if length trueStack == length falseStack && soundnessOK+              then do+                -- Merge stacks using ITE expressions, simplifying to prevent growth+                let condSimp = Expr.simplify cond+                    mergeExpr t f = Expr.simplify $ ITE condSimp t f+                    mergedStack = zipWith mergeExpr trueStack falseStack+                -- Use vm0 as base and update only PC and stack+                when conf.debug $ traceM $ "Merged forward jump"+                  <> runSrcLookup vm0.srcLookup vm0.env.contracts vm0.state.contract jumpTarget+                put vm0+                assign (#state % #pc) jumpTarget+                assign (#state % #stack) mergedStack+                assign #result Nothing+                assign (#mergeState % #msActive) False+                pure True+              else put vm0 >> pure False -- can't merge: stack depth or state differs++-- | Check that execution had no side effects (storage, memory, logs, etc.)+checkNoSideEffects :: VM Symbolic -> VM Symbolic -> Bool+checkNoSideEffects vm0 vmAfter =+  let memoryUnchanged = case (vm0.state.memory, vmAfter.state.memory) of+        (SymbolicMemory m1, SymbolicMemory m2) -> m1 == m2+        _ -> False+      memorySizeUnchanged = vm0.state.memorySize == vmAfter.state.memorySize+      returndataUnchanged = vm0.state.returndata == vmAfter.state.returndata+      storageUnchanged = vm0.env.contracts == vmAfter.env.contracts+      logsUnchanged = vm0.logs == vmAfter.logs+      constraintsUnchanged = vm0.constraints == vmAfter.constraints+      keccakUnchanged = vm0.keccakPreImgs == vmAfter.keccakPreImgs+      freshVarUnchanged = vm0.freshVar == vmAfter.freshVar+      framesUnchanged = length vm0.frames == length vmAfter.frames+      subStateUnchanged = vm0.tx.subState == vmAfter.tx.subState+  in memoryUnchanged && memorySizeUnchanged && returndataUnchanged+     && storageUnchanged && logsUnchanged && constraintsUnchanged+     && keccakUnchanged && freshVarUnchanged+     && framesUnchanged && subStateUnchanged

@@ -45,6 +45,7 @@     0x1b -> "SHL"     0x1c -> "SHR"     0x1d -> "SAR"+    0x1e -> "CLZ"     0x20 -> "SHA3"     0x30 -> "ADDRESS"     --@@ -206,6 +207,7 @@   OpShl -> "SHL"   OpShr -> "SHR"   OpSar -> "SAR"+  OpClz -> "CLZ"   OpSha3 -> "SHA3"   OpAddress -> "ADDRESS"   OpBalance -> "BALANCE"@@ -273,6 +275,7 @@ readOp x xs =   (\n -> Expr.readBytes (into n) (Lit 0) (Expr.fromList $ V.fromList xs)) <$> getOp x +{-# INLINE getOp #-} getOp :: Word8 -> GenericOp Word8 getOp x | x >= 0x80 && x <= 0x8f = OpDup (x - 0x80 + 1) getOp x | x >= 0x90 && x <= 0x9f = OpSwap (x - 0x90 + 1)@@ -305,6 +308,7 @@   0x1b -> OpShl   0x1c -> OpShr   0x1d -> OpSar+  0x1e -> OpClz   0x20 -> OpSha3   0x30 -> OpAddress   0x31 -> OpBalance

@@ -31,6 +31,7 @@ import Prelude hiding (LT, GT, Foldable(..))  import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT(..)) import Data.Containers.ListUtils (nubOrd, nubInt) import Data.ByteString (ByteString) import Data.ByteString qualified as BS@@ -475,6 +476,11 @@   IsZero a -> do     cond <- op2 "=" a (Lit 0)     pure $ "(ite " <> cond `sp` one `sp` zero <> ")"+  ITE c t f -> do+    condEnc <- exprToSMT c+    thenEnc <- exprToSMT t+    elseEnc <- exprToSMT f+    pure $ "(ite (distinct " <> condEnc `sp` zero <> ") " <> thenEnc `sp` elseEnc <> ")"   And a b -> op2 "bvand" a b   Or a b -> op2 "bvor" a b   Xor a b -> op2 "bvxor" a b@@ -482,6 +488,7 @@   SHL a b -> op2 "bvshl" b a   SHR a b -> op2 "bvlshr" b a   SAR a b -> op2 "bvashr" b a+  CLZ a -> op1 "clz256" a   SEx a b -> op2 "signext" a b   Div a b -> op2CheckZero "bvudiv" a b   SDiv a b -> op2CheckZero "bvsdiv" a b@@ -511,10 +518,6 @@     enc <- exprToSMT a     sz  <- exprToSMT $ Expr.bufLength a     pure $ "(keccak " <> enc <> " " <> sz <> ")"-  SHA256 a -> do-    enc <- exprToSMT a-    sz  <- exprToSMT $ Expr.bufLength a-    pure $ "(sha256 " <> enc <> " " <> sz <> ")"    TxValue -> pure $ fromString "txvalue"   Balance a -> pure $ fromString "balance_" <> formatEAddr a@@ -742,9 +745,6 @@ parseSC (SCBinary a) = readOrError Numeric.readBin a parseSC sc = internalError $ "cannot parse: " <> show sc -parseErr :: (Show a) => a -> b-parseErr res = internalError $ "cannot parse solver response: " <> show res- parseVar :: TS.Text -> Expr EWord parseVar = Var @@ -772,67 +772,59 @@   | Just a <- TS.stripPrefix "codehash_" name = CodeHash (parseEAddr a)   | otherwise = internalError $ "cannot parse " <> (TS.unpack name) <> " into an Expr" -getAddrs :: (TS.Text -> Expr EAddr) -> (Text -> IO Text) -> [TS.Text] -> IO (Map (Expr EAddr) Addr)-getAddrs parseName getVal names = Map.mapKeys parseName <$> foldM (getOne parseAddr getVal) mempty names+type ValGetter = Text -> MaybeIO Text -getVars :: (TS.Text -> Expr EWord) -> (Text -> IO Text) -> [TS.Text] -> IO (Map (Expr EWord) W256)-getVars parseName getVal names = Map.mapKeys parseName <$> foldM (getOne parseW256 getVal) mempty names+getAddrs :: (TS.Text -> Expr EAddr) -> ValGetter -> [TS.Text] -> MaybeIO (Map (Expr EAddr) Addr)+getAddrs parseName getVal names = do+  m <- foldM (getOne parseAddr getVal) mempty names+  pure $ Map.mapKeys parseName m -getOne :: (SpecConstant -> a) -> (Text -> IO Text) -> Map TS.Text a -> TS.Text -> IO (Map TS.Text a)+getVars :: (TS.Text -> Expr EWord) -> ValGetter -> [TS.Text] -> MaybeIO (Map (Expr EWord) W256)+getVars parseName getVal names = do+  m <- foldM (getOne parseW256 getVal) mempty names+  pure $ Map.mapKeys parseName m++getOne :: (SpecConstant -> a) -> ValGetter -> Map TS.Text a -> TS.Text -> MaybeIO (Map TS.Text a) getOne parseVal getVal acc name = do   raw <- getVal (T.fromStrict name)-  let-    parsed = case parseCommentFreeFileMsg getValueRes (T.toStrict raw) of-      Right (ResSpecific (valParsed :| [])) -> valParsed-      r -> parseErr r-    val = case parsed of-      (TermQualIdentifier (-        Unqualified (IdSymbol symbol)),-        TermSpecConstant sc)-          -> if symbol == name-             then parseVal sc-             else internalError "solver did not return model for requested value"-      r -> parseErr r+  val <- hoistMaybe $ do+    Right (ResSpecific (valParsed :| [])) <- pure $ parseCommentFreeFileMsg getValueRes (T.toStrict raw)+    (TermQualIdentifier (Unqualified (IdSymbol symbol)), TermSpecConstant sc) <- pure valParsed+    guard (symbol == name)+    pure $ parseVal sc   pure $ Map.insert name val acc  -- | Queries the solver for models for each of the expressions representing the -- max read index for a given buffer-queryMaxReads :: (Text -> IO Text) -> Map Text (Expr EWord)  -> IO (Map Text W256)+queryMaxReads :: ValGetter -> Map Text (Expr EWord) -> MaybeIO (Map Text W256) queryMaxReads getVal maxReads = mapM (queryValue getVal) maxReads  -- | Gets the initial model for each buffer, these will often be much too large for our purposes-getBufs :: (Text -> IO Text) -> [Text] -> IO (Map (Expr Buf) BufModel)+getBufs :: ValGetter -> [Text] -> MaybeIO (Map (Expr Buf) BufModel) getBufs getVal bufs = foldM getBuf mempty bufs   where-    getLength :: Text -> IO W256+    getLength :: Text -> MaybeIO W256     getLength name = do       val <- getVal (name <> "_length ")-      pure $ case parseCommentFreeFileMsg getValueRes (T.toStrict val) of-        Right (ResSpecific (parsed :| [])) -> case parsed of-          (TermQualIdentifier (Unqualified (IdSymbol symbol)), (TermSpecConstant sc))-            -> if symbol == (T.toStrict $ name <> "_length")-               then parseW256 sc-               else internalError "solver did not return model for requested value"-          res -> parseErr res-        res -> parseErr res+      hoistMaybe $ do+        Right (ResSpecific (parsed :| [])) <- pure $ parseCommentFreeFileMsg getValueRes (T.toStrict val)+        (TermQualIdentifier (Unqualified (IdSymbol symbol)), TermSpecConstant sc) <- pure parsed+        guard (symbol == T.toStrict (name <> "_length"))+        pure $ parseW256 sc -    getBuf :: Map (Expr Buf) BufModel -> Text -> IO (Map (Expr Buf) BufModel)+    getBuf :: Map (Expr Buf) BufModel -> Text -> MaybeIO (Map (Expr Buf) BufModel)     getBuf acc name = do       len <- getLength name       val <- getVal name--      buf <- case parseCommentFreeFileMsg getValueRes (T.toStrict val) of-        Right (ResSpecific (valParsed :| [])) -> case valParsed of-          (TermQualIdentifier (Unqualified (IdSymbol symbol)), term)-            -> if (T.fromStrict symbol) == name-               then pure $ parseBuf len term-               else internalError "solver did not return model for requested value"-          res -> internalError $ "cannot parse solver response: " <> show res-        res -> internalError $ "cannot parse solver response: " <> show res+      buf <- hoistMaybe $ do+        Right (ResSpecific (valParsed :| [])) <- pure $ parseCommentFreeFileMsg getValueRes (T.toStrict val)+        (TermQualIdentifier (Unqualified (IdSymbol symbol)), term) <- pure valParsed+        guard (T.fromStrict symbol == name)+        parseBuf len term       pure $ Map.insert (AbstractBuf $ T.toStrict name) buf acc -    parseBuf :: W256 -> Term -> BufModel-    parseBuf len = Comp . go mempty+    parseBuf :: W256 -> Term -> Maybe BufModel+    parseBuf len term = Comp <$> go mempty term       where         go env = \case           -- constant arrays@@ -843,71 +835,65 @@                 :| [SortSymbol (IdIndexed "BitVec" (IxNumeral "8" :| []))]               )             )) ((TermSpecConstant val :| [])))-            -> Base (parseW8 val) len+            -> Just $ Base (parseW8 val) len            -- writing a byte over some array           (TermApplication             (Unqualified (IdSymbol "store"))             (base :| [TermSpecConstant idx, TermSpecConstant val])-            ) -> let-              pbase = go env base-              pidx = parseW256 idx-              pval = parseW8 val-            in Write pval pidx pbase+            ) -> do+              pbase <- go env base+              let pidx = parseW256 idx+                  pval = parseW8 val+              Just $ Write pval pidx pbase            -- binding a new name-          (TermLet ((VarBinding name bound) :| []) term) -> let-              pbound = go env bound-            in go (Map.insert name pbound env) term+          (TermLet ((VarBinding name' bound) :| []) term') -> do+              pbound <- go env bound+              go (Map.insert name' pbound env) term'            -- looking up a bound name-          (TermQualIdentifier (Unqualified (IdSymbol name))) -> case Map.lookup name env of-            Just t -> t-            Nothing -> internalError $ "could not find "-                            <> (TS.unpack name)-                            <> " in environment mapping"-          p -> parseErr p+          (TermQualIdentifier (Unqualified (IdSymbol name'))) ->+            Map.lookup name' env +          _ -> Nothing+ -- | Takes a Map containing all reads from a store with an abstract base, as -- well as the concrete part of the storage prestate and returns a fully -- concretized storage getStore-  :: (Text -> IO Text)+  :: ValGetter   -> StorageReads-  -> IO (Map (Expr EAddr) (Map W256 W256))-getStore getVal (StorageReads innerMap) =-  fmap Map.fromList $ forM (Map.toList innerMap) $ \((addr, idx), slots) -> do+  -> MaybeIO (Map (Expr EAddr) (Map W256 W256))+getStore getVal (StorageReads innerMap) = do+  results <- 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-                   Right (ResSpecific (valParsed :| [])) -> valParsed-                   r -> parseErr r-        -- first interpret SMT term as a function-        fun = case parsed of-                (TermQualIdentifier (Unqualified (IdSymbol symbol)), term) ->-                  if symbol == (T.toStrict name)-                  then interpret1DArray Map.empty term-                  else internalError "solver did not return model for requested value"-                r -> parseErr r--    -- then create a map by adding only the locations that are read by the program+    fun <- hoistMaybe $ do+      Right (ResSpecific (valParsed :| [])) <- pure $ parseCommentFreeFileMsg getValueRes (T.toStrict raw)+      (TermQualIdentifier (Unqualified (IdSymbol symbol)), term) <- pure valParsed+      guard (symbol == T.toStrict name)+      pure $ interpret1DArray Map.empty term+    -- create a map by adding only the locations that are read by the program     store <- foldM (\m slot -> do       slot' <- queryValue getVal slot-      pure $ Map.insert slot' (fun slot') m) Map.empty slots+      pure $ Map.insert slot' (fun slot') m) Map.empty (Set.toList slots)     pure (addr, store)+  pure $ Map.fromList results  -- | Ask the solver to give us the concrete value of an arbitrary abstract word-queryValue :: (Text -> IO Text) -> Expr EWord -> IO W256+queryValue :: ValGetter -> Expr EWord -> MaybeIO W256 queryValue _ (Lit w) = pure w queryValue getVal w = do   -- this exprToSMT should never fail, since we have already ran the solver   let expr = toLazyText $ fromRight' $ exprToSMT w   raw <- getVal expr-  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+  hoistMaybe $ do+    valTxt <- extractValue raw+    Right sc <- pure $ parseString specConstant (T.toStrict valTxt)+    pure $ parseW256 sc   where+    extractValue :: Text -> Maybe Text     extractValue getValResponse = (T.stripSuffix "))") $ snd $ T.breakOnEnd " " $ T.stripEnd getValResponse  -- | Interpret an N-dimensional array as a value of type a.@@ -951,3 +937,7 @@         Just t -> interpretW256 env t         Nothing -> internalError "unknown identifier, cannot parse array"     interpretW256 _ t = internalError $ "cannot parse array value. Unexpected term: " <> (show t)+++hoistMaybe :: Monad m => Maybe a -> MaybeT m a+hoistMaybe = MaybeT . pure

@@ -27,10 +27,7 @@     "(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)"-    ])+    <> (fmap SMTCommand [ "(declare-fun keccak (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))",@@ -203,8 +200,44 @@       \(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)\-      \)))))))))))))))))))))))))))))))"-    ]+      \)))))))))))))))))))))))))))))))",+    "(define-fun clz256 ((x (_ BitVec 256))) (_ BitVec 256)\+      \(let ((x128 (ite (bvuge x     #x0000000000000000000000000000000100000000000000000000000000000000)\+      \                (bvlshr x        (_ bv128 256)) x))\+      \      (n128 (ite (bvuge x     #x0000000000000000000000000000000100000000000000000000000000000000)\+      \                (_ bv0 256) (_ bv128 256))))\+      \(let ((x64  (ite (bvuge x128  #x0000000000000000000000000000000000000000000000010000000000000000)\+      \                (bvlshr x128     (_ bv64 256)) x128))\+      \      (n64  (ite (bvuge x128  #x0000000000000000000000000000000000000000000000010000000000000000)\+      \               n128  (bvadd n128 (_ bv64 256)))))\+      \(let ((x32  (ite (bvuge x64   #x0000000000000000000000000000000000000000000000000000000100000000)\+      \                (bvlshr x64      (_ bv32 256)) x64))\+      \      (n32  (ite (bvuge x64   #x0000000000000000000000000000000000000000000000000000000100000000)\+      \               n64   (bvadd n64  (_ bv32 256)))))\+      \(let ((x16  (ite (bvuge x32   #x0000000000000000000000000000000000000000000000000000000000010000)\+      \                (bvlshr x32      (_ bv16 256)) x32))\+      \      (n16  (ite (bvuge x32   #x0000000000000000000000000000000000000000000000000000000000010000)\+      \               n32   (bvadd n32  (_ bv16 256)))))\+      \(let ((x8   (ite (bvuge x16   #x0000000000000000000000000000000000000000000000000000000000000100)\+      \                (bvlshr x16      (_ bv8 256)) x16))\+      \      (n8   (ite (bvuge x16   #x0000000000000000000000000000000000000000000000000000000000000100)\+      \               n16   (bvadd n16  (_ bv8 256)))))\+      \(let ((x4   (ite (bvuge x8    #x0000000000000000000000000000000000000000000000000000000000000010)\+      \                (bvlshr x8       (_ bv4 256)) x8))\+      \      (n4   (ite (bvuge x8    #x0000000000000000000000000000000000000000000000000000000000000010)\+      \               n8    (bvadd n8   (_ bv4 256)))))\+      \(let ((x2   (ite (bvuge x4    #x0000000000000000000000000000000000000000000000000000000000000004)\+      \                (bvlshr x4       (_ bv2 256)) x4))\+      \      (n2   (ite (bvuge x4    #x0000000000000000000000000000000000000000000000000000000000000004)\+      \               n4    (bvadd n4   (_ bv2 256)))))\+      \(let ((x1   (ite (bvuge x2    #x0000000000000000000000000000000000000000000000000000000000000002)\+      \                (bvlshr x2       (_ bv1 256)) x2))\+      \      (n1   (ite (bvuge x2    #x0000000000000000000000000000000000000000000000000000000000000002)\+      \               n2    (bvadd n2   (_ bv1 256)))))\+      \(ite           (bvuge x1 (_ bv1 256))\+      \               n1    (bvadd n1   (_ bv1 256)))\+      \)))))))))"+   ]   toText :: SMTEntry -> Text

@@ -1,12 +1,15 @@ module EVM.SMT.Types where -import Data.Text.Lazy (Text)-import Data.Text.Lazy.Builder+import Control.Monad.Trans.Maybe (MaybeT) import Data.Map (Map) import Data.Map qualified as Map (unionWith) import Data.Set (Set)+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Builder  import EVM.Types++type MaybeIO = MaybeT IO  data SMTEntry = SMTCommand Builder | SMTComment Builder   deriving (Eq)

@@ -48,7 +48,7 @@     r = unsafeInto $ sign_r sig     s = unsafeInto lowS -    -- this is a little bit sad, but cryptonite doesn't give us back a v value+    -- this is a little bit sad, but crypton doesn't give us back a v value     -- so we compute it by guessing one, and then seeing if that gives us the right answer from ecrecover     v = if ecrec 28 r s hash == deriveAddr sk         then 28

@@ -40,7 +40,6 @@   , containsLinkerHole   , makeSourceCache   , getContractsMap-  , WarningData(..) ) where  import EVM.ABI@@ -77,7 +76,6 @@ import Data.Text (pack, intercalate) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import Data.Text.IO (writeFile) import Data.Vector (Vector) import Data.Vector qualified as Vector import Data.Word (Word8)@@ -232,12 +230,6 @@   modifierDepth :: {-# UNPACK #-} !Int } deriving (Show, Eq, Ord, Generic) -data WarningData t = WarningData-  {solcContr :: SolcContract,-   sourceCache :: SourceCache,-   vm :: VM t-  }- data SrcMapParseState   = F1 String Int   | F2 Int String Int@@ -250,6 +242,9 @@ data CodeType = Creation | Runtime   deriving (Show, Eq, Ord) +type ContractName = Text+type SourceCode = Text+ -- Obscure but efficient parser for the Solidity sourcemap format. makeSrcMaps :: Text -> Maybe (Seq SrcMap) makeSrcMaps = (\case (_, Fe, _) -> Nothing; x -> Just (done x))@@ -391,31 +386,24 @@       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-  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+solidity :: MonadIO m => ContractName -> SourceCode -> m (Maybe ByteString)+solidity contract src = solcCode contract src Creation False -solcRuntime'-  :: App m-  => Text -> Text -> Bool -> m (Maybe ByteString)-solcRuntime' contract src viaIR = do-  conf <- readConfig-  liftIO $ do-    json <- solc Solidity src viaIR-    when conf.dumpExprs $ liftIO $ Data.Text.IO.writeFile "compiled_code.json" json-    case readStdJSON json of-      Right (Contracts sol) -> pure $ Map.lookup ("hevm.sol:" <> contract) sol <&> (.runtimeCode)-      Left _ -> internalError $ "unable to parse solidity output:\n" <> (T.unpack json)+solcRuntime' :: MonadIO m => ContractName -> SourceCode -> Bool -> m (Maybe ByteString)+solcRuntime' contract src viaIR = solcCode contract src Runtime viaIR -solcRuntime-  :: App m-  => Text -> Text -> m (Maybe ByteString)+solcRuntime :: MonadIO m => ContractName -> SourceCode -> m (Maybe ByteString) solcRuntime contract src = solcRuntime' contract src False++solcCode :: MonadIO m => ContractName -> SourceCode -> CodeType -> Bool -> m (Maybe ByteString)+solcCode contract src codeType viaIR = liftIO $ do+  json <- solc Solidity src viaIR+  case readStdJSON json of+    Right (Contracts sol) -> pure $ Map.lookup ("hevm.sol:" <> contract) sol+      <&> case codeType of+            Creation -> (.creationCode)+            Runtime -> (.runtimeCode)+    Left e -> internalError $ "unable to parse solidity output:\n" <> (T.unpack json) <> "\n" <> show e  functionAbi :: Text -> IO Method functionAbi f = do

@@ -2,16 +2,32 @@     Module: EVM.Solvers     Description: Solver orchestration -}-module EVM.Solvers where+{-# LANGUAGE CPP #-}+module EVM.Solvers+  ( withSolvers+  , Solver(..)+  , SolverGroup(..)+  , Task+  , MultiSol(..)+  , checkSat+  , checkSatWithProps+  , checkMulti+  , defMemLimit+  ) where ++ import Prelude hiding (LT, GT)  import GHC.Natural import GHC.IO.Handle (Handle, hFlush, hSetBuffering, BufferMode(..)) import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.QSem (QSem, newQSem, waitQSem, signalQSem)+import Control.Exception (bracket, bracket_, try, IOException) import Control.Concurrent.STM (writeTChan, newTChan, TChan, tryReadTChan, atomically) import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.State.Strict import Control.Monad.IO.Unlift import Data.Map (Map)@@ -19,6 +35,7 @@ import Data.Set (Set, isSubsetOf, fromList, toList) import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Either (isLeft)+import Data.Foldable (for_) import Data.Text qualified as TStrict import Data.Text.Lazy (Text) import Data.Text.Lazy qualified as T@@ -36,6 +53,11 @@ import EVM.SMT import EVM.Types ++-- In megabytes, i.e. 1GB+defMemLimit :: Natural+defMemLimit = 1024+ -- | Supported solvers data Solver   = Z3@@ -54,11 +76,10 @@  -- | A running solver instance data SolverInstance = SolverInstance-  { solvertype :: Solver-  , stdin      :: Handle-  , stdout     :: Handle-  , process    :: ProcessHandle-  }+  Solver -- solver type+  Handle -- stdin+  Handle -- stdout+  ProcessHandle  -- | A channel representing a group of solvers newtype SolverGroup = SolverGroup (Chan Task)@@ -76,16 +97,14 @@   deriving (Show, Eq)  data MultiData = MultiData-  { smt2 :: SMT2-  , multiSol :: MultiSol-  , resultChan :: Chan (Maybe [W256])-  }+  SMT2+  MultiSol+  (Chan (Maybe [W256])) -- result channel  data SingleData = SingleData-  { smt2 :: SMT2-  , props :: Maybe [Prop]-  , resultChan :: Chan SMTResult-  }+  SMT2+  (Maybe [Prop])+  (Chan SMTResult) -- result channel  -- returns True if a is a superset of any of the sets in bs supersetAny :: Set Prop -> [Set Prop] -> Bool@@ -131,150 +150,160 @@         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-    -- spawn solvers-    instances <- mapM (const $ liftIO $ spawnSolver solver threads timeout) [1..count]+withSolvers :: App m => Solver -> Natural -> Maybe Natural -> Natural -> (SolverGroup -> m a) -> m a+withSolvers solver count timeout maxMemory cont = do     -- spawn orchestration thread     taskq <- liftIO newChan     cacheq <- liftIO . atomically $ newTChan-    availableInstances <- liftIO newChan-    liftIO $ forM_ instances (writeChan availableInstances)-    orchestrate' <- toIO $ orchestrate taskq cacheq availableInstances [] 0+    sem <- liftIO $ newQSem (fromIntegral count)+    orchestrate' <- toIO $ orchestrate taskq cacheq sem [] 0     orchestrateId <- liftIO $ forkIO orchestrate'      -- run continuation with task queue     res <- cont (SolverGroup taskq)      -- cleanup and return results-    liftIO $ mapM_ (stopSolver) instances     liftIO $ killThread orchestrateId     pure res   where-    orchestrate :: App m => Chan Task -> TChan CacheEntry -> Chan SolverInstance -> [Set Prop] -> Int -> m b-    orchestrate taskq cacheq avail knownUnsat fileCounter = do+    orchestrate :: App m => Chan Task -> TChan CacheEntry -> QSem -> [Set Prop] -> Int -> m b+    orchestrate taskq cacheq sem knownUnsat fileCounter = do       conf <- readConfig       mx <- liftIO . atomically $ tryReadTChan cacheq       case mx of         Just (CacheEntry props)  -> do           let knownUnsat' = (fromList props):knownUnsat           when conf.debug $ liftIO $ putStrLn "   adding UNSAT cache"-          orchestrate taskq cacheq avail knownUnsat' fileCounter+          orchestrate taskq cacheq sem knownUnsat' fileCounter         Nothing -> do           task <- liftIO $ readChan taskq           case task of             TaskSingle (SingleData _ props r) | isJust props && supersetAny (fromList (fromJust props)) knownUnsat -> do               liftIO $ writeChan r Qed               when conf.debug $ liftIO $ putStrLn "   Qed found via cache!"-              orchestrate taskq cacheq avail knownUnsat fileCounter+              orchestrate taskq cacheq sem knownUnsat fileCounter             _ -> do-              inst <- liftIO $ readChan avail               runTask' <- case task of-                TaskSingle (SingleData smt2 props r) -> toIO $ getOneSol smt2 props r cacheq inst avail fileCounter-                TaskMulti (MultiData smt2 multiSol r) -> toIO $ getMultiSol smt2 multiSol r inst avail fileCounter+                TaskSingle (SingleData smt2 props r) -> toIO $ getOneSol solver timeout maxMemory smt2 props r cacheq sem fileCounter+                TaskMulti (MultiData smt2 multiSol r) -> toIO $ getMultiSol solver timeout maxMemory smt2 multiSol r sem fileCounter               _ <- liftIO $ forkIO runTask'-              orchestrate taskq cacheq avail knownUnsat (fileCounter + 1)+              orchestrate taskq cacheq sem knownUnsat (fileCounter + 1) -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+getMultiSol :: forall m. (MonadIO m, ReadConfig m) => Solver -> Maybe Natural -> Natural -> SMT2 -> MultiSol -> Chan (Maybe [W256]) -> QSem -> Int -> m ()+getMultiSol solver timeout maxMemory smt2@(SMT2 cmds cexvars _) multiSol r sem fileCounter = do   conf <- readConfig-  when conf.dumpQueries $ liftIO $ writeSMT2File smt2 "." (show fileCounter)-  -- reset solver and send all lines of provided script-  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 $ 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-  where+  let     maskFromBytesCount k       | k <= 32 = (2 ^ (8 * k) - 1)       | otherwise = internalError "Byte length exceeds 256-bit capacity"-    subRun :: (MonadIO m, ReadConfig m) => [W256] -> SMT2 -> Text -> m ()-    subRun vals fullSmt sat = do-      conf <- readConfig+    subRun :: SolverInstance -> [W256] -> SMT2 -> Text -> IO ()+    subRun inst vals fullSmt sat = do       case sat of-        "unsat" -> liftIO $ do+        "unsat" -> do           when conf.debug $ putStrLn $ "No more solutions to query, returning: " <> show vals-          liftIO $ writeChan r (Just vals)-        "timeout" -> liftIO $ do+          writeChan r (Just vals)+        "timeout" -> do            when conf.debug $ putStrLn "Timeout inside SMT solver."            writeChan r Nothing-        "unknown" -> liftIO $ do+        "unknown" -> 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+          if length vals >= multiSol.maxSols then do             when conf.debug $ putStrLn "Too many solutions to symbolic query."             writeChan r Nothing           else do-            cex <- liftIO $ getModel inst cexvars-            case Map.lookup (Var (TStrict.pack multiSol.var)) cex.vars of-              Just v -> do-                let hexMask = maskFromBytesCount multiSol.numBytes-                    maskedVal = v .&. hexMask-                    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 $ sendCommand inst restrict-                case out of-                  "success" -> do-                    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)-                    writeChan r Nothing-              Nothing -> internalError $ "variable " <>  multiSol.var <> " not part of model (i.e. cex) ... that's not possible"-        err -> liftIO $ do-          when conf.debug $ putStrLn $ "Unable to write SMT to solver: " <> (T.unpack err)+            mcex <- getModel inst cexvars+            case mcex of+              Nothing -> do+                when conf.debug $ putStrLn "Solver died while extracting model."+                writeChan r Nothing+              Just cex -> case Map.lookup (Var (TStrict.pack multiSol.var)) cex.vars of+                Just v -> do+                  let hexMask = maskFromBytesCount multiSol.numBytes+                      maskedVal = v .&. hexMask+                      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 $ 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 $ writeSMT2File newSmt "." (show fileCounter <> "-sol" <> show (length vals))+                  out <- sendCommand inst restrict+                  case out of+                    "success" -> do+                      out2 <- sendCommand inst  (SMTCommand "(check-sat)")+                      subRun inst (maskedVal:vals) newSmt out2+                    err -> do+                      when conf.debug $ putStrLn $ "Error while writing SMT to solver: " <> (T.unpack err)+                      writeChan r Nothing+                Nothing -> internalError $ "variable " <>  multiSol.var <> " not part of model (i.e. cex) ... that's not possible"+        err -> do+          when conf.debug $ putStrLn $ "Error while writing SMT to solver: " <> (T.unpack err)           writeChan r Nothing+  liftIO $ bracket_+    (waitQSem sem)+    (signalQSem sem)+    (do+      when conf.dumpQueries $ writeSMT2File smt2 "." (show fileCounter)+      bracket+        (spawnSolver solver timeout maxMemory)+        (stopSolver)+        (\inst -> do+          out <- sendScript inst cmds+          case out of+            Left err -> do+              when conf.debug $ putStrLn $ "Issue while writing SMT to solver (maybe it got killed)?: " <> (T.unpack err)+              writeChan r Nothing+            Right _ -> do+              sat <- sendCommand inst $ SMTCommand "(check-sat)"+              when conf.dumpQueries $ writeSMT2File smt2 "." (show fileCounter <> "-origquery")+              subRun inst [] smt2 sat+        )+    ) -getOneSol :: (MonadIO m, ReadConfig m) => SMT2 -> Maybe [Prop] -> Chan SMTResult -> TChan CacheEntry -> SolverInstance -> Chan SolverInstance -> Int -> m ()-getOneSol smt2@(SMT2 cmds cexvars _) props r cacheq inst availableInstances fileCounter = do+getOneSol :: (MonadIO m, ReadConfig m) => Solver -> Maybe Natural -> Natural -> SMT2 -> Maybe [Prop] -> Chan SMTResult -> TChan CacheEntry -> QSem -> Int -> m ()+getOneSol solver timeout maxMemory smt2@(SMT2 cmds cexvars _) props r cacheq sem fileCounter = do   conf <- readConfig-  liftIO $ do-    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+  liftIO $ bracket_+    (waitQSem sem)+    (signalQSem sem)+    (do+      when (conf.dumpQueries) $ writeSMT2File smt2 "." (show fileCounter)+      bracket+        (spawnSolver solver timeout maxMemory)+        (stopSolver)+        (\inst -> do+          out <- sendScript inst cmds+          case out of+            Left e -> writeChan r (Unknown $ "Issue while writing SMT to solver (maybe it got killed?): " <> T.unpack e)+            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" -> do+                      mmodel <- getModel inst cexvars+                      case mmodel of+                        Just model -> pure $ Cex model+                        Nothing -> pure $ Unknown "Solver died while extracting model"+                    _ -> let  supportIssue =+                                  ("does not yet support" `T.isInfixOf` sat)+                                  || ("unsupported" `T.isInfixOf` sat)+                                  || ("not support" `T.isInfixOf` sat)+                      in case supportIssue of+                       True -> pure . Error $ "SMT solver reported unsupported operation: " <> T.unpack sat+                       False -> pure . Unknown $ "Unable to parse SMT solver output (maybe it got killed?): " <> T.unpack sat+              writeChan r res+        )+    )  dumpUnsolved :: SMT2 -> Int -> Maybe FilePath -> IO () dumpUnsolved fullSmt fileCounter dump = do@@ -282,8 +311,8 @@      Just path -> writeSMT2File fullSmt path $ "unsolved-" <> show fileCounter      Nothing -> pure () -getModel :: SolverInstance -> CexVars -> IO SMTCex-getModel inst cexvars = do+getModel :: SolverInstance -> CexVars -> IO (Maybe SMTCex)+getModel inst cexvars = runMaybeT $ do   -- get an initial version of the model from the solver   initialModel <- getRaw   -- check the sizes of buffer models and shrink if needed@@ -291,10 +320,11 @@   then pure initialModel   else do     -- get concrete values for each buffers max read index-    hints <- capHints <$> queryMaxReads (getValue inst) cexvars.buffers-    snd <$> runStateT (shrinkModel hints) initialModel+    hints <- queryMaxReads (getValue inst) cexvars.buffers+    let cappedHints = capHints hints+    lift (execStateT (shrinkModel cappedHints) initialModel)   where-    getRaw :: IO SMTCex+    getRaw :: MaybeIO SMTCex     getRaw = do       vars <- getVars parseVar (getValue inst) (fmap T.toStrict cexvars.calldata)       addrs <- getAddrs parseEAddr (getValue inst) (fmap T.toStrict cexvars.addrs)@@ -332,23 +362,30 @@     shrinkBuf :: Text -> W256 -> StateT SMTCex IO ()     shrinkBuf buf hint = do       let encBound = "(_ bv" <> Data.Text.Lazy.Builder.Int.decimal hint <> " 256)"-      answer <- liftIO $ do-        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 $ 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 $ SMTCommand "(pop 1)"-          pure ()+      -- Try to push and assert; if either fails, solver died, keep current model+      setup <- liftIO $ runMaybeT $ do+        MaybeT $ checkCommand inst $ SMTCommand "(push 1)"+        MaybeT $ checkCommand inst $ SMTCommand ("(assert (bvule " <> (fromLazyText buf) <> "_length " <> encBound <> "))")+      case setup of+        Nothing -> pure ()  -- solver died during setup, keep current model+        Just () -> do+          answer <- liftIO $ sendCommand inst $ SMTCommand "(check-sat)"+          case answer of+            "sat" -> do+              mmodel <- liftIO $ runMaybeT getRaw+              for_ mmodel put  -- solver died, keep current model+            "unsat" -> do+              mpop <- liftIO $ checkCommand inst $ SMTCommand "(pop 1)"+              case mpop of+                Nothing -> pure ()  -- solver died, keep current model+                Just () -> do+                  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 $ SMTCommand "(pop 1)"+              pure ()       -- we set a pretty arbitrary upper limit (of 32) to decide if we need to do some shrinking@@ -361,24 +398,22 @@           -- TODO: do I need to check the write idx here?           (Write _ idx next) -> idx <= 32 && go (Comp next) -mkTimeout :: Maybe Natural -> Text-mkTimeout t = T.pack $ show $ (1000 *)$ case t of-  Nothing -> 300 :: Natural-  Just t' -> t' +-- Takes Maybe seconds, returns seconds+mkTimeout :: Maybe Natural -> Natural+mkTimeout = fromMaybe 300+ -- | Arguments used when spawning a solver instance-solverArgs :: Solver -> Natural -> Maybe Natural -> [Text]-solverArgs solver threads timeout = case solver of+solverArgs :: Solver -> Maybe Natural -> [Text]+solverArgs solver timeout = case solver of   Bitwuzla ->     [ "--lang=smt2"     , "--produce-models"-    , "--time-limit-per=" <> mkTimeout timeout-    , "--bv-solver=preprop"+    , "--time-limit-per=" <> millisecs     , "--bv-output-format=16"     ]   Z3 ->     [ "-st"-    , "smt.threads=" <> (T.pack $ show threads)     , "-in" ]   CVC5 ->     [ "--lang=smt"@@ -386,22 +421,58 @@     , "--print-success"     , "--interactive"     , "--incremental"-    , "--tlimit-per=" <> mkTimeout timeout+    , "--tlimit-per=" <> millisecs     , "--arrays-exp"     ]   EmptySolver -> []   Custom _ -> []+  where millisecs = T.pack $ show $ 1000 * (mkTimeout timeout)  -- | Spawns a solver instance, and sets the various global config options that we use for our queries-spawnSolver :: Solver -> Natural -> Maybe (Natural) -> IO SolverInstance-spawnSolver solver threads timeout = do+spawnSolver :: Solver -> Maybe (Natural) -> Natural -> IO SolverInstance+#if defined(mingw32_HOST_OS)+spawnSolver solver timeout _ = do   (readout, writeout) <- createPipe-  let cmd-        = (proc (show solver) (fmap T.unpack $ solverArgs solver threads timeout ))+  let solverCmd = show solver+      solverArgsStr = fmap T.unpack $ solverArgs solver timeout+      -- Windows: no ulimit available+      cmd = (proc solverCmd solverArgsStr)             { std_in = CreatePipe             , std_out = UseHandle writeout             , std_err = UseHandle writeout             }+#elif defined(darwin_HOST_OS)+spawnSolver solver timeout _ = do+  (readout, writeout) <- createPipe+  let timeoutSeconds = mkTimeout timeout+      solverCmd = show solver+      solverArgsStr = fmap T.unpack $ solverArgs solver timeout+      -- macOS: memory limit not possible, but CPU limits work+      -- ulimit -t sets RLIMIT_CPU (kernel-enforced CPU time limit in seconds)+      shellCmd = "sh"+      shellArgs = ["-c", "ulimit -t " ++ show timeoutSeconds ++ "; exec \"$0\" \"$@\"", solverCmd] ++ solverArgsStr+      cmd = (proc shellCmd shellArgs)+            { std_in = CreatePipe+            , std_out = UseHandle writeout+            , std_err = UseHandle writeout+            }+#else+spawnSolver solver timeout maxMemoryMB = do+  (readout, writeout) <- createPipe+  let timeoutSeconds = mkTimeout timeout+      solverCmd = show solver+      solverArgsStr = fmap T.unpack $ solverArgs solver timeout+      -- Linux: both CPU and memory limits work+      -- ulimit -v sets RLIMIT_AS (kernel-enforced virtual memory limit in KB)+      shellCmd = "sh"+      maxMemoryKB = maxMemoryMB * 1024  -- Convert MB to KB for ulimit -v+      shellArgs = ["-c", "ulimit -t " ++ show timeoutSeconds ++ "; ulimit -v " ++ show maxMemoryKB ++ "; exec \"$0\" \"$@\"", solverCmd] ++ solverArgsStr+      cmd = (proc shellCmd shellArgs)+            { std_in = CreatePipe+            , std_out = UseHandle writeout+            , std_err = UseHandle writeout+            }+#endif   (Just stdin, Nothing, Nothing, process) <- createProcess cmd   hSetBuffering stdin (BlockBuffering (Just 1000000))   let solverInstance = SolverInstance solver stdin readout process@@ -414,7 +485,6 @@     EmptySolver -> pure solverInstance     Z3 -> do       _ <- sendCommand solverInstance $ SMTCommand "(set-option :print-success true)"-      _ <- sendCommand solverInstance $ SMTCommand ("(set-option :timeout " <> (fromLazyText $ mkTimeout timeout) <> ")")       pure solverInstance     Custom _ -> pure solverInstance @@ -435,39 +505,48 @@         "success" -> go cs         e -> pure $ Left $ "Solver returned an error:\n" <> e <> "\nwhile sending the following command: " <> toLazyText command -checkCommand :: SolverInstance -> SMTEntry -> IO ()+-- | Returns Nothing if the solver died or returned an error+checkCommand :: SolverInstance -> SMTEntry -> IO (Maybe ()) checkCommand inst cmd = do   res <- sendCommand inst cmd-  case res of-    "success" -> pure ()-    _ -> internalError $ "Unexpected solver output: " <> T.unpack res+  pure $ if res == "success" then Just () else Nothing   -- | Strips trailing \r, if present stripCarriageReturn :: Text -> Text stripCarriageReturn t = fromMaybe t $ T.stripSuffix "\r" t +-- | Helper function for when we want to try an IO action and get Nothing on exception+tryIO :: forall a. IO a -> MaybeT IO a+tryIO action = MaybeT $ either (const Nothing) Just <$> (try action :: IO (Either IOException a))+ -- | Sends a string to the solver and appends a newline, returns the first available line from the output buffer+-- Returns "unknown" if the solver process has died (timeout, crash, etc.) 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)+  result <- runMaybeT $ do+    tryIO $ T.hPutStrLn stdin $ toLazyText cmd+    tryIO $ hFlush stdin+    tryIO $ stripCarriageReturn <$> T.hGetLine stdout+  pure $ fromMaybe "unknown" result  -- | Returns a string representation of the model for the requested variable-getValue :: SolverInstance -> Text -> IO Text+-- Returns Nothing if the solver process has died (timeout, crash, etc.)+getValue :: SolverInstance -> Text -> MaybeIO Text getValue (SolverInstance _ stdin stdout _) var = do-  T.hPutStrLn stdin (T.append (T.append "(get-value (" var) "))")-  hFlush stdin-  fmap (T.unlines . reverse) (readSExpr stdout)+  tryIO $ T.hPutStrLn stdin (T.append (T.append "(get-value (" var) "))")+  tryIO $ hFlush stdin+  val <- readSExpr stdout+  pure $ (T.unlines . reverse) val  -- | Reads lines from h until we have a balanced sexpr-readSExpr :: Handle -> IO [Text]+-- Returns Nothing if the solver process has died or parsing fails+readSExpr :: Handle -> MaybeIO [Text] readSExpr h = go 0 0 []   where     go 0 0 _ = do-      line <- T.hGetLine h+      line <- tryIO $ T.hGetLine h       let cleanLine = stripCarriageReturn line           ls = T.length $ T.filter (== '(') cleanLine           rs = T.length $ T.filter (== ')') cleanLine@@ -475,7 +554,7 @@          then pure [cleanLine]          else go ls rs [cleanLine]     go ls rs prev = do-      line <- T.hGetLine h+      line <- tryIO $ T.hGetLine h       let cleanLine = stripCarriageReturn line           ls' = T.length $ T.filter (== '(') cleanLine           rs' = T.length $ T.filter (== ')') cleanLine

@@ -11,9 +11,9 @@ import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan) import Control.Concurrent.Spawn (parMapIO, pool) import Control.Concurrent.STM (writeTChan, newTChan, TChan, readTChan, atomically, isEmptyTChan, STM)-import Control.Concurrent.STM.TVar (TVar, newTVarIO, modifyTVar, readTVar, writeTVar)+import Control.Concurrent.STM.TVar (TVar, newTVarIO, modifyTVar, readTVar, readTVarIO, writeTVar) import Control.Concurrent.STM.TMVar (TMVar, putTMVar, takeTMVar, newEmptyTMVarIO)-import Control.Monad (when, forM_, forM, forever)+import Control.Monad (when, unless, forM_, forM, forever, void) import Control.Monad.Loops (whileM) import Control.Monad.IO.Unlift (MonadUnliftIO, toIO, withRunInIO) import Control.Monad.Operational qualified as Operational@@ -48,13 +48,12 @@ import Text.Printf (printf) import Witch (into, unsafeInto) -import EVM (makeVm, abstractContract, initialContract, getCodeLocation, isValidJumpDest)+import EVM (makeVm, abstractContract, initialContract, getCodeLocation, isValidJumpDest, defaultVMOpts) import EVM.Exec (exec) import EVM.Fetch qualified as Fetch import EVM.ABI import EVM.Effects import EVM.Expr qualified as Expr-import EVM.FeeSchedule (feeSchedule) import EVM.Format (formatExpr, formatPartial, formatPartialDetailed, showVal, indent, formatBinary, formatProp, formatState, formatError) import EVM.SMT qualified as SMT import EVM.Solvers (SolverGroup, checkSatWithProps)@@ -63,8 +62,6 @@ import EVM.Traversals (mapExpr, mapExprM, foldTerm) import EVM.Types hiding (Comp) import EVM.Types qualified-import EVM.Solidity (WarningData (..))- data LoopHeuristic   = Naive   | StackBased@@ -79,11 +76,11 @@     getIssue _ = Nothing     grouped = NE.group $ sort $ mapMaybe getIssue results -groupPartials :: Maybe (WarningData t) -> [Expr End] -> [(Integer, String)]-groupPartials warnData e = map (\g -> (into (length g), NE.head g)) grouped+groupPartials :: Maybe SrcLookup -> Map (Expr EAddr) Contract -> [Expr End] -> [(Integer, String)]+groupPartials srcLookupM contracts e = map (\g -> (into (length g), NE.head g)) grouped   where     getPartial :: Expr End -> Maybe String-    getPartial (Partial _ _ reason) = Just $ T.unpack $ formatPartialDetailed warnData reason+    getPartial (Partial _ _ reason) = Just $ T.unpack $ formatPartialDetailed srcLookupM contracts reason     getPartial _ = Nothing     grouped = NE.group $ sort $ mapMaybe getPartial e @@ -119,8 +116,8 @@   -- | Abstract calldata argument generation-symAbiArg :: Text -> AbiType -> CalldataFragment-symAbiArg name = \case+symAbiArg :: Int -> Text -> AbiType -> CalldataFragment+symAbiArg maxDynSize name = \case   AbiUIntType n ->     if n `mod` 8 == 0 && n <= 256     then St [] v@@ -136,16 +133,29 @@     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)+    Comp . V.toList . V.imap (\(T.pack . show -> i) tp -> symAbiArg maxDynSize (name <> "-a-" <> i) tp) $ (V.replicate sz tps)   AbiTupleType tps ->-    Comp . V.toList . V.imap (\(T.pack . show -> i) tp -> symAbiArg (name <> "-t-" <> i) tp) $ tps+    Comp . V.toList . V.imap (\(T.pack . show -> i) tp -> symAbiArg maxDynSize (name <> "-t-" <> i) tp) $ tps+  -- Dynamic bytes/string: concretize with bounded symbolic length + abstract buffer+  AbiBytesDynamicType ->+    let bufName = AbstractBuf (name <> "-bytes")+        len = Var (name <> "-bytes-length")+        maxLit = Lit (fromIntegral maxDynSize)+        sizeBound = [PLEq len maxLit]+    in Dy sizeBound len maxDynSize bufName+  AbiStringType ->+    let bufName = AbstractBuf (name <> "-string")+        len = Var (name <> "-string-length")+        maxLit = Lit (fromIntegral maxDynSize)+        sizeBound = [PLEq len maxLit]+    in Dy sizeBound len maxDynSize bufName   t -> internalError $ "TODO: symbolic abi encoding for " <> show t   where     v = Var name  data CalldataFragment   = St [Prop] (Expr EWord)-  | Dy [Prop] (Expr EWord) (Expr Buf)+  | Dy [Prop] (Expr EWord) Int (Expr Buf) -- ^ props, symbolic length, max concrete size, buffer   | Comp [CalldataFragment]   deriving (Show, Eq) @@ -153,13 +163,13 @@ -- with concrete arguments. -- Any argument given as "<symbolic>" or omitted at the tail of the list are -- kept symbolic.-symCalldata :: App m => Text -> [AbiType] -> [String] -> Expr Buf -> m (Expr Buf, [Prop])+symCalldata :: App m => Text -> [AbiType] -> [String] -> Expr Buf -> m (Expr Buf, [Prop], [Caveat]) symCalldata sig typesignature concreteArgs base = do   conf <- readConfig   let     args = concreteArgs <> replicate (length typesignature - length concreteArgs) "<symbolic>"     mkArg :: AbiType -> String -> Int -> CalldataFragment-    mkArg typ "<symbolic>" n = symAbiArg (T.pack $ "arg" <> show n) typ+    mkArg typ "<symbolic>" n = symAbiArg conf.maxDynSize (T.pack $ "arg" <> show n) typ     mkArg typ arg _ =       case makeAbiValue typ arg of         AbiUInt _ w -> St [] . Lit . into $ w@@ -173,17 +183,38 @@     sizeConstraints       = (Expr.bufLength withSelector .>= cdLen calldatas)       .&& (Expr.bufLength withSelector .< (Lit (2 ^ conf.maxBufSize)))-  pure (withSelector, sizeConstraints : props)+    -- A dynamic (bytes/string) argument is turned into a 'Dy' fragment with its+    -- length bounded to maxDynSize. That is a restriction of the input domain+    -- (every path is still explored fully), so we record it as a program-wide+    -- 'Caveat' rather than a per-path 'Partial'. Derived from the fragments we+    -- actually built, so a concretely-supplied argument produces no caveat.+    caveats = [DynArgBounded conf.maxDynSize | any isDy calldatas]+  pure (withSelector, sizeConstraints : props, caveats)  cdLen :: [CalldataFragment] -> Expr EWord-cdLen = go (Lit 4)+cdLen frags = Expr.add (headLen frags) (tailLen frags)   where-    go acc = \case-      [] -> acc-      (hd:tl) -> case hd of-                   St _ _ -> go (Expr.add acc (Lit 32)) tl-                   Comp xs | all isSt xs -> go acc (xs <> tl)-                   _ -> internalError "unsupported"+    -- Head: 4 bytes selector + 32 bytes per top-level arg (static or dynamic pointer)+    headLen = go (Lit 4)+      where+        go acc = \case+          [] -> acc+          (hd:tl) -> case hd of+            St _ _  -> go (Expr.add acc (Lit 32)) tl+            Dy {}   -> go (Expr.add acc (Lit 32)) tl+            Comp xs | all isSt xs -> go acc (xs <> tl)+            _ -> internalError "unsupported"+    -- Tail: for each Dy fragment, 32 bytes (length word) + padded data+    tailLen = go (Lit 0)+      where+        go acc = \case+          [] -> acc+          (hd:tl) -> case hd of+            Dy _ _ maxSz _ ->+              let paddedMax = ((maxSz + 31) `Prelude.div` 32) * 32+              in go (Expr.add acc (Lit (fromIntegral (32 + paddedMax)))) tl+            Comp xs | all isSt xs -> go acc (xs <> tl)+            _ -> go acc tl  writeSelector :: Expr Buf -> Text -> Expr Buf writeSelector buf sig =@@ -193,17 +224,48 @@     writeSel idx = Expr.writeByte idx (Expr.readByte idx sel)  combineFragments :: [CalldataFragment] -> Expr Buf -> (Expr Buf, [Prop])-combineFragments fragments base = go (Lit 4) fragments (base, [])+combineFragments fragments base =+  let headBytes = countHeadBytes fragments+      tailStart = Expr.add (Lit 4) headBytes+  in go headBytes (Lit 4) tailStart (Lit 0) fragments (base, [])   where-    go :: Expr EWord -> [CalldataFragment] -> (Expr Buf, [Prop]) -> (Expr Buf, [Prop])-    go _ [] acc = acc-    go idx (f:rest) (buf, ps) =+    -- Each top-level fragment occupies 32 bytes in the head (value or offset pointer)+    countHeadBytes :: [CalldataFragment] -> Expr EWord+    countHeadBytes = foldl' countFrag (Lit 0)+      where+        countFrag acc (St _ _)  = Expr.add acc (Lit 32)+        countFrag acc (Dy {})   = Expr.add acc (Lit 32)+        countFrag acc (Comp xs) | all isSt xs = foldl' countFrag acc xs+        countFrag _ s = internalError $ "unsupported cd fragment: " <> show s++    go :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord+       -> [CalldataFragment] -> (Expr Buf, [Prop]) -> (Expr Buf, [Prop])+    go _ _ _ _ [] acc = acc+    go headSz idx tailBase tailAcc (f:rest) (buf, ps) =       case f of         -- static fragments get written as a word in place-        St p w -> go (Expr.add idx (Lit 32)) rest (Expr.writeWord idx w buf, p <> ps)+        St p w -> go headSz (Expr.add idx (Lit 32)) tailBase tailAcc rest+                    (Expr.writeWord idx w buf, p <> ps)         -- compound fragments that contain only static fragments get written in place-        Comp xs | all isSt xs -> go idx (xs <> rest) (buf,ps)-        -- dynamic fragments are not yet supported... :/+        Comp xs | all isSt xs -> go headSz idx tailBase tailAcc (xs <> rest) (buf, ps)+        -- dynamic fragments: write offset pointer in head, data in tail+        Dy p len maxSz dynBuf ->+          let paddedMax = ((maxSz + 31) `Prelude.div` 32) * 32+              -- ABI offset is relative to the start of the args (byte 4)+              offset = Expr.add headSz tailAcc+              -- Write the offset pointer in the head area+              buf1 = Expr.writeWord idx offset buf+              -- Write the length word at the tail position+              dynPos = Expr.add tailBase tailAcc+              buf2 = Expr.writeWord dynPos len buf1+              -- Copy maxDynSize bytes from the abstract buffer using concrete+              -- size to avoid symbolic CopySlice issues+              dataPos = Expr.add dynPos (Lit 32)+              buf3 = Expr.copySlice (Lit 0) dataPos (Lit (fromIntegral maxSz)) dynBuf buf2+              -- Advance tail by 32 (length word) + paddedMax+              newTailAcc = Expr.add tailAcc (Lit (fromIntegral (32 + paddedMax)))+          in go headSz (Expr.add idx (Lit 32)) tailBase newTailAcc rest+               (buf3, p <> ps)         s -> internalError $ "unsupported cd fragment: " <> show s  isSt :: CalldataFragment -> Bool@@ -211,7 +273,11 @@ isSt (Comp fs) = all isSt fs isSt _ = False +isDy :: CalldataFragment -> Bool+isDy (Dy {}) = True+isDy _ = False + abstractVM   :: (Expr Buf, [Prop])   -> ByteString@@ -234,33 +300,16 @@   -> (Expr Buf, [Prop])   -> ST RealWorld (VM Symbolic) loadEmptySymVM x callvalue cd =-  (makeVm $ VMOpts+  (makeVm $ defaultVMOpts     { contract = initialContract x-    , otherContracts = []     , calldata = cd     , value = callvalue-    , baseState = EmptyBase     , address = SymAddr "entrypoint"     , caller = SymAddr "caller"     , origin = SymAddr "origin"     , coinbase = SymAddr "coinbase"-    , number = Lit 0-    , timestamp = Lit 0     , blockGaslimit = 0-    , gasprice = 0     , prevRandao = 42069-    , gas = ()-    , gaslimit = 0xffffffffffffffff-    , baseFee = 0-    , priorityFee = 0-    , maxCodeSize = 0xffffffff-    , schedule = feeSchedule-    , chainId = 1-    , create = False-    , txAccessList = mempty-    , allowFFI = False-    , freshAddresses = 0-    , beaconRoot = 0     })  -- Creates a symbolic VM that has symbolic storage, unlike loadEmptySymVM@@ -271,9 +320,8 @@   -> Bool   -> ST RealWorld (VM Symbolic) loadSymVM x callvalue cd create =-  (makeVm $ VMOpts+  (makeVm $ defaultVMOpts     { contract = if create then initialContract x else abstractContract x (SymAddr "entrypoint")-    , otherContracts = []     , calldata = cd     , value = callvalue     , baseState = AbstractBase@@ -281,23 +329,9 @@     , caller = SymAddr "caller"     , origin = SymAddr "origin"     , coinbase = SymAddr "coinbase"-    , number = Lit 0-    , timestamp = Lit 0     , blockGaslimit = 0-    , gasprice = 0     , prevRandao = 42069-    , gas = ()-    , gaslimit = 0xffffffffffffffff-    , baseFee = 0-    , priorityFee = 0-    , maxCodeSize = 0xffffffff-    , schedule = feeSchedule-    , chainId = 1     , create = create-    , txAccessList = mempty-    , allowFFI = False-    , freshAddresses = 0-    , beaconRoot = 0     })  -- freezes any mutable refs, making it safe to share between threads@@ -319,6 +353,8 @@       ConcreteMemory m -> SymbolicMemory . ConcreteBuf . vectorToByteString <$> VS.freeze m       m@(SymbolicMemory _) -> pure m +type PathHandler m a = Expr End -> TVar Bool -> m a+ data InterpTask m a = InterpTask   {fetcher :: Fetch.Fetcher Symbolic m   , iterConf :: IterConfig@@ -326,22 +362,28 @@   , taskQ :: Chan (InterpTask m a)   , numTasks :: TVar Natural   , stepper :: Stepper Symbolic (Expr End)-  , handler :: Expr End -> m a+  , handler :: PathHandler m a+  , shouldAbort :: TVar Bool   }  data Process m a = Process   { result :: Expr End-  , handler :: Expr End -> m a+  , handler :: PathHandler m a   } +-- returns back the input path/branch of the program+noopPathHandler :: Applicative m => PathHandler m (Expr End)+noopPathHandler x _ = pure x+ interpret :: forall m a . App m   => Fetch.Fetcher Symbolic m   -> IterConfig   -> VM Symbolic   -> Stepper Symbolic (Expr End)-  -> (Expr End -> m a)+  -> PathHandler m a   -> m [a] interpret fetcher iterConf vm stepper handler = do+  shouldAbort <- liftIO $ newTVarIO False   conf <- readConfig   taskQ <- liftIO newChan   processQ <- liftIO newChan@@ -363,11 +405,11 @@   allProcessDone <- liftIO newEmptyTMVarIO    -- spawn task orchestration thread-  taskOrchestrate' <- toIO $ taskOrchestrate taskQ availableInstances processQ numTasks numProcs+  taskOrchestrate' <- toIO $ taskOrchestrate taskQ shouldAbort availableInstances processQ numTasks numProcs   taskOrchestrateId <- liftIO $ forkIO taskOrchestrate'    -- spawn processing orchestration thread-  processOrchestrate' <- toIO $ processOrchestrate processQ availableProcs resChan numProcs numTasks allProcessDone+  processOrchestrate' <- toIO $ processOrchestrate processQ shouldAbort availableProcs resChan numProcs numTasks allProcessDone   processOrchestrateId <- liftIO $ forkIO processOrchestrate'    -- Add in the first task, further tasks will be added by the interpreters themselves@@ -379,6 +421,7 @@         , numTasks = numTasks         , stepper = stepper         , handler = handler+        , shouldAbort = shouldAbort         }   liftIO $ writeChan taskQ interpTask @@ -394,30 +437,41 @@     -- orchestrator loop     taskOrchestrate :: App m       => Chan (InterpTask m a)+      -> TVar Bool       -> Chan () -> Chan (Process m a)-      -> TVar Natural -> TVar Natural -> m b-    taskOrchestrate taskQ avail processQ numTasks numProcs = forever $ do+      -> TVar Natural -> TVar Natural -> m ()+    taskOrchestrate taskQ shouldAbort avail processQ numTasks numProcs = forever $ do       _ <- liftIO $ readChan avail       task <- liftIO $ readChan taskQ-      runTask' <- toIO $ getOneExpr task avail processQ numTasks numProcs-      liftIO $ forkIO runTask'+      abortFlag <- liftIO $ readTVarIO shouldAbort+      if abortFlag+        then liftIO $ writeChan avail ()+        else do+          runTask' <- toIO $ getOneExpr task avail processQ numTasks numProcs+          void $ liftIO $ forkIO runTask'      -- processing orchestrator loop-    processOrchestrate :: App m => Chan (Process m a) -> Chan () -> TChan a -> TVar Natural -> TVar Natural -> TMVar () -> m b-    processOrchestrate processQ availProcessors resChan numProcs numTasks allProcessDone = forever $ do-      _ <- liftIO $ readChan availProcessors+    processOrchestrate :: App m+      => Chan (Process m a) -> TVar Bool -> Chan () -> TChan a+      -> TVar Natural -> TVar Natural -> TMVar () -> m ()+    processOrchestrate processQ shouldAbort avail resChan numProcs numTasks allProcessDone = forever $ do+      _ <- liftIO $ readChan avail       proc <- liftIO $ readChan processQ-      runProcess' <- toIO $ processOne proc availProcessors resChan numProcs numTasks allProcessDone-      liftIO $ forkIO runProcess'+      abortFlag <- liftIO $ readTVarIO shouldAbort+      if abortFlag+        then liftIO $ writeChan avail ()+        else do+          runProcess' <- toIO $ processOne proc shouldAbort avail resChan numProcs numTasks allProcessDone+          void $ liftIO $ forkIO runProcess'      -- process one task-    processOne :: App m => Process m a -> Chan () -> TChan a -> TVar Natural -> TVar Natural -> TMVar () -> m ()-    processOne task availProcs resChan numProcs numTasks allProcessDone = do-      processed <- task.handler task.result+    processOne :: App m => Process m a -> TVar Bool -> Chan () -> TChan a -> TVar Natural -> TVar Natural -> TMVar () -> m ()+    processOne task shouldAbort avail resChan numProcs numTasks allProcessDone = do+      processed <- task.handler task.result shouldAbort       liftIO . atomically $ writeTChan resChan processed        -- Return instance to pool immediately after processing-      liftIO $ writeChan availProcs ()+      liftIO $ writeChan avail ()        -- Decrement and check if all done       liftIO $ atomically $ do@@ -483,9 +537,12 @@           runOne frozen newDepth (v:rest) = do             conf <- readConfig             (ra, vma) <- liftIO $ stToIO $ runStateT (continue v) frozen { result = Nothing, exploreDepth = newDepth }-            liftIO $ atomically $ modifyTVar numTasks (+1)-            when (conf.debug && conf.verb >=2) $ liftIO $ putStrLn $ "Queuing new task for ForkMany at depth " <> show newDepth-            liftIO $ writeChan taskQ t { vm = vma, stepper = (k ra) }+            -- Check abort flag before queuing new task+            abortFlag <- liftIO $ readTVarIO shouldAbort+            unless abortFlag $ do+              liftIO $ atomically $ modifyTVar numTasks (+1)+              when (conf.debug && conf.verb >=2) $ liftIO $ putStrLn $ "Queuing new task for ForkMany at depth " <> show newDepth+              liftIO $ writeChan taskQ t { vm = vma, stepper = (k ra) }             runOne frozen newDepth rest           runOne _ _ [] = internalError "unreachable"       Stepper.Fork (PleaseRunBoth continue) -> do@@ -493,9 +550,12 @@         frozen <- liftIO $ stToIO $ freezeVM vm         let newDepth = vm.exploreDepth+1         (ra, vma) <- liftIO $ stToIO $ runStateT (continue True) frozen { result = Nothing, exploreDepth = newDepth }-        liftIO $ atomically $ modifyTVar numTasks (+1)-        liftIO $ writeChan taskQ $ t { vm = vma, stepper = (k ra) }-        when (conf.debug && conf.verb >= 2) $ liftIO $ putStrLn $ "Queued new task for Fork at depth " <> show newDepth+        -- Check abort flag before queuing new task+        abortFlag <- liftIO $ readTVarIO shouldAbort+        unless abortFlag $ do+          liftIO $ atomically $ modifyTVar numTasks (+1)+          liftIO $ writeChan taskQ $ t { vm = vma, stepper = (k ra) }+          when (conf.debug && conf.verb >= 2) $ liftIO $ putStrLn $ "Queued new task for Fork at depth " <> show newDepth          (rb, vmb) <- liftIO $ stToIO $ runStateT (continue False) frozen { result = Nothing, exploreDepth = newDepth }         when (conf.debug && conf.verb >=2) $ liftIO $ putStrLn $ "Continuing task for Fork at depth " <> show newDepth@@ -608,12 +668,12 @@   -> m [Expr End] getExprEmptyStore solvers c signature' concreteArgs opts = do   conf <- readConfig-  calldata <- mkCalldata signature' concreteArgs+  (calldata, _caveats) <- mkCalldata signature' concreteArgs   preState <- liftIO $ stToIO $ loadEmptySymVM (RuntimeCode (ConcreteRuntimeCode c)) (Lit 0) calldata-  paths <- interpret (Fetch.oracle solvers Nothing opts.rpcInfo) opts.iterConf preState runExpr pure+  paths <- interpret (Fetch.oracle solvers Nothing opts.rpcInfo) opts.iterConf preState runExpr noopPathHandler   if conf.simp then (pure $ map Expr.simplify paths) else pure paths --- Used only in testing+-- Used only in testing; TODO: unify with exploreContract, and keep only one getExpr   :: App m   => SolverGroup@@ -623,10 +683,8 @@   -> VeriOpts   -> m [Expr End] getExpr solvers c signature' concreteArgs opts = do+  paths <- exploreContract solvers c signature' concreteArgs opts Nothing   conf <- readConfig-  calldata <- mkCalldata signature' concreteArgs-  preState <- liftIO $ stToIO $ abstractVM calldata c Nothing False-  paths <- interpret (Fetch.oracle solvers Nothing opts.rpcInfo) opts.iterConf preState runExpr pure   if conf.simp then (pure $ map Expr.simplify paths) else pure paths  {- | Checks if an assertion violation has been encountered@@ -668,19 +726,23 @@ panicMsg err = selector "Panic(uint256)" <> encodeAbiValue (AbiUInt 256 err)  -- | Builds a buffer representing calldata from the provided method description--- and concrete arguments-mkCalldata :: App m => Maybe Sig -> [String] -> m (Expr Buf, [Prop])+-- and concrete arguments, together with any program-wide soundness caveats+-- incurred while building it (see 'Caveat').+mkCalldata :: App m => Maybe Sig -> [String] -> m ((Expr Buf, [Prop]), [Caveat]) mkCalldata Nothing _ = do   conf <- readConfig-  pure ( AbstractBuf "txdata"-       -- assert that the length of the calldata is never more than 2^64-       -- this is way larger than would ever be allowed by the gas limit-       -- and avoids spurious counterexamples during abi decoding-       -- TODO: can we encode calldata as an array with a smaller length?-       , [Expr.bufLength (AbstractBuf "txdata") .< (Lit (2 ^ conf.maxBufSize))]+  pure ( ( AbstractBuf "txdata"+         -- assert that the length of the calldata is never more than 2^64+         -- this is way larger than would ever be allowed by the gas limit+         -- and avoids spurious counterexamples during abi decoding+         -- TODO: can we encode calldata as an array with a smaller length?+         , [Expr.bufLength (AbstractBuf "txdata") .< (Lit (2 ^ conf.maxBufSize))]+         )+       , []        )-mkCalldata (Just (Sig name types)) args =-  symCalldata name types args (AbstractBuf "txdata")+mkCalldata (Just (Sig name types)) args = do+  (buf, props, caveats) <- symCalldata name types args (AbstractBuf "txdata")+  pure ((buf, props), caveats)  -- Used only in testing verifyContract :: forall m . App m@@ -693,7 +755,7 @@   -> Postcondition   -> m ([Expr End], [VerifyResult]) verifyContract solvers theCode signature' concreteArgs opts maybepre post = do-  calldata <- mkCalldata signature' concreteArgs+  (calldata, _caveats) <- mkCalldata signature' concreteArgs   preState <- liftIO $ stToIO $ abstractVM calldata theCode maybepre False   let fetcher = Fetch.oracle solvers Nothing opts.rpcInfo   verify solvers fetcher opts preState post Nothing@@ -708,10 +770,10 @@   -> Maybe Precondition   -> m [Expr End] exploreContract solvers theCode signature' concreteArgs opts maybepre = do-  calldata <- mkCalldata signature' concreteArgs+  (calldata, _caveats) <- mkCalldata signature' concreteArgs   preState <- liftIO $ stToIO $ abstractVM calldata theCode maybepre False   let fetcher = Fetch.oracle solvers Nothing opts.rpcInfo-  executeVM fetcher opts.iterConf preState pure+  executeVM fetcher opts.iterConf preState noopPathHandler  -- | Stepper that parses the result of Stepper.runFully into an Expr End runExpr :: Stepper.Stepper Symbolic (Expr End)@@ -776,7 +838,7 @@   -- | Symbolically execute the VM and return the representention of the execution-executeVM :: forall m a . App m => Fetch.Fetcher Symbolic m -> IterConfig -> VM Symbolic -> (Expr End -> m a) -> m [a]+executeVM :: forall m a . App m => Fetch.Fetcher Symbolic m -> IterConfig -> VM Symbolic -> (Expr End -> TVar Bool -> m a) -> m [a] executeVM fetcher iterConfig preState handlePath = interpret fetcher iterConfig preState runExpr handlePath  -- | Symbolically execute the VM and check all endstates against the@@ -821,7 +883,7 @@     putStrLn $ "   Keccak preimages in state: " <> (show $ length preState.keccakPreImgs)     putStrLn $ "   Exploring call " <> call -  results <- executeVM fetcher opts.iterConf preState $ \leaf -> do+  results <- executeVM fetcher opts.iterConf preState $ \leaf shouldAbort -> do     -- Extract partial if applicable     let mPartial = case leaf of           Partial _ _ p -> Just (p, leaf)@@ -835,7 +897,10 @@         when (conf.debug && conf.verb >=2) $ liftIO $ putStrLn $ "   Checking leaf with props: " <> show props <> " SMT result: " <> show res         -- Call custom handler if provided (for immediate Cex processing/validation/printing)         case (cexHandler, res) of-          (Just handler, cex@(Cex _)) -> handler preState cex leaf+          (Just handler, cex@(Cex _)) -> do+            handler preState cex leaf+            when conf.earlyAbort $ liftIO $ atomically $ writeTVar shouldAbort True+          (_, (Cex _)) -> when conf.earlyAbort $ liftIO $ atomically $ writeTVar shouldAbort True           _ -> pure ()         pure (res, leaf)       else pure (Qed, leaf)@@ -846,7 +911,7 @@     putStrLn $ "   Exploration and solving finished, " <> show (length results) <> " branch(es) checked in call " <> call <> " of which partial: "                 <> show (length smtResults)     let cexs = filter (\(res, _) -> not . isQed $ res) smtResults-    putStrLn $ "   Found " <> show (length cexs) <> " counterexample(s) in call " <> call+    putStrLn $ "   Found " <> show (length cexs) <> " potential counterexample(s) in call " <> call    pure (smtResults, catMaybes partials)   where@@ -908,7 +973,7 @@   conf <- readConfig   case bytecodeA == bytecodeB of     True -> liftIO $ do-      putStrLn "bytecodeA and bytecodeB are identical"+      when conf.debug $ putStrLn "bytecodeA and bytecodeB are identical"       pure mempty     False -> do       when conf.debug $ liftIO $ do@@ -933,7 +998,7 @@     getBranches bs = do       let bytecode = if BS.null bs then BS.pack [0] else bs       prestate <- liftIO $ stToIO $ abstractVM calldata bytecode Nothing create-      interpret (Fetch.oracle solvers sess Fetch.noRpc) opts.iterConf prestate runExpr pure+      interpret (Fetch.oracle solvers sess Fetch.noRpc) opts.iterConf prestate runExpr noopPathHandler     filterQeds (EqIssues res partials) = EqIssues (filter (\(r, _) -> not . isQed $ r) res) partials  rewriteFresh :: Text -> [Expr a] -> [Expr a]@@ -956,7 +1021,7 @@         liftIO $ printPartialIssues branchesB "codeB"        let allPairs = [(a,b) | a <- branchesA, b <- branchesB]-      liftIO $ putStrLn $ "Found " <> show (length allPairs) <> " total pairs of endstates"+      when conf.debug $ liftIO $ putStrLn $ "Found " <> show (length allPairs) <> " total pairs of endstates"        when conf.dumpEndStates $ liftIO $         putStrLn $ "endstates in bytecodeA: " <> show (length branchesA)@@ -965,9 +1030,9 @@       ps <- forM allPairs $ uncurry distinct       let differingEndStates = sortBySize $ mapMaybe (view _1) ps       let knownIssues = foldr ((<>) . (view _2)) mempty ps-      liftIO $ putStrLn $ "Asking the SMT solver for " <> (show $ length differingEndStates) <> " pairs"-      when conf.dumpEndStates $ forM_ (zip differingEndStates [(1::Integer)..]) (\(x, i) ->-        liftIO $ T.writeFile ("prop-checked-" <> show i <> ".prop") (T.pack $ show x))+      when conf.debug $ liftIO $ putStrLn $ "Asking the SMT solver for " <> (show $ length differingEndStates) <> " pairs"+      when conf.dumpEndStates $ forM_ (zip differingEndStates [(1::Integer)..]) (\((props, msg), i) ->+        liftIO $ T.writeFile ("prop-checked-" <> show i <> ".prop") (T.pack $ show props <> msg))        procs <- liftIO getNumProcessors       newDifferences <- checkAll differingEndStates procs@@ -1079,7 +1144,7 @@               <> " with constraints: " <> (T.unpack . T.unlines $ map formatProp aProps)             liftIO $ putStrLn $ "create deployed code B: " <> bsToHex codeB               <> " with constraints: " <> (T.unpack . T.unlines $ map formatProp bProps)-          calldata <- mkCalldata Nothing []+          (calldata, _) <- mkCalldata Nothing []           equivalenceCheck solvers sess codeA codeB defaultVeriOpts calldata False         _ -> internalError $ "Symbolic code returned from constructor." <> " A: " <> show simpA <> " B: " <> show simpB 

@@ -1,6 +1,6 @@ module EVM.Transaction where -import EVM (initialContract, ceilDiv)+import EVM (initialContract, ceilDiv, collision) import EVM.Expr qualified as Expr import EVM.FeeSchedule import EVM.Format (hexText)@@ -34,10 +34,14 @@   = LegacyTransaction   | AccessListTransaction   | EIP1559Transaction+  | EIP4844Transaction+  | EIP7702Transaction   deriving (Show, Eq, Generic)  instance JSON.ToJSON TxType where   toJSON t = case t of+               EIP7702Transaction    -> "0x4" -- permanently sets the code for an EOA+               EIP4844Transaction    -> "0x3" -- Proto-Danksharding                EIP1559Transaction    -> "0x2" -- EIP1559                LegacyTransaction     -> "0x1" -- EIP2718                AccessListTransaction -> "0x1" -- EIP2930@@ -107,6 +111,7 @@   where hash = keccak' (signingData tx)         v    = tx.v         v'   = if v == 27 || v == 28 then v+               else if v >= 35 then 28 - (v `mod` 2) -- EIP155                else 27 + v  sign :: Integer -> Transaction -> Transaction@@ -123,6 +128,8 @@       else normalData     AccessListTransaction -> eip2930Data     EIP1559Transaction -> eip1559Data+    EIP4844Transaction -> eip4844Data+    EIP7702Transaction -> eip7702Data   where v          = tx.v         to'        = case tx.toAddr of           Just a  -> BS $ word160Bytes a@@ -165,7 +172,6 @@           , BS tx.txdata           , rlpAccessList           ]-         eip2930Data = cons 0x01 $ rlpList           [ rlpWord256 tx.chainId           , rlpWord256 tx.nonce@@ -176,6 +182,31 @@           , BS tx.txdata           , rlpAccessList           ]+        eip4844Data = cons 0x03 $ rlpList+          [ rlpWord256 tx.chainId+          , rlpWord256 tx.nonce+          , rlpWord256 maxPrio+          , rlpWord256 maxFee+          , rlpWord256 (into tx.gasLimit)+          , to'+          , rlpWord256 tx.value+          , BS tx.txdata+          , rlpAccessList+          , rlpWord256 $ undefined -- TODO EIP4844 max_fee_per_blob_gas+          , undefined -- TODO EIP4844 blob_versioned_hashes+          ]+        eip7702Data = cons 0x04 $ rlpList+          [ rlpWord256 tx.chainId+          , rlpWord256 tx.nonce+          , rlpWord256 maxPrio+          , rlpWord256 maxFee+          , rlpWord256 (into tx.gasLimit)+          , to'+          , rlpWord256 tx.value+          , BS tx.txdata+          , rlpAccessList+          , undefined -- TODO EIP4844 authorization_list+          ]  accessListPrice :: FeeSchedule Word64 -> [AccessListEntry] -> Word64 accessListPrice fs al =@@ -198,6 +229,20 @@       initcodeCost = fs.g_initcodeword * unsafeInto (ceilDiv (BS.length calldata) 32)   in baseCost + zeroCost * (unsafeInto zeroBytes) + nonZeroCost * (unsafeInto nonZeroBytes) +-- | EIP-7623: Calculate floor gas cost based on calldata tokens+-- tokens = zero_bytes + (nonzero_bytes * 4)+-- floor_gas = 21000 + 10 * tokens+-- then gas_used = max(txGasCost, floor_gas)+txdataFloorGas :: FeeSchedule Word64 -> Transaction -> Word64+txdataFloorGas fs tx =+  let calldata     = tx.txdata+      zeroBytes    = BS.count 0 calldata+      nonZeroBytes = BS.length calldata - zeroBytes+      baseCost     = fs.g_transaction+      floorCost    = fs.g_txdatafloor+      tokens       = unsafeInto zeroBytes + unsafeInto nonZeroBytes * 4+  in baseCost + floorCost * tokens+ instance FromJSON AccessListEntry where   parseJSON (JSON.Object val) = do     accessAddress_ <- addrField val "address"@@ -219,7 +264,7 @@     toAddr   <- addrFieldMaybe val "to"     v        <- wordField val "v"     value    <- wordField val "value"-    txType   <- fmap (read :: String -> Int) <$> (val JSON..:? "type")+    txType   <- fmap (read :: String -> Int) <$> val JSON..:? "type"     case txType of       Just 0x00 -> pure $ Transaction tdata gasLimit gasPrice nonce r s toAddr v value LegacyTransaction [] Nothing Nothing 1       Just 0x01 -> do@@ -228,6 +273,14 @@       Just 0x02 -> do         accessListEntries <- (val JSON..: "accessList") >>= parseJSONList         pure $ Transaction tdata gasLimit gasPrice nonce r s toAddr v value EIP1559Transaction accessListEntries maxPrio maxFee 1+      Just 0x03 -> do+        accessListEntries <- (val JSON..: "accessList") >>= parseJSONList+        -- TODO: capture max_fee_per_blob_gas and blob_versioned_hashes EIP4844+        pure $ Transaction tdata gasLimit gasPrice nonce r s toAddr v value EIP4844Transaction accessListEntries maxPrio maxFee 1+      Just 0x04 -> do+        accessListEntries <- (val JSON..: "accessList") >>= parseJSONList+        -- TODO: capture authorization_list EIP7702+        pure $ Transaction tdata gasLimit gasPrice nonce r s toAddr v value EIP7702Transaction accessListEntries maxPrio maxFee 1       Just _ -> fail "unrecognized custom transaction type"       Nothing -> pure $ Transaction tdata gasLimit gasPrice nonce r s toAddr v value LegacyTransaction [] Nothing Nothing 1   parseJSON invalid =@@ -267,13 +320,21 @@     preState = setupTx origin coinbase gasPrice gasLimit vm.env.contracts     oldBalance = view (accountAt toAddr % #balance) preState     creation = vm.tx.isCreate-    initState =-        ((Map.adjust (over #balance (`Expr.sub` value))) origin)-      . (Map.adjust (over #balance (Expr.add value))) toAddr-      . (if creation-         then Map.insert toAddr (toContract & (set #balance oldBalance))-         else touchAccount toAddr)-      $ preState+    -- Check for collision at target address for CREATE transactions+    hasCollision = creation && collision (Map.lookup toAddr preState)+    -- For collision: don't transfer value, don't create contract+    initState = if hasCollision+      then touchAccount toAddr preState+      else ((Map.adjust (over #balance (`Expr.sub` value))) origin)+         . (Map.adjust (over #balance (Expr.add value))) toAddr+         . (if creation+            then Map.insert toAddr (toContract & (set #balance oldBalance))+            else touchAccount toAddr)+         $ preState+    applyWhen p f x = if p then f x else x   in     vm & #env % #contracts .~ initState        & #tx % #txReversion .~ preState+       -- For collision: set code to empty so exec1 immediately stops and calls finalize+       -- (don't set #result directly, as that bypasses finalize which handles gas payment)+       & applyWhen hasCollision (#state % #code .~ RuntimeCode (ConcreteRuntimeCode ""))

@@ -123,6 +123,7 @@       e@(SGT a b) -> f e <> (go a) <> (go b)       e@(Eq a b) -> f e <> (go a) <> (go b)       e@(IsZero a) -> f e <> (go a)+      e@(ITE c t el) -> f e <> (go c) <> (go t) <> (go el)        -- bits @@ -133,11 +134,11 @@       e@(SHL a b) -> f e <> (go a) <> (go b)       e@(SHR a b) -> f e <> (go a) <> (go b)       e@(SAR a b) -> f e <> (go a) <> (go b)+      e@(CLZ a) -> f e <> (go a)        -- Hashes        e@(Keccak a) -> f e <> (go a)-      e@(SHA256 a) -> f e <> (go a)        -- block context @@ -448,6 +449,11 @@   IsZero a -> do     a' <- mapExprM f a     f (IsZero a')+  ITE c t el -> do+    c' <- mapExprM f c+    t' <- mapExprM f t+    el' <- mapExprM f el+    f (ITE c' t' el')    -- bits @@ -478,6 +484,9 @@     a' <- mapExprM f a     b' <- mapExprM f b     f (SAR a' b')+  CLZ a -> do+    a' <- mapExprM f a+    f (CLZ a')     -- Hashes@@ -485,10 +494,6 @@   Keccak a -> do     a' <- mapExprM f a     f (Keccak a')--  SHA256 a -> do-    a' <- mapExprM f a-    f (SHA256 a')    -- block context 

@@ -259,6 +259,9 @@   Eq             :: Expr EWord -> Expr EWord -> Expr EWord   IsZero         :: Expr EWord -> Expr EWord +  -- conditional (if-then-else for path merging)+  ITE            :: Expr EWord -> Expr EWord -> Expr EWord -> Expr EWord+   -- bits    And            :: Expr EWord -> Expr EWord -> Expr EWord@@ -268,11 +271,11 @@   SHL            :: Expr EWord -> Expr EWord -> Expr EWord   SHR            :: Expr EWord -> Expr EWord -> Expr EWord   SAR            :: Expr EWord -> Expr EWord -> Expr EWord+  CLZ            :: Expr EWord -> Expr EWord    -- Hashes    Keccak         :: Expr Buf -> Expr EWord-  SHA256         :: Expr Buf -> Expr EWord    -- block context @@ -558,6 +561,7 @@   | NonceOverflow   | BadCheatCode String FunctionSelector   | NonexistentFork Int+  | AssumeCheatFailed   deriving (Show, Eq, Ord)  evmErrToString :: EvmError -> String@@ -596,6 +600,15 @@   | BranchTooDeep         { pc :: Int, addr :: Expr EAddr}   deriving (Show, Eq, Ord) +-- | A program-wide soundness caveat. Unlike a 'PartialExec', a caveat does not+-- mark an execution path that we failed to explore: every reachable path was+-- explored fully. It records that the *space of inputs* was restricted, so the+-- result is only valid within that restriction. It is therefore attached to the+-- verification result as a whole, not to an individual 'Expr End' leaf.+data Caveat+  = DynArgBounded { maxSize :: Int }  -- ^ dynamic (bytes/string) calldata args were bounded to this many bytes+  deriving (Show, Eq, Ord)+ -- | Effect types used by the vm implementation for side effects & control flow data Effect t where   Query :: Query t -> Effect t@@ -662,6 +675,36 @@  -- VM State ---------------------------------------------------------------------------------------- +-- | State tracking for speculative merge execution+data MergeState = MergeState+  { msActive          :: Bool   -- ^ Inside speculative execution+  , msRemainingBudget :: Int    -- ^ Instructions remaining in budget+  } deriving (Show, Eq, Generic)++defaultMergeState :: MergeState+defaultMergeState = MergeState False 0++-- | An active vm.expectRevert / vm.expectPartialRevert expectation set by a+-- cheat call. Consumed when the matching frame returns/reverts.+data ExpectedRevert = ExpectedRevert+  { reason         :: Maybe (Expr Buf)+  -- ^ Nothing matches any revert data; Just expected matches concrete bytes.+  , depth          :: Int+  -- ^ length of vm.frames at the cheat call. The matching boundary is the+  -- frame popping back down to this depth (i.e. the next outer subcall).+  , partialMatch   :: Bool+  -- ^ True for expectPartialRevert (compares only first 4 bytes of actual).+  , reverter       :: Maybe (Expr EAddr)+  -- ^ Nothing matches any reverter; Just want enforces actualReverter equals+  -- this address.+  , actualReverter :: Maybe (Expr EAddr)+  -- ^ The first contract observed reverting in a non-CREATE frame after the+  -- expectation was set. Captured on the first FrameReverted that arrives in a+  -- CALL frame; subsequent reverts (bubble-ups) do not overwrite it. Used at+  -- the matching boundary to compare against the expected reverter.+  }+  deriving (Show, Generic)+ data VMType = Symbolic | Concrete  type family Gas (t :: VMType) = r | r -> t where@@ -686,6 +729,7 @@   , config         :: RuntimeConfig   , forks          :: Seq ForkState   , currentFork    :: Int+  , srcLookup      :: Maybe SrcLookup   , labels         :: Map Addr Text   , osEnv          :: Map String String   , freshVar       :: Int@@ -693,6 +737,9 @@   --   during symbolic execution. See e.g. OpStaticcall   , exploreDepth   :: Int   , keccakPreImgs  :: Set (ByteString, W256)+  , mergeState     :: MergeState+  , expectedRevert :: Maybe ExpectedRevert+  -- ^ Active expectRevert/expectPartialRevert expectation, if any.   }   deriving (Generic) @@ -716,6 +763,19 @@   | AbstractBase   deriving (Show) +-- | A callback for looking up source location info given the contracts map,+-- an address, and a PC+newtype SrcLookup = SrcLookup (Map (Expr EAddr) Contract -> Expr EAddr -> Int -> String)++instance Show SrcLookup where+  show _ = "<SrcLookup Info>"++-- | Run a SrcLookup to get source location info, with a fallback for when+-- no SrcLookup is available.+runSrcLookup :: Maybe SrcLookup -> Map (Expr EAddr) Contract -> Expr EAddr -> Int -> String+runSrcLookup Nothing _ addr pc = " at addr: " <> show addr <> " at pc: " <> show pc+runSrcLookup (Just (SrcLookup f)) contracts addr pc = f contracts addr pc+ -- | Configuration options that need to be consulted at runtime data RuntimeConfig = RuntimeConfig   { allowFFI :: Bool@@ -809,6 +869,7 @@   , subState    :: SubState   , isCreate    :: Bool   , txReversion :: Map (Expr EAddr) Contract+  , txdataFloorGas :: Word64   }   deriving (Show) @@ -945,6 +1006,7 @@   | ErrorTrace EvmError   | EntryTrace Text   | ReturnTrace (Expr Buf) FrameContext+  | ConsoleLog (Expr Buf)   deriving (Eq, Ord, Show, Generic)  -- | Wrapper type containing vm traces and the context needed to pretty print them properly@@ -992,6 +1054,8 @@   , allowFFI :: Bool   , freshAddresses :: Int   , beaconRoot :: W256+  , parentHash :: W256      -- EIP-2935 parent block hash+  , txdataFloorGas :: Word64   }  deriving instance Show (VMOpts Symbolic)@@ -1030,6 +1094,7 @@   | OpShl   | OpShr   | OpSar+  | OpClz   | OpSha3   | OpAddress   | OpBalance@@ -1214,6 +1279,9 @@ newtype FunctionSelector = FunctionSelector { unFunctionSelector :: Word32 }   deriving (Bits, Num, Eq, Ord, Real, Enum, Integral) instance Show FunctionSelector where show s = "0x" <> showHex s ""+instance Read FunctionSelector where+  readsPrec _ ('0':'x':s) = first FunctionSelector <$> readHex s+  readsPrec _ s = first FunctionSelector <$> readHex s   -- ByteString wrapper ------------------------------------------------------------------------------

@@ -11,7 +11,6 @@ import EVM.Effects import EVM.Exec import EVM.Expr qualified as Expr-import EVM.FeeSchedule (feeSchedule) import EVM.Fetch qualified as Fetch import EVM.Format import EVM.Solidity@@ -23,7 +22,7 @@ import EVM.Tracing qualified as Tracing import EVM.Expr (maybeLitWordSimp) -import Control.Monad (void, when, forM, forM_)+import Control.Monad (void, when, unless, forM, forM_) import Control.Monad.ST (RealWorld, ST, stToIO) import Control.Monad.State.Strict (execState, get, put, liftIO, runStateT) import Optics.Core@@ -48,6 +47,8 @@ import System.IO (hFlush, stdout) import Witch (unsafeInto, into) import Data.Vector qualified as V+import Data.Vector.Storable qualified as VS+import Data.Sequence qualified as Seq import Data.Char (ord)  data UnitTestOptions = UnitTestOptions@@ -57,8 +58,7 @@   , maxIter       :: Maybe Integer   , askSmtIters   :: Integer   , smtTimeout    :: Maybe Natural-  , match         :: Text-  , prefix        :: Text+  , methodFilter  :: TestMethodFilter   , dapp          :: DappInfo   , testParams    :: TestVMParams   , ffiAllowed    :: Bool@@ -121,15 +121,14 @@ -- | Returns tuple of (No Cex, No warnings) unitTest :: App m => UnitTestOptions -> BuildOutput -> m (Bool, Bool) unitTest opts bo@(BuildOutput (Contracts cs) _) = do-  let unitTestContrs = findUnitTests opts.prefix opts.match $ Map.elems cs+  let unitTestContrs = [(c, methods) | c <- Map.elems cs, let methods = findUnitTests opts.methodFilter c, not (null methods)]   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+    let x = map (\(a,b) -> "  --> " <> a.contractName <> "  ---  functions: " <> (Text.pack $ show b)) unitTestContrs     putStrLn $ unlines $ map Text.unpack x-  results <- concatMapM (runUnitTestContract opts bo) unitTestContrs-  when conf.debug $ liftIO $ putStrLn $ "unitTest individual results: " <> show results-  let (firsts, seconds) = unzip results+  results <- mapM (runUnitTestContract opts bo) unitTestContrs+  let (firsts, seconds) = unzip $ concat results   pure (and firsts, and seconds)  -- | Assuming a constructor is loaded, this stepper will run the constructor@@ -205,33 +204,29 @@   :: App m   => UnitTestOptions   -> BuildOutput-  -> (Text, [Sig])+  -> (SolcContract, [Sig])   -> m [(Bool, Bool)] runUnitTestContract-  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 (getContractsMap buildOut.contracts) of-    Nothing -> internalError $ "Contract " ++ unpack name ++ " not found"-    Just solcContr -> do-      -- Construct the initial VM and begin the contract's constructor-      vm0 :: VM Concrete <- liftIO $ stToIO $ initialUnitTestVm opts solcContr-      vm1 <- Stepper.interpret (Fetch.oracle solvers (Just sess) rpcInfo) vm0 $ do-        Stepper.enter name-        initializeUnitTest opts solcContr-        Stepper.evm get+  opts@(UnitTestOptions {..}) buildOut (contract, testSigs) = do+  unless (Map.member contract.contractName (getContractsMap buildOut.contracts)) $ internalError $ "Contract " ++ unpack contract.contractName ++ " not found"+  liftIO $ putStrLn $ "Checking " ++ show (length testSigs) ++ " function(s) in contract " ++ unpack contract.contractName+  -- Construct the initial VM and begin the contract's constructor+  vm0 :: VM Concrete <- liftIO $ stToIO $ initialUnitTestVm opts contract+  vm1 <- Stepper.interpret (Fetch.oracle solvers (Just sess) rpcInfo) vm0 $ do+    Stepper.enter contract.contractName+    initializeUnitTest opts contract+    Stepper.evm get -      writeTraceDapp dapp vm1-      failOut <- failOutput vm1 opts "setUp()"-      case vm1.result of-        Just (VMFailure _) -> liftIO $ do-          Text.putStrLn "   \x1b[31m[BAIL]\x1b[0m setUp() "-          tick $ indentLines 3 failOut-          pure [(True, False)]-        Just (VMSuccess _) -> do-          forM testSigs $ \s -> symRun opts vm1 s solcContr buildOut.sources-        _ -> internalError "setUp() did not end with a result"+  writeTraceDapp dapp vm1+  failOut <- failOutput vm1 opts "setUp()"+  case vm1.result of+    Just (VMFailure _) -> liftIO $ do+      Text.putStrLn "   \x1b[31m[BAIL]\x1b[0m setUp() "+      tick $ indentLines 3 failOut+      pure [(True, False)]+    Just (VMSuccess _) -> do+      forM testSigs $ \s -> symRun opts vm1 s buildOut.sources+    _ -> internalError "setUp() did not end with a result"  dsTestFailedSym :: Map (Expr 'EAddr) (Expr EContract) -> VM t -> Prop dsTestFailedSym store vm =@@ -247,11 +242,12 @@  -- Define the thread spawner for symbolic tests -- Returns tuple of (No Cex, No warnings)-symRun :: forall m . App m => UnitTestOptions -> VM Concrete -> Sig -> SolcContract -> SourceCache -> m (Bool, Bool)-symRun opts@UnitTestOptions{..} vm sig@(Sig testName types) solcContr sourceCache = do+symRun :: forall m . App m => UnitTestOptions -> VM Concrete -> Sig -> SourceCache -> m (Bool, Bool)+symRun opts@UnitTestOptions{..} vm sig@(Sig testName types) sourceCache = do     let cs = callSig sig     liftIO $ putStrLn $ "\x1b[96m[RUNNING]\x1b[0m " <> Text.unpack cs-    cd <- symCalldata cs types [] (AbstractBuf "txdata")+    (cdBuf, cdProps, caveats) <- symCalldata cs types [] (AbstractBuf "txdata")+    let cd = (cdBuf, cdProps)     let shouldFail = "proveFail" `isPrefixOf` cs      -- define postcondition depending on `shouldFail`@@ -285,7 +281,8 @@      -- check postconditions against vm     let fetcherSym = Fetch.oracle solvers (Just sess) rpcInfo-    (ends, results) <- verify solvers fetcherSym (makeVeriOpts opts) (symbolify vm') postcondition (Just $ cexHandler cd fetcherConc)+    let symVm = symbolify vm' & set #srcLookup (Just $ makeSrcLookup dapp sourceCache)+    (ends, results) <- verify solvers fetcherSym (makeVeriOpts opts) symVm postcondition (Just $ cexHandler cd fetcherConc)     conf <- readConfig     when (conf.debug) $ liftIO $ do       putStrLn $ "   \x1b[94m[EXPLORATION COMPLETE]\x1b[0m " <> Text.unpack testName <> " -- explored " <> show (length ends) <> " paths."@@ -298,7 +295,11 @@     when (conf.debug && conf.verb >=2) $ liftIO $ do       putStrLn $ "Collected END-s:\n" <> prettyvmresults ends       putStrLn $ "Collected verification results: " <> show results-    let warnings = any Expr.isPartial ends || any isUnknown results || any isError results+    -- Caveats (e.g. dynamic args bounded to maxDynSize) restrict the input+    -- domain rather than leaving a path unexplored, so they are not Partials;+    -- they still count as a warning so a bounded run is not reported as a clean+    -- pass (avoids a false sense of security).+    let warnings = any Expr.isPartial ends || any isUnknown results || any isError results || not (null caveats)     let allReverts = not . (any Expr.isSuccess) $ ends     let unexpectedAllRevert = allReverts && not shouldFail     when conf.debug $ liftIO $ putStrLn $ "   symRun -- (cex,warnings,unexpectedAllRevert): " <> show (any isCex results, warnings, unexpectedAllRevert)@@ -319,8 +320,9 @@     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"-    let warnData = Just $ WarningData solcContr sourceCache vm'-    liftIO $ printWarnings warnData ends results $ "the test " <> Text.unpack testName+    let sl = Just $ makeSrcLookup dapp sourceCache+    liftIO $ printWarnings sl vm'.env.contracts ends results $ "the test " <> Text.unpack testName+    liftIO $ printCaveats caveats     pure (not (any isCex results), not (warnings || unexpectedAllRevert))     where       cexHandler :: (Expr 'Buf, [Prop])@@ -364,15 +366,24 @@               lhs = LitByte (c2w a)               rhs = Expr.readByte (Lit (fromIntegral n)) b ---printWarnings :: Maybe (WarningData t) -> GetUnknownStr b => [Expr 'End] -> [ProofResult a b] -> String -> IO ()-printWarnings warnData e results testName = do+printWarnings :: Maybe SrcLookup -> Map (Expr EAddr) Contract -> GetUnknownStr b => [Expr 'End] -> [ProofResult a b] -> String -> IO ()+printWarnings srcLookupM contracts 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 warnData e) $ \(num, str) -> putStrLn $ "      " <> show num <> "x -> " <> str+    forM_ (groupPartials srcLookupM contracts e) $ \(num, str) -> putStrLn $ "      " <> show num <> "x -> " <> str   putStrLn "" +-- | Print any program-wide soundness caveats (see 'Caveat'). Unlike+-- 'printWarnings' this is not about unexplored paths: it tells the user the+-- input domain was restricted, so a "no counterexample" result is only valid+-- within that restriction.+printCaveats :: [Caveat] -> IO ()+printCaveats caveats =+  forM_ caveats $ \c ->+    putStrLn $ "   \x1b[33m[CAVEAT]\x1b[0m " <> Text.unpack (formatCaveat c)+ getReproFailure :: App m => Sig -> Expr Buf -> SMTCex -> m (Err ReproducibleCex) getReproFailure sig@(Sig testName _) cd cex = do   bs <- calldataFromCex cex cd sig@@ -524,13 +535,10 @@   vm <- get   put $ initTx vm -initialUnitTestVm :: VMOps t => UnitTestOptions -> SolcContract -> ST RealWorld (VM t)+initialUnitTestVm :: forall t. VMOps t => UnitTestOptions -> SolcContract -> ST RealWorld (VM t) initialUnitTestVm (UnitTestOptions {..}) theContract = do-  vm <- makeVm $ VMOpts+  vm <- makeVm $ (defaultVMOpts @t)            { contract = initialContract (InitCode theContract.creationCode mempty)-           , otherContracts = []-           , calldata = mempty-           , value = Lit 0            , address = testParams.address            , caller = testParams.caller            , origin = testParams.origin@@ -545,20 +553,35 @@            , priorityFee = testParams.priorityFee            , maxCodeSize = testParams.maxCodeSize            , prevRandao = testParams.prevrandao-           , schedule = feeSchedule            , chainId = testParams.chainId            , create = True-           , baseState = EmptyBase-           , txAccessList = mempty -- TODO: support unit test access lists???            , allowFFI = ffiAllowed-           , freshAddresses = 0-           , beaconRoot = 0            }   let creator =         initialContract (RuntimeCode (ConcreteRuntimeCode ""))           & set #nonce (Just 1)           & set #balance (Lit testParams.balanceCreate)   pure $ vm & set (#env % #contracts % at (LitAddr ethrunAddress)) (Just creator)++-- | Build a SrcLookup callback that resolves (address, pc) to source location info+makeSrcLookup :: DappInfo -> SourceCache -> SrcLookup+makeSrcLookup dapp srcCache = SrcLookup $ \contracts addr pc ->+  let fallback = " at addr: " <> show addr <> " at pc: " <> show pc+  in fromMaybe fallback $ do+    contr <- Map.lookup addr contracts+    pcOp <- contr.opIxMap VS.!? pc+    sol <- findSrc contr dapp+    sMap <- case contr.code of+      RuntimeCode _ -> Seq.lookup pcOp sol.runtimeSrcmap+      InitCode _ _ -> Seq.lookup pcOp sol.creationSrcmap+      UnknownCode _ -> Nothing+    (fname, fcontent) <- Map.lookup sMap.file srcCache.files+    let eols = BS.count '\n' $ BS.take sMap.offset fcontent+    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  paramsFromRpc :: forall m . App m => Fetch.RpcInfo -> Fetch.Session -> m TestVMParams paramsFromRpc rpcInfo sess = do

@@ -0,0 +1,198 @@+{-# LANGUAGE QuasiQuotes #-}++module EVM.ConcreteExecution.ConcreteExecutionTests (tests) where++import Control.Monad.ST (stToIO)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Functor ((<&>))+import Data.Maybe (fromMaybe)+import Data.String.Here+import Data.Text (Text)+import Data.Text qualified as T+import Data.Tree (flatten)+import Data.Vector qualified as V++import EVM.ABI+import EVM.Effects qualified as Effects+import EVM.Fetch qualified as Fetch+import EVM.Solidity (solcRuntime)+import EVM.Solvers (defMemLimit)+import EVM.Stepper qualified+import EVM.Transaction (initTx)+import EVM.Types+import EVM (initialContract, makeVm, defaultVMOpts, traceForest)+import Test.Tasty+import Test.Tasty.HUnit++type SourceCode = Text+type ContractName = Text+type FunctionName = Text+type Args = [AbiValue]+type ExecResult = Either EvmError (Expr Buf)++compileOneContract :: SourceCode -> ContractName -> IO ByteString+compileOneContract sourceCode contractName =+  solcRuntime contractName sourceCode <&> fromMaybe (internalError $ "Contract " <> (show contractName) <> " not present in the given source code")+++-- | Set up and run a single contract call, returning the final VM state.+setupAndRunCall :: SourceCode -> ContractName -> FunctionName -> Args -> EVM.Stepper.Stepper Concrete a -> IO a+setupAndRunCall sourceCode contractName functionName abiArgs stepper = do+  runtimeCode <- compileOneContract sourceCode contractName+  let functionSignature = functionName <> "(" <> T.intercalate "," (map (abiTypeSolidity . abiValueType) abiArgs) <> ")"+  let callData = abiMethod functionSignature (AbiTuple $ V.fromList abiArgs)+  let contractWithCode = initialContract (RuntimeCode $ ConcreteRuntimeCode runtimeCode)+  initialVM <- stToIO $ makeVm $ defaultVMOpts+    { contract = contractWithCode+    , calldata = (ConcreteBuf callData, [])+    }+  let withInitializedTransactionVM = EVM.Transaction.initTx initialVM+  let fetcher = Fetch.zero 0 Nothing defMemLimit+  Effects.runApp $ EVM.Stepper.interpret fetcher withInitializedTransactionVM stepper++executeSingleCall :: SourceCode -> ContractName -> FunctionName -> Args -> IO ExecResult+executeSingleCall src name func args = setupAndRunCall src name func args EVM.Stepper.execFully++executeSingleCallVM :: SourceCode -> ContractName -> FunctionName -> Args -> IO (VM Concrete)+executeSingleCallVM src name func args = setupAndRunCall src name func args EVM.Stepper.runFully++tests :: TestTree+tests = testGroup "Concrete execution tests"+  [ testCase "return-updated-input-argument" $ expectValue (AbiUInt 8 3) =<< executeSingleCall simpleUncheckedArithmeticExample "C" "a" [AbiUInt 8 1]+  , testCase "silent-overflow-in-unchecked-arithmetic" $ expectValue (AbiUInt 8 245) =<< executeSingleCall simpleUncheckedArithmeticExample "C" "a" [AbiUInt 8 250]+  , testCase "revert-on-arithmetic-overflow" $ expectRevert =<< executeSingleCall simpleCheckedArithmeticExample "C" "a" [AbiUInt 8 250]+  , testCase "cheat-assume-satisfied" $ expectValue (AbiUInt 8 42) =<< executeSingleCall assumeCheatCodeExample "C" "a" [AbiUInt 8 42]+  , testCase "cheat-assume-failing" $ expectError AssumeCheatFailed =<< executeSingleCall assumeCheatCodeExample "C" "a" [AbiUInt 8 5]+  , testCase "console-log-does-not-revert" $ do+      res <- executeSingleCall consoleLogExample "C" "a" [AbiUInt 256 42]+      _ <- expectSuccess res+      pure ()+  , testCase "console-log-produces-trace" $ do+      vm <- executeSingleCallVM consoleLogExample "C" "a" [AbiUInt 256 42]+      let traces = concatMap flatten (traceForest vm)+          hasConsoleLog = any (\t -> case t.tracedata of ConsoleLog _ -> True; _ -> False) traces+      assertBool "Expected a ConsoleLog trace" hasConsoleLog+  , testCase "console-log-extcodesize-nonzero" $ do+      res <- executeSingleCall consoleLogExtcodesizeExample "C" "a" []+      val <- expectSuccess res+      let obtained = decodeAbiValue (AbiUIntType 256) (BS.fromStrict val)+      assertEqual "extcodesize of console addr should be nonzero" (AbiUInt 256 1) obtained+  , testCase "console-log-returns-correct-value" $ do+      res <- executeSingleCall consoleLogExample "C" "a" [AbiUInt 256 99]+      val <- expectSuccess res+      let obtained = decodeAbiValue (AbiUIntType 256) (BS.fromStrict val)+      assertEqual "return value should be x+1" (AbiUInt 256 100) obtained+  , testCase "console-log-multiple-calls" $ do+      vm <- executeSingleCallVM consoleLogMultipleExample "C" "a" [AbiUInt 256 5]+      let traces = concatMap flatten (traceForest vm)+          consoleLogs = filter (\t -> case t.tracedata of ConsoleLog _ -> True; _ -> False) traces+      assertEqual "Should have 2 console.log traces" 2 (length consoleLogs)+  ]++expectValue :: AbiValue -> ExecResult -> IO ()+expectValue expectedVal res = do+  let abiType = abiValueType expectedVal+  bs <- expectSuccess res+  let obtainedVal = decodeAbiValue abiType (BS.fromStrict bs)+  assertEqual "Incorrect result of concrete execution" expectedVal obtainedVal++expectSuccess :: ExecResult -> IO ByteString+expectSuccess res = do+  buf <- assertRight res+  case buf of+    ConcreteBuf bs -> pure bs+    _ -> assertFailure $ "Unexpected symbolic buffer: " <> show buf++expectRevert :: ExecResult -> IO ()+expectRevert res = do+  err <- assertLeft res+  case err of+    Revert _ -> pure ()+    _ -> assertFailure "Revert was expected, but got a different EVM error"++expectError :: EvmError -> ExecResult -> IO ()+expectError expectedErr res = do+  err <- assertLeft res+  assertEqual "Incorrect error obtained from concrete execution" expectedErr err++assertLeft :: Either e a -> IO e+assertLeft = \case+  Left e -> pure e+  Right _ -> assertFailure "Left we expected, but got Right"++assertRight :: Show e => Either e a -> IO a+assertRight = \case+  Left e -> assertFailure $ "Unexpected error: " <> show e+  Right x -> pure x++simpleUncheckedArithmeticExample :: Text+simpleUncheckedArithmeticExample = [here|+  contract C {+    function a(uint8 x) public returns (uint8 b) {+      unchecked { b = x*2+1; }+    }+  }+|]++simpleCheckedArithmeticExample :: Text+simpleCheckedArithmeticExample = [here|+  contract C {+    function a(uint8 x) public returns (uint8 b) {+      b = x*2+1;+    }+  }+|]++assumeCheatCodeExample :: Text+assumeCheatCodeExample = [here|+  interface Hevm {function assume(bool) external;}+  contract C {+    function a(uint8 x) public returns (uint8 b) {+      Hevm hevm = Hevm(0x7109709ECfa91a80626fF3989D68f67F5b1DD12D);+      hevm.assume(x > 10);+      b = x;+    }+  }+|]++consoleLogExtcodesizeExample :: Text+consoleLogExtcodesizeExample = [here|+  contract C {+    function a() public view returns (uint256) {+      address console = 0x000000000000000000636F6e736F6c652e6c6f67;+      uint256 sz;+      assembly { sz := extcodesize(console) }+      return sz;+    }+  }+|]++consoleLogMultipleExample :: Text+consoleLogMultipleExample = [here|+  contract C {+    function a(uint256 x) public view returns (uint256) {+      address console = 0x000000000000000000636F6e736F6c652e6c6f67;+      bytes memory p1 = abi.encodeWithSignature("log(string)", "before");+      (bool s1,) = console.staticcall(p1);+      require(s1);+      bytes memory p2 = abi.encodeWithSignature("log(uint256)", x);+      (bool s2,) = console.staticcall(p2);+      require(s2);+      return x;+    }+  }+|]++consoleLogExample :: Text+consoleLogExample = [here|+  contract C {+    function a(uint256 x) public view returns (uint256) {+      address console = 0x000000000000000000636F6e736F6c652e6c6f67;+      bytes memory payload = abi.encodeWithSignature("log(string,uint256)", "value is", x);+      (bool s,) = console.staticcall(payload);+      require(s);+      return x + 1;+    }+  }+|]

@@ -0,0 +1,566 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -Wno-x-partial #-}++module EVM.Equivalence.EquivalenceTests (tests) where++import Control.Monad (when, unless, forM_)+import Data.ByteString (ByteString)+import Data.Either.Extra (fromRight)+import Data.Functor ((<&>))+import Data.Maybe (fromMaybe, mapMaybe, fromJust)+import Data.List qualified as List (isInfixOf)+import Data.String.Here+import Data.Text (Text)+import Data.Text qualified as T+import Data.Time (diffUTCTime, getCurrentTime)+import System.Environment (lookupEnv)+import System.FilePath (makeRelative, normalise)+import System.FilePath.Find (find, always, filePath, fileType, (&&?), FileType(RegularFile))+import Test.Tasty+import Test.Tasty.ExpectedFailure (ignoreTest)+import Test.Tasty.HUnit+import Text.RE.TDFA.String hiding (matches)+import Text.RE.Replace (replaceAll, captureText, CaptureOrdinal(..), CaptureID(..))+++import EVM.Effects qualified as Effects+import EVM.Expr qualified as Expr+import EVM.Format (hexByteString)+import EVM.Types+import EVM.Solidity (solcRuntime, solidity, yul)+import EVM.Solidity qualified as Solidity (CodeType(..))+import EVM.Solvers (withSolvers, defMemLimit, Solver(..))+import EVM.SymExec++tests :: TestTree+tests = testGroup "Bytecode equivalence tests"+  [ runtimeSolidityEquivalenceTests+  , deploymentSolidityEquivalenceTests+  , bytecodeEquivalenceTests+  , yulEquivalenceTests+  ]+++type SourceCode = Text++infix 2 `with`+infix 1 `on`++type Substitution = (Text, Text)+with :: Text -> Text -> Substitution+with = (,)++type SubstitutionJob = (Substitution, Text)+on :: Substitution -> Text -> SubstitutionJob+on = (,)++replace :: SubstitutionJob -> Text+replace ((old, new), txt) =+  case break matches (T.lines txt) of+    (xs, _:ys) -> T.unlines (xs ++ new : ys)+    _          -> internalError "replace: line not found"+  where+    matches line = T.strip line == T.strip old++compile :: SourceCode -> Solidity.CodeType -> IO ByteString+compile sourceCode Solidity.Runtime = solcRuntime "C" sourceCode <&> fromMaybe (internalError "Contract C not present in the given source code")+compile sourceCode Solidity.Creation = solidity "C" sourceCode <&> fromMaybe (internalError "Contract C not present in the given source code")++run :: SourceCode -> SourceCode -> Solidity.CodeType -> IO EqIssues+run s s' codeType = do+  a <- compile s codeType+  b <- compile s' codeType+  Effects.runApp $ withSolvers Bitwuzla 3 Nothing defMemLimit $ \sg -> do+    (calldata, _) <- mkCalldata Nothing []+    equivalenceCheck sg Nothing a b defaultVeriOpts calldata (codeType == Solidity.Creation)++runtimeSolidityEquivalenceTests :: TestTree+runtimeSolidityEquivalenceTests = testGroup "Solidity runtime equivalence"+  [+    testCase "eq-simple-diff" $ do+      let a = [here|+                contract C {+                  function stuff() public returns (uint256) {+                    return 4;+                  }+                }+             |]+      let b = replace $ "return 4;" `with` "return 5;" `on` a+      expectDifference 1 a b+  -- diverging gas overapproximations are caught+  -- previously, they had the same name (gas_...), so they compared equal+  , testCase "eq-divergent-overapprox-gas" $ do+    let a = [here|+              contract C {+                uint x;+                function stuff(uint a) public returns (uint256) {+                  unchecked { x = a * 2; }+                  return gasleft();+                }+              }+            |]+    let b = replace $ "unchecked { x = a * 2; }" `with` "unchecked { x = a + a; }" `on` a+    expectDifference 1 a b+  -- diverging gas overapproximations are caught+  -- previously, CALL fresh variables were the same so they compared equal+  , testCase "eq-divergent-overapprox-call" $ do+    let a = [i|+              contract C {+                function checkval(address inputAddr, uint256 x, uint256 y) public returns (bool) {+                    bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y);+                    (bool success, bytes memory returnData) = inputAddr.staticcall(data);+                    return success;+                }+              }+            |]+    let b = replace $ [here|bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, y);|]+              `with`  [here|bytes memory data = abi.encodeWithSignature("add(uint256,uint256)", x, x);|]+              `on` a+    expectDifference 1 a b+  , testCase "eq-unknown-addr" $ do+      let a = [i|+                contract C {+                  address addr;+                  function a(address a, address b) public {+                    addr = a;+                  }+                }+              |]+      let b = replace $ "addr = a;" `with` "addr = b;" `on` a+      expectDifference 1 a b+  , testCase "eq-sol-exp-cex" $ do+      let a = [i|+                contract C {+                  function a(uint8 x) public returns (uint8 b) {+                    unchecked {+                      b = x*2+1;+                    }+                  }+                }+              |]+      let b = replace $ "b = x*2+1;" `with` "b = x<<1;" `on` a+      expectDifference 1 a b+  , testCase "eq-sol-exp-qed" $ do+      let a = [i|+                contract C {+                  function a(uint8 x) public returns (uint8 b) {+                    unchecked {+                      b = x*2;+                    }+                  }+                }+              |]+      let b = replace $ "b = x*2;" `with` "b = x<<1;" `on` a+      expectEquivalent a b+  , testCase "eq-balance-differs" $ do+      let a = [i|+                contract Send {+                  constructor(address payable dst) payable {+                    selfdestruct(dst);+                  }+                }+                contract C {+                  function f() public {+                    new Send{value:2}(payable(address(0x0)));+                  }+                }+              |]+      let b = replace $ "new Send{value:2}(payable(address(0x0)));" `with` "new Send{value:1}(payable(address(0x0)));" `on` a+      expectDifferent a b+  , testCase "eq-storage-write-to-static-array-uint128" $ do+      let a =+            [i|+              contract C {+                uint128[5] arr;+                function set(uint i, uint128 v) external returns (uint) {+                  arr[i] = v;+                  arr[i] = v;+                  return 0;+                }+              }+            |]+      let b = replace $ "arr[i] = v;" `with` "" `on` a -- NOTE: This effectively removes the first occurrence+      expectEquivalent a b+  , testCase "eq-storage-write-to-static-array-uint8" $ do+      let a =+            [i|+              contract C {+                uint8[10] arr;+                function set(uint i, uint8 v) external returns (uint) {+                  arr[i] = v;+                  arr[i] = v;+                  return 0;+                }+              }+            |]+      let b = replace $ "arr[i] = v;" `with` "" `on` a -- NOTE: This effectively removes the first occurrence+      expectEquivalent a b+  , testCase "eq-storage-write-to-static-array-uint32" $ do+      let a =+            [i|+              contract C {+                uint32[5] arr;+                function set(uint i, uint32 v) external returns (uint) {+                  arr[i] = 1;+                  arr[i] = v;+                  return 0;+                }+              }+            |]+      let b = replace $ "arr[i] = 1;" `with` "" `on` a+      expectEquivalent a b+  , ignoreTest $ testCase "eq-handles-contract-deployment" $ do -- TODO: this fails because we don't check equivalence of deployed contracts+      let a = [i|+                contract Send {+                  constructor(address payable dst) payable {+                    selfdestruct(dst);+                  }+                }++                contract A {+                  address parent;+                  constructor(address p) {+                    parent = p;+                  }+                  function evil() public {+                    parent.call(abi.encode(C.drain.selector));+                  }+                }++                contract C {+                  address child;+                  function a() public {+                    child = address(new A(address(this)));+                  }+                  function drain() public {+                    require(msg.sender == child);+                    new Send{value: address(this).balance}(payable(address(0x0)));+                  }+                }+              |]+      let b = [i|+                contract Send {+                  constructor(address payable dst) payable {+                    selfdestruct(dst);+                  }+                }++                contract A {+                  address parent;+                  constructor(address p) {+                      parent = p;+                  }+                }++                contract C {+                  address child;+                  function a() public {+                    child = address(new A(address(this)));+                  }+                  function drain() public {+                    require(msg.sender == child);+                    new Send{value: address(this).balance}(payable(address(0x0)));+                  }+                }+              |]+      expectDifferent a b+  ]+  where+    expectDifference :: Int -> SourceCode -> SourceCode -> IO ()+    expectDifference diffCount s s' = do+      eq <- run s s' Solidity.Runtime+      assertBool "Must have a difference" (any (isCex . fst) eq.res)+      let cexs = mapMaybe (getCex . fst) eq.res+      assertEqual "Must have exactly one cex" diffCount (length cexs)++    expectDifferent :: SourceCode -> SourceCode -> IO ()+    expectDifferent s s' = do+      eq <- run s s' Solidity.Runtime+      assertBool "Must have a difference" (any (isCex . fst) eq.res)++    expectEquivalent :: SourceCode -> SourceCode -> IO ()+    expectEquivalent s s' = do+      eq <- run s s' Solidity.Runtime+      assertEqual "Must have no difference" [] (map fst eq.res)++deploymentSolidityEquivalenceTests :: TestTree+deploymentSolidityEquivalenceTests = testGroup "Solidity deployment equivalence"+  [ testCase "constructor-same-deployed-diff" $ do+      let a = [i|+                contract C {+                  uint public immutable NUMBER;+                  constructor(uint a) {+                    NUMBER = 4;+                  }+                  function stuff(uint b) public returns (uint256) {+                    unchecked{return 2*b+NUMBER;}+                  }+                }+              |]+      let b = replace $ "unchecked{return 2*b+NUMBER;}" `with` "unchecked {return 4*b+NUMBER;}" `on` a+      expectDifferent a b+  , testCase "constructor-same-deployed-diff2" $ do+      let aBody = [i|+                    uint public immutable NUMBER;+                    constructor(uint a) {+                      NUMBER = 4;+                    }+                    function stuff(uint b) public returns (uint256) {+                      unchecked{return 4*b+NUMBER;}+                    }+                  |]+      let bBody = aBody+            <> [i|+                function stuff_other(uint b) public returns (uint256) {+                  unchecked {return 2*b+NUMBER;}+                }+              |]+      let a = wrap aBody+      let b = wrap bBody+      expectDifferent a b+  , testCase "constructor-same-deployed-diff3" $ do+      let aBody = [i|+                    uint public immutable NUMBER;+                    constructor(uint a) {+                      NUMBER = 4;+                    }+                  |]+      let bBody = aBody+            <> [i|+                function stuff(uint b) public returns (uint256) {+                    unchecked{return 4*b+NUMBER;}+                }+                |]+      let a = wrap aBody+      let b = wrap bBody+      expectDifferent a b++  -- We set x to be 0 on deployment. Default value is also 0. So they are equivalent+  -- We cannot deal with symbolic code. However, the below will generate symbolic code,+  -- because of the parameter in the constructor that is set to NUMBER in the deployed code.+  -- Hence, this test is ignored.+  , ignoreTest $ testCase "constructor-diff-deploy" $ do+    let a = [i|+              contract C {+                uint public immutable NUMBER;+                constructor(uint a) {+                  NUMBER = a+4;+                }+                function stuff(uint b) public returns (uint256) {+                  return NUMBER;+                }+              }+            |]+    let b = replace $ "NUMBER = a+4;" `with` "NUMBER = a*2;" `on` a+    expectDifferent a b+  -- We set x to be 0 on deployment. Default value is also 0. So they are equivalent+  , testCase "constructor-implicit" $ do+    let aBody = [i|+                  uint immutable x;+                  function stuff(uint a) public returns (uint256) {+                    unchecked {return 8+a;}+                  }+                |]+    let bBody = aBody <> "constructor() {x = 0;}"+    let a = wrap aBody+    let b = wrap bBody+    expectEquivalent a b+  -- We set x to be 3 vs 0 (default) on deployment.+  , testCase "constructor-differing" $ do+    let aBody = [i|+                  uint x;+                  function stuff(uint a) public returns (uint256) {+                    unchecked {return a+x;}+                  }+                |]+    let bBody = aBody <> "constructor() {x = 3;}"+    let a = wrap aBody+    let b = wrap bBody+    expectDifferent a b+  ]+  where+    expectDifferent :: SourceCode -> SourceCode -> IO ()+    expectDifferent s s' = do+      eq <- run s s' Solidity.Creation+      assertBool "Must have a difference" (any (isCex . fst) eq.res)++    expectEquivalent :: SourceCode -> SourceCode -> IO ()+    expectEquivalent s s' = do+      eq <- run s s' Solidity.Creation+      assertEqual "Must have no difference" [] (map fst eq.res)++    wrap body = "contract C {\n" <> body <> "}"++bytecodeEquivalenceTests :: TestTree+bytecodeEquivalenceTests = testGroup "Bytecode equivalence"+  [ testCase "eq-issue-with-length-cex-bug679" $ do -- check bug https://github.com/argotorg/hevm/issues/679+    let a = fromJust (hexByteString "5f610100526020610100f3")+        b = fromJust (hexByteString "5f356101f40115610100526020610100f3")+    eq <- Effects.runApp $ withSolvers Z3 1 Nothing defMemLimit $ \s -> do+      (calldata, _) <- mkCalldata Nothing []+      equivalenceCheck s Nothing a b defaultVeriOpts calldata False+    assertBool "Must have a difference" (any (isCex . fst) eq.res)+    let cexs :: [SMTCex] = mapMaybe (getCex . fst) eq.res+    cex <- case cexs of+      [cex] -> pure cex+      _     -> assertFailure "Must have exactly one cex"+    let def = fromRight (internalError "cannot be") $ defaultSymbolicValues $ subModel cex (AbstractBuf "txdata")+    let buf = prettyBuf $ Expr.concKeccakSimpExpr def+    assertBool "Must start with specific string" (T.isPrefixOf "0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffe0c" buf)+  ]++yulEquivalenceTests :: TestTree+yulEquivalenceTests = testGroup "Yul equivalence"+  [ testCase "eq-yul-simple-cex" $ do+    let a = [i|+              {+                calldatacopy(0, 0, 32)+                switch mload(0)+                case 0 { }+                case 1 { }+                default { invalid() }+              }+            |]+    let b = replace $ "case 1 { }" `with` "case 2 { }" `on` a+    Right aPrgm <- yul "" a+    Right bPrgm <- yul "" b+    eq <- Effects.runApp $ withSolvers Bitwuzla 1 Nothing defMemLimit $ \s -> do+      (calldata, _) <- mkCalldata Nothing []+      equivalenceCheck s Nothing aPrgm bPrgm defaultVeriOpts calldata False+    assertBool "Must have a difference" (any (isCex . fst) eq.res)+  , yulOptimizationsSolcTests+  ]++yulOptimizationsSolcTests :: TestTree+yulOptimizationsSolcTests = testCase "eq-all-yul-optimization-tests" $ do+        let opts = (defaultVeriOpts :: VeriOpts) { iterConf = defaultIterConf {maxIter = Just 5, askSmtIters = 20, loopHeuristic = Naive }}+            ignoredTests = fmap normalise+                    -- unbounded loop --+                    [ "commonSubexpressionEliminator/branches_for.yul"+                    , "conditionalSimplifier/no_opt_if_break_is_not_last.yul"+                    , "conditionalUnsimplifier/no_opt_if_break_is_not_last.yul"+                    , "expressionSimplifier/inside_for.yul"+                    , "forLoopConditionIntoBody/cond_types.yul"+                    , "forLoopConditionIntoBody/simple.yul"+                    , "fullSimplify/inside_for.yul"+                    , "fullSuite/no_move_loop_orig.yul"+                    , "loopInvariantCodeMotion/multi.yul"+                    , "redundantAssignEliminator/for_deep_simple.yul"+                    , "unusedAssignEliminator/for_deep_noremove.yul"+                    , "unusedAssignEliminator/for_deep_simple.yul"+                    , "ssaTransform/for_def_in_init.yul"+                    , "loopInvariantCodeMotion/simple_state.yul"+                    , "loopInvariantCodeMotion/simple.yul"+                    , "loopInvariantCodeMotion/recursive.yul"+                    , "loopInvariantCodeMotion/no_move_staticall_returndatasize.yul"+                    , "loopInvariantCodeMotion/no_move_state_loop.yul"+                    , "loopInvariantCodeMotion/no_move_state.yul" -- not infinite, but rollaround on a large int+                    , "loopInvariantCodeMotion/no_move_loop.yul"++                    -- infinite recursion+                    , "unusedStoreEliminator/function_side_effects_2.yul"+                    , "unusedStoreEliminator/write_before_recursion.yul"+                    , "fullInliner/multi_fun_callback.yul"+                    , "conditionalUnsimplifier/side_effects_of_functions.yul"+                    , "expressionInliner/double_recursive_calls.yul"+                    , "conditionalSimplifier/side_effects_of_functions.yul"++                    -- Takes too long, would timeout on most test setups.+                    -- We could probably fix these by "bunching together" queries+                    , "loadResolver/multi_sload_loop.yul"+                    , "fullSuite/abi_example1.yul"+                    , "loadResolver/merge_known_write_with_distance.yul"+                    , "loadResolver/second_mstore_with_delta.yul"+                    , "stackLimitEvader" -- all that are in this subdirectory++                    -- stack too deep --+                    , "fullSuite/aztec.yul"+                    , "stackCompressor/unusedPrunerWithMSize.yul"++                    -- New: symbolic index on MSTORE/MLOAD/CopySlice/CallDataCopy/ExtCodeCopy/Revert,+                    --      or exponent is symbolic (requires symbolic gas)+                    --      or SHA3 offset symbolic+                    , "expressionSimplifier/exp_simplifications.yul"+                    , "loadResolver/merge_mload_with_known_distance.yul"+                    , "loopInvariantCodeMotion/complex_move.yul"+                    , "loopInvariantCodeMotion/no_move_memory.yul"+                    , "loopInvariantCodeMotion/no_move_storage.yul"+                    -- EOF+                    , "loadResolver/extstaticcall.yul"+                    , "loadResolver/memory_with_extcall_invalidation.yul"+                    , "loadResolver/zero_length_reads_eof.yul"+                    -- Yul subobjects+                    , "fullSuite/sub_objects.yul"+                    ]++        solcRepo <- fromMaybe (internalError "cannot find solidity repo") <$> (lookupEnv "HEVM_SOLIDITY_REPO")+        let testDir = normalise $ solcRepo <> "/test/libyul/yulOptimizerTests"+            shouldIgnore fp = any (`List.isInfixOf` (makeRelative testDir fp)) ignoredTests+            isRegularFile = (== RegularFile) <$> fileType+        filesFiltered <- find always (isRegularFile &&? (not . shouldIgnore <$> filePath)) testDir++        -- Takes one file which follows the Solidity Yul optimizer unit tests format,+        -- extracts both the nonoptimized and the optimized versions, and checks equivalence.+        forM_ filesFiltered (\f-> do+          origcont <- readFile f+          let+            onlyAfter pattern (a:ax) = if a =~ pattern then ax else onlyAfter pattern ax+            onlyAfter _ [] = []+            replaceOnce pat repl inp = go inp [] where+              go (a:ax) b = if a =~ pat then let a2 = replaceAll repl $ a *=~ pat in b ++ a2:ax+                                        else go ax (b ++ [a])+              go [] b = b++            -- takes a yul program and ensures memory is symbolic by prepending+            -- `calldatacopy(0,0,1024)`. (calldata is symbolic, but memory starts empty).+            -- This forces the exploration of more branches, and makes the test vectors a+            -- little more thorough.+            symbolicMem program@(a:_) = if a =~ [re|^ *object|] then+                                      let replacementTemplate = "$0\n    calldatacopy(0,0,1024)"+                                          replaced = replaceAll replacementTemplate $ (unlines program) *=~ [re|code {|]+                                      in lines replaced+                                    else replaceOnce [re|^ *{|] "{\ncalldatacopy(0,0,1024)" program+            symbolicMem _ = internalError "Program too short"++            unfiltered = lines origcont+            filteredASym = symbolicMem [ x | x <- unfiltered, (not $ x =~ [re|^//|]) && (not $ x =~ [re|^$|]) ]+            filteredBSym = symbolicMem [ cleaned | x <- onlyAfter [re|^// step:|] unfiltered+                                        , let cleaned = replaceAll "" $ x *=~[re|^//|]+                                        , not $ null cleaned+                                       ]+            contractName = let+               match = head filteredASym ?=~ [re|^ *object +"([^"]+)"|]+               success = captureText (IsCaptureOrdinal $ CaptureOrdinal 1) match+             in T.pack $ case matched match of+                  False -> ""+                  True-> success+          start <- getCurrentTime+          let verbosity :: Int = 0+          when (verbosity > 0) $ putStrLn $ "Checking file: " <> f+          when (verbosity > 1) $ do+            putStrLn "-------------Original Below-----------------"+            mapM_ putStrLn unfiltered+            putStrLn "------------- Filtered A + Symb below-----------------"+            mapM_ putStrLn filteredASym+            putStrLn "------------- Filtered B + Symb below-----------------"+            mapM_ putStrLn filteredBSym+            putStrLn "------------- END -----------------"+          Right aPrgm <- yul contractName $ T.pack $ unlines filteredASym+          Right bPrgm <- yul contractName $ T.pack $ unlines filteredBSym+          eq <- Effects.runApp $ withSolvers Bitwuzla 1 (Just 100) defMemLimit $ \s -> do+            (calldata, _) <- mkCalldata Nothing []+            equivalenceCheck s Nothing aPrgm bPrgm opts calldata False+          let res = map fst eq.res+          end <- getCurrentTime+          case any isCex res of+            False -> do+              when (verbosity > 0) $ print $ "OK. Took " <> (show $ diffUTCTime end start) <> " seconds"+              let timeouts = filter isUnknown res+              let errors = filter isError res+              unless (null timeouts && null errors) $ do+                putStrLn $ "But " <> (show $ length timeouts) <> " timeout(s) and " <>  (show $ length errors) <> " error(s) occurred"+                assertFailure "Encountered timeout(s) and/or error(s)"+            True -> do+              putStrLn $ "Not OK: " <> show f <> " Got: " <> show res+              assertFailure "Was NOT equivalent"+           )

@@ -0,0 +1,1621 @@+{-# LANGUAGE TypeAbstractions #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- It's OK to crash in tests if the pattern does not match++module EVM.Expr.ExprTests (tests) where++import Prelude hiding (LT, GT)+import Test.Tasty+import Test.Tasty.ExpectedFailure (ignoreTest)+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck hiding (Failure, Success)++import Data.Bits (shiftL)+import Data.ByteString qualified as BS (pack)+import Data.Containers.ListUtils (nubOrd)+import Data.List qualified as List (nub)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Typeable++import EVM.Effects+import EVM.Expr qualified as Expr+import EVM.Expr.Generator+import EVM.Format (hexText)+import EVM.Solvers hiding (checkSat)+import EVM.SymExec (subModel)+import EVM.Traversals (mapExprM)+import EVM.Types hiding (Env)+++tests :: TestTree+tests = testGroup "Expr"+  [unitTests, fuzzTests]++unitTests :: TestTree+unitTests = testGroup "Unit tests"+  [ simplificationTests+  , constantPropagationTests+  , boundPropagationTests+  , comparisonTests+  , signExtendTests+  , concretizationTests+  ]++simplificationTests :: TestTree+simplificationTests = testGroup "Expr-rewriting"+  [ storageTests+  , copySliceTests+  , memoryTests+  , basicSimplificationTests+  , propSimplificationTests+  , wrappingTests+  ]++storageTests :: TestTree+storageTests = testGroup "Storage tests"+  [+    testCase "read-from-sstore" $ assertEqual errorMsg+        (Lit 0xab)+        (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x0) (Lit 0xab) (AbstractStore (LitAddr 0x0) Nothing)))+    , testCase "read-from-concrete" $ assertEqual errorMsg+        (Lit 0xab)+        (Expr.readStorage' (Lit 0x0) (ConcreteStore $ Map.fromList [(0x0, 0xab)]))+    , testCase "read-past-write" $ assertEqual errorMsg+        (Lit 0xab)+        (Expr.readStorage' (Lit 0x0) (SStore (Lit 0x1) (Var "b") (ConcreteStore $ Map.fromList [(0x0, 0xab)])))+    , testCase "simplify-storage-wordToAddr" $ do+       let a = "0x000000000000000000000000d95322745865822719164b1fc167930754c248de000000000000000000000000000000000000000000000000000000000000004a"+           store = ConcreteStore (Map.fromList[(W256 0xebd33f63ba5dda53a45af725baed5628cdad261db5319da5f5d921521fe1161d,W256 0x5842cf)])+           expr = SLoad (Keccak (ConcreteBuf (hexText a))) store+           simpExpr = Expr.wordToAddr expr+           simpExpr2 = Expr.concKeccakSimpExpr expr+       assertEqual "Expression should simplify to value." simpExpr (Just $ LitAddr 0x5842cf)+       assertEqual "Expression should simplify to value." simpExpr2 (Lit 0x5842cf)+    , testCase "simplify-storage-wordToAddr-complex" $ do+       let a = "0x000000000000000000000000d95322745865822719164b1fc167930754c248de000000000000000000000000000000000000000000000000000000000000004a"+           store = ConcreteStore (Map.fromList[(W256 0xebd33f63ba5dda53a45af725baed5628cdad261db5319da5f5d921521fe1161d,W256 0x5842cf)])+           expr = SLoad (Keccak (ConcreteBuf (hexText a))) store+           writeWChain = WriteWord (Lit 0x32) (Lit 0x72) (WriteWord (Lit 0x0) expr (ConcreteBuf ""))+           kecc = Keccak (CopySlice (Lit 0x0) (Lit 0x0) (Lit 0x20) (WriteWord (Lit 0x0) expr (writeWChain)) (ConcreteBuf ""))+           keccAnd =  (And (Lit 1461501637330902918203684832716283019655932542975) kecc)+           outer = And (Lit 1461501637330902918203684832716283019655932542975) (SLoad (keccAnd) (ConcreteStore (Map.fromList[(W256 1184450375068808042203882151692185743185288360635, W256 0xacab)])))+           simp = Expr.concKeccakSimpExpr outer+       assertEqual "Expression should simplify to value." simp (Lit 0xacab)+  ]+  where errorMsg = "Storage read expression not simplified correctly"++copySliceTests :: TestTree+copySliceTests = testGroup "CopySlice tests"+  [ testCase "copyslice-simps" $ do+        let e a b =  CopySlice (Lit 0) (Lit 0) (BufLength (AbstractBuf "buff")) (CopySlice (Lit 0) (Lit 0) (BufLength (AbstractBuf "buff")) (AbstractBuf "buff") (ConcreteBuf a)) (ConcreteBuf b)+            expr1 = e "" ""+            expr2 = e "" "aasdfasdf"+            expr3 = e "9832478932" ""+            expr4 = e "9832478932" "aasdfasdf"+        assertEqual "Not full simp" (Expr.simplify expr1) (AbstractBuf "buff")+        assertEqual "Not full simp" (Expr.simplify expr2) $ CopySlice (Lit 0x0) (Lit 0x0) (BufLength (AbstractBuf "buff")) (AbstractBuf "buff") (ConcreteBuf "aasdfasdf")+        assertEqual "Not full simp" (Expr.simplify expr3) (AbstractBuf "buff")+        assertEqual "Not full simp" (Expr.simplify expr4) $ CopySlice (Lit 0x0) (Lit 0x0) (BufLength (AbstractBuf "buff")) (AbstractBuf "buff") (ConcreteBuf "aasdfasdf")+  , testCase "copyslice-difficult-concretization" $ do+        let commonOffset = (Var "x")+        let concreteVal = (Lit 0xff00ff00ff00ff00ff00ff00ff00ff00ff00ff00ff00ff00ff00ff00ff00ff00)+        let src = WriteWord commonOffset concreteVal (AbstractBuf "buff")+        let dst = ConcreteBuf ""+        let e = CopySlice commonOffset (Lit 1) (Lit 3) src dst+        let simpl = Expr.simplify e+        let expected = ConcreteBuf $ BS.pack [0x00, 0xff, 0x00, 0xff]+        assertEqual "" expected simpl+  , testCase "copyslice-single-byte-concretizes" $ do+        -- Regression for issue #1066. A size-1 CopySlice whose read range is+        -- fully covered by a concrete WriteWord must concretize, even when an+        -- unrelated (out-of-range) symbolic write sits underneath it.+        let w = Lit 0xabcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789+            src = WriteWord (Lit 0x20) w (WriteWord (Lit 0x80) (Var "x") (ConcreteBuf ""))+            e = CopySlice (Lit 0x20) (Lit 0x0) (Lit 0x1) src (ConcreteBuf "")+        assertEqual "size-1 copy must concretize to the 1st byte, dropping the out-of-range symbolic write"+          (ConcreteBuf (BS.pack [0xab])) (Expr.simplify e)+  , testCase "copyslice-single-byte-value" $ do+        -- Same as above, but no symbolic write this time+        let w = Lit 0xabcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789+            src = WriteWord (Lit 0x20) w (ConcreteBuf "")+            e = CopySlice (Lit 0x3f) (Lit 0x0) (Lit 0x1) src (ConcreteBuf "")+        assertEqual "size-1 copy must read the correct (last) byte"+          (ConcreteBuf (BS.pack [0x89])) (Expr.simplify e)+  ]++memoryTests :: TestTree+memoryTests = testGroup "Memory tests"+  [ testCase "read-write-same-byte" $ assertEqual ""+      (LitByte 0x12)+      (Expr.readByte (Lit 0x20) (WriteByte (Lit 0x20) (LitByte 0x12) mempty))+  , testCase "read-write-same-word" $ assertEqual ""+      (Lit 0x12)+      (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty))+  , testCase "read-byte-write-word" $ assertEqual ""+      -- reading at byte 31 a word that's been written should return LSB+      (LitByte 0x12)+      (Expr.readByte (Lit 0x1f) (WriteWord (Lit 0x0) (Lit 0x12) mempty))+  , testCase "read-byte-write-word2" $ assertEqual ""+      -- Same as above, but offset not 0+      (LitByte 0x12)+      (Expr.readByte (Lit 0x20) (WriteWord (Lit 0x1) (Lit 0x12) mempty))+  , testCase "read-write-with-offset" $ assertEqual ""+      -- 0x3F = 63 decimal, 0x20 = 32. 0x12 = 18+      --    We write 128bits (32 Bytes), representing 18 at offset 32.+      --    Hence, when reading out the 63rd byte, we should read out the LSB 8 bits+      --           which is 0x12+      (LitByte 0x12)+      (Expr.readByte (Lit 0x3F) (WriteWord (Lit 0x20) (Lit 0x12) mempty))+  , testCase "read-write-with-offset2" $ assertEqual ""+      --  0x20 = 32, 0x3D = 61+      --  we write 128 bits (32 Bytes) representing 0x10012, at offset 32.+      --  we then read out a byte at offset 61.+      --  So, at 63 we'd read 0x12, at 62 we'd read 0x00, at 61 we should read 0x1+      (LitByte 0x1)+      (Expr.readByte (Lit 0x3D) (WriteWord (Lit 0x20) (Lit 0x10012) mempty))+  , testCase "read-write-with-extension-to-zero" $ assertEqual ""+      -- write word and read it at the same place (i.e. 0 offset)+      (Lit 0x12)+      (Expr.readWord (Lit 0x0) (WriteWord (Lit 0x0) (Lit 0x12) mempty))+  , testCase "read-write-with-extension-to-zero-with-offset" $ assertEqual ""+      -- write word and read it at the same offset of 4+      (Lit 0x12)+      (Expr.readWord (Lit 0x4) (WriteWord (Lit 0x4) (Lit 0x12) mempty))+  , testCase "read-write-with-extension-to-zero-with-offset2" $ assertEqual ""+      -- write word and read it at the same offset of 16+      (Lit 0x12)+      (Expr.readWord (Lit 0x20) (WriteWord (Lit 0x20) (Lit 0x12) mempty))+  , testCase "read-word-over-write-byte" $ assertEqual ""+      (ReadWord (Lit 0x4) (AbstractBuf "abs"))+      (Expr.readWord (Lit 0x4) (WriteByte (Lit 0x1) (LitByte 0x12) (AbstractBuf "abs")))+  , testCase "read-word-copySlice-overlap" $ assertEqual ""+      -- we should not recurse into a copySlice if the read index + 32 overlaps the sliced region+      (ReadWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi")))+      (Expr.readWord (Lit 40) (CopySlice (Lit 0) (Lit 30) (Lit 12) (WriteWord (Lit 10) (Lit 0x64) (AbstractBuf "hi")) (AbstractBuf "hi")))+  , testCase "read-word-copySlice-after-slice" $ assertEqual "Read word simplification missing!"+      (ReadWord (Lit 100) (AbstractBuf "dst"))+      (Expr.readWord (Lit 100) (CopySlice (Var "srcOff") (Lit 12) (Lit 60) (AbstractBuf "src") (AbstractBuf "dst")))+  , testCase "indexword-MSB" $ assertEqual ""+      -- 31st is the LSB byte (of 32)+      (LitByte 0x78)+      (Expr.indexWord (Lit 31) (Lit 0x12345678))+  , testCase "indexword-LSB" $ assertEqual ""+      -- 0th is the MSB byte (of 32), Lit 0xff22bb... is exactly 32 Bytes.+      (LitByte 0xff)+      (Expr.indexWord (Lit 0) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122))+  , testCase "indexword-LSB2" $ assertEqual ""+      -- same as above, but with offset 2+      (LitByte 0xbb)+      (Expr.indexWord (Lit 2) (Lit 0xff22bb4455667788990011223344556677889900112233445566778899001122))+  , testCase "indexword-oob-sym" $ assertEqual ""+      -- indexWord should return 0 for oob access+      (LitByte 0x0)+      (Expr.indexWord (Lit 100) (JoinBytes+        (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0)+        (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0)+        (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0)+        (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0) (LitByte 0)))+  , testCase "stripbytes-concrete-bug" $ assertEqual ""+      (Expr.simplifyReads (ReadByte (Lit 0) (ConcreteBuf "5")))+      (LitByte 53)++  -- Interval-bounds disjointness for readWord over WriteWord (Add (Lit c) X).++  , testCase "readWord-skip-write-above-and-bounded" $ assertEqual+      "write at Add (Lit 100) (And (Lit 0xff) X) must be skipped when reading at 0"+      (Lit 0)+      (Expr.readWord (Lit 0)+        (WriteWord (Add (Lit 100) (And (Lit 0xff) (Var "x")))+                   (Lit 0x42)+                   mempty))++  , testCase "readWord-skip-write-above-mul-and-bounded" $ assertEqual+      "write at Add (Lit 100) (Mul 32 (And 0xff X)) must be skipped when reading at 0"+      (Lit 0)+      (Expr.readWord (Lit 0)+        (WriteWord (Add (Lit 100) (Mul (Lit 32) (And (Lit 0xff) (Var "x"))))+                   (Lit 0x42)+                   mempty))++  , testCase "readWord-no-skip-write-above-unbounded" $ do+      -- Unbounded X: rule must NOT fire.+      let r = Expr.readWord (Lit 0)+                (WriteWord (Add (Lit 100) (Var "x")) (Lit 0x42) mempty)+      assertBool ("rule fired on unbounded X (unsound): " <> show r)+                 (r /= Lit 0)++  , testCase "readWord-no-skip-write-wrap-risk" $ do+      -- c near maxBound: write region can wrap, so rule must NOT fire.+      let bigC = (maxBound :: W256) - 50+          r = Expr.readWord (Lit 0)+                (WriteWord (Add (Lit bigC) (And (Lit 0xff) (Var "x")))+                           (Lit 0x42)+                           mempty)+      assertBool ("rule fired on wrap-risk write (unsound): " <> show r)+                 (r /= Lit 0)++  , testCase "readWord-no-skip-write-possible-overlap" $ do+      -- Read [80,111] vs write [100,355] overlap; rule must NOT fire.+      let r = Expr.readWord (Lit 80)+                (WriteWord (Add (Lit 100) (And (Lit 0xff) (Var "x")))+                           (Lit 0x42)+                           mempty)+      assertBool ("rule fired on possibly-overlapping write (unsound): " <> show r)+                 (r /= Lit 0)+  ]++basicSimplificationTests :: TestTree+basicSimplificationTests = testGroup "Basic simplification tests"+  [ testCase "simp-readByte1" $ do+      let srcOffset = (ReadWord (Lit 0x1) (AbstractBuf "stuff1"))+          size = (ReadWord (Lit 0x1) (AbstractBuf "stuff2"))+          src = (AbstractBuf "stuff2")+          e = ReadByte (Lit 0x0) (CopySlice srcOffset (Lit 0x10) size src (AbstractBuf "dst"))+          simp = Expr.simplify e+      assertEqual "" simp (ReadByte (Lit 0x0) (AbstractBuf "dst"))+  , testCase "simp-readByte2" $ do+      let srcOffset = (ReadWord (Lit 0x1) (AbstractBuf "stuff1"))+          size = (Lit 0x1)+          src = (AbstractBuf "stuff2")+          e = ReadByte (Lit 0x0) (CopySlice srcOffset (Lit 0x10) size src (AbstractBuf "dst"))+          simp = Expr.simplify e+      assertEqual "" (ReadByte (Lit 0x0) (AbstractBuf "dst")) simp+  , testCase "simp-readWord1" $ do+      let srcOffset = (ReadWord (Lit 0x1) (AbstractBuf "stuff1"))+          size = (ReadWord (Lit 0x1) (AbstractBuf "stuff2"))+          src = (AbstractBuf "stuff2")+          e = ReadWord (Lit 0x1) (CopySlice srcOffset (Lit 0x40) size src (AbstractBuf "dst"))+          simp = Expr.simplify e+      assertEqual "" simp (ReadWord (Lit 0x1) (AbstractBuf "dst"))+  , testCase "simp-readWord2" $ do+    let srcOffset = (ReadWord (Lit 0x12) (AbstractBuf "stuff1"))+        size = (Lit 0x1)+        src = (AbstractBuf "stuff2")+        e = ReadWord (Lit 0x12) (CopySlice srcOffset (Lit 0x50) size src (AbstractBuf "dst"))+        simp = Expr.simplify e+    assertEqual "readWord simplification" (ReadWord (Lit 0x12) (AbstractBuf "dst")) simp+  , testCase "simp-max-buflength" $ do+      let simp = Expr.simplify $ Max (Lit 0) (BufLength (AbstractBuf "txdata"))+      assertEqual "max-buflength rules" simp $ BufLength (AbstractBuf "txdata")+  , testCase "simp-PLT-max" $ do+      let simp = Expr.simplifyProp $ PLT (Max (Lit 5) (BufLength (AbstractBuf "txdata"))) (Lit 99)+      assertEqual "max-buflength rules" simp $ PLT (BufLength (AbstractBuf "txdata")) (Lit 99)+  , testCase "simp-assoc-add1" $ do+      let simp = Expr.simplify $ Add (Add (Var "c") (Var "a")) (Var "b")+      assertEqual "assoc rules" simp $ Add (Var "a") (Add (Var "b") (Var "c"))+  , testCase "simp-assoc-add2" $ do+      let simp = Expr.simplify $ Add (Add (Lit 1) (Var "c")) (Var "b")+      assertEqual "assoc rules" simp $ Add (Lit 1) (Add (Var "b") (Var "c"))+  , testCase "simp-assoc-add3" $ do+      let simp = Expr.simplify $ Add (Lit 1) (Add (Lit 2) (Var "c"))+      assertEqual "assoc rules" simp $ Add (Lit 3) (Var "c")+  , testCase "simp-assoc-add4" $ do+      let simp = Expr.simplify $ Add (Lit 1) (Add (Var "b") (Lit 2))+      assertEqual "assoc rules" simp $ Add (Lit 3) (Var "b")+  , testCase "simp-assoc-add5" $ do+      let simp = Expr.simplify $ Add (Var "a") (Add (Lit 1) (Lit 2))+      assertEqual "assoc rules" simp $ Add (Lit 3) (Var "a")+  , testCase "simp-assoc-add6" $ do+      let simp = Expr.simplify $ Add (Lit 7) (Add (Lit 1) (Lit 2))+      assertEqual "assoc rules" simp $ Lit 10+  , testCase "simp-assoc-add-7" $ do+      let simp = Expr.simplify $ Add (Var "a") (Add (Var "b") (Lit 2))+      assertEqual "assoc rules" simp $ Add (Lit 2) (Add (Var "a") (Var "b"))+  , testCase "simp-assoc-add8" $ do+      let simp = Expr.simplify $ Add (Add (Var "a") (Add (Lit 0x2) (Var "b"))) (Add (Var "c") (Add (Lit 0x2) (Var "d")))+      assertEqual "assoc rules" simp $ Add (Lit 4) (Add (Var "a") (Add (Var "b") (Add (Var "c") (Var "d"))))+  , testCase "simp-assoc-mul1" $ do+      let simp = Expr.simplify $ Mul (Mul (Var "b") (Var "a")) (Var "c")+      assertEqual "assoc rules" simp $ Mul (Var "a") (Mul (Var "b") (Var "c"))+  , testCase "simp-assoc-mul2" $ do+      let simp = Expr.simplify $ Mul (Lit 2) (Mul (Var "a") (Lit 3))+      assertEqual "assoc rules" simp $ Mul (Lit 6) (Var "a")+  , testCase "simp-assoc-xor1" $ do+      let simp = Expr.simplify $ Xor (Lit 2) (Xor (Var "a") (Lit 3))+      assertEqual "assoc rules" simp $ Xor (Lit 1) (Var "a")+  , testCase "simp-assoc-xor2" $ do+      let simp = Expr.simplify $ Xor (Lit 2) (Xor (Var "b") (Xor (Var "a") (Lit 3)))+      assertEqual "assoc rules" simp $ Xor (Lit 1) (Xor (Var "a") (Var "b"))+  , testCase "sign-extend-conc-1" $ do+      let p = Expr.sex (Lit 0) (Lit 0xff)+      assertEqual "" p (Lit Expr.maxLit)+      let p2 = Expr.sex (Lit 30) (Lit 0xff)+      assertEqual "" p2 (Lit 0xff)+      let p3 = Expr.sex (Lit 1) (Lit 0xff)+      assertEqual "" p3 (Lit 0xff)+      let p4 = Expr.sex (Lit 0) (Lit 0x1)+      assertEqual "" p4 (Lit 0x1)+      let p5 = Expr.sex (Lit 0) (Lit 0x0)+      assertEqual "" p5 (Lit 0x0)+  , testCase "writeWord-overflow" $ do+      let simp = Expr.simplify $ ReadByte (Lit 0x0) (WriteWord (Lit 0xfffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffd) (Lit 0x0) (ConcreteBuf "\255\255\255\255"))+      assertEqual "writeWord overflow incorrect" (LitByte 0) simp+  , testCase "buffer-length-copy-slice-beyond-source1" $ do+      let simp = Expr.simplify $ BufLength (CopySlice (Lit 0x2) (Lit 0x2) (Lit 0x1) (ConcreteBuf "a") (ConcreteBuf ""))+      assertEqual "" (Lit 3) simp+  , testCase "copy-slice of size 0 is noop" $ do+        let simp = Expr.simplify $ BufLength $ CopySlice (Lit 0) (Lit 0x10) (Lit 0) (AbstractBuf "buffer") (ConcreteBuf "bimm")+        assertEqual "" (Lit 0x4) simp+  , testCase "length of concrete buffer is concrete" $ do+      let simp = Expr.simplify $ BufLength (ConcreteBuf "ab")+      assertEqual "" (Lit 2) simp+  , testCase "simplify read over write byte" $ do+      let simp = Expr.simplify $ ReadByte (Lit 0xf0000000000000000000000000000000000000000000000000000000000000) (WriteByte (And (Keccak (ConcreteBuf "")) (Lit 0x1)) (LitByte 0) (ConcreteBuf ""))+      assertEqual "" (LitByte 0) simp+  , testCase "storage-slot-single" $ do+      -- this tests that "" and "0"x32 is not equivalent in Keccak+      let x = SLoad (Add (Keccak (ConcreteBuf "")) (Lit 1)) (SStore (Keccak (ConcreteBuf "\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL")) (Lit 0) (AbstractStore (SymAddr "stuff") Nothing))+      let simplified = Expr.simplify x+      let expected = SLoad (Add (Lit 1) (Keccak (ConcreteBuf ""))) (AbstractStore (SymAddr "stuff") Nothing)+      assertEqual "" expected simplified+  , testCase "word-eq-bug" $ do+      -- This test is actually OK because the simplified takes into account that it's impossible to find a+      -- near-collision in the keccak hash+      let x = (SLoad (Keccak (AbstractBuf "es")) (SStore (Add (Keccak (ConcreteBuf "")) (Lit 0x1)) (Lit 0xacab) (ConcreteStore (Map.empty))))+      let simplified = Expr.simplify x+      let expected = (SLoad (Keccak (AbstractBuf "es")) (ConcreteStore (Map.empty))) -- TODO: This should be simplified to (Lit 0)+      assertEqual "Must be equal, given keccak distance axiom" expected simplified+  , testCase "expr-simp-and-commut-assoc" $ do+      let+        a = And (Lit 4) (And (Lit 5) (Var "a"))+        b = Expr.simplify a+      assertEqual "Must reorder and perform And" (And (Lit 4) (Var "a")) b+  , testCase "expr-simp-order-eqbyte" $ do+      let+        a = EqByte (ReadByte (Lit 1) (AbstractBuf "b")) (ReadByte (Lit 1) (AbstractBuf "a"))+        b = Expr.simplify a+      assertEqual "Must order eqbyte params" b (EqByte (ReadByte (Lit 1) (AbstractBuf "a")) (ReadByte (Lit 1) (AbstractBuf "b")))+  , testCase "prop-simp-expr" $ do+      let+        successPath props = Success props mempty (ConcreteBuf "") mempty+        a = successPath [PEq (Add (Lit 1) (Lit 2)) (Sub (Lit 4) (Lit 1))]+        b = Expr.simplify a+      assertEqual "Must simplify down" (successPath []) b+  , testCase "simp-mul-neg1" $ do+      let simp = Expr.simplify $ Mul (Lit Expr.maxLit) (Var "x")+      assertEqual "mul by -1 is negation" (Sub (Lit 0) (Var "x")) simp+  , testCase "simp-not-plus1" $ do+      let simp = Expr.simplify $ Add (Lit 1) (Not (Var "x"))+      assertEqual "~x + 1 is negation" (Sub (Lit 0) (Var "x")) simp+  , testCase "simp-xor-maxlit-plus1" $ do+      let simp = Expr.simplify $ Add (Lit 1) (Xor (Lit Expr.maxLit) (Var "x"))+      assertEqual "xor(maxLit, x) + 1 is negation" (Sub (Lit 0) (Var "x")) simp+  , testCase "simp-double-not" $ do+      let simp = Expr.simplify $ Not (Not (Var "a"))+      assertEqual "Not should be concretized" (Var "a") simp+  ]++propSimplificationTests :: TestTree+propSimplificationTests = testGroup "prop-simplifications"+  [ testCase "simpProp-concrete-trues" $ do+      let+        t = [PBool True, PBool True]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [] simplified+  , testCase "simpProp-concrete-false1" $ do+      let+        t = [PBool True, PBool False]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PBool False] simplified+  , testCase "simpProp-concrete-false2" $ do+      let+        t = [PBool False, PBool False]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PBool False] simplified+  , testCase "simpProp-concrete-or-1" $ do+      let+        -- a = 5 && (a=4 || a=3)  -> False+        t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PBool False] simplified+  , ignoreTest $ testCase "simpProp-concrete-or-2" $ do+      let+        -- Currently does not work, because we don't do simplification inside+        --   POr/PAnd using canBeSat+        -- a = 5 && (a=4 || a=5)  -> a=5+        t = [PEq (Lit 5) (Var "a"), POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 5))]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [] simplified+  , testCase "simpProp-concrete-and-1" $ do+      let+        -- a = 5 && (a=4 && a=3)  -> False+        t = [PEq (Lit 5) (Var "a"), PAnd (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 3))]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PBool False] simplified+  , testCase "simpProp-concrete-or-of-or" $ do+      let+        -- a = 5 && ((a=4 || a=6) || a=3)  -> False+        t = [PEq (Lit 5) (Var "a"), POr (POr (PEq (Var "a") (Lit 4)) (PEq (Var "a") (Lit 6))) (PEq (Var "a") (Lit 3))]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PBool False] simplified+  , testCase "simpProp-inner-expr-simp" $ do+      let+        -- 5+1 = 6+        t = [PEq (Add (Lit 5) (Lit 1)) (Var "a")]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PEq (Lit 6) (Var "a")] simplified+  , testCase "simpProp-inner-expr-simp-with-canBeSat" $ do+      let+        -- 5+1 = 6, 6 != 7+        t = [PAnd (PEq (Add (Lit 5) (Lit 1)) (Var "a")) (PEq (Var "a") (Lit 7))]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PBool False] simplified+  , testCase "simpProp-inner-expr-bitwise-and" $ do+      let+        -- 1 & 2 != 2+        t = [PEq (And (Lit 1) (Lit 2)) (Lit 2)]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PBool False] simplified+  , testCase "simpProp-inner-expr-bitwise-or" $ do+      let+        -- 2 | 4 == 6+        t = [PEq (Or (Lit 2) (Lit 4)) (Lit 6)]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [] simplified+  , testCase "simpProp-constpropagate-1" $ do+      let+        -- 5+1 = 6+        t = [PEq (Add (Lit 5) (Lit 1)) (Var "a"), PEq (Var "b") (Var "a")]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PEq (Lit 6) (Var "a"), PEq (Lit 6) (Var "b")] simplified+  , testCase "simpProp-constpropagate-2" $ do+      let+        -- 5+1 = 6+        t = [PEq (Add (Lit 5) (Lit 1)) (Var "a"), PEq (Var "b") (Var "a"), PEq (Var "c") (Sub (Var "b") (Lit 1))]+        simplified = Expr.simplifyProps t+      assertEqual "Must be equal" [PEq (Lit 6) (Var "a"), PEq (Lit 6) (Var "b"), PEq (Lit 5) (Var "c")] simplified+  , testCase "simpProp-constpropagate-3" $ do+      let+        t = [ PEq (Add (Lit 5) (Lit 1)) (Var "a") -- a = 6+            , PEq (Var "b") (Var "a")             -- b = 6+            , PEq (Var "c") (Sub (Var "b") (Lit 1)) -- c = 5+            , PEq (Var "d") (Sub (Var "b") (Var "c"))] -- d = 1+        simplified = Expr.simplifyProps t+      assertEqual "Must  know d == 1" ((PEq (Lit 1) (Var "d")) `elem` simplified) True+  , testCase "PEq-and-PNot-PEq-1" $ do+      let a = [PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1"))]+      assertEqual "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False])+  , testCase "PEq-and-PNot-PEq-2" $ do+      let a = [PEq (Var "arg1") (Lit 0x539),PNeg (PEq (Lit 0x539) (Var "arg1"))]+      assertEqual "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False])+  , testCase "PEq-and-PNot-PEq-3" $ do+      let a = [PEq (Var "arg1") (Lit 0x539),PNeg (PEq (Var "arg1") (Lit 0x539))]+      assertEqual "Must simplify to PBool False" (Expr.simplifyProps a) ([PBool False])+  , testCase "propSimp-no-duplicate1" $ do+      let a = [PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)), PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x63) (Var "arg2"),PEq (Lit 0x539) (Var "arg1"),PEq TxValue (Lit 0x0),PEq (IsZero (Eq (Lit 0x63) (Var "arg2"))) (Lit 0x0)]+      let simp = Expr.simplifyProps a+      assertEqual "must not duplicate" simp (nubOrd simp)+  , testCase "propSimp-no-duplicate2" $ do+      let a = [PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x539) (Var "arg1"),PNeg (PEq (Lit 0x539) (Var "arg1")),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0)),PNeg (PEq (IsZero TxValue) (Lit 0x0))]+      let simp = Expr.simplifyProps a+      assertEqual "must not duplicate" simp (nubOrd simp)+  , testCase "full-order-prop1" $ do+      let a =[PNeg (PBool False),PAnd (PGEq (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x44)) (PLT (Max (Lit 0x44) (BufLength (AbstractBuf "txdata"))) (Lit 0x10000000000000000)),PAnd (PGEq (Var "arg2") (Lit 0x0)) (PLEq (Var "arg2") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PAnd (PGEq (Var "arg1") (Lit 0x0)) (PLEq (Var "arg1") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)),PEq (Lit 0x63) (Var "arg2"),PEq (Lit 0x539) (Var "arg1"),PEq TxValue (Lit 0x0),PLT (BufLength (AbstractBuf "txdata")) (Lit 0x10000000000000000),PEq (IsZero (Eq (Lit 0x63) (Var "arg2"))) (Lit 0x0),PEq (IsZero (Eq (Lit 0x539) (Var "arg1"))) (Lit 0x0),PNeg (PEq (IsZero TxValue) (Lit 0x0))]+      let simp = Expr.simplifyProps a+      assertEqual "must not duplicate" simp (nubOrd simp)+  , testCase "dont simplify abstract buffer of size 0" $ do+      let+        p = Expr.peq (BufLength (AbstractBuf "b")) (Lit 0x0)+        simp = Expr.simplifyProp p+      assertEqual "peq does not normalize arguments" (PEq (Lit (0x0)) (BufLength (AbstractBuf "b"))) p+      assertBool "" (p == simp)+  , testCase "simplify comparison GEq" $ do+      let simp = Expr.simplifyProp $ PEq (Lit 0x1) (GEq (Var "v") (Lit 0x2))+      assertEqual "" (PLEq (Lit 0x2) (Var "v")) simp+  , testCase "prop-simp-bool1" $ do+      let+        a = [PAnd (PBool True) (PBool False)]+        b = Expr.simplifyProps a+      assertEqual "Must simplify down" [PBool False] b+  , testCase "prop-simp-bool2" $ do+      let+        a = [POr (PBool True) (PBool False)]+        b = Expr.simplifyProps a+      assertEqual "Must simplify down" [] b+  , testCase "prop-simp-LT" $ do+      let+        a = [PLT (Lit 1) (Lit 2)]+        b = Expr.simplifyProps a+      assertEqual "Must simplify down" [] b+  , testCase "prop-simp-GEq" $ do+      let+        a = [PGEq (Lit 1) (Lit 2)]+        b = Expr.simplifyProps a+      assertEqual "Must simplify down" [PBool False] b+  , testCase "prop-simp-liteq-false" $ do+      let+        a = [PEq (LitByte 10) (LitByte 12)]+        b = Expr.simplifyProps a+      assertEqual "Must simplify down" [PBool False] b+  , testCase "prop-simp-concbuf-false" $ do+      let+        a = [PEq (ConcreteBuf "a") (ConcreteBuf "ab")]+        b = Expr.simplifyProps a+      assertEqual "Must simplify down" [PBool False] b+  , testCase "prop-simp-sort-eq-arguments" $ do+      let+        a = [PEq (Var "a") (Var "b"), PEq (Var "b") (Var "a")]+        b = Expr.simplifyProps a+      assertEqual "Must reorder and nubOrd" (length b) 1+  , testCase "prop-simp-demorgan-pneg-pand" $ do+      let+        a = [PNeg (PAnd (PEq (Lit 4) (Var "a")) (PEq (Lit 5) (Var "b")))]+        b = Expr.simplifyProps a+      assertEqual "Must apply demorgan" b [POr (PNeg (PEq (Lit 4) (Var "a"))) (PNeg (PEq (Lit 5) (Var "b")))]+  , testCase "prop-simp-demorgan-pneg-por" $ do+    let+      a = [PNeg (POr (PEq (Lit 4) (Var "a")) (PEq (Lit 5) (Var "b")))]+      b = Expr.simplifyProps a+    assertEqual "Must apply demorgan" [PNeg (PEq (Lit 4) (Var "a")), PNeg (PEq (Lit 5) (Var "b"))] b+  , testCase "prop-simp-lit0-or-both-0" $ do+    let+      a = [PEq (Lit 0) (Or (Var "a") (Var "b"))]+      b = Expr.simplifyProps a+    assertEqual "Must apply demorgan" [PEq (Lit 0) (Var "a"), PEq (Lit 0) (Var "b")] b+  , testCase "prop-simp-impl" $ do+      let+        a = [PImpl (PBool False) (PEq (Var "abc") (Var "bcd"))]+        b = Expr.simplifyProps a+      assertEqual "Must simplify down" [] b+  ]++constantPropagationTests :: TestTree+constantPropagationTests = testGroup "isUnsat-concrete-tests"+  [+    testCase "disjunction-left-false" $+    let+      t = [PEq (Var "x") (Lit 1), POr (PEq (Var "x") (Lit 0)) (PEq (Var "y") (Lit 1)), PEq (Var "y") (Lit 2)]+      propagated = Expr.constPropagate t+    in+    mustContainFalse propagated+  , testCase "disjunction-right-false" $+      let+        t = [PEq (Var "x") (Lit 1), POr (PEq (Var "y") (Lit 1)) (PEq (Var "x") (Lit 0)), PEq (Var "y") (Lit 2)]+        propagated = Expr.constPropagate t+      in+      mustContainFalse propagated+  , testCase "disjunction-both-false" $+      let+        t = [PEq (Var "x") (Lit 1), POr (PEq (Var "x") (Lit 2)) (PEq (Var "x") (Lit 0)), PEq (Var "y") (Lit 2)]+        propagated = Expr.constPropagate t+      in+      mustContainFalse propagated+  , ignoreTest $ testCase "disequality-and-equality" $+      let+        t = [PNeg (PEq (Lit 1) (Var "arg1")), PEq (Lit 1) (Var "arg1")]+        propagated = Expr.constPropagate t+      in+      mustContainFalse propagated+  , testCase "equality-and-disequality" $+      let+        t = [PEq (Lit 1) (Var "arg1"), PNeg (PEq (Lit 1) (Var "arg1"))]+        propagated = Expr.constPropagate t+      in+      mustContainFalse propagated+  ]+  where+    mustContainFalse props = assertBool "Expression must simplify to False" $ (PBool False) `elem` props++boundPropagationTests :: TestTree+boundPropagationTests =  testGroup "inequality-propagation-tests" [+  testCase "PLT-detects-impossible-constraint" $+  let+    -- x < 0 is impossible for unsigned integers+    t = [PLT (Var "x") (Lit 0)]+    propagated = Expr.constPropagate t+  in+    mustContainFalse propagated+  , testCase "PLT-overflow-check" $+      let+        -- maxLit < y is impossible+        t = [PLT (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Var "y")]+        propagated = Expr.constPropagate t+      in+        mustContainFalse propagated+  , testCase "PGT-detects-impossible-constraint" $+      let+        -- x > maxLit is impossible+        t = [PGT (Var "x") (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff)]+        propagated = Expr.constPropagate t+      in+        mustContainFalse propagated+  , testCase "PGT-overflow-check" $+      let+        -- 0 > y is impossible+        t = [PGT (Lit 0) (Var "y")]+        propagated = Expr.constPropagate t+      in+        mustContainFalse propagated+  , testCase "inequality-conflict-detection-narrow" $+      let+        -- x < 2 && x > 5 is impossible+        t = [PLT (Var "x") (Lit 2), PGT (Var "x") (Lit 5)]+        propagated = Expr.constPropagate t+      in+        mustContainFalse propagated+  , testCase "inequality-conflict-detection-wide" $+      let+        -- x < 5 && x > 10 is impossible+        t = [PLT (Var "x") (Lit 5), PGT (Var "x") (Lit 10)]+        propagated = Expr.constPropagate t+      in+        mustContainFalse propagated+  , testCase "inequality-tight-bounds-satisfied" $+      let+        -- x >= 5 && x <= 5 and x == 5 should be consistent+        t = [PGEq (Var "x") (Lit 5), PLEq (Var "x") (Lit 5), PEq (Var "x") (Lit 5)]+        propagated = Expr.constPropagate t+      in+        mustNotContainFalse propagated+  , testCase "inequality-tight-bounds-violated" $+      let+        -- x >= 5 && x <= 5 and x != 5 should be inconsistent+        t = [PGEq (Var "x") (Lit 5), PLEq (Var "x") (Lit 5), PNeg (PEq (Var "x") (Lit 5))]+        propagated = Expr.constPropagate t+      in+        mustContainFalse propagated+  , testCase "inequality-with-existing-equality-consistent" $+      let+        -- x == 5 && x < 10 is consistent+        t = [PEq (Var "x") (Lit 5), PLT (Var "x") (Lit 10)]+        propagated = Expr.constPropagate t+      in+        mustNotContainFalse propagated+  , testCase "inequality-with-existing-equality-inconsistent" $+      let+        -- x == 5 && x < 5 is inconsistent+        t = [PEq (Var "x") (Lit 5), PLT (Var "x") (Lit 5)]+        propagated = Expr.constPropagate t+      in+        mustContainFalse propagated+    ]+  where+    mustContainFalse props = assertBool "Expression must simplify to False" $ (PBool False) `elem` props+    mustNotContainFalse props = assertBool "Expression must NOT simplify to False" $ (PBool False) `notElem` props++comparisonTests :: TestTree+comparisonTests = testGroup "Prop comparison tests"+  [+    testCase "nubOrd-Prop-PLT" $ do+        let a = [ PLT (Lit 0x0) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata"))+                , PLT (Lit 0x1) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata"))+                , PLT (Lit 0x2) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata"))+                , PLT (Lit 0x0) (ReadWord (ReadWord (Lit 0x0) (AbstractBuf "txdata")) (AbstractBuf "txdata"))]+        let simp = nubOrd a+            simp2 = List.nub a+        assertEqual "Must be 3-length" 3 (length simp)+        assertEqual "Must be 3-length" 3 (length simp2)+    , testCase "nubOrd-Prop-PEq" $ do+        let a = [ PEq (Lit 0x0) (ReadWord (Lit 0x0) (AbstractBuf "txdata"))+                , PEq (Lit 0x0) (ReadWord (Lit 0x1) (AbstractBuf "txdata"))+                , PEq (Lit 0x0) (ReadWord (Lit 0x2) (AbstractBuf "txdata"))+                , PEq (Lit 0x0) (ReadWord (Lit 0x0) (AbstractBuf "txdata"))]+        let simp = nubOrd a+            simp2 = List.nub a+        assertEqual "Must be 3-length" 3 (length simp)+        assertEqual "Must be 3-length" 3 (length simp2)+  ]++signExtendTests :: TestTree+signExtendTests = testGroup "SEx tests"+  [+    -- these should run without simplification to test the SMT solver's ability to handle sign extension+    testCase "sign-extend-1" $ do+        let p = (PEq (Lit 1) (SLT (Lit 1774544) (SEx (Lit 2) (Lit 1774567))))+        let simp = Expr.simplifyProps [p]+        assertEqual "Must simplify to PBool True" simp []+        res <- checkSat p+        assertBool "Must be satisfiable!" $ isSat res+  , testCase "sign-extend-2" $ do+      let p = (PEq (Lit 1) (SLT (SEx (Lit 2) (Var "arg1")) (Lit 0)))+      res <- checkSat p+      assertBool "Must be satisfiable!" $ isSat res+  , testCase "sign-extend-3" $ do+      let p = PAnd+              (PEq (Lit 1) (SLT (SEx (Lit 2) (Var "arg1")) (Lit 115792089237316195423570985008687907853269984665640564039457584007913128752664)))+              (PEq (Var "arg1") (SEx (Lit 2) (Var "arg1")))+      res <- checkSat p+      assertBool "Must be satisfiable!" $ isSat res+  , testProperty "sign-extend-vs-smt" $ withMaxSuccess 30 $ \(a :: W256, b :: W256) -> ioProperty $ do+      let p = (PEq (Var "arg1") (SEx (Lit (a `mod` 50)) (Lit b)))+      Cex cex <- checkSat p+      let Right (Lit v1) = subModel cex (Var "arg1")+      let [PEq (Lit v2) (Var "arg1")] = Expr.simplifyProps [p]+      pure $ v1 === v2+  ]++concretizationTests :: TestTree+concretizationTests = testGroup "Concretization tests"+  [ -- Arithmetic operations+    testCase "conc-add" $ do+      let simp = Expr.simplify $ Add (Lit 0x10) (Lit 0x20)+      assertEqual "Add should be concretized" (Lit 0x30) simp+  , testCase "conc-add-overflow" $ do+      let simp = Expr.simplify $ Add (Lit Expr.maxLit) (Lit 1)+      assertEqual "Add overflow should wrap" (Lit 0) simp+  , testCase "conc-sub" $ do+      let simp = Expr.simplify $ Sub (Lit 0x30) (Lit 0x10)+      assertEqual "Sub should be concretized" (Lit 0x20) simp+  , testCase "conc-sub-underflow" $ do+      let simp = Expr.simplify $ Sub (Lit 0) (Lit 1)+      assertEqual "Sub underflow should wrap" (Lit Expr.maxLit) simp+  , testCase "conc-mul" $ do+      let simp = Expr.simplify $ Mul (Lit 0x10) (Lit 0x20)+      assertEqual "Mul should be concretized" (Lit 0x200) simp+  , testCase "conc-mul-zero" $ do+      let simp = Expr.simplify $ Mul (Lit 0) (Lit 0x1234)+      assertEqual "Mul by zero" (Lit 0) simp+  , testCase "conc-div" $ do+      let simp = Expr.simplify $ Div (Lit 0x20) (Lit 0x10)+      assertEqual "Div should be concretized" (Lit 0x2) simp+  , testCase "conc-div-by-zero" $ do+      let simp = Expr.simplify $ Div (Lit 0x20) (Lit 0)+      assertEqual "Div by zero should be 0" (Lit 0) simp+  , testCase "conc-sdiv" $ do+      -- -6 / 3 = -2 in signed arithmetic+      -- -6 in W256 is maxLit - 5+      let neg6 = Expr.maxLit - 5+          neg2 = Expr.maxLit - 1+          simp = Expr.simplify $ SDiv (Lit neg6) (Lit 3)+      assertEqual "SDiv should handle signed division" (Lit neg2) simp+  , testCase "conc-sdiv-by-zero" $ do+      let simp = Expr.simplify $ SDiv (Lit 0x20) (Lit 0)+      assertEqual "SDiv by zero should be 0" (Lit 0) simp+  , testCase "conc-mod" $ do+      let simp = Expr.simplify $ Mod (Lit 0x25) (Lit 0x10)+      assertEqual "Mod should be concretized" (Lit 0x5) simp+  , testCase "conc-mod-by-zero" $ do+      let simp = Expr.simplify $ Mod (Lit 0x25) (Lit 0)+      assertEqual "Mod by zero should be 0" (Lit 0) simp+  , testCase "conc-smod" $ do+      -- -7 smod 3 = -1 in signed arithmetic+      let neg7 = Expr.maxLit - 6+          neg1 = Expr.maxLit+          simp = Expr.simplify $ SMod (Lit neg7) (Lit 3)+      assertEqual "SMod should handle signed mod" (Lit neg1) simp+  , testCase "conc-smod-by-zero" $ do+      let simp = Expr.simplify $ SMod (Lit 0x25) (Lit 0)+      assertEqual "SMod by zero should be 0" (Lit 0) simp+  , testCase "conc-addmod" $ do+      let simp = Expr.simplify $ AddMod (Lit 10) (Lit 10) (Lit 8)+      assertEqual "AddMod should be concretized" (Lit 4) simp+  , testCase "conc-addmod-by-zero" $ do+      let simp = Expr.simplify $ AddMod (Lit 10) (Lit 10) (Lit 0)+      assertEqual "AddMod by zero should be 0" (Lit 0) simp+  , testCase "conc-mulmod" $ do+      let simp = Expr.simplify $ MulMod (Lit 10) (Lit 10) (Lit 8)+      assertEqual "MulMod should be concretized" (Lit 4) simp+  , testCase "conc-mulmod-by-zero" $ do+      let simp = Expr.simplify $ MulMod (Lit 10) (Lit 10) (Lit 0)+      assertEqual "MulMod by zero should be 0" (Lit 0) simp+  , testCase "conc-exp" $ do+      let simp = Expr.simplify $ Exp (Lit 2) (Lit 10)+      assertEqual "Exp should be concretized" (Lit 1024) simp+  , testCase "conc-exp-zero" $ do+      let simp = Expr.simplify $ Exp (Lit 2) (Lit 0)+      assertEqual "x^0 should be 1" (Lit 1) simp+  , testCase "conc-sex" $ do+      -- sign-extend byte 0 of 0xff -> all 1s (since bit 7 is set)+      let simp = Expr.simplify $ SEx (Lit 0) (Lit 0xff)+      assertEqual "SEx should be concretized" (Lit Expr.maxLit) simp+  , testCase "conc-sex-no-extend" $ do+      -- sign-extend byte 30 of 0xff -> 0xff (bit 247 is not set)+      let simp = Expr.simplify $ SEx (Lit 30) (Lit 0xff)+      assertEqual "SEx should not extend" (Lit 0xff) simp++    -- Comparison operations+  , testCase "conc-lt-true" $ do+      let simp = Expr.simplify $ LT (Lit 1) (Lit 2)+      assertEqual "LT true" (Lit 1) simp+  , testCase "conc-lt-false" $ do+      let simp = Expr.simplify $ LT (Lit 2) (Lit 1)+      assertEqual "LT false" (Lit 0) simp+  , testCase "conc-gt-true" $ do+      let simp = Expr.simplify $ GT (Lit 2) (Lit 1)+      assertEqual "GT true" (Lit 1) simp+  , testCase "conc-gt-false" $ do+      let simp = Expr.simplify $ GT (Lit 1) (Lit 2)+      assertEqual "GT false" (Lit 0) simp+  , testCase "conc-leq-true" $ do+      let simp = Expr.simplify $ LEq (Lit 1) (Lit 1)+      assertEqual "LEq equal" (Lit 1) simp+  , testCase "conc-leq-false" $ do+      let simp = Expr.simplify $ LEq (Lit 2) (Lit 1)+      assertEqual "LEq false" (Lit 0) simp+  , testCase "conc-geq-true" $ do+      let simp = Expr.simplify $ GEq (Lit 2) (Lit 1)+      assertEqual "GEq true" (Lit 1) simp+  , testCase "conc-geq-false" $ do+      let simp = Expr.simplify $ GEq (Lit 1) (Lit 2)+      assertEqual "GEq false" (Lit 0) simp+  , testCase "conc-slt-true" $ do+      -- -1 < 0 in signed: maxLit < 0+      let simp = Expr.simplify $ SLT (Lit Expr.maxLit) (Lit 0)+      assertEqual "SLT true (negative < zero)" (Lit 1) simp+  , testCase "conc-slt-false" $ do+      let simp = Expr.simplify $ SLT (Lit 0) (Lit Expr.maxLit)+      assertEqual "SLT false (zero < negative)" (Lit 0) simp+  , testCase "conc-sgt-true" $ do+      let simp = Expr.simplify $ SGT (Lit 0) (Lit Expr.maxLit)+      assertEqual "SGT true (zero > negative)" (Lit 1) simp+  , testCase "conc-sgt-false" $ do+      let simp = Expr.simplify $ SGT (Lit Expr.maxLit) (Lit 0)+      assertEqual "SGT false (negative > zero)" (Lit 0) simp+  , testCase "conc-eq-true" $ do+      let simp = Expr.simplify $ Eq (Lit 42) (Lit 42)+      assertEqual "Eq true" (Lit 1) simp+  , testCase "conc-eq-false" $ do+      let simp = Expr.simplify $ Eq (Lit 42) (Lit 43)+      assertEqual "Eq false" (Lit 0) simp+  , testCase "conc-iszero-true" $ do+      let simp = Expr.simplify $ IsZero (Lit 0)+      assertEqual "IsZero of 0" (Lit 1) simp+  , testCase "conc-iszero-false" $ do+      let simp = Expr.simplify $ IsZero (Lit 42)+      assertEqual "IsZero of non-zero" (Lit 0) simp++    -- Bitwise operations+  , testCase "conc-and" $ do+      let simp = Expr.simplify $ And (Lit 0xff00) (Lit 0x0ff0)+      assertEqual "And should be concretized" (Lit 0x0f00) simp+  , testCase "conc-or" $ do+      let simp = Expr.simplify $ Or (Lit 0xff00) (Lit 0x00ff)+      assertEqual "Or should be concretized" (Lit 0xffff) simp+  , testCase "conc-xor" $ do+      let simp = Expr.simplify $ Xor (Lit 0xff00) (Lit 0x0ff0)+      assertEqual "Xor should be concretized" (Lit 0xf0f0) simp+  , testCase "conc-xor-same" $ do+      let simp = Expr.simplify $ Xor (Lit 0x1234) (Lit 0x1234)+      assertEqual "Xor of same values is 0" (Lit 0) simp+  , testCase "conc-xor-self" $ do+      let simp = Expr.simplify $ Xor (Var "x") (Var "x")+      assertEqual "x xor x = 0" (Lit 0) simp+  , testCase "conc-not" $ do+      let simp = Expr.simplify $ Not (Lit 0x55)+      assertEqual "Not should be concretized" (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffaa) simp+  , testCase "conc-not-zero" $ do+      let simp = Expr.simplify $ Not (Lit 0)+      assertEqual "Not of 0 is maxLit" (Lit Expr.maxLit) simp+  , testCase "conc-shl" $ do+      let simp = Expr.simplify $ SHL (Lit 4) (Lit 0xff)+      assertEqual "SHL should be concretized" (Lit 0xff0) simp+  , testCase "conc-shl-overflow" $ do+      let simp = Expr.simplify $ SHL (Lit 256) (Lit 0xff)+      assertEqual "SHL by 256 should be 0" (Lit 0) simp+  , testCase "conc-shr" $ do+      let simp = Expr.simplify $ SHR (Lit 4) (Lit 0xff)+      assertEqual "SHR should be concretized" (Lit 0xf) simp+  , testCase "conc-shr-overflow" $ do+      let simp = Expr.simplify $ SHR (Lit 257) (Lit 0xff)+      assertEqual "SHR by >256 should be 0" (Lit 0) simp+  , testCase "conc-sar-positive" $ do+      let simp = Expr.simplify $ SAR (Lit 4) (Lit 0xff)+      assertEqual "SAR positive should be like SHR" (Lit 0xf) simp+  , testCase "conc-sar-negative" $ do+      -- SAR of a negative number (MSB set) should fill with 1s+      -- maxLit has MSB set, shifting right by 4 should fill top 4 bits with 1s+      let simp = Expr.simplify $ SAR (Lit 4) (Lit Expr.maxLit)+      assertEqual "SAR negative should fill with 1s" (Lit Expr.maxLit) simp+  , testCase "conc-sar-large-shift-negative" $ do+      -- SAR by >= 255 of negative number -> maxBound (all 1s)+      let simp = Expr.simplify $ SAR (Lit 255) (Lit Expr.maxLit)+      assertEqual "SAR large shift negative" (Lit Expr.maxLit) simp+  , testCase "conc-sar-large-shift-positive" $ do+      -- SAR by >= 255 of positive number -> 0+      let simp = Expr.simplify $ SAR (Lit 255) (Lit 1)+      assertEqual "SAR large shift positive" (Lit 0) simp+  , testCase "conc-clz-zero" $ do+      let simp = Expr.simplify $ CLZ (Lit 0)+      assertEqual "CLZ of 0 should be 256" (Lit 256) simp+  , testCase "conc-clz-one" $ do+      let simp = Expr.simplify $ CLZ (Lit 1)+      assertEqual "CLZ of 1 should be 255" (Lit 255) simp+  , testCase "conc-clz-max" $ do+      let simp = Expr.simplify $ CLZ (Lit Expr.maxLit)+      assertEqual "CLZ of maxLit should be 0" (Lit 0) simp++    -- Min/Max operations+  , testCase "conc-min" $ do+      let simp = Expr.simplify $ Min (Lit 5) (Lit 10)+      assertEqual "Min should be concretized" (Lit 5) simp+  , testCase "conc-max" $ do+      let simp = Expr.simplify $ Max (Lit 5) (Lit 10)+      assertEqual "Max should be concretized" (Lit 10) simp++    -- Byte-level operations+  , testCase "conc-eqbyte-true" $ do+      let simp = Expr.eqByte (LitByte 0x42) (LitByte 0x42)+      assertEqual "EqByte equal" (Lit 1) simp+  , testCase "conc-eqbyte-false" $ do+      let simp = Expr.eqByte (LitByte 0x42) (LitByte 0x43)+      assertEqual "EqByte not equal" (Lit 0) simp+  , testCase "conc-joinbytes" $ do+      let simp = Expr.joinBytes (replicate 31 (LitByte 0) ++ [LitByte 0x42])+      assertEqual "JoinBytes all concrete" (Lit 0x42) simp+  , testCase "conc-joinbytes-msb" $ do+      let simp = Expr.joinBytes (LitByte 0xff : replicate 31 (LitByte 0))+      assertEqual "JoinBytes MSB set" (Lit 0xff00000000000000000000000000000000000000000000000000000000000000) simp++  -- Keccak+  , testCase "conc-keccak" $ do+      let simp = Expr.concKeccakSimpExpr $ Keccak (ConcreteBuf "")+      assertEqual "Keccak of empty should be concretized" (Lit (keccak' "")) simp+  , testCase "conc-keccak-nonempty" $ do+      let simp = Expr.concKeccakSimpExpr $ Keccak (ConcreteBuf "hello")+      assertEqual "Keccak of hello should be concretized" (Lit (keccak' "hello")) simp++  -- PEq simplifyProp over Props+  , testCase "conc-peq-lit-true" $ do+      let simp = Expr.simplifyProp $ PEq (Lit 42) (Lit 42)+      assertEqual "PEq Lit equal" (PBool True) simp+  , testCase "conc-peq-lit-false" $ do+      let simp = Expr.simplifyProp $ PEq (Lit 42) (Lit 43)+      assertEqual "PEq Lit not equal" (PBool False) simp+  , testCase "conc-peq-litaddr-true" $ do+      let simp = Expr.simplifyProp $ PEq (LitAddr 0x1234) (LitAddr 0x1234)+      assertEqual "PEq LitAddr equal" (PBool True) simp+  , testCase "conc-peq-litaddr-false" $ do+      let simp = Expr.simplifyProp $ PEq (LitAddr 0x1234) (LitAddr 0x5678)+      assertEqual "PEq LitAddr not equal" (PBool False) simp+  , testCase "conc-peq-litbyte-true" $ do+      let simp = Expr.simplifyProp $ PEq (LitByte 0xab) (LitByte 0xab)+      assertEqual "PEq LitByte equal" (PBool True) simp+  , testCase "conc-peq-litbyte-false" $ do+      let simp = Expr.simplifyProp $ PEq (LitByte 0xab) (LitByte 0xcd)+      assertEqual "PEq LitByte not equal" (PBool False) simp+  , testCase "conc-peq-concretebuf-true" $ do+      let simp = Expr.simplifyProp $ PEq (ConcreteBuf "hello") (ConcreteBuf "hello")+      assertEqual "PEq ConcreteBuf equal" (PBool True) simp+  , testCase "conc-peq-concretebuf-false" $ do+      let simp = Expr.simplifyProp $ PEq (ConcreteBuf "hello") (ConcreteBuf "world")+      assertEqual "PEq ConcreteBuf not equal" (PBool False) simp+  , testCase "conc-peq-concretestore-true" $ do+      let simp = Expr.simplifyProp $ PEq (ConcreteStore (Map.fromList [(1, 2)])) (ConcreteStore (Map.fromList [(1, 2)]))+      assertEqual "PEq ConcreteStore equal" (PBool True) simp+  , testCase "conc-peq-concretestore-false" $ do+      let simp = Expr.simplifyProp $ PEq (ConcreteStore (Map.fromList [(1, 2)])) (ConcreteStore (Map.fromList [(1, 3)]))+      assertEqual "PEq ConcreteStore not equal" (PBool False) simp+  , testCase "conc-peq-var-self" $ do+      let simp = Expr.simplifyProp $ PEq (Var "x") (Var "x")+      assertEqual "PEq Var self-equal" (PBool True) simp+  , testCase "conc-peq-symaddr-self" $ do+      let simp = Expr.simplifyProp $ PEq (SymAddr "a") (SymAddr "a")+      assertEqual "PEq SymAddr self-equal" (PBool True) simp+  , testCase "conc-peq-abstractbuf-self" $ do+      let simp = Expr.simplifyProp $ PEq (AbstractBuf "b") (AbstractBuf "b")+      assertEqual "PEq AbstractBuf self-equal" (PBool True) simp+  , testCase "conc-peq-abstractstore-self" $ do+      let simp = Expr.simplifyProp $ PEq (AbstractStore (LitAddr 0x1) Nothing) (AbstractStore (LitAddr 0x1) Nothing)+      assertEqual "PEq AbstractStore self-equal" (PBool True) simp+  -- Other simplifications over Props+  , testCase "conc-plt-true" $ do+      let simp = Expr.simplifyProp $ PLT (Lit 1) (Lit 2)+      assertEqual "PLT true" (PBool True) simp+  , testCase "conc-plt-false" $ do+      let simp = Expr.simplifyProp $ PLT (Lit 2) (Lit 1)+      assertEqual "PLT false" (PBool False) simp+  , testCase "conc-plt-equal" $ do+      let simp = Expr.simplifyProp $ PLT (Lit 5) (Lit 5)+      assertEqual "PLT equal is false" (PBool False) simp+  , testCase "conc-pgt-true" $ do+      let simp = Expr.simplifyProp $ PGT (Lit 2) (Lit 1)+      -- PGT a b is simplified to PLT b a+      assertEqual "PGT true" (PBool True) simp+  , testCase "conc-pgt-false" $ do+      let simp = Expr.simplifyProp $ PGT (Lit 1) (Lit 2)+      assertEqual "PGT false" (PBool False) simp+  , testCase "conc-pgeq-true" $ do+      let simp = Expr.simplifyProp $ PGEq (Lit 2) (Lit 1)+      -- PGEq a b is simplified to PLEq b a+      assertEqual "PGEq true" (PBool True) simp+  , testCase "conc-pgeq-false" $ do+      let simp = Expr.simplifyProp $ PGEq (Lit 1) (Lit 2)+      assertEqual "PGEq false" (PBool False) simp+  , testCase "conc-pgeq-equal" $ do+      let simp = Expr.simplifyProp $ PGEq (Lit 5) (Lit 5)+      assertEqual "PGEq equal is true" (PBool True) simp+  , testCase "conc-prop-pleq-true" $ do+      let simp = Expr.simplifyProp $ PLEq (Lit 1) (Lit 2)+      assertEqual "PLEq true" (PBool True) simp+  , testCase "conc-prop-pleq-false" $ do+      let simp = Expr.simplifyProp $ PLEq (Lit 2) (Lit 1)+      assertEqual "PLEq false" (PBool False) simp+  , testCase "conc-pneg-true" $ do+      let simp = Expr.simplifyProp $ PNeg (PBool True)+      assertEqual "PNeg True" (PBool False) simp+  , testCase "conc-pneg-false" $ do+      let simp = Expr.simplifyProp $ PNeg (PBool False)+      assertEqual "PNeg False" (PBool True) simp+  , testCase "conc-pand-true" $ do+      let simp = Expr.simplifyProp $ PAnd (PBool True) (PBool True)+      assertEqual "PAnd True True" (PBool True) simp+  , testCase "conc-pand-false" $ do+      let simp = Expr.simplifyProp $ PAnd (PBool True) (PBool False)+      assertEqual "PAnd True False" (PBool False) simp+  , testCase "conc-por-true" $ do+      let simp = Expr.simplifyProp $ POr (PBool False) (PBool True)+      assertEqual "POr False True" (PBool True) simp+  , testCase "conc-por-false" $ do+      let simp = Expr.simplifyProp $ POr (PBool False) (PBool False)+      assertEqual "POr False False" (PBool False) simp+  , testCase "conc-pimpl-true-true" $ do+      let simp = Expr.simplifyProp $ PImpl (PBool True) (PBool True)+      assertEqual "PImpl True True" (PBool True) simp+  , testCase "conc-pimpl-true-false" $ do+      let simp = Expr.simplifyProp $ PImpl (PBool True) (PBool False)+      assertEqual "PImpl True False" (PBool False) simp+  , testCase "conc-pimpl-false-any" $ do+      let simp = Expr.simplifyProp $ PImpl (PBool False) (PBool False)+      assertEqual "PImpl False _ is True" (PBool True) simp++    -- WAddr concretization+  , testCase "conc-waddr" $ do+      let simp = Expr.simplify $ WAddr (LitAddr 0x1234)+      assertEqual "WAddr LitAddr should be concretized" (Lit 0x1234) simp++    -- BufLength concretization+  , testCase "conc-buflength-empty" $ do+      let simp = Expr.simplify $ BufLength (ConcreteBuf "")+      assertEqual "BufLength of empty" (Lit 0) simp+  , testCase "conc-buflength-nonempty" $ do+      let simp = Expr.simplify $ BufLength (ConcreteBuf "hello")+      assertEqual "BufLength of hello" (Lit 5) simp++    -- ITE with concrete condition+  , testCase "conc-ite-true" $ do+      let simp = Expr.simplify $ ITE (Lit 1) (Lit 42) (Lit 99)+      assertEqual "ITE true takes true branch" (Lit 42) simp+  , testCase "conc-ite-false" $ do+      let simp = Expr.simplify $ ITE (Lit 0) (Lit 42) (Lit 99)+      assertEqual "ITE false takes false branch" (Lit 99) simp+  , testCase "conc-ite-same-branches" $ do+      let simp = Expr.simplify $ ITE (Var "c") (Lit 42) (Lit 42)+      assertEqual "ITE with same branches" (Lit 42) simp++    -- Eq in simplifier (structural equality)+  , testCase "conc-eq-self" $ do+      let simp = Expr.simplify $ Eq (Var "x") (Var "x")+      assertEqual "Eq self" (Lit 1) simp++    -- GT/LT/SLT/SGT special cases+  , testCase "conc-lt-zero" $ do+      let simp = Expr.simplify $ LT (Var "x") (Lit 0)+      assertEqual "Nothing is < 0 unsigned" (Lit 0) simp+  , testCase "conc-lt-maxlit" $ do+      let simp = Expr.simplify $ LT (Lit Expr.maxLit) (Var "x")+      assertEqual "maxLit is never < anything" (Lit 0) simp+  , testCase "conc-gt-maxlit" $ do+      -- GT _ maxLit becomes lt maxLit _ which is 0+      let simp = Expr.simplify $ GT (Var "x") (Lit Expr.maxLit)+      assertEqual "Nothing is > maxLit" (Lit 0) simp+  , testCase "conc-gt-zero" $ do+      let simp = Expr.simplify $ GT (Lit 0) (Var "x")+      assertEqual "0 is not > anything unsigned" (Lit 0) simp+  , testCase "conc-slt-min-signed" $ do+      let simp = Expr.simplify $ SLT (Var "x") (Lit Expr.minLitSigned)+      assertEqual "Nothing is SLT minLitSigned" (Lit 0) simp+  , testCase "conc-slt-max-signed" $ do+      let simp = Expr.simplify $ SLT (Lit Expr.maxLitSigned) (Var "x")+      assertEqual "maxLitSigned is not SLT anything" (Lit 0) simp+  , testCase "conc-sgt-min-signed" $ do+      let simp = Expr.simplify $ SGT (Lit Expr.minLitSigned) (Var "x")+      assertEqual "minLitSigned is not SGT anything" (Lit 0) simp+  , testCase "conc-sgt-max-signed" $ do+      let simp = Expr.simplify $ SGT (Var "x") (Lit Expr.maxLitSigned)+      assertEqual "Nothing is SGT maxLitSigned" (Lit 0) simp++    -- Sub self+  , testCase "conc-sub-self" $ do+      let simp = Expr.simplify $ Sub (Var "x") (Var "x")+      assertEqual "x - x = 0" (Lit 0) simp++    -- Div/SDiv special cases+  , testCase "conc-div-zero-num" $ do+      let simp = Expr.simplify $ Div (Lit 0) (Var "x")+      assertEqual "0 / x = 0" (Lit 0) simp+  , testCase "conc-div-zero-denom" $ do+      let simp = Expr.simplify $ Div (Var "x") (Lit 0)+      assertEqual "x / 0 = 0" (Lit 0) simp+  , testCase "conc-div-by-one" $ do+      let simp = Expr.simplify $ Div (Var "x") (Lit 1)+      assertEqual "x / 1 = x" (Var "x") simp+  , testCase "conc-sdiv-zero-num" $ do+      let simp = Expr.simplify $ SDiv (Lit 0) (Var "x")+      assertEqual "0 sdiv x = 0" (Lit 0) simp+  , testCase "conc-sdiv-zero-denom" $ do+      let simp = Expr.simplify $ SDiv (Var "x") (Lit 0)+      assertEqual "x sdiv 0 = 0" (Lit 0) simp+  , testCase "conc-sdiv-by-one" $ do+      let simp = Expr.simplify $ SDiv (Var "x") (Lit 1)+      assertEqual "x sdiv 1 = x" (Var "x") simp++    -- Mod/SMod special cases+  , testCase "conc-mod-zero-denom" $ do+      let simp = Expr.simplify $ Mod (Var "x") (Lit 0)+      assertEqual "x mod 0 = 0" (Lit 0) simp+  , testCase "conc-mod-zero-num" $ do+      let simp = Expr.simplify $ Mod (Lit 0) (Var "x")+      assertEqual "0 mod x = 0" (Lit 0) simp+  , testCase "conc-mod-self" $ do+      let simp = Expr.simplify $ Mod (Var "x") (Var "x")+      assertEqual "x mod x = 0" (Lit 0) simp+  , testCase "conc-smod-zero-denom" $ do+      let simp = Expr.simplify $ SMod (Var "x") (Lit 0)+      assertEqual "x smod 0 = 0" (Lit 0) simp+  , testCase "conc-smod-zero-num" $ do+      let simp = Expr.simplify $ SMod (Lit 0) (Var "x")+      assertEqual "0 smod x = 0" (Lit 0) simp+  , testCase "conc-smod-self" $ do+      let simp = Expr.simplify $ SMod (Var "x") (Var "x")+      assertEqual "x smod x = 0" (Lit 0) simp+  , testCase "conc-mod-one" $ do+      let simp = Expr.simplify $ Mod (Var "x") (Lit 1)+      assertEqual "x mod 1 = 0" (Lit 0) simp+  , testCase "conc-smod-one" $ do+      let simp = Expr.simplify $ SMod (Var "x") (Lit 1)+      assertEqual "x smod 1 = 0" (Lit 0) simp++    -- MulMod/AddMod zero cases+  , testCase "conc-mulmod-zero-first" $ do+      let simp = Expr.simplify $ MulMod (Lit 0) (Var "y") (Var "z")+      assertEqual "0 * y mod z = 0" (Lit 0) simp+  , testCase "conc-mulmod-zero-second" $ do+      let simp = Expr.simplify $ MulMod (Var "x") (Lit 0) (Var "z")+      assertEqual "x * 0 mod z = 0" (Lit 0) simp+  , testCase "conc-mulmod-zero-mod" $ do+      let simp = Expr.simplify $ MulMod (Var "x") (Var "y") (Lit 0)+      assertEqual "x * y mod 0 = 0" (Lit 0) simp+  , testCase "conc-addmod-zero-mod" $ do+      let simp = Expr.simplify $ AddMod (Var "x") (Var "y") (Lit 0)+      assertEqual "x + y mod 0 = 0" (Lit 0) simp++    -- Exp special cases+  , testCase "conc-exp-zero-exp" $ do+      let simp = Expr.simplify $ Exp (Var "x") (Lit 0)+      assertEqual "x^0 = 1" (Lit 1) simp+  , testCase "conc-exp-one-exp" $ do+      let simp = Expr.simplify $ Exp (Var "x") (Lit 1)+      assertEqual "x^1 = x" (Var "x") simp+  , testCase "conc-exp-one-base" $ do+      let simp = Expr.simplify $ Exp (Lit 1) (Var "x")+      assertEqual "1^x = 1" (Lit 1) simp++    -- Mul special cases+  , testCase "conc-mul-zero-left" $ do+      let simp = Expr.simplify $ Mul (Lit 0) (Var "x")+      assertEqual "0 * x = 0" (Lit 0) simp+  , testCase "conc-mul-one" $ do+      let simp = Expr.simplify $ Mul (Lit 1) (Var "x")+      assertEqual "1 * x = x" (Var "x") simp++    -- And/Or special cases+  , testCase "conc-and-zero" $ do+      let simp = Expr.simplify $ And (Lit 0) (Var "x")+      assertEqual "0 & x = 0" (Lit 0) simp+  , testCase "conc-and-maxlit" $ do+      let simp = Expr.simplify $ And (Lit Expr.maxLit) (Var "x")+      assertEqual "maxLit & x = x" (Var "x") simp+  , testCase "conc-and-self" $ do+      let simp = Expr.simplify $ And (Var "x") (Var "x")+      assertEqual "x & x = x" (Var "x") simp+  , testCase "conc-and-complement" $ do+      let simp = Expr.simplify $ And (Not (Var "x")) (Var "x")+      assertEqual "~x & x = 0" (Lit 0) simp+  , testCase "conc-or-zero" $ do+      let simp = Expr.simplify $ Or (Lit 0) (Var "x")+      assertEqual "0 | x = x" (Var "x") simp+  , testCase "conc-or-self" $ do+      let simp = Expr.simplify $ Or (Var "x") (Var "x")+      assertEqual "x | x = x" (Var "x") simp+  , testCase "conc-or-maxlit-left" $ do+      let simp = Expr.simplify $ Or (Lit Expr.maxLit) (Var "x")+      assertEqual "maxLit | x = maxLit" (Lit Expr.maxLit) simp+  , testCase "conc-or-maxlit-right" $ do+      let simp = Expr.simplify $ Or (Var "x") (Lit Expr.maxLit)+      assertEqual "x | maxLit = maxLit" (Lit Expr.maxLit) simp++    -- SHL/SHR with zero+  , testCase "conc-shl-zero-amount" $ do+      let simp = Expr.simplify $ SHL (Lit 0) (Var "x")+      assertEqual "x << 0 = x" (Var "x") simp+  , testCase "conc-shl-zero-value" $ do+      let simp = Expr.simplify $ SHL (Var "n") (Lit 0)+      assertEqual "0 << n = 0" (Lit 0) simp+  , testCase "conc-shl-large-shift" $ do+      let simp = Expr.simplify $ SHL (Lit 256) (Var "x")+      assertEqual "x << 256 = 0" (Lit 0) simp+  , testCase "conc-shl-very-large-shift" $ do+      let simp = Expr.simplify $ SHL (Lit 1000) (Var "x")+      assertEqual "x << 1000 = 0" (Lit 0) simp+  , testCase "conc-shr-zero-amount" $ do+      let simp = Expr.simplify $ SHR (Lit 0) (Var "x")+      assertEqual "x >> 0 = x" (Var "x") simp+  , testCase "conc-shr-zero-value" $ do+      let simp = Expr.simplify $ SHR (Var "n") (Lit 0)+      assertEqual "0 >> n = 0" (Lit 0) simp+  , testCase "conc-shr-large-shift" $ do+      let simp = Expr.simplify $ SHR (Lit 256) (Var "x")+      assertEqual "x >> 256 = 0" (Lit 0) simp+  , testCase "conc-shr-very-large-shift" $ do+      let simp = Expr.simplify $ SHR (Lit 1000) (Var "x")+      assertEqual "x >> 1000 = 0" (Lit 0) simp++    -- ReadWord+  , testCase "conc-readword" $ do+      let simp = Expr.simplify $ ReadWord (Lit 0) (WriteWord (Lit 0) (Lit 0x42) (AbstractBuf "abc"))+      assertEqual "ReadWord from WriteWord" (Lit 0x42) simp++    -- WriteByte+  , testCase "conc-writebyte" $ do+      let simp = Expr.simplify $ ReadByte (Lit 0) (WriteByte (Lit 0) (LitByte 0xff) (AbstractBuf "abc"))+      assertEqual "WriteByte then ReadByte" (LitByte 0xff) simp++    -- WriteWord+  , testCase "conc-writeword" $ do+      let simp = Expr.simplify $ ReadWord (Lit 0) (WriteWord (Lit 0) (Lit 0xab) (AbstractBuf "abc"))+      assertEqual "WriteWord then ReadWord" (Lit 0xab) simp++    -- CopySlice of zero size should be a no-op+  , testCase "conc-copyslice-zero-size" $ do+      let simp = Expr.simplify $ CopySlice (Lit 0) (Lit 0) (Lit 0) (AbstractBuf "src") (AbstractBuf "dst")+      assertEqual "CopySlice size 0 is noop" (AbstractBuf "dst") simp++    -- IndexWord+  , testCase "conc-indexword" $ do+      let simp = Expr.simplify $ IndexWord (Lit 31) (Lit 0x42)+      assertEqual "IndexWord LSB" (LitByte 0x42) simp+  , testCase "conc-indexword-msb" $ do+      let simp = Expr.simplify $ IndexWord (Lit 0) (Lit 0xff00000000000000000000000000000000000000000000000000000000000000)+      assertEqual "IndexWord MSB" (LitByte 0xff) simp++    -- SEx special case+  , testCase "conc-sex-zero" $ do+      let simp = Expr.simplify $ SEx (Var "b") (Lit 0)+      assertEqual "SEx of 0 is 0" (Lit 0) simp++    -- Min with zero+  , testCase "conc-min-zero" $ do+      let simp = Expr.simplify $ Min (Lit 0) (Var "x")+      assertEqual "min(0, x) = 0" (Lit 0) simp+  ]++-- | Regression tests for W256 unsigned wrapping bugs in the expression simplifier.+-- Each test constructs an expression that triggers a specific wrapping edge case where+-- the simplifier previously produced a result that was not semantically equivalent to+-- the original expression. See commit c4d33256 for the fix.+wrappingTests :: TestTree+wrappingTests = testGroup "W256 wrapping edge cases"+  [ -- A1: readByte, CopySlice before-region, symbolic size+    -- dstOffset near maxBound makes dstOffset+size potentially wrap to low addresses.+    -- Old code only checked dstOffset > x, missing the wrapping case.+    testCase "readByte-copySlice-before-symSize-wrap" $ do+      let dstOff = maxBound - 5 :: W256+          x = 3 :: W256+          buf = CopySlice (Lit 0) (Lit dstOff) (Var "sz") (AbstractBuf "src") (AbstractBuf "dst")+          full = ReadByte (Lit x) buf+          simplified = Expr.readByte (Lit x) buf+      result <- proveEquivExpr full simplified+      assertBool "readByte with near-maxBound dstOffset and symbolic size" result++  , -- A2: readByte, CopySlice before-region, concrete size, dstOffset+size wraps+    -- dstOffset + size wraps past zero, overwriting low addresses.+    testCase "readByte-copySlice-before-concSize-wrap" $ do+      let dstOff = maxBound - 30 :: W256+          size = 58 :: W256+          x = 10 :: W256+          buf = CopySlice (Lit 0) (Lit dstOff) (Lit size) (AbstractBuf "src") (AbstractBuf "dst")+          full = ReadByte (Lit x) buf+          simplified = Expr.readByte (Lit x) buf+      result <- proveEquivExpr full simplified+      assertBool "readByte with wrapping dstOffset+size" result++  , -- B1: readWord, CopySlice before-region, symbolic size+    -- Same wrapping issue as A1 but for 32-byte reads.+    testCase "readWord-copySlice-before-symSize-wrap" $ do+      let dstOff = maxBound - 5 :: W256+          x = 3 :: W256+          buf = CopySlice (Lit 0) (Lit dstOff) (Var "sz") (AbstractBuf "src") (AbstractBuf "dst")+          full = ReadWord (Lit x) buf+          simplified = Expr.readWord (Lit x) buf+      result <- proveEquivExpr full simplified+      assertBool "readWord with near-maxBound dstOffset and symbolic size" result++  , -- B2: readWord, CopySlice before-region, concrete size, wrapping+    -- Same as A2 but for word reads.+    testCase "readWord-copySlice-before-concSize-wrap" $ do+      let dstOff = maxBound - 30 :: W256+          size = 100 :: W256+          x = 3 :: W256+          buf = CopySlice (Lit 0) (Lit dstOff) (Lit size) (AbstractBuf "src") (AbstractBuf "dst")+          full = ReadWord (Lit x) buf+          simplified = Expr.readWord (Lit x) buf+      result <- proveEquivExpr full simplified+      assertBool "readWord with wrapping dstOffset+size" result++  , -- C1: readWord, CopySlice before-region, x+32 wraps past maxBound+    -- When x is near maxBound, x+32 wraps to a small value, making+    -- dstOffset >= x+32 true even though the 32-byte read wraps into the CopySlice region.+    testCase "readWord-copySlice-before-x32-wrap" $ do+      let dstOff = maxBound - 100 :: W256+          x = maxBound - 10 :: W256  -- x+32 = 21, wraps!+          buf = CopySlice (Lit 0) (Lit dstOff) (Var "sz") (AbstractBuf "src") (AbstractBuf "dst")+          full = ReadWord (Lit x) buf+          simplified = Expr.readWord (Lit x) buf+      result <- proveEquivExpr full simplified+      assertBool "readWord with x+32 wrapping" result++  , -- C2: readWord, CopySlice after-region, concrete size, dstOffset+size wraps+    -- x is inside the wrapped CopySlice region => the expression cannot be simplified+    testCase "readWord-copySlice-after-concSize-wrap" $ do+      let dstOff = maxBound - 100 :: W256+          size = 200 :: W256+          x = maxBound - 50 :: W256+          buf = CopySlice (Lit 0) (Lit dstOff) (Lit size) (AbstractBuf "src") (AbstractBuf "dst")+          full = ReadWord (Lit x) buf+          simplified = Expr.readWord (Lit x) buf+      result <- proveEquivExpr full simplified+      assertBool "readWord after-region with wrapping dstOffset+size" result++  , -- D1: readWord, ConcreteBuf, idx+31 wraps+    -- readWord previously did not handle this case correctly due to overflow of idx+31+    testCase "readWord-concreteBuf-wrap" $ do+      let idx = maxBound - 19 :: W256+          buf = ConcreteBuf (BS.pack [1..50])+          full = ReadWord (Lit idx) buf+          simplified = Expr.readWord (Lit idx) buf+      result <- proveEquivExpr full simplified+      assertBool "readWord with idx+31 wrapping on ConcreteBuf" result++  , -- D2: readWord, non-concrete buf, idx+31 wraps+    -- Same wrapping issue as D1 but with a non-concrete buffer (WriteByte over ConcreteBuf).+    -- WriteByte at maxBound-5 is within the read range and won't be incorrectly skipped.+    testCase "readWord-abstractBuf-wrap" $ do+      let idx = maxBound - 10 :: W256+          buf = WriteByte (Lit (maxBound - 5)) (LitByte 0xAB) (ConcreteBuf (BS.pack [1..50]))+          full = ReadWord (Lit idx) buf+          simplified = Expr.readWord (Lit idx) buf+      result <- proveEquivExpr full simplified+      assertBool "readWord with idx+31 wrapping on abstract buf" result++  , -- E1: copySlice fully concrete, srcOffset near maxBound wraps+    -- When srcOffset is near maxBound, srcOffset > BS.length triggers zero-fill,+    -- but the wrapped indices actually read real source data.+    testCase "copySlice-concrete-srcOffset-wrap" $ do+      let srcOff = maxBound - 9 :: W256+          size = 20 :: W256+          srcBuf = ConcreteBuf (BS.pack [1..50])+          dstBuf = ConcreteBuf (BS.pack (replicate 50 0))+          full = CopySlice (Lit srcOff) (Lit 0) (Lit size) srcBuf dstBuf+          simplified = Expr.copySlice (Lit srcOff) (Lit 0) (Lit size) srcBuf dstBuf+      result <- proveEquivExpr full simplified+      assertBool "copySlice with wrapping srcOffset" result+  ]++fuzzTests :: TestTree+fuzzTests = adjustOption (\(Test.Tasty.QuickCheck.QuickCheckTests n) -> Test.Tasty.QuickCheck.QuickCheckTests (div n 2)) $+  testGroup "ExprFuzzTests" [equivalenceSanityChecks, simplifierFuzzTests]++equivalenceSanityChecks :: TestTree+equivalenceSanityChecks = testGroup "Expr equivalence sanity checks"+  [ testCase "read-beyond-bound (negative-test)" $ do+      let+        e1 = CopySlice (Lit 1) (Lit 0) (Lit 2) (ConcreteBuf "a") (ConcreteBuf "")+        e2 = ConcreteBuf "Definitely not the same!"+      equal <- proveEquivExpr e1 e2+      assertBool "Should not be equivalent!" $ not equal+  , testProperty "expr equality is satisfiable" $ \(buf, idx) -> ioProperty $ do+        let simplified = Expr.readWord idx buf+            full = ReadWord idx buf+        res <- checkSat (Expr.peq full simplified)+        pure $ isSatOrUnknown res+  ]++-- These tests fuzz the simplifier by generating a random expression,+-- applying some simplification rules, and then using the smt encoding to+-- check that the simplified version is semantically equivalent to the+-- unsimplified one+simplifierFuzzTests :: TestTree+simplifierFuzzTests = testGroup "SimplifierPropertyTests"+    [ testProperty  "buffer-simplification" $ \(expr :: Expr Buf) -> ioProperty $ proveEquivExpr expr (Expr.simplify expr)+    , testProperty  "buffer-simplification-len" $ \(expr :: Expr Buf) -> ioProperty $ do+        let buflen = BufLength expr+        proveEquivExpr buflen (Expr.simplify buflen)+    , testProperty "store-simplification" $ \(expr :: Expr Storage) -> ioProperty $ proveEquivExpr expr (Expr.simplify expr)+    , testProperty "load-simplification" $ \(GenWriteStorageLoad expr) -> ioProperty $ proveEquivExpr expr (Expr.simplify expr)+    , ignoreTest $ testProperty "load-decompose" $ \(GenWriteStorageLoad expr) -> ioProperty $ do+        let simp = Expr.simplify expr+        let decomposed = fromMaybe simp $ mapExprM Expr.decomposeStorage simp+        proveEquivExpr expr decomposed+    , testProperty "byte-simplification" $ \(expr :: Expr Byte) -> ioProperty $ proveEquivExpr expr (Expr.simplify expr)+    , askOption $ \(QuickCheckTests n) -> testProperty "word-simplification" $ withMaxSuccess (min n 20) $ \(ZeroDepthWord expr) ->+        ioProperty $ proveEquivExpr expr (Expr.simplify expr)+    , testProperty "readStorage-equivalance" $ \(store, slot) -> ioProperty $ do+        let simplified = Expr.readStorage' slot store+            full = SLoad slot store+        proveEquivExpr full simplified+    , testProperty "writeStorage-equivalance" $ \(val, GenWriteStorageExpr (slot, store)) -> ioProperty $ do+        let simplified = Expr.writeStorage slot val store+            full = SStore slot val store+        proveEquivExpr full simplified+    , testProperty "readWord-equivalance" $ \(buf, idx) -> ioProperty $ do+        let simplified = Expr.readWord idx buf+            full = ReadWord idx buf+        proveEquivExpr full simplified+    , testProperty "writeWord-equivalance" $ \(idx, val, WriteWordBuf buf) -> ioProperty $ do+        let simplified = Expr.writeWord idx val buf+            full = WriteWord idx val buf+        proveEquivExpr full simplified+    , testProperty "arith-simplification" $ \(_ :: Int) -> ioProperty $ do+        expr <- generate . sized $ genWordArith 15+        let simplified = Expr.simplify expr+        proveEquivExpr expr simplified+    , testProperty "readByte-equivalance" $ \(buf, idx) -> ioProperty $ do+        let simplified = Expr.readByte idx buf+            full = ReadByte idx buf+        proveEquivExpr full simplified+    -- we currently only simplify concrete writes over concrete buffers so that's what we test here+    , testProperty "writeByte-equivalance" $ \(LitOnly val, LitOnly buf, GenWriteByteIdx idx) -> ioProperty $ do+        let simplified = Expr.writeByte idx val buf+            full = WriteByte idx val buf+        proveEquivExpr full simplified+    , testProperty "copySlice-equivalance" $ \(srcOff, GenCopySliceBuf src, GenCopySliceBuf dst, LitWord @300 size) -> ioProperty $ do+        -- we bias buffers to be concrete more often than not+        dstOff <- generate (maybeBoundedLit 100_000)+        let simplified = Expr.copySlice srcOff dstOff size src dst+            full = CopySlice srcOff dstOff size src dst+        proveEquivExpr full simplified+    , testProperty "indexWord-equivalence" $ \(src, LitWord @50 idx) -> ioProperty $ do+        let simplified = Expr.indexWord idx src+            full = IndexWord idx src+        proveEquivExpr full simplified+    , testProperty "pow-base2-simp" $ \(_ :: Int) -> ioProperty $ do+        expo <- generate . sized $ genWordArith 15+        let full = Exp (Lit 2) expo+            simplified = Expr.simplify full+        proveEquivExpr full simplified+    , testProperty "pow-low-exponent-simp" $ \(LitWord @100 expo) -> ioProperty $ do+        base <- generate . sized $ genWordArith 15+        let full = Exp base expo+            simplified = Expr.simplify full+        proveEquivExpr full simplified+    , testProperty "indexWord-mask-equivalence" $ \(src :: Expr EWord, LitWord @35 idx) -> ioProperty $ do+        mask <- generate $ do+          pow <- arbitrary :: Gen Int+          frequency+           [ (1, pure $ Lit $ (shiftL 1 (pow `mod` 256)) - 1)        -- potentially non byte aligned+           , (1, pure $ Lit $ (shiftL 1 ((pow * 8) `mod` 256)) - 1)  -- byte aligned+           ]+        let+          input = And mask src+          simplified = Expr.indexWord idx input+          full = IndexWord idx input+        proveEquivExpr full simplified+    , testProperty "toList-equivalance" $ \buf -> ioProperty $ do+        let+          -- transforms the input buffer to give it a known length+          fixLength :: Expr Buf -> Gen (Expr Buf)+          fixLength = mapExprM go+            where+              go :: Expr a -> Gen (Expr a)+              go = \case+                WriteWord _ val b -> WriteWord <$> idx <*> (pure val) <*> (pure b)+                WriteByte _ val b -> WriteByte <$> idx <*> (pure val) <*> (pure b)+                CopySlice so _ sz src dst -> CopySlice <$> (pure so) <*> idx <*> (pure sz) <*> (pure src) <*> (pure dst)+                AbstractBuf _ -> cbuf+                e -> pure e+              cbuf = do+                bs <- arbitrary+                pure $ ConcreteBuf bs+              idx = do+                w <- arbitrary+                -- we use 100_000 as an upper bound for indices to keep tests reasonably fast here+                pure $ Lit (w `mod` 100_000)++        input <- generate $ fixLength buf+        case Expr.toList input of+          Nothing -> do+            pure True -- ignore cases where the buf cannot be represented as a list+          Just asList -> do+            let asBuf = Expr.fromList asList+            proveEquivExpr asBuf input+    , testProperty "simplifyProp-equivalence-lit" $ \(LitProp p) -> ioProperty $ do+        let simplified = Expr.simplifyProps [p]+        case simplified of+          [] -> proveEquivProp (PBool True) p+          [val@(PBool _)] -> proveEquivProp val p+          _ -> assertFailure "must evaluate down to a literal bool"+    , testProperty "simplifyProp-equivalence-sym" $ \(p) -> ioProperty $ proveEquivProp p (Expr.simplifyProp p)+    , testProperty "simplify-joinbytes" $ \(SymbolicJoinBytes exprList) -> ioProperty $ do+        let x = joinBytesFromList exprList+        let simplified = Expr.simplify x+        proveEquivExpr x simplified+    , testProperty "simpProp-equivalence-sym-Prop" $ withMaxSuccess 20 $ \(ps :: [Prop]) -> ioProperty $ do+        let simplified = pand (Expr.simplifyProps ps)+        proveEquivProp (pand ps) simplified+    , testProperty "simpProp-equivalence-sym-LitProp" $ \(LitProp p) -> ioProperty $ do+        let simplified = pand (Expr.simplifyProps [p])+        proveEquivProp p simplified+    , testProperty "storage-slot-simp-property" $ \(StorageExp s) -> ioProperty $ do+        -- we have to run `Expr.litToKeccak` on the unsimplified system, or+        -- we'd need some form of minimal simplifier for things to work out. As long as+        -- we trust the litToKeccak, this is fine, as that function is stand-alone,+        -- and quite minimal+        let s2 = Expr.litToKeccak s+        let simplified = Expr.simplify s2+        proveEquivExpr s2 simplified+    , testProperty "expr-ordering" $ \(p) -> ioProperty $ do+      let simp = Expr.simplifyProp p+      pure $ Expr.checkLHSConstProp simp+    ]+    {- NOTE: These tests were designed to test behaviour on reading from a buffer such that the indices overflow 2^256.+           However, such scenarios are impossible in the real world (the operation would run out of gas). The problem+           is that the behaviour of bytecode interpreters does not match the semantics of SMT. Intrepreters just+           return all zeroes for any read beyond buffer size, while in SMT reading multiple bytes may lead to overflow+           on indices and subsequently to reading from the beginning of the buffer (wrap-around semantics).+  , testGroup "concrete-buffer-simplification-large-index" [+      test "copy-slice-large-index-nooverflow" $ do+        let+          e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x1) (ConcreteBuf "a") (ConcreteBuf "")+          s = Expr.simplify e+        equal <- checkEquiv e s+        assertEqualM "Must be equal" True equal+    , test "copy-slice-overflow-back-into-source" $ do+        let+          e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x2) (ConcreteBuf "a") (ConcreteBuf "")+          s = Expr.simplify e+        equal <- checkEquiv e s+        assertEqualM "Must be equal" True equal+    , test "copy-slice-overflow-beyond-source" $ do+        let+          e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x3) (ConcreteBuf "a") (ConcreteBuf "")+          s = Expr.simplify e+        equal <- checkEquiv e s+        assertEqualM "Must be equal" True equal+    , test "copy-slice-overflow-beyond-source-into-nonempty" $ do+        let+          e = CopySlice (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (Lit 0x0) (Lit 0x3) (ConcreteBuf "a") (ConcreteBuf "b")+          s = Expr.simplify e+        equal <- checkEquiv e s+        assertEqualM "Must be equal" True equal+    , test "read-word-overflow-back-into-source" $ do+        let+          e = ReadWord (Lit 0xffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff) (ConcreteBuf "kkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkkk")+          s = Expr.simplify e+        equal <- checkEquiv e s+        assertEqualM "Must be equal" True equal+  ]+  -}+++proveEquivProp :: Prop -> Prop -> IO Bool+proveEquivProp a b+  | a == b = pure True+  | otherwise = do+      res <- checkSat $ PNeg ((PImpl a b) .&& (PImpl b a))+      pure $ isUnsatOrUnknown res++proveEquivExpr :: Typeable a => Expr a -> Expr a -> IO Bool+proveEquivExpr a b+  | a == b = pure True+  | otherwise = do+      res <- (checkSat $ a ./= b)+      pure $ isUnsatOrUnknown res++checkSat :: Prop -> IO SMTResult+checkSat p = runEnv (Env {config = equivConfig}) $+    withOneBitwuzla $ \solvers -> checkSatWithProps solvers [p]++equivConfig :: Config+equivConfig = defaultConfig {simp = False, dumpQueries = False}++withOneBitwuzla :: App m => (SolverGroup -> m a) -> m a+withOneBitwuzla = withSolvers Bitwuzla 1 (Just 1) defMemLimit++isSat :: SMTResult -> Bool+isSat = isCex++isSatOrUnknown :: SMTResult -> Bool+isSatOrUnknown res = isSat res || isUnknown res++isUnsatOrUnknown :: SMTResult -> Bool+isUnsatOrUnknown res = isQed res || isUnknown res