Mutable memory

ethereum · Jul 18, 2023 · 1db1bfb · 1db1bfb
1 parent 9968f7a
commit 1db1bfb
Show file tree

Hide file tree

Showing 17 changed files with 628 additions and 499 deletions.
diff --git a/hevm-cli/hevm-cli.hs b/hevm-cli/hevm-cli.hs
@@ -52,6 +52,7 @@ import EVM.Transaction qualified
 import EVM.TTY qualified as TTY
 import EVM.Types hiding (word)
 import EVM.UnitTest
+import Control.Monad.ST (RealWorld, stToIO)
 
 -- This record defines the program's command-line options
 -- automatically via the `optparse-generic` package.
@@ -199,7 +200,7 @@ optsMode x
   | x.jsontrace = JsonTrace
   | otherwise = Run
 
-applyCache :: (Maybe String, Maybe String) -> IO (VM -> VM)
+applyCache :: (Maybe String, Maybe String) -> IO (VM RealWorld -> VM RealWorld)
 applyCache (state, cache) =
   let applyState = flip Facts.apply
       applyCache' = flip Facts.applyCache
@@ -217,7 +218,7 @@ applyCache (state, cache) =
       stateFacts <- Git.loadFacts (Git.RepoAt statePath)
       pure $ (applyState stateFacts) . (applyCache' cacheFacts)
 
-unitTestOptions :: Command Options.Unwrapped -> SolverGroup -> Maybe BuildOutput -> IO UnitTestOptions
+unitTestOptions :: Command Options.Unwrapped -> SolverGroup -> Maybe BuildOutput -> IO (UnitTestOptions RealWorld)
 unitTestOptions cmd solvers buildOutput = do
   root <- getRoot cmd
   let srcInfo = maybe emptyDapp (dappInfo root) buildOutput
@@ -453,7 +454,7 @@ getTimeout :: ProofResult a b c -> Maybe c
 getTimeout (Timeout c) = Just c
 getTimeout _ = Nothing
 
-dappCoverage :: UnitTestOptions -> Mode -> BuildOutput -> IO ()
+dappCoverage :: UnitTestOptions RealWorld -> Mode -> BuildOutput -> IO ()
 dappCoverage opts _ bo@(BuildOutput (Contracts cs) cache) = do
   let unitTests = findUnitTests opts.match $ Map.elems cs
   covs <- mconcat <$> mapM
@@ -533,7 +534,7 @@ launchExec cmd = do
            rpcinfo = (,) block <$> cmd.rpc
 
 -- | Creates a (concrete) VM from command line options
-vmFromCommand :: Command Options.Unwrapped -> IO VM
+vmFromCommand :: Command Options.Unwrapped -> IO (VM RealWorld)
 vmFromCommand cmd = do
   withCache <- applyCache (cmd.state, cmd.cache)
 
@@ -579,7 +580,8 @@ vmFromCommand cmd = do
         Just t -> t
         Nothing -> internalError "unexpected symbolic timestamp when executing vm test"
 
-  pure $ EVM.Transaction.initTx $ withCache (vm0 baseFee miner ts' blockNum prevRan contract)
+  vm <- stToIO $ vm0 baseFee miner ts' blockNum prevRan contract
+  pure $ EVM.Transaction.initTx $ withCache vm
     where
         block   = maybe EVM.Fetch.Latest EVM.Fetch.BlockNumber cmd.block
         value   = word (.value) 0
@@ -624,7 +626,7 @@ vmFromCommand cmd = do
         addr f def = fromMaybe def (f cmd)
         bytes f def = maybe def decipher (f cmd)
 
-symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (VM)
+symvmFromCommand :: Command Options.Unwrapped -> (Expr Buf, [Prop]) -> IO (VM RealWorld)
 symvmFromCommand cmd calldata = do
   (miner,blockNum,baseFee,prevRan) <- case cmd.rpc of
     Nothing -> pure (0,0,0,0)
@@ -667,7 +669,8 @@ symvmFromCommand cmd calldata = do
     (_, _, Nothing) ->
       error "Error: must provide at least (rpc + address) or code"
 
-  pure $ (EVM.Transaction.initTx $ withCache $ vm0 baseFee miner ts blockNum prevRan calldata callvalue caller contract)
+  vm <- stToIO $ vm0 baseFee miner ts blockNum prevRan calldata callvalue caller contract
+  pure $ (EVM.Transaction.initTx $ withCache vm)
     & set (#env % #storage) store
 
   where