Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Refactors in Exec.hs #1282

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Refactors in Exec.hs #1282

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
292 changes: 151 additions & 141 deletions lib/Echidna/Exec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ import Control.Monad.Reader (MonadReader, ask, asks)
import Control.Monad.ST (ST, stToIO, RealWorld)
import Data.Bits
import Data.ByteString qualified as BS
import Data.IORef (readIORef, atomicWriteIORef, newIORef, writeIORef, modifyIORef')
import Data.IORef (IORef, readIORef, atomicWriteIORef, newIORef, writeIORef, modifyIORef')
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, fromJust)
import Data.Text qualified as T
Expand Down Expand Up @@ -102,91 +102,8 @@ execTxWith executeTx tx = do
pure (vmResult, gasLeftBeforeTx - gasLeftAfterTx)
where
runFully = do
config <- asks (.cfg)
-- TODO: Is the latest block a good default? It makes fuzzing hard to reproduce. Rethink this.
let rpcBlock = maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . fromIntegral) config.rpcBlock

vmResult <- executeTx
-- For queries, we halt execution because the VM needs some additional
-- information from the outside. We provide this information and resume
-- the execution by recursively calling `runFully`.
case getQuery vmResult of
-- A previously unknown contract is required
Just q@(PleaseFetchContract addr _ continuation) -> do
cacheRef <- asks (.fetchContractCache)
cache <- liftIO $ readIORef cacheRef
case Map.lookup addr cache of
Just (Just contract) -> fromEVM (continuation contract)
Just Nothing -> do
v <- get
v' <- liftIO $ stToIO $ execStateT (continuation emptyAccount) v
put v'
Nothing -> do
logMsg $ "INFO: Performing RPC: " <> show q
case config.rpcUrl of
Just rpcUrl -> do
ret <- liftIO $ safeFetchContractFrom rpcBlock rpcUrl addr
case ret of
-- TODO: fix hevm to not return an empty contract in case of an error
Just contract | contract.code /= RuntimeCode (ConcreteRuntimeCode "") -> do
fromEVM (continuation contract)
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr (Just contract) cache
_ -> do
-- TODO: better error reporting in HEVM, when intermittent
-- network error then retry
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
logMsg $ "ERROR: Failed to fetch contract: " <> show q
-- TODO: How should we fail here? It could be a network error,
-- RPC server returning junk etc.
fromEVM (continuation emptyAccount)
Nothing -> do
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
-- TODO: How should we fail here? RPC is not configured but VM
-- wants to fetch
fromEVM (continuation emptyAccount)
runFully -- resume execution

-- A previously unknown slot is required
Just q@(PleaseFetchSlot addr slot continuation) -> do
cacheRef <- asks (.fetchSlotCache)
cache <- liftIO $ readIORef cacheRef
case Map.lookup addr cache >>= Map.lookup slot of
Just (Just value) -> fromEVM (continuation value)
Just Nothing -> fromEVM (continuation 0)
Nothing -> do
logMsg $ "INFO: Performing RPC: " <> show q
case config.rpcUrl of
Just rpcUrl -> do
ret <- liftIO $ safeFetchSlotFrom rpcBlock rpcUrl addr slot
case ret of
Just value -> do
fromEVM (continuation value)
liftIO $ atomicWriteIORef cacheRef $
Map.insertWith Map.union addr (Map.singleton slot (Just value)) cache
Nothing -> do
-- TODO: How should we fail here? It could be a network error,
-- RPC server returning junk etc.
logMsg $ "ERROR: Failed to fetch slot: " <> show q
liftIO $ atomicWriteIORef cacheRef $
Map.insertWith Map.union addr (Map.singleton slot Nothing) cache
fromEVM (continuation 0)
Nothing -> do
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
-- Use the zero slot
fromEVM (continuation 0)
runFully -- resume execution

-- Execute a FFI call
Just (PleaseDoFFI (cmd : args) continuation) -> do
(_, stdout, _) <- liftIO $ readProcessWithExitCode cmd args ""
let encodedResponse = encodeAbiValue $
AbiTuple (V.fromList [AbiBytesDynamic . hexText . T.pack $ stdout])
fromEVM (continuation encodedResponse)
runFully

-- No queries to answer, the tx is fully executed and the result is final
_ -> pure vmResult
maybe (pure vmResult) (\q -> handleQuery q >> runFully) (getQuery vmResult)

-- | Handles reverts, failures and contract creations that might be the result
-- (`vmResult`) of executing transaction `tx`.
Expand Down Expand Up @@ -217,6 +134,92 @@ execTxWith executeTx tx = do
modify' $ execState $ loadContract (LitAddr tx.dst)
_ -> pure ()

getRpcInfo = do
config <- asks (.cfg)
-- TODO: Is the latest block a good default? It makes fuzzing hard to reproduce. Rethink this.
let rpcBlock = maybe EVM.Fetch.Latest (EVM.Fetch.BlockNumber . fromIntegral) config.rpcBlock
return (config.rpcUrl, rpcBlock)


-- For queries, we halt execution because the VM needs some additional
-- information from the outside. We provide this information, and then
-- the execution is resumed.

-- A previously unknown contract is required
handleQuery q@(PleaseFetchContract addr _ continuation) = do
cacheRef <- asks (.fetchContractCache)
cache <- liftIO $ readIORef cacheRef
case Map.lookup addr cache of
Just (Just contract) -> fromEVM (continuation contract)
Just Nothing -> do
v <- get
v' <- liftIO $ stToIO $ execStateT (continuation emptyAccount) v
put v'
Nothing -> do
logMsg $ "INFO: Performing RPC: " <> show q
(maybeRpcUrl, rpcBlock) <- getRpcInfo
case maybeRpcUrl of
Just rpcUrl -> do
ret <- liftIO $ safeFetchContractFrom rpcBlock rpcUrl addr
case ret of
-- TODO: fix hevm to not return an empty contract in case of an error
Just contract | contract.code /= RuntimeCode (ConcreteRuntimeCode "") -> do
fromEVM (continuation contract)
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr (Just contract) cache
_ -> do
-- TODO: better error reporting in HEVM, when intermittent
-- network error then retry
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
logMsg $ "ERROR: Failed to fetch contract: " <> show q
-- TODO: How should we fail here? It could be a network error,
-- RPC server returning junk etc.
fromEVM (continuation emptyAccount)
Nothing -> do
liftIO $ atomicWriteIORef cacheRef $ Map.insert addr Nothing cache
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
-- TODO: How should we fail here? RPC is not configured but VM
-- wants to fetch
fromEVM (continuation emptyAccount)

-- A previously unknown slot is required
handleQuery q@(PleaseFetchSlot addr slot continuation) = do
cacheRef <- asks (.fetchSlotCache)
cache <- liftIO $ readIORef cacheRef
case Map.lookup addr cache >>= Map.lookup slot of
Just (Just value) -> fromEVM (continuation value)
Just Nothing -> fromEVM (continuation 0)
Nothing -> do
logMsg $ "INFO: Performing RPC: " <> show q
(maybeRpcUrl, rpcBlock) <- getRpcInfo
case maybeRpcUrl of
Just rpcUrl -> do
ret <- liftIO $ safeFetchSlotFrom rpcBlock rpcUrl addr slot
case ret of
Just value -> do
fromEVM (continuation value)
liftIO $ atomicWriteIORef cacheRef $
Map.insertWith Map.union addr (Map.singleton slot (Just value)) cache
Nothing -> do
-- TODO: How should we fail here? It could be a network error,
-- RPC server returning junk etc.
logMsg $ "ERROR: Failed to fetch slot: " <> show q
liftIO $ atomicWriteIORef cacheRef $
Map.insertWith Map.union addr (Map.singleton slot Nothing) cache
fromEVM (continuation 0)
Nothing -> do
logMsg $ "ERROR: Requested RPC but it is not configured: " <> show q
-- Use the zero slot
fromEVM (continuation 0)

-- Execute a FFI call
handleQuery (PleaseDoFFI (cmd : args) continuation) = do
(_, stdout, _) <- liftIO $ readProcessWithExitCode cmd args ""
let encodedResponse = encodeAbiValue $
AbiTuple (V.fromList [AbiBytesDynamic . hexText . T.pack $ stdout])
fromEVM (continuation encodedResponse)

handleQuery (PleaseDoFFI [] _) = error "Malformed FFI call"

logMsg :: (MonadIO m, MonadReader Env m) => String -> m ()
logMsg msg = do
cfg <- asks (.cfg)
Expand Down Expand Up @@ -262,63 +265,70 @@ execTxWithCov tx = do
_ -> pure False

pure (r, grew || grew')

-- | The same as EVM.exec but collects coverage, will stop on a query
execCov
:: (MonadIO m, MonadState (VM Concrete RealWorld) m, MonadThrow m)
=> Env
-> IORef (Bool, Maybe (VMut.IOVector CoverageInfo, Int))
-> m (VMResult Concrete RealWorld)
execCov env covContextRef = do
vm <- get
(r, vm') <- liftIO $ loop vm
put vm'
pure r
where
-- the same as EVM.exec but collects coverage, will stop on a query
execCov env covContextRef = do
vm <- get
(r, vm') <- liftIO $ loop vm
put vm'
pure r
where
-- | Repeatedly exec a step and add coverage until we have an end result
loop :: VM Concrete RealWorld -> IO (VMResult Concrete RealWorld, VM Concrete RealWorld)
loop !vm = case vm.result of
Nothing -> do
addCoverage vm
stepVM vm >>= loop
Just r -> pure (r, vm)

-- | Execute one instruction on the EVM
stepVM :: VM Concrete RealWorld -> IO (VM Concrete RealWorld)
stepVM = stToIO . execStateT exec1

-- | Add current location to the CoverageMap
addCoverage :: VM Concrete RealWorld -> IO ()
addCoverage !vm = do
let (pc, opIx, depth) = currentCovLoc vm
contract = currentContract vm

maybeCovVec <- lookupUsingCodehashOrInsert env.codehashMap contract env.dapp env.coverageRef $ do
let size = BS.length . forceBuf . fromJust . view bytecode $ contract
if size == 0 then pure Nothing else do
-- IO for making a new vec
vec <- VMut.new size
-- We use -1 for opIx to indicate that the location was not covered
forM_ [0..size-1] $ \i -> VMut.write vec i (-1, 0, 0)
pure $ Just vec

case maybeCovVec of
Nothing -> pure ()
Just vec -> do
-- TODO: no-op when pc is out-of-bounds. This shouldn't happen but
-- we observed this in some real-world scenarios. This is likely a
-- bug in another place, investigate.
-- ... this should be fixed now, since we use `codeContract` instead
-- of `contract` for everything; it may be safe to remove this check.
when (pc < VMut.length vec) $
VMut.read vec pc >>= \case
(_, depths, results) | depth < 64 && not (depths `testBit` depth) -> do
VMut.write vec pc (opIx, depths `setBit` depth, results `setBit` fromEnum Stop)
writeIORef covContextRef (True, Just (vec, pc))
_ ->
modifyIORef' covContextRef $ \(new, _) -> (new, Just (vec, pc))

-- | Get the VM's current execution location
currentCovLoc vm = (vm.state.pc, fromMaybe 0 $ vmOpIx vm, length vm.frames)

-- | Get the current contract being executed
currentContract vm = fromMaybe (error "no contract information on coverage") $
vm ^? #env % #contracts % at vm.state.codeContract % _Just
-- | Repeatedly exec a step and add coverage until we have an end result
loop :: VM Concrete RealWorld -> IO (VMResult Concrete RealWorld, VM Concrete RealWorld)
loop !vm = case vm.result of
Nothing -> do
addCoverage vm
stepVM vm >>= loop
Just r -> pure (r, vm)

-- | Execute one instruction on the EVM
stepVM :: VM Concrete RealWorld -> IO (VM Concrete RealWorld)
stepVM = stToIO . execStateT exec1

-- | Add current location to the CoverageMap
addCoverage :: VM Concrete RealWorld -> IO ()
addCoverage !vm = do
let (pc, opIx, depth) = currentCovLoc vm
contract = currentContract vm

maybeCovVec <- lookupUsingCodehashOrInsert env.codehashMap contract env.dapp env.coverageRef $ createCoverageVec contract

case maybeCovVec of
Nothing -> pure ()
Just vec ->
-- TODO: no-op when pc is out-of-bounds. This shouldn't happen but
-- we observed this in some real-world scenarios. This is likely a
-- bug in another place, investigate.
-- ... this should be fixed now, since we use `codeContract` instead
-- of `contract` for everything; it may be safe to remove this check.
when (pc < VMut.length vec) $
VMut.read vec pc >>= \case
(_, depths, results) | depth < 64 && not (depths `testBit` depth) -> do
VMut.write vec pc (opIx, depths `setBit` depth, results `setBit` fromEnum Stop)
writeIORef covContextRef (True, Just (vec, pc))
_ ->
modifyIORef' covContextRef $ \(new, _) -> (new, Just (vec, pc))

createCoverageVec contract = do
let size = BS.length . forceBuf . fromJust . view bytecode $ contract
if size == 0 then pure Nothing else do
-- IO for making a new vec
vec <- VMut.new size
-- We use -1 for opIx to indicate that the location was not covered
forM_ [0..size-1] $ \i -> VMut.write vec i (-1, 0, 0)
pure $ Just vec

-- | Get the VM's current execution location
currentCovLoc vm = (vm.state.pc, fromMaybe 0 $ vmOpIx vm, length vm.frames)

-- | Get the current contract being executed
currentContract vm = fromMaybe (error "no contract information on coverage") $
vm ^? #env % #contracts % at vm.state.codeContract % _Just

initialVM :: Bool -> ST s (VM Concrete s)
initialVM ffi = do
Expand Down
Loading