From a14a0c65aa16ad727c946d0f63d39ac97e6d536c Mon Sep 17 00:00:00 2001
From: ggrieco <gustavo.grieco+github@gmail.com>
Date: Sat, 28 Jun 2025 14:07:09 +0200
Subject: [PATCH 01/11] started to add some code to produce futamura
 projections

---
 hevm.cabal          |  5 +++
 src/EVM.hs          | 30 +++++++++++++++++-
 src/EVM/Futamura.hs | 77 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 111 insertions(+), 1 deletion(-)
 create mode 100644 src/EVM/Futamura.hs

diff --git a/hevm.cabal b/hevm.cabal
index debd39c4d..896b2b47c 100644
--- a/hevm.cabal
+++ b/hevm.cabal
@@ -104,6 +104,7 @@ library
     EVM.Format,
     EVM.Fetch,
     EVM.FeeSchedule,
+    EVM.Futamura,
     EVM.Op,
     EVM.Precompiled,
     EVM.RLP,
@@ -141,6 +142,10 @@ library
   install-includes:
     ethjet/tinykeccak.h, ethjet/ethjet.h, ethjet/ethjet-ff.h, ethjet/blake2.h
   build-depends:
+    ghc                               >= 9.6 && < 10,
+    ghc-paths                         >= 0.1,
+    directory                         >= 1.3,
+    temporary                         >= 1.2.0 && < 1.4, 
     system-cxx-std-lib                >= 1.0 && < 2.0,
     QuickCheck                        >= 2.13.2 && < 2.15,
     Decimal                           >= 0.5.1 && < 0.6,
diff --git a/src/EVM.hs b/src/EVM.hs
index cae94113f..795d77a96 100644
--- a/src/EVM.hs
+++ b/src/EVM.hs
@@ -29,7 +29,7 @@ import EVM.Effects (Config (..))
 
 import Control.Monad (unless, when)
 import Control.Monad.ST (ST)
-import Control.Monad.State.Strict (MonadState, State, get, gets, lift, modify', put)
+import Control.Monad.State.Strict (MonadState, State, StateT, get, gets, lift, modify', put)
 import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize)
 import Data.ByteArray qualified as BA
 import Data.ByteString (ByteString)
@@ -63,6 +63,7 @@ import Data.Vector.Storable.ByteString (vectorToByteString)
 import Data.Word (Word8, Word32, Word64)
 import Text.Read (readMaybe)
 import Witch (into, tryFrom, unsafeInto, tryInto)
+import Witch.From (From)
 
 import Crypto.Hash (Digest, SHA256, RIPEMD160)
 import Crypto.Hash qualified as Crypto
@@ -289,6 +290,33 @@ getOpW8 state = case state.code of
 getOpName :: forall (t :: VMType) s . FrameState t s -> [Char]
 getOpName state = intToOpName $ fromEnum $ getOpW8 state
 
+{-# INLINE runOpcodeDup #-}
+runOpcodeDup :: (From source Int, VMOps t, ?op::Word8) =>
+                source -> StateT (VM t s) (ST s) ()
+runOpcodeDup i = do 
+    vm <- get
+    let
+      stk  = vm.state.stack
+      FeeSchedule {..} = vm.block.schedule
+    case preview (ix (into i - 1)) stk of
+              Nothing -> underrun
+              Just y ->
+                limitStack 1 $
+                  burn g_verylow $ do
+                    next
+                    pushSym y
+
+{-# INLINE runOpcodePush0 #-}
+runOpcodePush0 :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodePush0 = do
+  vm <- get
+  let FeeSchedule {..} = vm.block.schedule
+  limitStack 1 $
+    burn g_base $ do
+      next
+      pushSym (Lit 0)
+
 -- | Executes the EVM one step
 exec1 :: forall (t :: VMType) s. (VMOps t) => Config ->  EVM t s ()
 exec1 conf = do
diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
new file mode 100644
index 000000000..b1880a06f
--- /dev/null
+++ b/src/EVM/Futamura.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE ImplicitParams, FlexibleContexts, GADTs #-}
+
+module EVM.Futamura where
+
+import Control.Monad.State.Strict
+import Control.Monad.ST
+import System.Directory (getTemporaryDirectory)
+import System.IO.Temp (createTempDirectory)
+import System.FilePath
+import Data.Word (Word8)
+import GHC
+import GHC.Paths (libdir)
+import Unsafe.Coerce
+
+-- Adjust imports to your project
+import EVM.Op
+import EVM.Types
+
+--------------------------------------------------------------------------------
+-- | Generate Haskell Code From a List of Opcodes
+--------------------------------------------------------------------------------
+
+generateHaskellCode :: [GenericOp Word8] -> String
+generateHaskellCode ops =
+  unlines $
+    [ "{-# LANGUAGE ImplicitParams, FlexibleContexts #-}"
+    , "module Generated where"
+    , "import Control.Monad.State.Strict"
+    , "import Control.Monad.ST"
+    , "import EVM"
+    , "import EVM.Types"
+    , "import EVM.Op"
+    , "runSpecialized :: (VMOps t, ?op :: Word8) => StateT (VM t s) (ST s) ()"
+    , "runSpecialized = do"
+    ] ++ map genOp ops
+
+genOp :: GenericOp Word8 -> String
+genOp (OpPush n)  = "  runOpcodePush " ++ show n
+genOp (OpAdd)     = "  runOpcodeAdd"
+genOp (OpDup i)   = "  runOpcodeDup " ++ show i
+-- Add more opcodes as needed
+genOp other       = error $ "Opcode not supported in specialization: " ++ show other
+
+--------------------------------------------------------------------------------
+-- | Compile and Run a Specialized EVM Program at Runtime
+--------------------------------------------------------------------------------
+
+compileAndRunSpecialized :: [GenericOp Word8] -> VM t s -> IO (VM t s)
+compileAndRunSpecialized ops vmState = do
+  tmpDir <- getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "evmjit"
+  let hsPath = tmpDir </> "Generated.hs"
+  writeFile hsPath (generateHaskellCode ops)
+  dynCompileAndRun hsPath vmState
+
+--------------------------------------------------------------------------------
+-- | Use GHC API to Compile and Run the Generated Code
+--------------------------------------------------------------------------------
+
+dynCompileAndRun :: forall t s. FilePath -> VM t s -> IO (VM t s)
+dynCompileAndRun filePath vmState = runGhc (Just libdir) $ do
+  dflags <- getSessionDynFlags
+  _ <- setSessionDynFlags dflags
+
+  target <- guessTarget filePath Nothing Nothing
+  setTargets [target]
+  _ <- load LoadAllTargets
+
+  setContext [IIDecl $ simpleImportDecl (mkModuleName "Generated")]
+
+  value <- compileExpr "Generated.runSpecialized"
+
+  -- Move annotation outside of `let` to avoid scoped type var issue
+  let specialized :: forall s1. StateT (VM t s) (ST s1) ()
+      specialized = unsafeCoerce value
+
+  -- Wrap runST inside IO to unify the lifetimes of `s1` and `s`
+  return $ runST (execStateT specialized vmState)
\ No newline at end of file

From b84b9f179251ccf6cf07da23b7793fb42f5cc8bb Mon Sep 17 00:00:00 2001
From: ggrieco <gustavo.grieco+github@gmail.com>
Date: Sun, 29 Jun 2025 15:32:16 +0200
Subject: [PATCH 02/11] removed some compilation errors, but still some others
 there

---
 cli/cli.hs          |  2 ++
 hevm.cabal          |  1 +
 src/EVM/Futamura.hs | 41 ++++++++++++++++++++++++++++++-----------
 3 files changed, 33 insertions(+), 11 deletions(-)

diff --git a/cli/cli.hs b/cli/cli.hs
index d3a86413e..b59b807ef 100644
--- a/cli/cli.hs
+++ b/cli/cli.hs
@@ -53,6 +53,7 @@ import EVM.Types qualified
 import EVM.UnitTest
 import EVM.Effects
 import EVM.Expr (maybeLitWordSimp, maybeLitAddrSimp)
+import EVM.Futamura (compileAndRunSpecialized)
 
 data AssertionType = DSTest | Forge
   deriving (Eq, Show, Read)
@@ -300,6 +301,7 @@ getFullVersion = showVersion Paths.version <> " [" <> gitVersion <> "]"
 
 main :: IO ()
 main = do
+  _ <- compileAndRunSpecialized [OpPush0] undefined
   cmd <- execParser $ info (commandParser <**> helper)
     ( Options.fullDesc
     <> progDesc "hevm, a symbolic and concrete EVM bytecode execution framework"
diff --git a/hevm.cabal b/hevm.cabal
index 896b2b47c..1ac4f4fe5 100644
--- a/hevm.cabal
+++ b/hevm.cabal
@@ -144,6 +144,7 @@ library
   build-depends:
     ghc                               >= 9.6 && < 10,
     ghc-paths                         >= 0.1,
+    ghc-boot-th                       >= 9.6 && < 10,
     directory                         >= 1.3,
     temporary                         >= 1.2.0 && < 1.4, 
     system-cxx-std-lib                >= 1.0 && < 2.0,
diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index b1880a06f..13ea9349d 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -2,15 +2,20 @@
 
 module EVM.Futamura where
 
+import Prelude
 import Control.Monad.State.Strict
 import Control.Monad.ST
 import System.Directory (getTemporaryDirectory)
 import System.IO.Temp (createTempDirectory)
 import System.FilePath
 import Data.Word (Word8)
+import Unsafe.Coerce
+
 import GHC
 import GHC.Paths (libdir)
-import Unsafe.Coerce
+import GHC.LanguageExtensions.Type (Extension(..))
+import GHC.Driver.Flags (Language(..))
+import GHC.Data.EnumSet (fromList)
 
 -- Adjust imports to your project
 import EVM.Op
@@ -23,19 +28,19 @@ import EVM.Types
 generateHaskellCode :: [GenericOp Word8] -> String
 generateHaskellCode ops =
   unlines $
-    [ "{-# LANGUAGE ImplicitParams, FlexibleContexts #-}"
-    , "module Generated where"
+    [ "module Generated where"
+    , "import Prelude"
     , "import Control.Monad.State.Strict"
     , "import Control.Monad.ST"
-    , "import EVM"
-    , "import EVM.Types"
-    , "import EVM.Op"
+    , "import EVM (runOpcodePush0)"
+    , ""
     , "runSpecialized :: (VMOps t, ?op :: Word8) => StateT (VM t s) (ST s) ()"
     , "runSpecialized = do"
     ] ++ map genOp ops
 
 genOp :: GenericOp Word8 -> String
 genOp (OpPush n)  = "  runOpcodePush " ++ show n
+genOp (OpPush0)   = "  runOpcodePush0"
 genOp (OpAdd)     = "  runOpcodeAdd"
 genOp (OpDup i)   = "  runOpcodeDup " ++ show i
 -- Add more opcodes as needed
@@ -49,6 +54,7 @@ compileAndRunSpecialized :: [GenericOp Word8] -> VM t s -> IO (VM t s)
 compileAndRunSpecialized ops vmState = do
   tmpDir <- getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "evmjit"
   let hsPath = tmpDir </> "Generated.hs"
+  putStrLn $ "Generating Haskell code for EVM specialization in: " ++ hsPath
   writeFile hsPath (generateHaskellCode ops)
   dynCompileAndRun hsPath vmState
 
@@ -56,10 +62,25 @@ compileAndRunSpecialized ops vmState = do
 -- | Use GHC API to Compile and Run the Generated Code
 --------------------------------------------------------------------------------
 
+neededExtensionFlags :: [Extension]
+neededExtensionFlags =
+    [ DuplicateRecordFields
+    , LambdaCase
+    , OverloadedRecordDot
+    , OverloadedStrings
+    , OverloadedLabels
+    , RecordWildCards
+    , TypeFamilies
+    , ViewPatterns
+    , DataKinds
+    , ImportQualifiedPost
+    , TraditionalRecordSyntax
+    ]
+
 dynCompileAndRun :: forall t s. FilePath -> VM t s -> IO (VM t s)
 dynCompileAndRun filePath vmState = runGhc (Just libdir) $ do
-  dflags <- getSessionDynFlags
-  _ <- setSessionDynFlags dflags
+  dflags <- getSessionDynFlags  
+  _ <- setSessionDynFlags dflags { importPaths = importPaths dflags ++ ["src", filePath], extensionFlags = fromList neededExtensionFlags, language = Just GHC2021 }
 
   target <- guessTarget filePath Nothing Nothing
   setTargets [target]
@@ -69,9 +90,7 @@ dynCompileAndRun filePath vmState = runGhc (Just libdir) $ do
 
   value <- compileExpr "Generated.runSpecialized"
 
-  -- Move annotation outside of `let` to avoid scoped type var issue
   let specialized :: forall s1. StateT (VM t s) (ST s1) ()
       specialized = unsafeCoerce value
 
-  -- Wrap runST inside IO to unify the lifetimes of `s1` and `s`
-  return $ runST (execStateT specialized vmState)
\ No newline at end of file
+  return $ runST (execStateT specialized vmState)

From 30b4e18718c1afae7ba4b443e4090a58f8ae4b3c Mon Sep 17 00:00:00 2001
From: ggrieco <gustavo.grieco+github@gmail.com>
Date: Mon, 30 Jun 2025 19:48:51 +0200
Subject: [PATCH 03/11] compilation works

---
 src/EVM/Futamura.hs | 146 +++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 136 insertions(+), 10 deletions(-)

diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 13ea9349d..8ed70c77e 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -2,25 +2,132 @@
 
 module EVM.Futamura where
 
-import Prelude
 import Control.Monad.State.Strict
 import Control.Monad.ST
-import System.Directory (getTemporaryDirectory)
+import System.Directory (getTemporaryDirectory, doesFileExist)
 import System.IO.Temp (createTempDirectory)
 import System.FilePath
+import System.Process (readProcess)
+import Control.Exception (catch, IOException)
 import Data.Word (Word8)
+import Data.List (isPrefixOf, dropWhileEnd)
+import Data.Maybe (catMaybes, listToMaybe)
+import Data.Char (isSpace)
 import Unsafe.Coerce
 
 import GHC
 import GHC.Paths (libdir)
 import GHC.LanguageExtensions.Type (Extension(..))
 import GHC.Driver.Flags (Language(..))
-import GHC.Data.EnumSet (fromList)
+import GHC.Driver.Session (PackageFlag(..), PackageArg(..), ModRenaming(..), PackageDBFlag(..), PkgDbRef(..), xopt_set)
 
 -- Adjust imports to your project
 import EVM.Op
 import EVM.Types
 
+projectPackages :: [String]
+projectPackages =
+  [ "ghc"
+  , "ghc-paths"
+  , "ghc-boot-th"
+  , "directory"
+  , "temporary"
+  , "system-cxx-std-lib"
+  , "QuickCheck"
+  , "Decimal"
+  , "containers"
+  , "transformers"
+  , "tree-view"
+  , "aeson"
+  , "bytestring"
+  , "scientific"
+  , "binary"
+  , "text"
+  , "unordered-containers"
+  , "vector"
+  , "base16"
+  , "megaparsec"
+  , "mtl"
+  , "filepath"
+  , "cereal"
+  , "cryptonite"
+  , "memory"
+  , "data-dword"
+  , "process"
+  , "optics-core"
+  , "optics-extra"
+  , "optics-th"
+  , "aeson-optics"
+  , "async"
+  , "operational"
+  , "optparse-generic"
+  , "pretty-hex"
+  , "rosezipper"
+  , "wreq"
+  , "regex-tdfa"
+  , "base"
+  , "here"
+  , "smt2-parser"
+  , "spool"
+  , "stm"
+  , "spawn"
+  , "filepattern"
+  , "witch"
+  , "unliftio-core"
+  , "split"
+  , "template-haskell"
+  , "extra"
+  ]
+
+-- Code from Halive
+
+-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
+--   Exception is thrown if the sandbox config file is broken.
+extractKey :: String -> String -> Maybe FilePath
+extractKey key conf = extractValue <$> parse conf
+  where
+    keyLen = length key
+
+    parse = listToMaybe . filter (key `isPrefixOf`) . lines
+    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
+-- From ghc-mod
+mightExist :: FilePath -> IO (Maybe FilePath)
+mightExist f = do
+    exists <- doesFileExist f
+    return $ if exists then (Just f) else (Nothing)
+
+------------------------
+---------- Stack project
+------------------------
+
+-- | Get path to the project's snapshot and local package DBs via 'stack path'
+getStackDb :: IO (Maybe [FilePath])
+getStackDb = do
+    pathInfo <- readProcess "stack" ["path"] "" `catch` (\(_e::IOException) -> return [])
+    return . Just . catMaybes $ map (flip extractKey pathInfo)
+        ["global-pkg-db:", "local-pkg-db:", "snapshot-pkg-db:"]
+
+updateDynFlagsWithStackDB :: MonadIO m => DynFlags -> m DynFlags
+updateDynFlagsWithStackDB dflags =
+    liftIO getStackDb >>= \case
+        Nothing -> error "Failed to get stack package DBs. Ensure you are in a Stack project."
+        Just stackDBs -> do
+            liftIO $ putStrLn $ "Using Stack package DBs: " ++ show stackDBs
+            let pkgs = map (PackageDB . PkgDbPath) stackDBs
+            return dflags { packageDBFlags = pkgs ++ packageDBFlags dflags }
+
+addPackageFlags :: [String] -> DynFlags -> DynFlags
+addPackageFlags pkgs df =
+    df{packageFlags = packageFlags df ++ expose `map` pkgs}
+  where
+    expose pkg = ExposePackage pkg (PackageArg pkg) (ModRenaming True [])
+
+addPackageHides :: [String] -> DynFlags -> DynFlags
+addPackageHides pkgs df =
+    df{packageFlags = packageFlags df ++ hide `map` pkgs}
+    where
+        hide pkg = HidePackage pkg
+
 --------------------------------------------------------------------------------
 -- | Generate Haskell Code From a List of Opcodes
 --------------------------------------------------------------------------------
@@ -29,18 +136,20 @@ generateHaskellCode :: [GenericOp Word8] -> String
 generateHaskellCode ops =
   unlines $
     [ "module Generated where"
-    , "import Prelude"
     , "import Control.Monad.State.Strict"
     , "import Control.Monad.ST"
     , "import EVM (runOpcodePush0)"
+    , "import Data.Word (Word8)"
+    , "import EVM.Types"
+    , "import EVM.Op"
     , ""
-    , "runSpecialized :: (VMOps t, ?op :: Word8) => StateT (VM t s) (ST s) ()"
+    , "runSpecialized :: StateT (VM Concrete s) (ST s) ()"
     , "runSpecialized = do"
     ] ++ map genOp ops
 
 genOp :: GenericOp Word8 -> String
-genOp (OpPush n)  = "  runOpcodePush " ++ show n
-genOp (OpPush0)   = "  runOpcodePush0"
+genOp (OpPush n)  = " let ?op = 1 in runOpcodePush " ++ show n
+genOp (OpPush0)   = " let ?op = 1 in runOpcodePush0"
 genOp (OpAdd)     = "  runOpcodeAdd"
 genOp (OpDup i)   = "  runOpcodeDup " ++ show i
 -- Add more opcodes as needed
@@ -75,16 +184,33 @@ neededExtensionFlags =
     , DataKinds
     , ImportQualifiedPost
     , TraditionalRecordSyntax
+    , ImplicitParams
+    , FlexibleInstances
+    , ConstraintKinds
+    , DisambiguateRecordFields
     ]
 
 dynCompileAndRun :: forall t s. FilePath -> VM t s -> IO (VM t s)
 dynCompileAndRun filePath vmState = runGhc (Just libdir) $ do
-  dflags <- getSessionDynFlags  
-  _ <- setSessionDynFlags dflags { importPaths = importPaths dflags ++ ["src", filePath], extensionFlags = fromList neededExtensionFlags, language = Just GHC2021 }
+  dflags0 <- getSessionDynFlags
+  dflags1 <- updateDynFlagsWithStackDB dflags0
+  let dflags2 = foldl xopt_set dflags1 neededExtensionFlags
+  let dflags3 = addPackageFlags projectPackages dflags2
+  let dflags4 = addPackageHides ["base16-bytestring", "crypton"] dflags3
+  _ <- setSessionDynFlags dflags4 { 
+    importPaths = importPaths dflags1, -- ++ ["/Users/g/Code/echidna/hevm"], 
+    language = Just GHC2021,
+    ghcLink   = LinkBinary,      -- Link everything in memory
+    verbosity = 1,
+    debugLevel = 1
+  }
 
   target <- guessTarget filePath Nothing Nothing
   setTargets [target]
-  _ <- load LoadAllTargets
+  result <- load LoadAllTargets
+  case result of
+    Failed -> liftIO $ error "Failed to load targets"
+    Succeeded -> return ()
 
   setContext [IIDecl $ simpleImportDecl (mkModuleName "Generated")]
 

From efa4aee971b5999be52972b05c4d0665f38e18b3 Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Tue, 1 Jul 2025 17:17:35 +0200
Subject: [PATCH 04/11] first opcodes correctly compiled and executed

---
 cli/cli.hs          |   8 ++-
 hevm.cabal          |   7 ++-
 src/EVM.hs          |  30 +---------
 src/EVM/Futamura.hs | 141 +++++++++++++++-----------------------------
 src/EVM/Opcodes.hs  | 107 +++++++++++++++++++++++++++++++++
 5 files changed, 164 insertions(+), 129 deletions(-)
 create mode 100644 src/EVM/Opcodes.hs

diff --git a/cli/cli.hs b/cli/cli.hs
index b59b807ef..a365a36a6 100644
--- a/cli/cli.hs
+++ b/cli/cli.hs
@@ -138,6 +138,7 @@ data CommonExecOptions = CommonExecOptions
   , gaslimit      ::Maybe Word64
   , gasprice      ::Maybe W256
   , maxcodesize   ::Maybe W256
+  , useFutamura   ::Bool
   , prevRandao    ::Maybe W256
   , chainid       ::Maybe W256
   , rpc           ::Maybe URL
@@ -160,6 +161,7 @@ commonExecOptions = CommonExecOptions
   <*> (optional $ option auto $ long "gaslimit"      <> help "Tx: gas limit")
   <*> (optional $ option auto $ long "gasprice"      <> help "Tx: gas price")
   <*> (optional $ option auto $ long "maxcodesize"   <> help "Block: max code size")
+  <*> (switch $ long "use-futamura"  <> help "Use Futamura specialization for execution")
   <*> (optional $ option auto $ long "prev-randao"   <> help "Block: prevRandao")
   <*> (optional $ option auto $ long "chainid"       <> help "Env: chainId")
   <*> rpcParser
@@ -301,7 +303,6 @@ getFullVersion = showVersion Paths.version <> " [" <> gitVersion <> "]"
 
 main :: IO ()
 main = do
-  _ <- compileAndRunSpecialized [OpPush0] undefined
   cmd <- execParser $ info (commandParser <**> helper)
     ( Options.fullDesc
     <> progDesc "hevm, a symbolic and concrete EVM bytecode execution framework"
@@ -566,7 +567,10 @@ launchExec cFileOpts execOpts cExecOpts cOpts = do
 
   -- TODO: we shouldn't need solvers to execute this code
   withSolvers Z3 0 1 Nothing $ \solvers -> do
-    vm' <- EVM.Stepper.interpret (Fetch.oracle solvers rpcinfo) vm EVM.Stepper.runFully
+    vm' <- case cExecOpts.useFutamura of
+      True  -> liftIO $ compileAndRunSpecialized vm
+      False -> EVM.Stepper.interpret (Fetch.oracle solvers rpcinfo) vm EVM.Stepper.runFully
+
     writeTraceDapp dapp vm'
     case vm'.result of
       Just (VMFailure (Revert msg)) -> liftIO $ do
diff --git a/hevm.cabal b/hevm.cabal
index 1ac4f4fe5..e27a8ad99 100644
--- a/hevm.cabal
+++ b/hevm.cabal
@@ -2,7 +2,7 @@ cabal-version: 3.0
 name:
   hevm
 version:
-  0.54.2
+  0.54.3
 synopsis:
   Symbolic EVM Evaluator
 description:
@@ -104,6 +104,7 @@ library
     EVM.Format,
     EVM.Fetch,
     EVM.FeeSchedule,
+    EVM.Opcodes,
     EVM.Futamura,
     EVM.Op,
     EVM.Precompiled,
@@ -146,7 +147,7 @@ library
     ghc-paths                         >= 0.1,
     ghc-boot-th                       >= 9.6 && < 10,
     directory                         >= 1.3,
-    temporary                         >= 1.2.0 && < 1.4, 
+    temporary                         >= 1.2.0 && < 1.4,
     system-cxx-std-lib                >= 1.0 && < 2.0,
     QuickCheck                        >= 2.13.2 && < 2.15,
     Decimal                           >= 0.5.1 && < 0.6,
@@ -202,7 +203,7 @@ executable hevm
     cli
   main-is:
     cli.hs
-  ghc-options: -threaded -with-rtsopts=-N
+  ghc-options: -threaded -with-rtsopts=-N -optl-rdynamic
   other-modules:
     Paths_hevm
   autogen-modules:
diff --git a/src/EVM.hs b/src/EVM.hs
index 795d77a96..cae94113f 100644
--- a/src/EVM.hs
+++ b/src/EVM.hs
@@ -29,7 +29,7 @@ import EVM.Effects (Config (..))
 
 import Control.Monad (unless, when)
 import Control.Monad.ST (ST)
-import Control.Monad.State.Strict (MonadState, State, StateT, get, gets, lift, modify', put)
+import Control.Monad.State.Strict (MonadState, State, get, gets, lift, modify', put)
 import Data.Bits (FiniteBits, countLeadingZeros, finiteBitSize)
 import Data.ByteArray qualified as BA
 import Data.ByteString (ByteString)
@@ -63,7 +63,6 @@ import Data.Vector.Storable.ByteString (vectorToByteString)
 import Data.Word (Word8, Word32, Word64)
 import Text.Read (readMaybe)
 import Witch (into, tryFrom, unsafeInto, tryInto)
-import Witch.From (From)
 
 import Crypto.Hash (Digest, SHA256, RIPEMD160)
 import Crypto.Hash qualified as Crypto
@@ -290,33 +289,6 @@ getOpW8 state = case state.code of
 getOpName :: forall (t :: VMType) s . FrameState t s -> [Char]
 getOpName state = intToOpName $ fromEnum $ getOpW8 state
 
-{-# INLINE runOpcodeDup #-}
-runOpcodeDup :: (From source Int, VMOps t, ?op::Word8) =>
-                source -> StateT (VM t s) (ST s) ()
-runOpcodeDup i = do 
-    vm <- get
-    let
-      stk  = vm.state.stack
-      FeeSchedule {..} = vm.block.schedule
-    case preview (ix (into i - 1)) stk of
-              Nothing -> underrun
-              Just y ->
-                limitStack 1 $
-                  burn g_verylow $ do
-                    next
-                    pushSym y
-
-{-# INLINE runOpcodePush0 #-}
-runOpcodePush0 :: (VMOps t, ?op::Word8) =>
-                StateT (VM t s) (ST s) ()
-runOpcodePush0 = do
-  vm <- get
-  let FeeSchedule {..} = vm.block.schedule
-  limitStack 1 $
-    burn g_base $ do
-      next
-      pushSym (Lit 0)
-
 -- | Executes the EVM one step
 exec1 :: forall (t :: VMType) s. (VMOps t) => Config ->  EVM t s ()
 exec1 conf = do
diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 8ed70c77e..593a1bee1 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -1,10 +1,8 @@
-{-# LANGUAGE ImplicitParams, FlexibleContexts, GADTs #-}
-
 module EVM.Futamura where
 
 import Control.Monad.State.Strict
 import Control.Monad.ST
-import System.Directory (getTemporaryDirectory, doesFileExist)
+import System.Directory (getTemporaryDirectory)
 import System.IO.Temp (createTempDirectory)
 import System.FilePath
 import System.Process (readProcess)
@@ -15,69 +13,17 @@ import Data.Maybe (catMaybes, listToMaybe)
 import Data.Char (isSpace)
 import Unsafe.Coerce
 
-import GHC
+import GHC (SuccessFlag(..), compileExpr, mkModuleName, simpleImportDecl, InteractiveImport(..), setContext, LoadHowMuch(..), load, setTargets, guessTarget, setSessionDynFlags, getSessionDynFlags, runGhc)
 import GHC.Paths (libdir)
 import GHC.LanguageExtensions.Type (Extension(..))
-import GHC.Driver.Flags (Language(..))
-import GHC.Driver.Session (PackageFlag(..), PackageArg(..), ModRenaming(..), PackageDBFlag(..), PkgDbRef(..), xopt_set)
-
--- Adjust imports to your project
-import EVM.Op
-import EVM.Types
-
-projectPackages :: [String]
-projectPackages =
-  [ "ghc"
-  , "ghc-paths"
-  , "ghc-boot-th"
-  , "directory"
-  , "temporary"
-  , "system-cxx-std-lib"
-  , "QuickCheck"
-  , "Decimal"
-  , "containers"
-  , "transformers"
-  , "tree-view"
-  , "aeson"
-  , "bytestring"
-  , "scientific"
-  , "binary"
-  , "text"
-  , "unordered-containers"
-  , "vector"
-  , "base16"
-  , "megaparsec"
-  , "mtl"
-  , "filepath"
-  , "cereal"
-  , "cryptonite"
-  , "memory"
-  , "data-dword"
-  , "process"
-  , "optics-core"
-  , "optics-extra"
-  , "optics-th"
-  , "aeson-optics"
-  , "async"
-  , "operational"
-  , "optparse-generic"
-  , "pretty-hex"
-  , "rosezipper"
-  , "wreq"
-  , "regex-tdfa"
-  , "base"
-  , "here"
-  , "smt2-parser"
-  , "spool"
-  , "stm"
-  , "spawn"
-  , "filepattern"
-  , "witch"
-  , "unliftio-core"
-  , "split"
-  , "template-haskell"
-  , "extra"
-  ]
+import GHC.Driver.Session --(PackageFlag(..), PackageArg(..), ModRenaming(..), PackageDBFlag(..), PkgDbRef(..), xopt_set)
+
+import EVM.Opcodes
+import EVM (currentContract)
+import EVM.Op (getOp)
+import EVM.Types (VM, GenericOp(..), ContractCode(..), RuntimeCode(..), contract, code)
+
+import qualified Data.ByteString as BS
 
 -- Code from Halive
 
@@ -90,11 +36,6 @@ extractKey key conf = extractValue <$> parse conf
 
     parse = listToMaybe . filter (key `isPrefixOf`) . lines
     extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
--- From ghc-mod
-mightExist :: FilePath -> IO (Maybe FilePath)
-mightExist f = do
-    exists <- doesFileExist f
-    return $ if exists then (Just f) else (Nothing)
 
 ------------------------
 ---------- Stack project
@@ -116,18 +57,6 @@ updateDynFlagsWithStackDB dflags =
             let pkgs = map (PackageDB . PkgDbPath) stackDBs
             return dflags { packageDBFlags = pkgs ++ packageDBFlags dflags }
 
-addPackageFlags :: [String] -> DynFlags -> DynFlags
-addPackageFlags pkgs df =
-    df{packageFlags = packageFlags df ++ expose `map` pkgs}
-  where
-    expose pkg = ExposePackage pkg (PackageArg pkg) (ModRenaming True [])
-
-addPackageHides :: [String] -> DynFlags -> DynFlags
-addPackageHides pkgs df =
-    df{packageFlags = packageFlags df ++ hide `map` pkgs}
-    where
-        hide pkg = HidePackage pkg
-
 --------------------------------------------------------------------------------
 -- | Generate Haskell Code From a List of Opcodes
 --------------------------------------------------------------------------------
@@ -135,22 +64,42 @@ addPackageHides pkgs df =
 generateHaskellCode :: [GenericOp Word8] -> String
 generateHaskellCode ops =
   unlines $
-    [ "module Generated where"
+    [ "{-# LANGUAGE ImplicitParams #-}"
+    , "module Generated where"
     , "import Control.Monad.State.Strict"
     , "import Control.Monad.ST"
-    , "import EVM (runOpcodePush0)"
     , "import Data.Word (Word8)"
+    , "import EVM"
     , "import EVM.Types"
     , "import EVM.Op"
+    , "import EVM.Expr qualified as Expr"
+    , "import EVM.FeeSchedule (FeeSchedule (..))"
+    , ""
+    , "runOpcodeAdd :: " ++ runOpcodeAddType
+    , "runOpcodeAdd = " ++ runOpcodeAddSrc
+    , "runOpcodePush0 ::" ++ runOpcodePush0Type
+    , "runOpcodePush0 = " ++ runOpcodePush0Src
+    , "runOpcodeStop :: " ++ runOpcodeStopType
+    , "runOpcodeStop = " ++ runOpcodeStopSrc
+    , "runOpcodeRevert :: " ++ runOpcodeRevertType
+    , "runOpcodeRevert = " ++ runOpcodeRevertSrc
     , ""
     , "runSpecialized :: StateT (VM Concrete s) (ST s) ()"
     , "runSpecialized = do"
-    ] ++ map genOp ops
+    ] ++ map (checkIfVmResulted . genOp) ops -- ++ [" doStop"]
+
+checkIfVmResulted :: String -> String
+checkIfVmResulted op =
+  " get >>= \\vm ->\n" ++
+  "   case vm.result of\n" ++
+  "     Nothing ->" ++ op ++ "\n" ++
+  "     Just r -> return ()"
 
 genOp :: GenericOp Word8 -> String
-genOp (OpPush n)  = " let ?op = 1 in runOpcodePush " ++ show n
 genOp (OpPush0)   = " let ?op = 1 in runOpcodePush0"
-genOp (OpAdd)     = "  runOpcodeAdd"
+genOp (OpRevert)  = " let ?op = 1 in runOpcodeRevert"
+genOp (OpStop)    = " let ?op = 1 in runOpcodeStop"
+genOp (OpAdd)     = " let ?op = 1 in runOpcodeAdd"
 genOp (OpDup i)   = "  runOpcodeDup " ++ show i
 -- Add more opcodes as needed
 genOp other       = error $ "Opcode not supported in specialization: " ++ show other
@@ -159,13 +108,19 @@ genOp other       = error $ "Opcode not supported in specialization: " ++ show o
 -- | Compile and Run a Specialized EVM Program at Runtime
 --------------------------------------------------------------------------------
 
-compileAndRunSpecialized :: [GenericOp Word8] -> VM t s -> IO (VM t s)
-compileAndRunSpecialized ops vmState = do
+compileAndRunSpecialized :: VM t s -> IO (VM t s)
+compileAndRunSpecialized vm = do
   tmpDir <- getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "evmjit"
+  let contract = currentContract vm
+  let ops = case contract of
+              Nothing -> error "No current contract found in VM"
+              Just c -> map getOp $ BS.unpack $ extractCode $ c.code
   let hsPath = tmpDir </> "Generated.hs"
   putStrLn $ "Generating Haskell code for EVM specialization in: " ++ hsPath
   writeFile hsPath (generateHaskellCode ops)
-  dynCompileAndRun hsPath vmState
+  dynCompileAndRun hsPath vm
+   where extractCode (RuntimeCode (ConcreteRuntimeCode ops)) = ops
+         extractCode _ = error "Expected ConcreteRuntimeCode"
 
 --------------------------------------------------------------------------------
 -- | Use GHC API to Compile and Run the Generated Code
@@ -194,13 +149,9 @@ dynCompileAndRun :: forall t s. FilePath -> VM t s -> IO (VM t s)
 dynCompileAndRun filePath vmState = runGhc (Just libdir) $ do
   dflags0 <- getSessionDynFlags
   dflags1 <- updateDynFlagsWithStackDB dflags0
-  let dflags2 = foldl xopt_set dflags1 neededExtensionFlags
-  let dflags3 = addPackageFlags projectPackages dflags2
-  let dflags4 = addPackageHides ["base16-bytestring", "crypton"] dflags3
-  _ <- setSessionDynFlags dflags4 { 
-    importPaths = importPaths dflags1, -- ++ ["/Users/g/Code/echidna/hevm"], 
+  let dflags = foldl xopt_set dflags1 neededExtensionFlags
+  _ <- setSessionDynFlags dflags {
     language = Just GHC2021,
-    ghcLink   = LinkBinary,      -- Link everything in memory
     verbosity = 1,
     debugLevel = 1
   }
diff --git a/src/EVM/Opcodes.hs b/src/EVM/Opcodes.hs
new file mode 100644
index 000000000..07dcdb345
--- /dev/null
+++ b/src/EVM/Opcodes.hs
@@ -0,0 +1,107 @@
+{-# LANGUAGE TemplateHaskell, ImplicitParams #-}
+
+module EVM.Opcodes where
+
+import Optics.Core
+
+import Control.Monad.ST (ST)
+import Control.Monad.State.Strict (StateT, get)
+import Witch.From (From)
+import Witch (into)
+import Data.Word (Word8)
+
+import EVM
+import EVM.Types
+import EVM.FeeSchedule (FeeSchedule (..))
+import EVM.Expr qualified as Expr
+
+runOpcodeAdd :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
+runOpcodeAdd = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp2 g_verylow Expr.add
+
+runOpcodeAddSrc :: String
+runOpcodeAddSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp2 g_verylow Expr.add"
+
+runOpcodeAddType :: String
+runOpcodeAddType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+{-# INLINE runOpcodeDup #-}
+runOpcodeDup :: (From source Int, VMOps t, ?op::Word8) =>
+                source -> StateT (VM t s) (ST s) ()
+runOpcodeDup i = do
+    vm <- get
+    let
+      stk  = vm.state.stack
+      FeeSchedule {..} = vm.block.schedule
+    case preview (ix (into i - 1)) stk of
+              Nothing -> underrun
+              Just y ->
+                limitStack 1 $
+                  burn g_verylow $ do
+                    next
+                    pushSym y
+
+
+runOpcodePush0 :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodePush0 = do
+  vm <- get
+  let FeeSchedule {..} = vm.block.schedule
+  limitStack 1 $
+    burn g_base $ do
+      next
+      pushSym (Lit 0)
+
+runOpcodePush0Type :: String
+runOpcodePush0Type = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodePush0Src :: String
+runOpcodePush0Src = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  limitStack 1 $\n\
+\    burn g_base $ do\n\
+\      next\n\
+\      pushSym (Lit 0)"
+
+{-# INLINE runOpcodeRevert #-}
+runOpcodeRevert :: (VMOps t) =>
+                StateT (VM t s) (ST s) ()
+runOpcodeRevert = do
+  vm <- get
+  let stk = vm.state.stack
+  case stk of
+    xOffset:xSize:_ ->
+      accessMemoryRange xOffset xSize $ do
+        output <- readMemory xOffset xSize
+        finishFrame (FrameReverted output)
+    _ -> underrun
+
+runOpcodeRevertSrc :: String
+runOpcodeRevertSrc = "do\n\
+\  vm <- get\n\
+\  let stk = vm.state.stack\n\
+\  case stk of\n\
+\    xOffset:xSize:_ ->\n\
+\      accessMemoryRange xOffset xSize $ do\n\
+\        output <- readMemory xOffset xSize\n\
+\        finishFrame (FrameReverted output)\n\
+\    _ -> underrun"
+
+runOpcodeRevertType :: String
+runOpcodeRevertType = "(VMOps t) => StateT (VM t s) (ST s) ()"
+
+runOpStop :: (VMOps t) => EVM t s ()
+runOpStop = finishFrame (FrameReturned mempty)
+
+runOpcodeStopSrc :: String
+runOpcodeStopSrc = "finishFrame (FrameReturned mempty)"
+
+runOpcodeStopType :: String
+runOpcodeStopType = "VMOps t => EVM t s ()"

From 288423f94f9fae19fc689a39c248a2c0568f8a0e Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Wed, 2 Jul 2025 10:39:27 +0200
Subject: [PATCH 05/11] more opcodes and better interfaces

---
 cli/cli.hs          |  3 +-
 src/EVM/Futamura.hs | 56 +++++++++++++++++------------
 src/EVM/Opcodes.hs  | 87 ++++++++++++++++++++++++++++++++++++++-------
 src/EVM/Stepper.hs  |  5 +++
 4 files changed, 115 insertions(+), 36 deletions(-)

diff --git a/cli/cli.hs b/cli/cli.hs
index a365a36a6..d10ce8d6e 100644
--- a/cli/cli.hs
+++ b/cli/cli.hs
@@ -568,7 +568,8 @@ launchExec cFileOpts execOpts cExecOpts cOpts = do
   -- TODO: we shouldn't need solvers to execute this code
   withSolvers Z3 0 1 Nothing $ \solvers -> do
     vm' <- case cExecOpts.useFutamura of
-      True  -> liftIO $ compileAndRunSpecialized vm
+      True  ->  do f <- liftIO (compileAndRunSpecialized vm)
+                   return $ f vm
       False -> EVM.Stepper.interpret (Fetch.oracle solvers rpcinfo) vm EVM.Stepper.runFully
 
     writeTraceDapp dapp vm'
diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 593a1bee1..5377092ed 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -18,7 +18,7 @@ import GHC.Paths (libdir)
 import GHC.LanguageExtensions.Type (Extension(..))
 import GHC.Driver.Session --(PackageFlag(..), PackageArg(..), ModRenaming(..), PackageDBFlag(..), PkgDbRef(..), xopt_set)
 
-import EVM.Opcodes
+import EVM.Opcodes (opcodesImpl)
 import EVM (currentContract)
 import EVM.Op (getOp)
 import EVM.Types (VM, GenericOp(..), ContractCode(..), RuntimeCode(..), contract, code)
@@ -66,27 +66,35 @@ generateHaskellCode ops =
   unlines $
     [ "{-# LANGUAGE ImplicitParams #-}"
     , "module Generated where"
+    , "import Optics.Core"
+    , "import Optics.State"
+    , "import Optics.State.Operators"
+    , "import Optics.Zoom"
+    , "import Optics.Operators.Unsafe"
+    , ""
     , "import Control.Monad.State.Strict"
     , "import Control.Monad.ST"
     , "import Data.Word (Word8)"
+    , "import Witch.From (From)"
+    , "import Witch (into)"
+    , ""
     , "import EVM"
     , "import EVM.Types"
     , "import EVM.Op"
     , "import EVM.Expr qualified as Expr"
     , "import EVM.FeeSchedule (FeeSchedule (..))"
-    , ""
-    , "runOpcodeAdd :: " ++ runOpcodeAddType
-    , "runOpcodeAdd = " ++ runOpcodeAddSrc
-    , "runOpcodePush0 ::" ++ runOpcodePush0Type
-    , "runOpcodePush0 = " ++ runOpcodePush0Src
-    , "runOpcodeStop :: " ++ runOpcodeStopType
-    , "runOpcodeStop = " ++ runOpcodeStopSrc
-    , "runOpcodeRevert :: " ++ runOpcodeRevertType
-    , "runOpcodeRevert = " ++ runOpcodeRevertSrc
-    , ""
+    , "" ]
+    ++ map genOpImpl opcodesImpl ++
+    [ ""
     , "runSpecialized :: StateT (VM Concrete s) (ST s) ()"
     , "runSpecialized = do"
-    ] ++ map (checkIfVmResulted . genOp) ops -- ++ [" doStop"]
+    ] ++ map (checkIfVmResulted . genOp) ops
+
+
+genOpImpl :: (String, String, String, String) -> String
+genOpImpl (opName, opParams, typeSig, src) =
+  "runOpcode" ++ opName ++ " :: " ++ typeSig ++ "\n" ++
+  "runOpcode" ++ opName ++ opParams ++ " = " ++ src ++ "\n"
 
 checkIfVmResulted :: String -> String
 checkIfVmResulted op =
@@ -100,15 +108,17 @@ genOp (OpPush0)   = " let ?op = 1 in runOpcodePush0"
 genOp (OpRevert)  = " let ?op = 1 in runOpcodeRevert"
 genOp (OpStop)    = " let ?op = 1 in runOpcodeStop"
 genOp (OpAdd)     = " let ?op = 1 in runOpcodeAdd"
-genOp (OpDup i)   = "  runOpcodeDup " ++ show i
+genOp (OpDup i)   = " let ?op = 1 in runOpcodeDup (" ++ show i ++ " :: Int)"
+genOp (OpSwap i)  = " let ?op = 1 in runOpcodeSwap (" ++ show i ++ " :: Int)"
 -- Add more opcodes as needed
 genOp other       = error $ "Opcode not supported in specialization: " ++ show other
 
---------------------------------------------------------------------------------
--- | Compile and Run a Specialized EVM Program at Runtime
---------------------------------------------------------------------------------
-
-compileAndRunSpecialized :: VM t s -> IO (VM t s)
+-- | Compile and return a function that runs the specialized VM
+--   This function will generate Haskell code based on the current contract's opcodes,
+--   compile it using GHC API, and return a function that can be used to run
+--   the specialized VM.
+--   The generated code will be placed in a temporary directory.
+compileAndRunSpecialized :: VM t s -> IO (VM t s -> VM t s)
 compileAndRunSpecialized vm = do
   tmpDir <- getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "evmjit"
   let contract = currentContract vm
@@ -118,7 +128,7 @@ compileAndRunSpecialized vm = do
   let hsPath = tmpDir </> "Generated.hs"
   putStrLn $ "Generating Haskell code for EVM specialization in: " ++ hsPath
   writeFile hsPath (generateHaskellCode ops)
-  dynCompileAndRun hsPath vm
+  dynCompileAndRun hsPath
    where extractCode (RuntimeCode (ConcreteRuntimeCode ops)) = ops
          extractCode _ = error "Expected ConcreteRuntimeCode"
 
@@ -145,12 +155,12 @@ neededExtensionFlags =
     , DisambiguateRecordFields
     ]
 
-dynCompileAndRun :: forall t s. FilePath -> VM t s -> IO (VM t s)
-dynCompileAndRun filePath vmState = runGhc (Just libdir) $ do
+dynCompileAndRun :: forall t s. FilePath -> IO (VM t s -> VM t s)
+dynCompileAndRun filePath = runGhc (Just libdir) $ do
   dflags0 <- getSessionDynFlags
   dflags1 <- updateDynFlagsWithStackDB dflags0
   let dflags = foldl xopt_set dflags1 neededExtensionFlags
-  _ <- setSessionDynFlags dflags {
+  _ <- setSessionDynFlags $ updOptLevel 2 $ dflags {
     language = Just GHC2021,
     verbosity = 1,
     debugLevel = 1
@@ -170,4 +180,4 @@ dynCompileAndRun filePath vmState = runGhc (Just libdir) $ do
   let specialized :: forall s1. StateT (VM t s) (ST s1) ()
       specialized = unsafeCoerce value
 
-  return $ runST (execStateT specialized vmState)
+  return $ \vm -> runST (execStateT specialized vm)
diff --git a/src/EVM/Opcodes.hs b/src/EVM/Opcodes.hs
index 07dcdb345..da89634b6 100644
--- a/src/EVM/Opcodes.hs
+++ b/src/EVM/Opcodes.hs
@@ -3,6 +3,11 @@
 module EVM.Opcodes where
 
 import Optics.Core
+import Optics.State
+import Optics.State.Operators
+import Optics.Zoom
+import Optics.Operators.Unsafe
+
 
 import Control.Monad.ST (ST)
 import Control.Monad.State.Strict (StateT, get)
@@ -35,18 +40,65 @@ runOpcodeAddType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
 runOpcodeDup :: (From source Int, VMOps t, ?op::Word8) =>
                 source -> StateT (VM t s) (ST s) ()
 runOpcodeDup i = do
-    vm <- get
-    let
-      stk  = vm.state.stack
-      FeeSchedule {..} = vm.block.schedule
-    case preview (ix (into i - 1)) stk of
-              Nothing -> underrun
-              Just y ->
-                limitStack 1 $
-                  burn g_verylow $ do
-                    next
-                    pushSym y
-
+  vm <- get
+  let
+    stk  = vm.state.stack
+    FeeSchedule {..} = vm.block.schedule
+  case preview (ix (into i - 1)) stk of
+    Nothing -> underrun
+    Just y ->
+      limitStack 1 $
+        burn g_verylow $ do
+          next
+          pushSym y
+
+runOpcodeDupSrc :: String
+runOpcodeDupSrc = "do\n\
+\  vm <- get\n\
+\  let stk = vm.state.stack\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  case preview (ix (into i - 1)) stk of\n\
+\    Nothing -> underrun\n\
+\    Just y ->\n\
+\      limitStack 1 $\n\
+\        burn g_verylow $ do\n\
+\          next\n\
+\          pushSym y"
+
+runOpcodeDupType :: String
+runOpcodeDupType = "(From source Int, VMOps t, ?op::Word8) => source -> StateT (VM t s) (ST s) ()"
+
+runOpcodeSwap :: (?op::Word8, VMOps t, From source Int) => source -> StateT (VM t s) (ST s) ()
+runOpcodeSwap i = do
+  vm <- get
+  let
+    stk  = vm.state.stack
+    FeeSchedule {..} = vm.block.schedule
+  if length stk < (into i) + 1
+    then underrun
+    else
+      burn g_verylow $ do
+        next
+        zoom (#state % #stack) $ do
+          assign (ix 0) (stk ^?! ix (into i))
+          assign (ix (into i)) (stk ^?! ix 0)
+
+runOpcodeSwapSrc :: String
+runOpcodeSwapSrc = "do\n\
+\  vm <- get\n\
+\  let stk = vm.state.stack\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  if length stk < (into i) + 1\n\
+\    then underrun\n\
+\    else\n\
+\      burn g_verylow $ do\n\
+\        next\n\
+\        zoom (#state % #stack) $ do\n\
+\          assign (ix 0) (stk ^?! ix (into i))\n\
+\          assign (ix (into i)) (stk ^?! ix 0)"
+
+runOpcodeSwapType :: String
+runOpcodeSwapType = "(?op::Word8, VMOps t, From source Int) => source -> StateT (VM t s) (ST s) ()"
 
 runOpcodePush0 :: (VMOps t, ?op::Word8) =>
                 StateT (VM t s) (ST s) ()
@@ -105,3 +157,14 @@ runOpcodeStopSrc = "finishFrame (FrameReturned mempty)"
 
 runOpcodeStopType :: String
 runOpcodeStopType = "VMOps t => EVM t s ()"
+
+opcodesImpl :: [(String, String, String, String)]
+opcodesImpl =
+  [
+    ("Add",  "", runOpcodeAddType, runOpcodeAddSrc)
+  , ("Push0", "", runOpcodePush0Type, runOpcodePush0Src)
+  , ("Stop", "", runOpcodeStopType, runOpcodeStopSrc)
+  , ("Revert", "", runOpcodeRevertType, runOpcodeRevertSrc)
+  , ("Dup", " i", runOpcodeDupType, runOpcodeDupSrc)
+  , ("Swap", " i", runOpcodeSwapType, runOpcodeSwapSrc)
+  ]
diff --git a/src/EVM/Stepper.hs b/src/EVM/Stepper.hs
index b66b8fda2..439db2181 100644
--- a/src/EVM/Stepper.hs
+++ b/src/EVM/Stepper.hs
@@ -7,6 +7,7 @@ module EVM.Stepper
   , execFully
   , run
   , runFully
+  , runFullyNoEffects
   , wait
   , fork
   , evm
@@ -95,9 +96,13 @@ runFully = do
     Just _ ->
       pure vm
 
+runFullyNoEffects :: VMOps t => Config -> VM t RealWorld -> IO (VM t RealWorld, VM t RealWorld)
+runFullyNoEffects conf vm = stToIO $ runStateT (EVM.Exec.run conf) vm
+
 enter :: Text -> Stepper t s ()
 enter t = evm (EVM.pushTrace (EntryTrace t))
 
+
 interpret
   :: forall m a . (App m)
   => Fetch.Fetcher Concrete m RealWorld

From ffa35011111f683ba603a2330c50e2376ba4c70c Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Wed, 2 Jul 2025 13:30:01 +0200
Subject: [PATCH 06/11] basic block production

---
 src/EVM/Futamura.hs | 116 +++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 103 insertions(+), 13 deletions(-)

diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 5377092ed..680e64195 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE ImpredicativeTypes #-}
+
 module EVM.Futamura where
 
 import Control.Monad.State.Strict
@@ -8,7 +10,7 @@ import System.FilePath
 import System.Process (readProcess)
 import Control.Exception (catch, IOException)
 import Data.Word (Word8)
-import Data.List (isPrefixOf, dropWhileEnd)
+import Data.List (isPrefixOf, dropWhileEnd, intercalate)
 import Data.Maybe (catMaybes, listToMaybe)
 import Data.Char (isSpace)
 import Unsafe.Coerce
@@ -61,8 +63,8 @@ updateDynFlagsWithStackDB dflags =
 -- | Generate Haskell Code From a List of Opcodes
 --------------------------------------------------------------------------------
 
-generateHaskellCode :: [GenericOp Word8] -> String
-generateHaskellCode ops =
+generateHaskellCode :: [(BasicBlockRange, [GenericOp Word8])] -> String
+generateHaskellCode bbs =
   unlines $
     [ "{-# LANGUAGE ImplicitParams #-}"
     , "module Generated where"
@@ -84,12 +86,27 @@ generateHaskellCode ops =
     , "import EVM.Expr qualified as Expr"
     , "import EVM.FeeSchedule (FeeSchedule (..))"
     , "" ]
-    ++ map genOpImpl opcodesImpl ++
-    [ ""
-    , "runSpecialized :: StateT (VM Concrete s) (ST s) ()"
-    , "runSpecialized = do"
-    ] ++ map (checkIfVmResulted . genOp) ops
+    ++ map genOpImpl opcodesImpl
+    ++ [""] ++ concatMap genBasicBlockImpl bbs
+    -- ++ genBasicBlockList [bb]
+
+--genBasicBlockList :: [(BasicBlockRange, [GenericOp Word8])] -> [String]
+--genBasicBlockList [] = []
+--genBasicBlockList bbs = [
+--   "basicBlocks :: (VMOps t, ?op::Word8) => [((Int, Int), StateT (VM t s) (ST s) ())]",
+--   "basicBlocks = [" ++ (intercalate " ," $ map genBasicBlockName bbs) ++ "]"
+--  ]
 
+genBasicBlockFuncName :: (BasicBlockRange, [GenericOp Word8]) -> String
+genBasicBlockFuncName ((start, end), _) = "runBasicBlock_" ++ show start ++ "_" ++ show end
+
+genBasicBlockImpl :: (BasicBlockRange, [GenericOp Word8]) -> [String]
+genBasicBlockImpl bb@(_, ops) =
+  let blockFuncName = genBasicBlockFuncName bb
+  in [
+     blockFuncName ++ " :: StateT (VM Concrete s) (ST s) ()",
+     blockFuncName ++ " = do"
+     ] ++ map (checkIfVmResulted . genOp) ops
 
 genOpImpl :: (String, String, String, String) -> String
 genOpImpl (opName, opParams, typeSig, src) =
@@ -125,13 +142,84 @@ compileAndRunSpecialized vm = do
   let ops = case contract of
               Nothing -> error "No current contract found in VM"
               Just c -> map getOp $ BS.unpack $ extractCode $ c.code
+
+  let bb = splitBasicBlocks ops
+  putStrLn $ "Splitting into basic blocks: " ++ show bb
   let hsPath = tmpDir </> "Generated.hs"
   putStrLn $ "Generating Haskell code for EVM specialization in: " ++ hsPath
-  writeFile hsPath (generateHaskellCode ops)
-  dynCompileAndRun hsPath
+  writeFile hsPath (generateHaskellCode bb)
+
+  let bbFuncNames = map genBasicBlockFuncName bb
+  dynCompileAndRun hsPath bbFuncNames
    where extractCode (RuntimeCode (ConcreteRuntimeCode ops)) = ops
          extractCode _ = error "Expected ConcreteRuntimeCode"
 
+type BasicBlockRange = (Int, Int)
+
+-- | Split bytecode into basic blocks with their ranges.
+splitBasicBlocks :: [GenericOp Word8] -> [(BasicBlockRange, [GenericOp Word8])]
+splitBasicBlocks ops =
+  let blocks = splitBasicBlocks' ops
+      -- Filter out any empty blocks that might be generated by the splitting logic.
+      nonEmptyBlocks = filter (not . null) blocks
+      -- Calculate ranges based on the cumulative lengths of the blocks
+      lengths = map length nonEmptyBlocks
+      starts = scanl (+) 0 lengths
+      ranges = zip starts (tail starts)
+  in zip ranges nonEmptyBlocks
+
+-- | The core function to split opcodes into a list of basic blocks.
+splitBasicBlocks' :: [GenericOp Word8] -> [[GenericOp Word8]]
+splitBasicBlocks' [] = []
+splitBasicBlocks' ops =
+  -- Process the opcodes sequentially, splitting on both leaders and terminators
+  let (block, rest) = takeBasicBlock ops
+  in block : splitBasicBlocks' rest
+
+-- | Take one basic block from the front of the opcode list
+takeBasicBlock :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
+takeBasicBlock [] = ([], [])
+takeBasicBlock ops =
+    if isLeaderOp (head ops)
+    then takeBlockStartingWithLeader ops
+    else takeBlockWithoutLeader ops
+
+-- | Take a block starting with a leader until a terminator or next leader
+takeBlockStartingWithLeader :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
+takeBlockStartingWithLeader [] = ([], [])
+takeBlockStartingWithLeader (leader:rest) =
+    let (block, remaining) = takeUntilTerminatorOrLeader rest
+    in ([leader] ++ block, remaining)
+
+-- | Take a block not starting with a leader until a terminator or next leader
+takeBlockWithoutLeader :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
+takeBlockWithoutLeader ops = takeUntilTerminatorOrLeader ops
+
+-- | Take opcodes until hitting a terminator (inclusive) or leader (exclusive)
+takeUntilTerminatorOrLeader :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
+takeUntilTerminatorOrLeader [] = ([], [])
+takeUntilTerminatorOrLeader (op:rest)
+    | isTerminatorOp op = ([op], rest)  -- Include terminator, stop here
+    | isLeaderOp op = ([], op:rest)     -- Don't include leader, it starts next block
+    | otherwise =
+        let (block, remaining) = takeUntilTerminatorOrLeader rest
+        in (op:block, remaining)
+
+-- | Identifies opcodes that *start* a new basic block.
+isLeaderOp :: GenericOp Word8 -> Bool
+isLeaderOp OpJumpdest = True
+isLeaderOp _         = False
+
+-- | Identifies opcodes that *end* a basic block.
+isTerminatorOp :: GenericOp Word8 -> Bool
+isTerminatorOp OpJump   = True
+isTerminatorOp OpJumpi  = True
+isTerminatorOp OpStop   = True
+isTerminatorOp OpRevert = True
+isTerminatorOp OpReturn = True
+-- Note: Other terminators like SELFDESTRUCT or INVALID could be added here.
+isTerminatorOp _        = False
+
 --------------------------------------------------------------------------------
 -- | Use GHC API to Compile and Run the Generated Code
 --------------------------------------------------------------------------------
@@ -155,8 +243,8 @@ neededExtensionFlags =
     , DisambiguateRecordFields
     ]
 
-dynCompileAndRun :: forall t s. FilePath -> IO (VM t s -> VM t s)
-dynCompileAndRun filePath = runGhc (Just libdir) $ do
+dynCompileAndRun :: forall t s. FilePath -> [String] -> IO (VM t s -> VM t s)
+dynCompileAndRun filePath bbNames = runGhc (Just libdir) $ do
   dflags0 <- getSessionDynFlags
   dflags1 <- updateDynFlagsWithStackDB dflags0
   let dflags = foldl xopt_set dflags1 neededExtensionFlags
@@ -175,7 +263,9 @@ dynCompileAndRun filePath = runGhc (Just libdir) $ do
 
   setContext [IIDecl $ simpleImportDecl (mkModuleName "Generated")]
 
-  value <- compileExpr "Generated.runSpecialized"
+  let firstBlock = head bbNames
+  liftIO $ putStrLn $ "Getting basic block: " ++ firstBlock
+  value <- compileExpr ("Generated." ++ firstBlock)
 
   let specialized :: forall s1. StateT (VM t s) (ST s1) ()
       specialized = unsafeCoerce value

From 4969edbe4269a577a36d4d026551ac1a7a8ec897 Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Wed, 2 Jul 2025 14:31:49 +0200
Subject: [PATCH 07/11] initial handling of basic blocks

---
 src/EVM/Futamura.hs | 80 +++++++++++++++++++++++++++++++++------------
 1 file changed, 59 insertions(+), 21 deletions(-)

diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 680e64195..497b9cc31 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -19,11 +19,12 @@ import GHC (SuccessFlag(..), compileExpr, mkModuleName, simpleImportDecl, Intera
 import GHC.Paths (libdir)
 import GHC.LanguageExtensions.Type (Extension(..))
 import GHC.Driver.Session --(PackageFlag(..), PackageArg(..), ModRenaming(..), PackageDBFlag(..), PkgDbRef(..), xopt_set)
+import GHC.Driver.Monad (Ghc)
 
 import EVM.Opcodes (opcodesImpl)
 import EVM (currentContract)
 import EVM.Op (getOp)
-import EVM.Types (VM, GenericOp(..), ContractCode(..), RuntimeCode(..), contract, code)
+import EVM.Types (VM, GenericOp(..), ContractCode(..), RuntimeCode(..), contract, code, result, state, pc, VMResult(..))
 
 import qualified Data.ByteString as BS
 
@@ -87,15 +88,8 @@ generateHaskellCode bbs =
     , "import EVM.FeeSchedule (FeeSchedule (..))"
     , "" ]
     ++ map genOpImpl opcodesImpl
-    ++ [""] ++ concatMap genBasicBlockImpl bbs
-    -- ++ genBasicBlockList [bb]
-
---genBasicBlockList :: [(BasicBlockRange, [GenericOp Word8])] -> [String]
---genBasicBlockList [] = []
---genBasicBlockList bbs = [
---   "basicBlocks :: (VMOps t, ?op::Word8) => [((Int, Int), StateT (VM t s) (ST s) ())]",
---   "basicBlocks = [" ++ (intercalate " ," $ map genBasicBlockName bbs) ++ "]"
---  ]
+    ++ [""]
+    ++ concatMap genBasicBlockImpl bbs
 
 genBasicBlockFuncName :: (BasicBlockRange, [GenericOp Word8]) -> String
 genBasicBlockFuncName ((start, end), _) = "runBasicBlock_" ++ show start ++ "_" ++ show end
@@ -150,7 +144,9 @@ compileAndRunSpecialized vm = do
   writeFile hsPath (generateHaskellCode bb)
 
   let bbFuncNames = map genBasicBlockFuncName bb
-  dynCompileAndRun hsPath bbFuncNames
+  fs <- dynCompileAndRun hsPath bbFuncNames
+  return (\x -> runSpecialized (zip (map fst bb) fs) x)
+
    where extractCode (RuntimeCode (ConcreteRuntimeCode ops)) = ops
          extractCode _ = error "Expected ConcreteRuntimeCode"
 
@@ -243,8 +239,8 @@ neededExtensionFlags =
     , DisambiguateRecordFields
     ]
 
-dynCompileAndRun :: forall t s. FilePath -> [String] -> IO (VM t s -> VM t s)
-dynCompileAndRun filePath bbNames = runGhc (Just libdir) $ do
+dynCompileAndRun :: forall t s. FilePath -> [String] -> IO [(VM t s -> VM t s)]
+dynCompileAndRun filePath bbFuncNames = runGhc (Just libdir) $ do
   dflags0 <- getSessionDynFlags
   dflags1 <- updateDynFlagsWithStackDB dflags0
   let dflags = foldl xopt_set dflags1 neededExtensionFlags
@@ -263,11 +259,53 @@ dynCompileAndRun filePath bbNames = runGhc (Just libdir) $ do
 
   setContext [IIDecl $ simpleImportDecl (mkModuleName "Generated")]
 
-  let firstBlock = head bbNames
-  liftIO $ putStrLn $ "Getting basic block: " ++ firstBlock
-  value <- compileExpr ("Generated." ++ firstBlock)
-
-  let specialized :: forall s1. StateT (VM t s) (ST s1) ()
-      specialized = unsafeCoerce value
-
-  return $ \vm -> runST (execStateT specialized vm)
+  -- Compile each basic block function
+  compiledBlocks <- mapM extractBasicBlockFunction bbFuncNames
+  liftIO $ putStrLn "Compilation successful, returning functions."
+  return compiledBlocks
+
+ where
+  extractBasicBlockFunction bbName = do
+    value <- compileExpr ("Generated." ++ bbName)
+    let specialized :: forall s1. StateT (VM t s) (ST s1) ()
+        specialized = unsafeCoerce value
+    return $ \vm -> runST (execStateT specialized vm)
+
+-- | Run the specialized VM for each basic block
+--   This function takes a VM and a list of basic blocks with their ranges,
+--   and returns a VM that has executed until vm.result is not Nothing.
+--   It should use the state.pc to determine which block to run next.
+runSpecialized :: [(BasicBlockRange, VM t s -> VM t s)] -> VM t s -> VM t s
+runSpecialized bbs vm =
+  -- The execution loop continues as long as the VM has not produced a result.
+  -- This also serves as the base case for the recursion.
+  case vm.result of
+    Just _ -> vm
+    Nothing ->
+      -- Find the compiled function for the basic block at the current program counter.
+      -- In the EVM, valid jump destinations must be a JUMPDEST opcode.
+      -- Our `splitBasicBlocks` logic ensures that every JUMPDEST starts a new
+      -- basic block. Therefore, we can find the correct block by matching
+      -- vm.pc with the starting address of a block.
+      let
+        currentPc = fromIntegral vm.state.pc
+        -- We can use `lookup` for an efficient search by converting the list of
+        -- blocks into an association list of (startAddress, function).
+        blockAssocList = map (\((start, _), f) -> (start, f)) bbs
+        maybeBlockFunc = lookup currentPc blockAssocList
+      in
+        case maybeBlockFunc of
+          -- If a matching block is found, execute its compiled function.
+          Just blockFunc ->
+            -- The `blockFunc` takes the current VM state and returns the new
+            -- state after executing the opcodes in that block.
+            let newVm = blockFunc vm
+            -- Continue execution from the new VM state by making a recursive call.
+            in runSpecialized bbs newVm
+
+          -- If no block starts at the current PC, it means we've jumped to an
+          -- invalid location (i.e., not a JUMPDEST).
+          Nothing ->
+            -- In this case, we terminate the VM with an `InvalidJump` error,
+            -- as per EVM semantics.
+            error "Invalid jump destination: no basic block starts at the current PC"
\ No newline at end of file

From 231e3ba6798de00603c2f47e5bacb41b5cf922a1 Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Wed, 2 Jul 2025 22:01:18 +0200
Subject: [PATCH 08/11] added enough opcodes to start benchmarking

---
 src/EVM/Futamura.hs | 102 ++++++++++---
 src/EVM/Op.hs       |  88 +++++++++++
 src/EVM/Opcodes.hs  | 364 +++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 528 insertions(+), 26 deletions(-)

diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 497b9cc31..8d92be03d 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -22,9 +22,9 @@ import GHC.Driver.Session --(PackageFlag(..), PackageArg(..), ModRenaming(..), P
 import GHC.Driver.Monad (Ghc)
 
 import EVM.Opcodes (opcodesImpl)
-import EVM (currentContract)
+import EVM (currentContract, opslen)
 import EVM.Op (getOp)
-import EVM.Types (VM, GenericOp(..), ContractCode(..), RuntimeCode(..), contract, code, result, state, pc, VMResult(..))
+import EVM.Types (VM, GenericOp(..), ContractCode(..), RuntimeCode(..), contract, code, result, state, pc, VMResult(..), Expr(ConcreteBuf), EvmError(..))
 
 import qualified Data.ByteString as BS
 
@@ -79,12 +79,15 @@ generateHaskellCode bbs =
     , "import Control.Monad.ST"
     , "import Data.Word (Word8)"
     , "import Witch.From (From)"
-    , "import Witch (into)"
+    , "import Witch (into, tryInto)"
+    , "import Data.ByteString qualified as BS"
+    , "import Data.Vector qualified as V"
     , ""
     , "import EVM"
     , "import EVM.Types"
     , "import EVM.Op"
     , "import EVM.Expr qualified as Expr"
+    , "import EVM.Effects (defaultConfig, maxDepth)"
     , "import EVM.FeeSchedule (FeeSchedule (..))"
     , "" ]
     ++ map genOpImpl opcodesImpl
@@ -102,6 +105,16 @@ genBasicBlockImpl bb@(_, ops) =
      blockFuncName ++ " = do"
      ] ++ map (checkIfVmResulted . genOp) ops
 
+isBasicBlockInvalid :: (BasicBlockRange, [GenericOp Word8]) -> Bool
+isBasicBlockInvalid (_, []) = True
+isBasicBlockInvalid (_, ((OpUnknown _):ops)) = length ops > 0
+isBasicBlockInvalid _ = False
+
+-- | Filter out basic blocks that are empty or contain only unknown opcodes.
+-- After it finds a basic block with an unknown opcode, it stops processing further blocks.
+filterBasicBlocks :: [(BasicBlockRange, [GenericOp Word8])] -> [(BasicBlockRange, [GenericOp Word8])]
+filterBasicBlocks = takeWhile (not . isBasicBlockInvalid)
+
 genOpImpl :: (String, String, String, String) -> String
 genOpImpl (opName, opParams, typeSig, src) =
   "runOpcode" ++ opName ++ " :: " ++ typeSig ++ "\n" ++
@@ -121,6 +134,21 @@ genOp (OpStop)    = " let ?op = 1 in runOpcodeStop"
 genOp (OpAdd)     = " let ?op = 1 in runOpcodeAdd"
 genOp (OpDup i)   = " let ?op = 1 in runOpcodeDup (" ++ show i ++ " :: Int)"
 genOp (OpSwap i)  = " let ?op = 1 in runOpcodeSwap (" ++ show i ++ " :: Int)"
+genOp (OpMul)     = " let ?op = 1 in runOpcodeMul"
+genOp (OpSub)     = " let ?op = 1 in runOpcodeSub"
+genOp (OpDiv)     = " let ?op = 1 in runOpcodeDiv"
+genOp (OpMod)     = " let ?op = 1 in runOpcodeMod"
+genOp (OpJumpi)    = " let ?op = opToWord8(OpJumpi) in runOpcodeJumpi"
+genOp (OpJump)   = " let ?op = opToWord8(OpJump) in runOpcodeJump"
+genOp (OpJumpdest) = " let ?op = opToWord8(OpJumpdest) in runOpcodeJumpdest"
+genOp (OpPush n)  = " let ?op = opToWord8(OpPush " ++ show n ++ ") in runOpcodePush (" ++ show n ++ " :: Int)"
+genOp (OpPop)     = " let ?op = opToWord8(OpPop) in runOpcodePop"
+genOp (OpMstore)  = " let ?op = opToWord8(OpMstore) in runOpcodeMStore"
+genOp (OpMload)   = " let ?op = opToWord8(OpMload) in runOpcodeMLoad"
+genOp (OpSlt)     = " let ?op = opToWord8(OpSlt) in runOpcodeSlt"
+genOp (OpIszero)  = " let ?op = opToWord8(OpIszero) in runOpcodeIsZero"
+genOp (OpEq)      = " let ?op = opToWord8(OpEq) in runOpcodeEq"
+genOp (OpUnknown n) = "error \"Unknown opcode: " ++ show n ++ "\""
 -- Add more opcodes as needed
 genOp other       = error $ "Opcode not supported in specialization: " ++ show other
 
@@ -133,11 +161,11 @@ compileAndRunSpecialized :: VM t s -> IO (VM t s -> VM t s)
 compileAndRunSpecialized vm = do
   tmpDir <- getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "evmjit"
   let contract = currentContract vm
-  let ops = case contract of
+  let bs = case contract of
               Nothing -> error "No current contract found in VM"
-              Just c -> map getOp $ BS.unpack $ extractCode $ c.code
+              Just c -> extractCode $ c.code
 
-  let bb = splitBasicBlocks ops
+  let bb = filterBasicBlocks $ splitBasicBlocks bs
   putStrLn $ "Splitting into basic blocks: " ++ show bb
   let hsPath = tmpDir </> "Generated.hs"
   putStrLn $ "Generating Haskell code for EVM specialization in: " ++ hsPath
@@ -152,25 +180,50 @@ compileAndRunSpecialized vm = do
 
 type BasicBlockRange = (Int, Int)
 
--- | Split bytecode into basic blocks with their ranges.
-splitBasicBlocks :: [GenericOp Word8] -> [(BasicBlockRange, [GenericOp Word8])]
-splitBasicBlocks ops =
-  let blocks = splitBasicBlocks' ops
+-- | Split bytecode into basic blocks with their ranges, properly disassembling first.
+splitBasicBlocks :: BS.ByteString -> [(BasicBlockRange, [GenericOp Word8])]
+splitBasicBlocks bytecode =
+  let ops = disassemble bytecode
+      blocks = splitBasicBlocks' ops
       -- Filter out any empty blocks that might be generated by the splitting logic.
       nonEmptyBlocks = filter (not . null) blocks
-      -- Calculate ranges based on the cumulative lengths of the blocks
-      lengths = map length nonEmptyBlocks
-      starts = scanl (+) 0 lengths
-      ranges = zip starts (tail starts)
+      -- Calculate ranges based on the actual byte positions in original bytecode
+      ranges = calculateRanges ops nonEmptyBlocks
   in zip ranges nonEmptyBlocks
 
+-- | Disassemble bytecode into a list of opcodes with their byte positions
+disassemble :: BS.ByteString -> [(Int, GenericOp Word8)]
+disassemble bs = disassemble' (BS.unpack bs) 0
+  where
+    disassemble' [] _ = []
+    disassemble' (b:rest) pos =
+      let op = getOp b
+          size = opcodeByteSize op
+          remaining = drop (size - 1) rest  -- Skip the data bytes for PUSH instructions
+      in (pos, op) : disassemble' remaining (pos + size)
+
+-- | Calculate the byte size of an opcode
+opcodeByteSize :: GenericOp Word8 -> Int
+opcodeByteSize (OpPush n) = fromIntegral n + 1  -- n data bytes + 1 opcode byte
+opcodeByteSize _          = 1
+
+-- | Calculate byte ranges for basic blocks in the original bytecode
+calculateRanges :: [(Int, GenericOp Word8)] -> [[GenericOp Word8]] -> [BasicBlockRange]
+calculateRanges _ blocks =
+  let blockSizes = map (sum . map opcodeByteSize) blocks
+      starts = scanl (+) 0 blockSizes
+  in zip starts (tail starts)
+
 -- | The core function to split opcodes into a list of basic blocks.
-splitBasicBlocks' :: [GenericOp Word8] -> [[GenericOp Word8]]
-splitBasicBlocks' [] = []
-splitBasicBlocks' ops =
-  -- Process the opcodes sequentially, splitting on both leaders and terminators
-  let (block, rest) = takeBasicBlock ops
-  in block : splitBasicBlocks' rest
+splitBasicBlocks' :: [(Int, GenericOp Word8)] -> [[GenericOp Word8]]
+splitBasicBlocks' posOps =
+  let ops = map snd posOps  -- Extract just the opcodes for splitting logic
+  in splitBasicBlocks'' ops
+
+splitBasicBlocks'' :: [GenericOp Word8] -> [[GenericOp Word8]]
+splitBasicBlocks'' [] = []
+splitBasicBlocks'' ops = let (block, rest) = takeBasicBlock ops
+                         in block : splitBasicBlocks'' rest
 
 -- | Take one basic block from the front of the opcode list
 takeBasicBlock :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
@@ -305,7 +358,8 @@ runSpecialized bbs vm =
 
           -- If no block starts at the current PC, it means we've jumped to an
           -- invalid location (i.e., not a JUMPDEST).
-          Nothing ->
-            -- In this case, we terminate the VM with an `InvalidJump` error,
-            -- as per EVM semantics.
-            error "Invalid jump destination: no basic block starts at the current PC"
\ No newline at end of file
+          Nothing -> if (vm.state.pc >= opslen vm.state.code) then
+                      error $ "Invalid jump destination: " ++ show vm.state.pc
+                      --vm {result = Just (VMSuccess $ ConcreteBuf $ BS.fromString $ show vm.state.pc)}
+                     else
+                      vm {result = Just (VMFailure $ BadJumpDestination)}
diff --git a/src/EVM/Op.hs b/src/EVM/Op.hs
index 410bd9e35..d3c6c76c9 100644
--- a/src/EVM/Op.hs
+++ b/src/EVM/Op.hs
@@ -5,6 +5,7 @@ module EVM.Op
   , intToOpName
   , getOp
   , readOp
+  , opToWord8
   ) where
 
 import EVM.Expr qualified as Expr
@@ -359,3 +360,90 @@ getOp x = case x of
   0xfa -> OpStaticcall
   0xff -> OpSelfdestruct
   _    -> OpUnknown x
+
+-- | Convert a 'GenericOp' to an Word8
+opToWord8 :: GenericOp Word8 -> Word8
+opToWord8 (OpDup n) = 0x80 + fromIntegral (n - 1)
+opToWord8 (OpSwap n) = 0x90 + fromIntegral (n - 1)
+opToWord8 (OpLog n) = 0xa0 + fromIntegral n
+opToWord8 (OpPush n) = 0x60 + fromIntegral (n - 1)
+opToWord8 OpPush0 = 0x5f
+opToWord8 OpStop = 0x00
+opToWord8 OpAdd = 0x01
+opToWord8 OpMul = 0x02
+opToWord8 OpSub = 0x03
+opToWord8 OpDiv = 0x04
+opToWord8 OpSdiv = 0x05
+opToWord8 OpMod = 0x06
+opToWord8 OpSmod = 0x07
+opToWord8 OpAddmod = 0x08
+opToWord8 OpMulmod = 0x09
+opToWord8 OpExp = 0x0a
+opToWord8 OpSignextend = 0x0b
+opToWord8 OpLt = 0x10
+opToWord8 OpGt = 0x11
+opToWord8 OpSlt = 0x12
+opToWord8 OpSgt = 0x13
+opToWord8 OpEq = 0x14
+opToWord8 OpIszero = 0x15
+opToWord8 OpAnd = 0x16
+opToWord8 OpOr = 0x17
+opToWord8 OpXor = 0x18
+opToWord8 OpNot = 0x19
+opToWord8 OpByte = 0x1a
+opToWord8 OpShl = 0x1b
+opToWord8 OpShr = 0x1c
+opToWord8 OpSar = 0x1d
+opToWord8 OpSha3 = 0x20
+opToWord8 OpAddress = 0x30
+opToWord8 OpBalance = 0x31
+opToWord8 OpOrigin = 0x32
+opToWord8 OpCaller = 0x33
+opToWord8 OpCallvalue = 0x34
+opToWord8 OpCalldataload = 0x35
+opToWord8 OpCalldatasize = 0x36
+opToWord8 OpCalldatacopy = 0x37
+opToWord8 OpCodesize = 0x38
+opToWord8 OpCodecopy = 0x39
+opToWord8 OpGasprice = 0x3a
+opToWord8 OpExtcodesize = 0x3b
+opToWord8 OpExtcodecopy = 0x3c
+opToWord8 OpReturndatasize = 0x3d
+opToWord8 OpReturndatacopy = 0x3e
+opToWord8 OpExtcodehash = 0x3f
+opToWord8 OpBlockhash = 0x40
+opToWord8 OpCoinbase = 0x41
+opToWord8 OpTimestamp = 0x42
+opToWord8 OpNumber = 0x43
+opToWord8 OpPrevRandao = 0x44
+opToWord8 OpGaslimit = 0x45
+opToWord8 OpChainid = 0x46
+opToWord8 OpSelfbalance = 0x47
+opToWord8 OpBaseFee = 0x48
+opToWord8 OpBlobhash = 0x49
+opToWord8 OpBlobBaseFee = 0x4a
+opToWord8 OpPop = 0x50
+opToWord8 OpMcopy = 0x5e
+opToWord8 OpMload = 0x51
+opToWord8 OpMstore = 0x52
+opToWord8 OpMstore8 = 0x53
+opToWord8 OpSload = 0x54
+opToWord8 OpSstore = 0x55
+opToWord8 OpTload = 0x5c
+opToWord8 OpTstore = 0x5d
+opToWord8 OpJump = 0x56
+opToWord8 OpJumpi = 0x57
+opToWord8 OpPc = 0x58
+opToWord8 OpMsize = 0x59
+opToWord8 OpGas = 0x5a
+opToWord8 OpJumpdest = 0x5b
+opToWord8 OpCreate = 0xf0
+opToWord8 OpCall = 0xf1
+opToWord8 OpStaticcall = 0xfa
+opToWord8 OpCallcode = 0xf2
+opToWord8 OpReturn = 0xf3
+opToWord8 OpDelegatecall = 0xf4
+opToWord8 OpCreate2 = 0xf5
+opToWord8 OpSelfdestruct = 0xff
+opToWord8 OpRevert = 0xfd
+opToWord8 (OpUnknown x) = x
diff --git a/src/EVM/Opcodes.hs b/src/EVM/Opcodes.hs
index da89634b6..577672667 100644
--- a/src/EVM/Opcodes.hs
+++ b/src/EVM/Opcodes.hs
@@ -10,15 +10,18 @@ import Optics.Operators.Unsafe
 
 
 import Control.Monad.ST (ST)
-import Control.Monad.State.Strict (StateT, get)
+import Control.Monad.State.Strict (StateT, get, gets)
 import Witch.From (From)
-import Witch (into)
+import Witch (into, tryInto)
 import Data.Word (Word8)
+import Data.Vector qualified as V
+import Data.ByteString qualified as BS
 
 import EVM
 import EVM.Types
 import EVM.FeeSchedule (FeeSchedule (..))
 import EVM.Expr qualified as Expr
+import EVM.Effects (defaultConfig, maxDepth)
 
 runOpcodeAdd :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
 runOpcodeAdd = do
@@ -36,6 +39,70 @@ runOpcodeAddSrc = "do\n\
 runOpcodeAddType :: String
 runOpcodeAddType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
 
+runOpcodeMul :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
+runOpcodeMul = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp2 g_low Expr.mul
+
+runOpcodeMulSrc :: String
+runOpcodeMulSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp2 g_low Expr.mul"
+
+runOpcodeMulType :: String
+runOpcodeMulType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeSub :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
+runOpcodeSub = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp2 g_verylow Expr.sub
+
+runOpcodeSubSrc :: String
+runOpcodeSubSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp2 g_verylow Expr.sub"
+
+runOpcodeSubType :: String
+runOpcodeSubType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeDiv :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
+runOpcodeDiv = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp2 g_low Expr.div
+
+runOpcodeDivSrc :: String
+runOpcodeDivSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp2 g_low Expr.div"
+
+runOpcodeDivType :: String
+runOpcodeDivType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeMod :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
+runOpcodeMod = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp2 g_low Expr.mod
+
+runOpcodeModSrc :: String
+runOpcodeModSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp2 g_low Expr.mod"
+
+runOpcodeModType :: String
+runOpcodeModType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
 {-# INLINE runOpcodeDup #-}
 runOpcodeDup :: (From source Int, VMOps t, ?op::Word8) =>
                 source -> StateT (VM t s) (ST s) ()
@@ -122,6 +189,65 @@ runOpcodePush0Src = "do\n\
 \      next\n\
 \      pushSym (Lit 0)"
 
+runOpcodePush :: (From source Int, VMOps t, ?op::Word8) => source -> StateT (VM t s) (ST s) ()
+runOpcodePush i = do
+  vm <- get
+  let FeeSchedule {..} = vm.block.schedule
+  let n = into i
+      !xs = case vm.state.code of
+        UnknownCode _ -> internalError "Cannot execute unknown code"
+        InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + vm.state.pc) conc)
+        RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + vm.state.pc) bs
+        RuntimeCode (SymbolicRuntimeCode ops) ->
+          let bytes = V.take n $ V.drop (1 + vm.state.pc) ops
+          in Expr.readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes
+  limitStack 1 $
+    burn g_verylow $ do
+      next
+      pushSym xs
+
+runOpcodePushSrc :: String
+runOpcodePushSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  let n = into i\n\
+\      !xs = case vm.state.code of\n\
+\        UnknownCode _ -> internalError \"Cannot execute unknown code\"\n\
+\        InitCode conc _ -> Lit $ word $ padRight n $ BS.take n (BS.drop (1 + vm.state.pc) conc)\n\
+\        RuntimeCode (ConcreteRuntimeCode bs) -> Lit $ word $ BS.take n $ BS.drop (1 + vm.state.pc) bs\n\
+\        RuntimeCode (SymbolicRuntimeCode ops) ->\n\
+\          let bytes = V.take n $ V.drop (1 + vm.state.pc) ops\n\
+\          in Expr.readWord (Lit 0) $ Expr.fromList $ padLeft' 32 bytes\n\
+\  limitStack 1 $\n\
+\    burn g_verylow $ do\n\
+\      next\n\
+\      pushSym xs"
+
+runOpcodePushType :: String
+runOpcodePushType = "(From source Int, VMOps t, ?op::Word8) => source -> StateT (VM t s) (ST s) ()"
+
+runOpcodePop :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodePop = do
+  vm <- get
+  let stk = vm.state.stack
+      FeeSchedule {..} = vm.block.schedule
+  case stk of
+    _:xs -> burn g_base (next >> assign (#state % #stack) xs)
+    _    -> underrun
+
+runOpcodePopSrc :: String
+runOpcodePopSrc = "do\n\
+\  vm <- get\n\
+\  let stk = vm.state.stack\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  case stk of\n\
+\    _:xs -> burn g_base (next >> assign (#state % #stack) xs)\n\
+\    _    -> underrun"
+
+runOpcodePopType :: String
+runOpcodePopType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
 {-# INLINE runOpcodeRevert #-}
 runOpcodeRevert :: (VMOps t) =>
                 StateT (VM t s) (ST s) ()
@@ -158,13 +284,247 @@ runOpcodeStopSrc = "finishFrame (FrameReturned mempty)"
 runOpcodeStopType :: String
 runOpcodeStopType = "VMOps t => EVM t s ()"
 
+runOpcodeJumpi :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
+runOpcodeJumpi = do
+  vm <- get
+  let conf = defaultConfig -- TODO
+  let stk = vm.state.stack
+      FeeSchedule {..} = vm.block.schedule
+  case stk of
+    x:y:xs -> let ?conf = defaultConfig in forceConcreteLimitSz x 2 "JUMPI: symbolic jumpdest" $ \x' ->
+      burn g_high $
+        let jump :: (VMOps t) => Bool -> EVM t s ()
+            jump False = assign (#state % #stack) xs >> next
+            jump _    = case tryInto x' of
+              Left _ -> vmError BadJumpDestination
+              Right i -> checkJump i xs
+        in branch conf.maxDepth y jump
+    _ -> underrun
+
+runOpcodeJumpiSrc :: String
+runOpcodeJumpiSrc = "do\n\
+\  vm <- get\n\
+\  let conf = defaultConfig -- TODO\n\
+\  let stk = vm.state.stack\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  case stk of\n\
+\    x:y:xs -> let ?conf = defaultConfig in forceConcreteLimitSz x 2 \"JUMPI: symbolic jumpdest\" $ \\x' ->\n\
+\      burn g_high $\n\
+\        let jump :: (VMOps t) => Bool -> EVM t s ()\n\
+\            jump False = assign (#state % #stack) xs >> next\n\
+\            jump _    = case tryInto x' of\n\
+\              Left _ -> vmError BadJumpDestination\n\
+\              Right i -> checkJump i xs\n\
+\        in branch conf.maxDepth y jump\n\
+\    _ -> underrun"
+
+runOpcodeJumpiType :: String
+runOpcodeJumpiType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeJump :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodeJump = do
+  vm <- get
+  let stk = vm.state.stack
+      FeeSchedule {..} = vm.block.schedule
+  case stk of
+    x:xs ->
+      burn g_mid $ let ?conf = defaultConfig in forceConcreteLimitSz x 2 "JUMP: symbolic jumpdest" $ \x' ->
+        case tryInto x' of
+          Left _ -> vmError BadJumpDestination
+          Right i -> checkJump i xs
+    _ -> underrun
+
+runOpcodeJumpSrc :: String
+runOpcodeJumpSrc = "do\n\
+\  vm <- get\n\
+\  let stk = vm.state.stack\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  case stk of\n\
+\    x:xs ->\n\
+\      burn g_mid $ let ?conf = defaultConfig in forceConcreteLimitSz x 2 \"JUMP: symbolic jumpdest\" $ \\x' ->\n\
+\        case tryInto x' of\n\
+\          Left _ -> vmError BadJumpDestination\n\
+\          Right i -> checkJump i xs\n\
+\    _ -> underrun"
+
+runOpcodeJumpType :: String
+runOpcodeJumpType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeJumpdest :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodeJumpdest = do
+  vm <- get
+  let FeeSchedule {..} = vm.block.schedule
+  burn g_jumpdest next
+
+runOpcodeJumpdestSrc :: String
+runOpcodeJumpdestSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  burn g_jumpdest next"
+
+runOpcodeJumpdestType :: String
+runOpcodeJumpdestType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeMStore :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodeMStore = do
+  vm <- get
+  let stk = vm.state.stack
+      FeeSchedule {..} = vm.block.schedule
+  case stk of
+    x:y:xs ->
+      burn g_verylow $
+        accessMemoryWord x $ do
+          next
+          gets (.state.memory) >>= \case
+            ConcreteMemory mem -> do
+              case y of
+                Lit w ->
+                  copyBytesToMemory (ConcreteBuf (word256Bytes w)) (Lit 32) (Lit 0) x
+                _ -> do
+                  -- copy out and move to symbolic memory
+                  buf <- freezeMemory mem
+                  assign (#state % #memory) (SymbolicMemory $ Expr.writeWord x y buf)
+            SymbolicMemory mem ->
+              assign (#state % #memory) (SymbolicMemory $ Expr.writeWord x y mem)
+          assign (#state % #stack) xs
+    _ -> underrun
+
+runOpcodeMStoreSrc :: String
+runOpcodeMStoreSrc = "do\n\
+\  vm <- get\n\
+\  let stk = vm.state.stack\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  case stk of\n\
+\    x:y:xs ->\n\
+\      burn g_verylow $\n\
+\        accessMemoryWord x $ do\n\
+\          next\n\
+\          gets (.state.memory) >>= \\case\n\
+\            ConcreteMemory mem -> do\n\
+\              case y of\n\
+\                Lit w ->\n\
+\                  copyBytesToMemory (ConcreteBuf (word256Bytes w)) (Lit 32) (Lit 0) x\n\
+\                _ -> do\n\
+\                  -- copy out and move to symbolic memory\n\
+\                  buf <- freezeMemory mem\n\
+\                  assign (#state % #memory) (SymbolicMemory $ Expr.writeWord x y buf)\n\
+\            SymbolicMemory mem ->\n\
+\              assign (#state % #memory) (SymbolicMemory $ Expr.writeWord x y mem)\n\
+\          assign (#state % #stack) xs\n\
+\    _ -> underrun"
+
+runOpcodeMStoreType :: String
+runOpcodeMStoreType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeMLoad :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodeMLoad = do
+  vm <- get
+  let stk = vm.state.stack
+      FeeSchedule {..} = vm.block.schedule
+  case stk of
+    x:xs ->
+      burn g_verylow $
+        accessMemoryWord x $ do
+          next
+          buf <- readMemory x (Lit 32)
+          let w = Expr.readWordFromBytes (Lit 0) buf
+          assign (#state % #stack) (w : xs)
+    _ -> underrun
+
+runOpcodeMLoadSrc :: String
+runOpcodeMLoadSrc = "do\n\
+\  vm <- get\n\
+\  let stk = vm.state.stack\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  case stk of\n\
+\    x:xs ->\n\
+\      burn g_verylow $\n\
+\        accessMemoryWord x $ do\n\
+\          next\n\
+\          buf <- readMemory x (Lit 32)\n\
+\          let w = Expr.readWordFromBytes (Lit 0) buf\n\
+\          assign (#state % #stack) (w : xs)\n\
+\    _ -> underrun"
+
+runOpcodeMLoadType :: String
+runOpcodeMLoadType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeSlt :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+runOpcodeSlt = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp2 g_verylow Expr.slt
+
+runOpcodeSltSrc :: String
+runOpcodeSltSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp2 g_verylow Expr.slt"
+
+runOpcodeSltType :: String
+runOpcodeSltType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeIsZero :: (VMOps t, ?op::Word8) =>
+                StateT (VM t s) (ST s) ()
+
+runOpcodeIsZero = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp1 g_verylow Expr.iszero
+
+runOpcodeIsZeroSrc :: String
+runOpcodeIsZeroSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp1 g_verylow Expr.iszero"
+
+runOpcodeIsZeroType :: String
+runOpcodeIsZeroType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
+runOpcodeEq :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
+runOpcodeEq = do
+  vm <- get
+  let
+    FeeSchedule {..} = vm.block.schedule
+  stackOp2 g_verylow Expr.eq
+
+runOpcodeEqSrc :: String
+runOpcodeEqSrc = "do\n\
+\  vm <- get\n\
+\  let FeeSchedule {..} = vm.block.schedule\n\
+\  stackOp2 g_verylow Expr.eq"
+
+runOpcodeEqType :: String
+runOpcodeEqType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
+
 opcodesImpl :: [(String, String, String, String)]
 opcodesImpl =
   [
     ("Add",  "", runOpcodeAddType, runOpcodeAddSrc)
+  , ("Mul",  "", runOpcodeMulType, runOpcodeMulSrc)
+  , ("Sub",  "", runOpcodeSubType, runOpcodeSubSrc)
+  , ("Div",  "", runOpcodeDivType, runOpcodeDivSrc)
+  , ("Mod",  "", runOpcodeModType, runOpcodeModSrc)
   , ("Push0", "", runOpcodePush0Type, runOpcodePush0Src)
+  , ("Push", " i", runOpcodePushType, runOpcodePushSrc)
+  , ("Pop",  "", runOpcodePopType, runOpcodePopSrc)
   , ("Stop", "", runOpcodeStopType, runOpcodeStopSrc)
   , ("Revert", "", runOpcodeRevertType, runOpcodeRevertSrc)
   , ("Dup", " i", runOpcodeDupType, runOpcodeDupSrc)
   , ("Swap", " i", runOpcodeSwapType, runOpcodeSwapSrc)
+  , ("MStore", "", runOpcodeMStoreType, runOpcodeMStoreSrc)
+  , ("MLoad", "", runOpcodeMLoadType, runOpcodeMLoadSrc)
+  , ("IsZero", "", runOpcodeIsZeroType, runOpcodeIsZeroSrc)
+  , ("Eq", "", runOpcodeEqType, runOpcodeEqSrc)
+  , ("Jumpi", "", runOpcodeJumpiType, runOpcodeJumpiSrc)
+  , ("Jump", "", runOpcodeJumpType, runOpcodeJumpSrc)
+  , ("Jumpdest", "", runOpcodeJumpdestType, runOpcodeJumpdestSrc)
+  , ("Slt", "", runOpcodeSltType, runOpcodeSltSrc)
   ]

From 615fe9501ab2f39fa82e91578fd460c2a499f9ea Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Thu, 3 Jul 2025 13:23:05 +0200
Subject: [PATCH 09/11] more opcodes and use st monad a single time

---
 src/EVM/Futamura.hs | 104 +++++++++++++++++++++++---------------------
 src/EVM/Opcodes.hs  |  56 +++++++++++++++---------
 2 files changed, 90 insertions(+), 70 deletions(-)

diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 8d92be03d..4c99b7c98 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -13,6 +13,8 @@ import Data.Word (Word8)
 import Data.List (isPrefixOf, dropWhileEnd, intercalate)
 import Data.Maybe (catMaybes, listToMaybe)
 import Data.Char (isSpace)
+import Data.IntMap.Lazy (IntMap, lookup, fromList)
+import Prelude hiding (lookup)
 import Unsafe.Coerce
 
 import GHC (SuccessFlag(..), compileExpr, mkModuleName, simpleImportDecl, InteractiveImport(..), setContext, LoadHowMuch(..), load, setTargets, guessTarget, setSessionDynFlags, getSessionDynFlags, runGhc)
@@ -77,13 +79,13 @@ generateHaskellCode bbs =
     , ""
     , "import Control.Monad.State.Strict"
     , "import Control.Monad.ST"
-    , "import Data.Word (Word8)"
+    , "import Data.Word (Word8, Word64)"
     , "import Witch.From (From)"
     , "import Witch (into, tryInto)"
     , "import Data.ByteString qualified as BS"
     , "import Data.Vector qualified as V"
     , ""
-    , "import EVM"
+    , "import EVM hiding (stackOp2)"
     , "import EVM.Types"
     , "import EVM.Op"
     , "import EVM.Expr qualified as Expr"
@@ -115,11 +117,17 @@ isBasicBlockInvalid _ = False
 filterBasicBlocks :: [(BasicBlockRange, [GenericOp Word8])] -> [(BasicBlockRange, [GenericOp Word8])]
 filterBasicBlocks = takeWhile (not . isBasicBlockInvalid)
 
-genOpImpl :: (String, String, String, String) -> String
-genOpImpl (opName, opParams, typeSig, src) =
+genOpImpl :: (String, String, String, String, Bool) -> String
+genOpImpl (opName, opParams, typeSig, src, True) =
+  "{-# INLINE runOpcode" ++ opName ++ " #-}\n" ++
   "runOpcode" ++ opName ++ " :: " ++ typeSig ++ "\n" ++
   "runOpcode" ++ opName ++ opParams ++ " = " ++ src ++ "\n"
 
+genOpImpl (opName, opParams, typeSig, src, False) =
+  "{-# INLINE " ++ opName ++ " #-}\n" ++
+  opName ++ " :: " ++ typeSig ++ "\n" ++
+  opName ++ opParams ++ " = " ++ src ++ "\n"
+
 checkIfVmResulted :: String -> String
 checkIfVmResulted op =
   " get >>= \\vm ->\n" ++
@@ -148,7 +156,7 @@ genOp (OpMload)   = " let ?op = opToWord8(OpMload) in runOpcodeMLoad"
 genOp (OpSlt)     = " let ?op = opToWord8(OpSlt) in runOpcodeSlt"
 genOp (OpIszero)  = " let ?op = opToWord8(OpIszero) in runOpcodeIsZero"
 genOp (OpEq)      = " let ?op = opToWord8(OpEq) in runOpcodeEq"
-genOp (OpUnknown n) = "error \"Unknown opcode: " ++ show n ++ "\""
+genOp (OpUnknown _) = " let ?op = 1 in runOpcodeRevert" --"error \"Unknown opcode: " ++ show n ++ "\""
 -- Add more opcodes as needed
 genOp other       = error $ "Opcode not supported in specialization: " ++ show other
 
@@ -157,7 +165,7 @@ genOp other       = error $ "Opcode not supported in specialization: " ++ show o
 --   compile it using GHC API, and return a function that can be used to run
 --   the specialized VM.
 --   The generated code will be placed in a temporary directory.
-compileAndRunSpecialized :: VM t s -> IO (VM t s -> VM t s)
+compileAndRunSpecialized :: forall t s. VM t s -> IO (VM t s -> VM t s)
 compileAndRunSpecialized vm = do
   tmpDir <- getTemporaryDirectory >>= \tmp -> createTempDirectory tmp "evmjit"
   let contract = currentContract vm
@@ -173,8 +181,15 @@ compileAndRunSpecialized vm = do
 
   let bbFuncNames = map genBasicBlockFuncName bb
   fs <- dynCompileAndRun hsPath bbFuncNames
-  return (\x -> runSpecialized (zip (map fst bb) fs) x)
-
+  let blockMap = fromList
+        [ (start, func)
+        | (((start, _), _), func) <- zip bb fs
+        ]
+
+  -- We take the result of execStateT, which has type `ST s (VM t s)`,
+  -- and we unsafely coerce it to `forall s'. ST s' (VM t s)`,
+  -- which is exactly what `runST` expects.
+  return $ \x -> runST (unsafeCoerce $ execStateT (dispatcherLoop blockMap) x)
    where extractCode (RuntimeCode (ConcreteRuntimeCode ops)) = ops
          extractCode _ = error "Expected ConcreteRuntimeCode"
 
@@ -292,7 +307,7 @@ neededExtensionFlags =
     , DisambiguateRecordFields
     ]
 
-dynCompileAndRun :: forall t s. FilePath -> [String] -> IO [(VM t s -> VM t s)]
+dynCompileAndRun :: forall t s. FilePath -> [String] -> IO [StateT (VM t s) (ST s) ()]
 dynCompileAndRun filePath bbFuncNames = runGhc (Just libdir) $ do
   dflags0 <- getSessionDynFlags
   dflags1 <- updateDynFlagsWithStackDB dflags0
@@ -322,44 +337,35 @@ dynCompileAndRun filePath bbFuncNames = runGhc (Just libdir) $ do
     value <- compileExpr ("Generated." ++ bbName)
     let specialized :: forall s1. StateT (VM t s) (ST s1) ()
         specialized = unsafeCoerce value
-    return $ \vm -> runST (execStateT specialized vm)
-
--- | Run the specialized VM for each basic block
---   This function takes a VM and a list of basic blocks with their ranges,
---   and returns a VM that has executed until vm.result is not Nothing.
---   It should use the state.pc to determine which block to run next.
-runSpecialized :: [(BasicBlockRange, VM t s -> VM t s)] -> VM t s -> VM t s
-runSpecialized bbs vm =
-  -- The execution loop continues as long as the VM has not produced a result.
-  -- This also serves as the base case for the recursion.
+    return specialized
+
+-- This is the new, efficient execution loop (a trampoline).
+-- It runs entirely within the StateT monad, never exiting until the VM halts.
+dispatcherLoop :: forall t s. IntMap (StateT (VM t s) (ST s) ()) -> StateT (VM t s) (ST s) ()
+dispatcherLoop blockMap = do
+  vm <- get
   case vm.result of
-    Just _ -> vm
-    Nothing ->
-      -- Find the compiled function for the basic block at the current program counter.
-      -- In the EVM, valid jump destinations must be a JUMPDEST opcode.
-      -- Our `splitBasicBlocks` logic ensures that every JUMPDEST starts a new
-      -- basic block. Therefore, we can find the correct block by matching
-      -- vm.pc with the starting address of a block.
-      let
-        currentPc = fromIntegral vm.state.pc
-        -- We can use `lookup` for an efficient search by converting the list of
-        -- blocks into an association list of (startAddress, function).
-        blockAssocList = map (\((start, _), f) -> (start, f)) bbs
-        maybeBlockFunc = lookup currentPc blockAssocList
-      in
-        case maybeBlockFunc of
-          -- If a matching block is found, execute its compiled function.
-          Just blockFunc ->
-            -- The `blockFunc` takes the current VM state and returns the new
-            -- state after executing the opcodes in that block.
-            let newVm = blockFunc vm
-            -- Continue execution from the new VM state by making a recursive call.
-            in runSpecialized bbs newVm
-
-          -- If no block starts at the current PC, it means we've jumped to an
-          -- invalid location (i.e., not a JUMPDEST).
-          Nothing -> if (vm.state.pc >= opslen vm.state.code) then
-                      error $ "Invalid jump destination: " ++ show vm.state.pc
-                      --vm {result = Just (VMSuccess $ ConcreteBuf $ BS.fromString $ show vm.state.pc)}
-                     else
-                      vm {result = Just (VMFailure $ BadJumpDestination)}
+    -- Base case: The VM has halted. Stop the loop.
+    Just _ -> pure ()
+
+    -- Recursive step: The VM is still running.
+    Nothing -> do
+      let currentPc = fromIntegral vm.state.pc
+
+      case lookup currentPc blockMap of
+        -- Found a compiled block at the current PC.
+        Just blockAction -> do
+          -- Execute the action for this block. It will modify the VM state,
+          -- including changing the PC for the next jump.
+          blockAction
+          -- Loop to the next block without exiting the monad.
+          dispatcherLoop blockMap
+
+        -- No block starts at the current PC.
+        Nothing ->
+          -- This is an invalid jump. Modify the VM state to set the error
+          -- and the loop will terminate on the next iteration.
+          if (vm.state.pc >= opslen vm.state.code) then
+            error $ "Invalid jump destination: " ++ show vm.state.pc
+          else
+            modify' (\v -> v { result = Just (VMFailure BadJumpDestination) })
diff --git a/src/EVM/Opcodes.hs b/src/EVM/Opcodes.hs
index 577672667..74a5fdd03 100644
--- a/src/EVM/Opcodes.hs
+++ b/src/EVM/Opcodes.hs
@@ -504,27 +504,41 @@ runOpcodeEqSrc = "do\n\
 runOpcodeEqType :: String
 runOpcodeEqType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
 
-opcodesImpl :: [(String, String, String, String)]
+runOpcodeStackOp2Src :: String
+runOpcodeStackOp2Src =
+  "use (#state % #stack) >>= \\case\n\
+\  x:y:xs ->\n\
+\    burn cost $ do\n\
+\      next\n\
+\      #state % #stack .= f x y : xs\n\
+\  _ ->\n\
+\    underrun"
+
+runOpcodeStackOp2Type :: String
+runOpcodeStackOp2Type = "(?op :: Word8, VMOps t) => Word64 -> (Expr EWord -> Expr EWord -> Expr EWord) -> EVM t s ()"
+
+opcodesImpl :: [(String, String, String, String, Bool)]
 opcodesImpl =
   [
-    ("Add",  "", runOpcodeAddType, runOpcodeAddSrc)
-  , ("Mul",  "", runOpcodeMulType, runOpcodeMulSrc)
-  , ("Sub",  "", runOpcodeSubType, runOpcodeSubSrc)
-  , ("Div",  "", runOpcodeDivType, runOpcodeDivSrc)
-  , ("Mod",  "", runOpcodeModType, runOpcodeModSrc)
-  , ("Push0", "", runOpcodePush0Type, runOpcodePush0Src)
-  , ("Push", " i", runOpcodePushType, runOpcodePushSrc)
-  , ("Pop",  "", runOpcodePopType, runOpcodePopSrc)
-  , ("Stop", "", runOpcodeStopType, runOpcodeStopSrc)
-  , ("Revert", "", runOpcodeRevertType, runOpcodeRevertSrc)
-  , ("Dup", " i", runOpcodeDupType, runOpcodeDupSrc)
-  , ("Swap", " i", runOpcodeSwapType, runOpcodeSwapSrc)
-  , ("MStore", "", runOpcodeMStoreType, runOpcodeMStoreSrc)
-  , ("MLoad", "", runOpcodeMLoadType, runOpcodeMLoadSrc)
-  , ("IsZero", "", runOpcodeIsZeroType, runOpcodeIsZeroSrc)
-  , ("Eq", "", runOpcodeEqType, runOpcodeEqSrc)
-  , ("Jumpi", "", runOpcodeJumpiType, runOpcodeJumpiSrc)
-  , ("Jump", "", runOpcodeJumpType, runOpcodeJumpSrc)
-  , ("Jumpdest", "", runOpcodeJumpdestType, runOpcodeJumpdestSrc)
-  , ("Slt", "", runOpcodeSltType, runOpcodeSltSrc)
+    ("Add",  "", runOpcodeAddType, runOpcodeAddSrc, True)
+  , ("Mul",  "", runOpcodeMulType, runOpcodeMulSrc, True)
+  , ("Sub",  "", runOpcodeSubType, runOpcodeSubSrc, True)
+  , ("Div",  "", runOpcodeDivType, runOpcodeDivSrc, True)
+  , ("Mod",  "", runOpcodeModType, runOpcodeModSrc, True)
+  , ("Push0", "", runOpcodePush0Type, runOpcodePush0Src, True)
+  , ("Push", " i", runOpcodePushType, runOpcodePushSrc, True)
+  , ("Pop",  "", runOpcodePopType, runOpcodePopSrc, True)
+  , ("Stop", "", runOpcodeStopType, runOpcodeStopSrc, True)
+  , ("Revert", "", runOpcodeRevertType, runOpcodeRevertSrc, True)
+  , ("Dup", " i", runOpcodeDupType, runOpcodeDupSrc, True)
+  , ("Swap", " i", runOpcodeSwapType, runOpcodeSwapSrc, True)
+  , ("MStore", "", runOpcodeMStoreType, runOpcodeMStoreSrc, True)
+  , ("MLoad", "", runOpcodeMLoadType, runOpcodeMLoadSrc, True)
+  , ("IsZero", "", runOpcodeIsZeroType, runOpcodeIsZeroSrc, True)
+  , ("Eq", "", runOpcodeEqType, runOpcodeEqSrc, True)
+  , ("Jumpi", "", runOpcodeJumpiType, runOpcodeJumpiSrc, True)
+  , ("Jump", "", runOpcodeJumpType, runOpcodeJumpSrc, True)
+  , ("Jumpdest", "", runOpcodeJumpdestType, runOpcodeJumpdestSrc, True)
+  , ("Slt", "", runOpcodeSltType, runOpcodeSltSrc, True)
+  , ("stackOp2", " cost f", runOpcodeStackOp2Type, runOpcodeStackOp2Src, False)
   ]

From bdaf32a0d8175b231e1fcab380694286ed36af0d Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Sat, 5 Jul 2025 11:44:04 +0200
Subject: [PATCH 10/11] naive cfg building to generate a complete program in
 haskell from opcodes

---
 src/EVM/Futamura.hs | 495 +++++++++++++++++++++++++++-----------------
 1 file changed, 305 insertions(+), 190 deletions(-)

diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 4c99b7c98..73ec818d0 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -10,10 +10,13 @@ import System.FilePath
 import System.Process (readProcess)
 import Control.Exception (catch, IOException)
 import Data.Word (Word8)
-import Data.List (isPrefixOf, dropWhileEnd, intercalate)
+import Data.List (isPrefixOf, dropWhileEnd, intercalate, foldl', find)
 import Data.Maybe (catMaybes, listToMaybe)
 import Data.Char (isSpace)
+import Data.Map qualified as Map
+import Data.IntSet qualified as IntSet
 import Data.IntMap.Lazy (IntMap, lookup, fromList)
+import Data.Bits (shiftL)
 import Prelude hiding (lookup)
 import Unsafe.Coerce
 
@@ -25,7 +28,7 @@ import GHC.Driver.Monad (Ghc)
 
 import EVM.Opcodes (opcodesImpl)
 import EVM (currentContract, opslen)
-import EVM.Op (getOp)
+import EVM.Op (getOp, opToWord8)
 import EVM.Types (VM, GenericOp(..), ContractCode(..), RuntimeCode(..), contract, code, result, state, pc, VMResult(..), Expr(ConcreteBuf), EvmError(..))
 
 import qualified Data.ByteString as BS
@@ -66,8 +69,8 @@ updateDynFlagsWithStackDB dflags =
 -- | Generate Haskell Code From a List of Opcodes
 --------------------------------------------------------------------------------
 
-generateHaskellCode :: [(BasicBlockRange, [GenericOp Word8])] -> String
-generateHaskellCode bbs =
+generateHaskellCode :: Map.Map Int BasicBlock -> String
+generateHaskellCode cfg =
   unlines $
     [ "{-# LANGUAGE ImplicitParams #-}"
     , "module Generated where"
@@ -94,28 +97,271 @@ generateHaskellCode bbs =
     , "" ]
     ++ map genOpImpl opcodesImpl
     ++ [""]
-    ++ concatMap genBasicBlockImpl bbs
-
-genBasicBlockFuncName :: (BasicBlockRange, [GenericOp Word8]) -> String
-genBasicBlockFuncName ((start, end), _) = "runBasicBlock_" ++ show start ++ "_" ++ show end
+    ++ map (genBasicBlockImpl cfg) (Map.elems cfg)
+
+-- | Generates a function name for a basic block based on its start PC.
+genBasicBlockFuncName :: BasicBlock -> String
+genBasicBlockFuncName block = "runBlock_" ++ show (fst block.bbRange)
+
+-- | Generates the Haskell code for a single BasicBlock.
+genBasicBlockImpl :: Map.Map Int BasicBlock -> BasicBlock -> String
+genBasicBlockImpl cfg block =
+  let
+    funcName = genBasicBlockFuncName block
+    -- Generate a `runOpcode` call for ALL opcodes in the block.
+    opCodeStmts = map (("  " ++) . genOp) block.bbOps
+    -- Generate the final control-flow transfer statement.
+    successorStmt = "  " ++ genSuccessorDispatch cfg block
+  in
+    unlines $
+      [ "{-# INLINE " ++ funcName ++ " #-}",
+        funcName ++ " :: StateT (VM Concrete s) (ST s) ()",
+        funcName ++ " = do"
+      ] ++ opCodeStmts ++ [successorStmt]
+
+-- | Generates the final line of a block function, which dispatches to the next block.
+-- This code runs AFTER all opcodes in the block have been executed.
+genSuccessorDispatch :: Map.Map Int BasicBlock -> BasicBlock -> String
+genSuccessorDispatch cfg block = case block.bbSuccessor of
+  -- The last opcode was not a terminator. Directly call the next block's function.
+  -- This overrides any PC change from the last opcode.
+  FallthroughTo pc   -> if Map.member pc cfg then genBasicBlockFuncName (cfg Map.! pc) else "pure ()"
+
+  -- The JUMP opcode was executed (consuming gas & stack), but we ignore its
+  -- effect on the PC and instead make a direct call to the static destination.
+  StaticJump pc      -> genBasicBlockFuncName (cfg Map.! pc)
+
+  -- The JUMPI opcode was executed (consuming gas & stack). We then check the
+  -- vm.result to see if it failed (e.g., stack underrun). If not, we know
+  -- the pc was set to one of two values, but we ignore that and make our own
+  -- direct call based on the *original* condition, which is now gone from the stack.
+  -- This is a flaw. The logic must be to check the PC set by the JUMPI.
+  --
+  -- CORRECTED LOGIC: The `runOpcode OpJumpi` has already set the PC to either
+  -- the destination or pc+1. We now read that PC and dispatch accordingly.
+  ConditionalJump truePc falsePc ->
+    unlines
+      [ "vm <- get"
+      , "  if vm.state.pc == " ++ show truePc
+      , "  then " ++ genBasicBlockFuncName (cfg Map.! truePc)
+      , "  else " ++ genBasicBlockFuncName (cfg Map.! falsePc)
+      ]
+
+  DynamicJump ->
+    "error \"JIT Error: Dynamic jumps are not supported.\""
+
+  Terminal ->
+    -- The last executed opcode (e.g., runOpcode OpStop) has set vm.result.
+    -- There is nothing more to do, the machine has halted.
+    "pure ()"
+
+-- | Generates a call to the original `runOpcode` interpreter function.
+genOpCall :: GenericOp Word8 -> String
+genOpCall op =
+  let opcodeByte = opToWord8 op
+  in "do { vm <- get; case vm.result of Just _ -> pure (); Nothing -> runOpcode " ++ show opcodeByte ++ " }"
+
+-- | Data Structures for the Control Flow Graph
+type BasicBlockRange = (Int, Int)
 
-genBasicBlockImpl :: (BasicBlockRange, [GenericOp Word8]) -> [String]
-genBasicBlockImpl bb@(_, ops) =
-  let blockFuncName = genBasicBlockFuncName bb
-  in [
-     blockFuncName ++ " :: StateT (VM Concrete s) (ST s) ()",
-     blockFuncName ++ " = do"
-     ] ++ map (checkIfVmResulted . genOp) ops
+-- A single node in our Control Flow Graph.
+data BasicBlock = BasicBlock
+  { bbRange     :: (Int, Int)          -- (start_pc, end_pc_exclusive)
+  , bbOps       :: [GenericOp Word8]   -- Opcodes within the block
+  , bbSuccessor :: Successor           -- How this block connects to others
+  } deriving (Show, Eq)
+
+-- Represents where control flows after a basic block finishes.
+data Successor
+  = FallthroughTo Int     -- Statically known PC of the next instruction
+  | StaticJump Int        -- A JUMP to a constant, known destination PC
+  | ConditionalJump Int Int -- A JUMPI to a constant destination and a fallthrough PC
+  | DynamicJump           -- A JUMP or JUMPI to an unknown (dynamic) destination
+  | Terminal              -- Block ends with STOP, REVERT, RETURN, etc.
+  deriving (Show, Eq)
+
+-- A fully decoded instruction with its position and raw data.
+data Instruction = Instruction
+  { instrPC   :: Int
+  , instrOp   :: GenericOp Word8
+  , instrData :: BS.ByteString -- The raw bytes for a PUSH, otherwise empty
+  } deriving (Show)
+
+-- | Core CFG Construction Logic
+
+-- The main function to build the CFG.
+-- Returns a map from a block's starting PC to the BasicBlock itself.
+buildCFG :: BS.ByteString -> Map.Map Int BasicBlock
+buildCFG bytecode =
+  let
+    instrs = disassemble bytecode
+    leaders = findLeaders instrs
+    -- 1. Form the complete CFG for the entire bytecode.
+    fullCfg = formBlocks instrs leaders
+    -- 2. Filter out the data section at the end.
+    filteredCfg = filterDataSection fullCfg
+  in
+    filteredCfg
+
+-- ... (The rest of your CFG functions: disassemble, findLeaders, formBlocks, etc., remain the same)
+
+-- Disassembles bytecode into a stream of instructions.
+disassemble :: BS.ByteString -> [Instruction]
+disassemble bs = go 0
+  where
+    go pc
+      | pc >= BS.length bs = []
+      | otherwise =
+          let opcodeByte = BS.index bs pc
+              op = getOp opcodeByte
+          in case op of
+               OpPush n ->
+                 let numBytes = fromIntegral n
+                     start = pc + 1
+                     end = start + numBytes
+                 in if end > BS.length bs then
+                      -- This PUSH reads past the end of the bytecode. It's an invalid instruction.
+                      let invalidInstr = Instruction pc (OpUnknown opcodeByte) BS.empty
+                      in invalidInstr : go (pc + 1)
+                    else
+                      let pushData = BS.take numBytes (BS.drop start bs)
+                          instr = Instruction pc op pushData
+                          nextPc = pc + 1 + numBytes
+                      in instr : go nextPc
+               _ ->
+                 let instr = Instruction pc op BS.empty
+                     nextPc = pc + 1
+                 in instr : go nextPc
+
+-- Finds all "leaders" - instructions that start a basic block.
+findLeaders :: [Instruction] -> IntSet.IntSet
+findLeaders instrs = IntSet.insert 0 $ fst $ foldl' go (IntSet.empty, False) instrs
+  where
+    go (leaders, wasTerminator) instr =
+      let currentPc = instr.instrPC
+          -- If the previous instruction was a terminator, this one is a leader.
+          leaders' = if wasTerminator then IntSet.insert currentPc leaders else leaders
+          -- If this instruction is a JUMPDEST, it's a leader.
+          finalLeaders = if isLeaderOp instr.instrOp then IntSet.insert currentPc leaders' else leaders'
+      in (finalLeaders, isTerminatorOp instr.instrOp)
+
+-- Forms a Map of BasicBlocks from the instruction stream and leader set.
+formBlocks :: [Instruction] -> IntSet.IntSet -> Map.Map Int BasicBlock
+formBlocks [] _ = Map.empty
+formBlocks instrs leaders =
+  let (blockInstrs, restInstrs) = span (not . isLeaderAfterFirst) (tail instrs)
+      firstInstr = head instrs
+      -- The first block always starts at PC 0.
+      currentBlock = firstInstr : blockInstrs
+      startPc = firstInstr.instrPC
+      -- The block ends right before the next leader (or at the end of the code).
+      endPc = case restInstrs of
+                [] -> let lastI = last currentBlock in lastI.instrPC + instructionByteSize lastI
+                (nextLeader:_) -> nextLeader.instrPC
+      block = BasicBlock
+        { bbRange = (startPc, endPc)
+        , bbOps = map (.instrOp) currentBlock
+        , bbSuccessor = analyzeSuccessor currentBlock
+        }
+  in Map.insert startPc block (formBlocks restInstrs leaders)
+  where
+    isLeaderAfterFirst instr = IntSet.member (instr.instrPC) leaders
+
+-- Analyzes the last instruction(s) of a block to find its successor type.
+analyzeSuccessor :: [Instruction] -> Successor
+analyzeSuccessor instrs =
+  case reverse instrs of
+    [] -> Terminal -- Should not happen for a non-empty block
+
+    -- JUMP case: Look for a preceding PUSH
+    (jumpInstr : pushInstr : _)
+      | jumpInstr.instrOp == OpJump, isPush pushInstr.instrOp ->
+          let dest = bytesToInteger (BS.unpack pushInstr.instrData)
+          in StaticJump (fromInteger dest)
+
+    -- JUMPI case: Look for a preceding PUSH
+    (jumpiInstr : pushInstr : _)
+      | jumpiInstr.instrOp == OpJumpi, isPush pushInstr.instrOp ->
+          let dest = bytesToInteger (BS.unpack pushInstr.instrData)
+              -- CORRECTED: Fallthrough is the PC of the instruction *after* the JUMPI
+              fallthroughPc = jumpiInstr.instrPC + instructionByteSize jumpiInstr
+          in ConditionalJump (fromInteger dest) fallthroughPc
+
+    -- Default cases for dynamic jumps and terminators
+    (lastInstr : _) ->
+      let op = lastInstr.instrOp
+          pc = lastInstr.instrPC
+          size = instructionByteSize lastInstr
+      in case op of
+        OpJump -> DynamicJump
+        OpJumpi -> DynamicJump
+        _ | isTerminatorOp op -> Terminal
+          | otherwise         -> FallthroughTo (pc + size)
+
+-- | Helper Functions
+
+instructionByteSize :: Instruction -> Int
+instructionByteSize instr = case instr.instrOp of
+  OpPush n -> 1 + fromIntegral n
+  _        -> 1
+
+isPush :: GenericOp a -> Bool
+isPush (OpPush _) = True
+isPush _          = False
+
+bytesToInteger :: [Word8] -> Integer
+bytesToInteger = foldl' (\acc byte -> (acc `shiftL` 8) + fromIntegral byte) 0
 
-isBasicBlockInvalid :: (BasicBlockRange, [GenericOp Word8]) -> Bool
-isBasicBlockInvalid (_, []) = True
-isBasicBlockInvalid (_, ((OpUnknown _):ops)) = length ops > 0
-isBasicBlockInvalid _ = False
+isLeaderOp :: GenericOp Word8 -> Bool
+isLeaderOp OpJumpdest = True
+isLeaderOp _         = False
 
--- | Filter out basic blocks that are empty or contain only unknown opcodes.
--- After it finds a basic block with an unknown opcode, it stops processing further blocks.
-filterBasicBlocks :: [(BasicBlockRange, [GenericOp Word8])] -> [(BasicBlockRange, [GenericOp Word8])]
-filterBasicBlocks = takeWhile (not . isBasicBlockInvalid)
+isTerminatorOp :: GenericOp Word8 -> Bool
+isTerminatorOp op = case op of
+  OpJump         -> True
+  OpJumpi        -> True
+  OpStop         -> True
+  OpRevert       -> True
+  OpReturn       -> True
+  OpSelfdestruct -> True -- FIX: Was missing
+  OpUnknown _    -> True -- FIX: Was missing
+  _              -> False
+
+
+-- | Determines if a basic block is the start of the non-executable data section.
+-- According to the pattern, this is a block that starts with an unknown/invalid
+-- opcode but is not a simple, single invalid instruction.
+isDataSectionBlock :: BasicBlock -> Bool
+isDataSectionBlock block =
+  case block.bbOps of
+    -- An empty block isn't the pattern, but it's good to consider it invalid.
+    [] -> True
+    -- The key pattern: starts with OpUnknown but has more content.
+    (OpUnknown _ : _ : _) -> True
+    -- Any other case is a valid executable block.
+    _ -> False
+
+-- | Filters the CFG to remove blocks that are part of the contract's metadata section.
+-- It finds the first block that looks like a data section marker and removes
+-- it and all blocks that come after it.
+filterDataSection :: Map.Map Int BasicBlock -> Map.Map Int BasicBlock
+filterDataSection cfg =
+  -- Find the first block that matches our data section pattern.
+  -- `find` on a Map returns the first element in key-order.
+  case find isDataSectionBlock (Map.elems cfg) of
+    -- No data section block was found; the entire CFG is valid.
+    Nothing -> cfg
+    -- We found a data section block. Its starting PC is the cutoff point.
+    Just invalidBlock ->
+      let
+        (startPc, _) = invalidBlock.bbRange
+        -- `split` divides the map into elements < separator and >= separator.
+        -- We just want the part that comes before the invalid block.
+        (executableBlocks, _) = Map.split startPc cfg
+      in
+        executableBlocks
+
+-- | Generate Haskell code for each opcode implementation.
 
 genOpImpl :: (String, String, String, String, Bool) -> String
 genOpImpl (opName, opParams, typeSig, src, True) =
@@ -136,29 +382,29 @@ checkIfVmResulted op =
   "     Just r -> return ()"
 
 genOp :: GenericOp Word8 -> String
-genOp (OpPush0)   = " let ?op = 1 in runOpcodePush0"
-genOp (OpRevert)  = " let ?op = 1 in runOpcodeRevert"
-genOp (OpStop)    = " let ?op = 1 in runOpcodeStop"
-genOp (OpAdd)     = " let ?op = 1 in runOpcodeAdd"
-genOp (OpDup i)   = " let ?op = 1 in runOpcodeDup (" ++ show i ++ " :: Int)"
-genOp (OpSwap i)  = " let ?op = 1 in runOpcodeSwap (" ++ show i ++ " :: Int)"
-genOp (OpMul)     = " let ?op = 1 in runOpcodeMul"
-genOp (OpSub)     = " let ?op = 1 in runOpcodeSub"
-genOp (OpDiv)     = " let ?op = 1 in runOpcodeDiv"
-genOp (OpMod)     = " let ?op = 1 in runOpcodeMod"
-genOp (OpJumpi)    = " let ?op = opToWord8(OpJumpi) in runOpcodeJumpi"
-genOp (OpJump)   = " let ?op = opToWord8(OpJump) in runOpcodeJump"
-genOp (OpJumpdest) = " let ?op = opToWord8(OpJumpdest) in runOpcodeJumpdest"
-genOp (OpPush n)  = " let ?op = opToWord8(OpPush " ++ show n ++ ") in runOpcodePush (" ++ show n ++ " :: Int)"
-genOp (OpPop)     = " let ?op = opToWord8(OpPop) in runOpcodePop"
-genOp (OpMstore)  = " let ?op = opToWord8(OpMstore) in runOpcodeMStore"
-genOp (OpMload)   = " let ?op = opToWord8(OpMload) in runOpcodeMLoad"
-genOp (OpSlt)     = " let ?op = opToWord8(OpSlt) in runOpcodeSlt"
-genOp (OpIszero)  = " let ?op = opToWord8(OpIszero) in runOpcodeIsZero"
-genOp (OpEq)      = " let ?op = opToWord8(OpEq) in runOpcodeEq"
-genOp (OpUnknown _) = " let ?op = 1 in runOpcodeRevert" --"error \"Unknown opcode: " ++ show n ++ "\""
+genOp (OpPush0)   = "let ?op = 1 in runOpcodePush0"
+genOp (OpRevert)  = "let ?op = 1 in runOpcodeRevert"
+genOp (OpStop)    = "let ?op = 1 in runOpcodeStop"
+genOp (OpAdd)     = "let ?op = 1 in runOpcodeAdd"
+genOp (OpDup i)   = "let ?op = 1 in runOpcodeDup (" ++ show i ++ " :: Int)"
+genOp (OpSwap i)  = "let ?op = opToWord8(OpSwap " ++ show i ++") in runOpcodeSwap (" ++ show i ++ " :: Int)"
+genOp (OpMul)     = "let ?op = opToWord8(OpMul) in runOpcodeMul"
+genOp (OpSub)     = "let ?op = opToWord8(OpSub) in runOpcodeSub"
+genOp (OpDiv)     = "let ?op = opToWord8(OpDiv) in runOpcodeDiv"
+genOp (OpMod)     = "let ?op = opToWord8(OpMod) in runOpcodeMod"
+genOp (OpJumpi)    = "let ?op = opToWord8(OpJumpi) in runOpcodeJumpi"
+genOp (OpJump)   = "let ?op = opToWord8(OpJump) in runOpcodeJump"
+genOp (OpJumpdest) = "let ?op = opToWord8(OpJumpdest) in runOpcodeJumpdest"
+genOp (OpPush n)  = "let ?op = opToWord8(OpPush " ++ show n ++ ") in runOpcodePush (" ++ show n ++ " :: Int)"
+genOp (OpPop)     = "let ?op = opToWord8(OpPop) in runOpcodePop"
+genOp (OpMstore)  = "let ?op = opToWord8(OpMstore) in runOpcodeMStore"
+genOp (OpMload)   = "let ?op = opToWord8(OpMload) in runOpcodeMLoad"
+genOp (OpSlt)     = "let ?op = opToWord8(OpSlt) in runOpcodeSlt"
+genOp (OpIszero)  = "let ?op = opToWord8(OpIszero) in runOpcodeIsZero"
+genOp (OpEq)      = "let ?op = opToWord8(OpEq) in runOpcodeEq"
+genOp (OpUnknown _) = "let ?op = 1 in runOpcodeRevert" --"error \"Unknown opcode: " ++ show n ++ "\""
 -- Add more opcodes as needed
-genOp other       = error $ "Opcode not supported in specialization: " ++ show other
+genOp other       = "pure ()" --error $ "Opcode not supported in specialization: " ++ show other
 
 -- | Compile and return a function that runs the specialized VM
 --   This function will generate Haskell code based on the current contract's opcodes,
@@ -173,116 +419,16 @@ compileAndRunSpecialized vm = do
               Nothing -> error "No current contract found in VM"
               Just c -> extractCode $ c.code
 
-  let bb = filterBasicBlocks $ splitBasicBlocks bs
-  putStrLn $ "Splitting into basic blocks: " ++ show bb
+  let cfg = buildCFG bs --filterBasicBlocks $ splitBasicBlocks bs
+  putStrLn $ "Splitting into basic blocks: " ++ show cfg
   let hsPath = tmpDir </> "Generated.hs"
   putStrLn $ "Generating Haskell code for EVM specialization in: " ++ hsPath
-  writeFile hsPath (generateHaskellCode bb)
-
-  let bbFuncNames = map genBasicBlockFuncName bb
-  fs <- dynCompileAndRun hsPath bbFuncNames
-  let blockMap = fromList
-        [ (start, func)
-        | (((start, _), _), func) <- zip bb fs
-        ]
-
-  -- We take the result of execStateT, which has type `ST s (VM t s)`,
-  -- and we unsafely coerce it to `forall s'. ST s' (VM t s)`,
-  -- which is exactly what `runST` expects.
-  return $ \x -> runST (unsafeCoerce $ execStateT (dispatcherLoop blockMap) x)
-   where extractCode (RuntimeCode (ConcreteRuntimeCode ops)) = ops
-         extractCode _ = error "Expected ConcreteRuntimeCode"
+  writeFile hsPath (generateHaskellCode cfg)
 
-type BasicBlockRange = (Int, Int)
-
--- | Split bytecode into basic blocks with their ranges, properly disassembling first.
-splitBasicBlocks :: BS.ByteString -> [(BasicBlockRange, [GenericOp Word8])]
-splitBasicBlocks bytecode =
-  let ops = disassemble bytecode
-      blocks = splitBasicBlocks' ops
-      -- Filter out any empty blocks that might be generated by the splitting logic.
-      nonEmptyBlocks = filter (not . null) blocks
-      -- Calculate ranges based on the actual byte positions in original bytecode
-      ranges = calculateRanges ops nonEmptyBlocks
-  in zip ranges nonEmptyBlocks
-
--- | Disassemble bytecode into a list of opcodes with their byte positions
-disassemble :: BS.ByteString -> [(Int, GenericOp Word8)]
-disassemble bs = disassemble' (BS.unpack bs) 0
-  where
-    disassemble' [] _ = []
-    disassemble' (b:rest) pos =
-      let op = getOp b
-          size = opcodeByteSize op
-          remaining = drop (size - 1) rest  -- Skip the data bytes for PUSH instructions
-      in (pos, op) : disassemble' remaining (pos + size)
-
--- | Calculate the byte size of an opcode
-opcodeByteSize :: GenericOp Word8 -> Int
-opcodeByteSize (OpPush n) = fromIntegral n + 1  -- n data bytes + 1 opcode byte
-opcodeByteSize _          = 1
-
--- | Calculate byte ranges for basic blocks in the original bytecode
-calculateRanges :: [(Int, GenericOp Word8)] -> [[GenericOp Word8]] -> [BasicBlockRange]
-calculateRanges _ blocks =
-  let blockSizes = map (sum . map opcodeByteSize) blocks
-      starts = scanl (+) 0 blockSizes
-  in zip starts (tail starts)
-
--- | The core function to split opcodes into a list of basic blocks.
-splitBasicBlocks' :: [(Int, GenericOp Word8)] -> [[GenericOp Word8]]
-splitBasicBlocks' posOps =
-  let ops = map snd posOps  -- Extract just the opcodes for splitting logic
-  in splitBasicBlocks'' ops
-
-splitBasicBlocks'' :: [GenericOp Word8] -> [[GenericOp Word8]]
-splitBasicBlocks'' [] = []
-splitBasicBlocks'' ops = let (block, rest) = takeBasicBlock ops
-                         in block : splitBasicBlocks'' rest
-
--- | Take one basic block from the front of the opcode list
-takeBasicBlock :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
-takeBasicBlock [] = ([], [])
-takeBasicBlock ops =
-    if isLeaderOp (head ops)
-    then takeBlockStartingWithLeader ops
-    else takeBlockWithoutLeader ops
-
--- | Take a block starting with a leader until a terminator or next leader
-takeBlockStartingWithLeader :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
-takeBlockStartingWithLeader [] = ([], [])
-takeBlockStartingWithLeader (leader:rest) =
-    let (block, remaining) = takeUntilTerminatorOrLeader rest
-    in ([leader] ++ block, remaining)
-
--- | Take a block not starting with a leader until a terminator or next leader
-takeBlockWithoutLeader :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
-takeBlockWithoutLeader ops = takeUntilTerminatorOrLeader ops
-
--- | Take opcodes until hitting a terminator (inclusive) or leader (exclusive)
-takeUntilTerminatorOrLeader :: [GenericOp Word8] -> ([GenericOp Word8], [GenericOp Word8])
-takeUntilTerminatorOrLeader [] = ([], [])
-takeUntilTerminatorOrLeader (op:rest)
-    | isTerminatorOp op = ([op], rest)  -- Include terminator, stop here
-    | isLeaderOp op = ([], op:rest)     -- Don't include leader, it starts next block
-    | otherwise =
-        let (block, remaining) = takeUntilTerminatorOrLeader rest
-        in (op:block, remaining)
-
--- | Identifies opcodes that *start* a new basic block.
-isLeaderOp :: GenericOp Word8 -> Bool
-isLeaderOp OpJumpdest = True
-isLeaderOp _         = False
-
--- | Identifies opcodes that *end* a basic block.
-isTerminatorOp :: GenericOp Word8 -> Bool
-isTerminatorOp OpJump   = True
-isTerminatorOp OpJumpi  = True
-isTerminatorOp OpStop   = True
-isTerminatorOp OpRevert = True
-isTerminatorOp OpReturn = True
--- Note: Other terminators like SELFDESTRUCT or INVALID could be added here.
-isTerminatorOp _        = False
+  f <- dynCompileAndRun hsPath "runBlock_0"
+  return $ \x -> runST (unsafeCoerce $ execStateT f x)
+  where extractCode (RuntimeCode (ConcreteRuntimeCode ops)) = ops
+        extractCode _ = error "Expected ConcreteRuntimeCode"
 
 --------------------------------------------------------------------------------
 -- | Use GHC API to Compile and Run the Generated Code
@@ -307,8 +453,8 @@ neededExtensionFlags =
     , DisambiguateRecordFields
     ]
 
-dynCompileAndRun :: forall t s. FilePath -> [String] -> IO [StateT (VM t s) (ST s) ()]
-dynCompileAndRun filePath bbFuncNames = runGhc (Just libdir) $ do
+dynCompileAndRun :: forall t s. FilePath -> String -> IO (StateT (VM t s) (ST s) ())
+dynCompileAndRun filePath startBlockName = runGhc (Just libdir) $ do
   dflags0 <- getSessionDynFlags
   dflags1 <- updateDynFlagsWithStackDB dflags0
   let dflags = foldl xopt_set dflags1 neededExtensionFlags
@@ -320,52 +466,21 @@ dynCompileAndRun filePath bbFuncNames = runGhc (Just libdir) $ do
 
   target <- guessTarget filePath Nothing Nothing
   setTargets [target]
+  -- Compile the file with the GHC API.
   result <- load LoadAllTargets
   case result of
     Failed -> liftIO $ error "Failed to load targets"
     Succeeded -> return ()
 
   setContext [IIDecl $ simpleImportDecl (mkModuleName "Generated")]
+  liftIO $ putStrLn "Compilation successful, returning start function."
+  startBlock <- extractBasicBlockFunction startBlockName
 
-  -- Compile each basic block function
-  compiledBlocks <- mapM extractBasicBlockFunction bbFuncNames
-  liftIO $ putStrLn "Compilation successful, returning functions."
-  return compiledBlocks
+  return startBlock
 
  where
   extractBasicBlockFunction bbName = do
     value <- compileExpr ("Generated." ++ bbName)
     let specialized :: forall s1. StateT (VM t s) (ST s1) ()
         specialized = unsafeCoerce value
-    return specialized
-
--- This is the new, efficient execution loop (a trampoline).
--- It runs entirely within the StateT monad, never exiting until the VM halts.
-dispatcherLoop :: forall t s. IntMap (StateT (VM t s) (ST s) ()) -> StateT (VM t s) (ST s) ()
-dispatcherLoop blockMap = do
-  vm <- get
-  case vm.result of
-    -- Base case: The VM has halted. Stop the loop.
-    Just _ -> pure ()
-
-    -- Recursive step: The VM is still running.
-    Nothing -> do
-      let currentPc = fromIntegral vm.state.pc
-
-      case lookup currentPc blockMap of
-        -- Found a compiled block at the current PC.
-        Just blockAction -> do
-          -- Execute the action for this block. It will modify the VM state,
-          -- including changing the PC for the next jump.
-          blockAction
-          -- Loop to the next block without exiting the monad.
-          dispatcherLoop blockMap
-
-        -- No block starts at the current PC.
-        Nothing ->
-          -- This is an invalid jump. Modify the VM state to set the error
-          -- and the loop will terminate on the next iteration.
-          if (vm.state.pc >= opslen vm.state.code) then
-            error $ "Invalid jump destination: " ++ show vm.state.pc
-          else
-            modify' (\v -> v { result = Just (VMFailure BadJumpDestination) })
+    return specialized
\ No newline at end of file

From 4ab3b8b2a1fc9b30b988d76c79775608b5b72309 Mon Sep 17 00:00:00 2001
From: gustavo-grieco <gustavo.grieco+github@gmail.com>
Date: Sun, 6 Jul 2025 11:46:28 +0200
Subject: [PATCH 11/11] experimented a bit with opcodes

---
 src/EVM/Futamura.hs |  35 +++++++----
 src/EVM/Opcodes.hs  | 141 ++++++++++++++++++++++++++++++++------------
 2 files changed, 128 insertions(+), 48 deletions(-)

diff --git a/src/EVM/Futamura.hs b/src/EVM/Futamura.hs
index 73ec818d0..74d87cd3e 100644
--- a/src/EVM/Futamura.hs
+++ b/src/EVM/Futamura.hs
@@ -25,6 +25,7 @@ import GHC.Paths (libdir)
 import GHC.LanguageExtensions.Type (Extension(..))
 import GHC.Driver.Session --(PackageFlag(..), PackageArg(..), ModRenaming(..), PackageDBFlag(..), PkgDbRef(..), xopt_set)
 import GHC.Driver.Monad (Ghc)
+import GHC.Driver.Flags (DumpFlag(..))
 
 import EVM.Opcodes (opcodesImpl)
 import EVM (currentContract, opslen)
@@ -88,7 +89,7 @@ generateHaskellCode cfg =
     , "import Data.ByteString qualified as BS"
     , "import Data.Vector qualified as V"
     , ""
-    , "import EVM hiding (stackOp2)"
+    , "import EVM hiding (stackOp2, next)"
     , "import EVM.Types"
     , "import EVM.Op"
     , "import EVM.Expr qualified as Expr"
@@ -114,7 +115,7 @@ genBasicBlockImpl cfg block =
     successorStmt = "  " ++ genSuccessorDispatch cfg block
   in
     unlines $
-      [ "{-# INLINE " ++ funcName ++ " #-}",
+      [ --"{-# INLINE " ++ funcName ++ " #-}",
         funcName ++ " :: StateT (VM Concrete s) (ST s) ()",
         funcName ++ " = do"
       ] ++ opCodeStmts ++ [successorStmt]
@@ -365,12 +366,12 @@ filterDataSection cfg =
 
 genOpImpl :: (String, String, String, String, Bool) -> String
 genOpImpl (opName, opParams, typeSig, src, True) =
-  "{-# INLINE runOpcode" ++ opName ++ " #-}\n" ++
+  --"{-# INLINE runOpcode" ++ opName ++ " #-}\n" ++
   "runOpcode" ++ opName ++ " :: " ++ typeSig ++ "\n" ++
   "runOpcode" ++ opName ++ opParams ++ " = " ++ src ++ "\n"
 
 genOpImpl (opName, opParams, typeSig, src, False) =
-  "{-# INLINE " ++ opName ++ " #-}\n" ++
+  --"{-# INLINE " ++ opName ++ " #-}\n" ++
   opName ++ " :: " ++ typeSig ++ "\n" ++
   opName ++ opParams ++ " = " ++ src ++ "\n"
 
@@ -382,12 +383,12 @@ checkIfVmResulted op =
   "     Just r -> return ()"
 
 genOp :: GenericOp Word8 -> String
-genOp (OpPush0)   = "let ?op = 1 in runOpcodePush0"
-genOp (OpRevert)  = "let ?op = 1 in runOpcodeRevert"
-genOp (OpStop)    = "let ?op = 1 in runOpcodeStop"
-genOp (OpAdd)     = "let ?op = 1 in runOpcodeAdd"
-genOp (OpDup i)   = "let ?op = 1 in runOpcodeDup (" ++ show i ++ " :: Int)"
-genOp (OpSwap i)  = "let ?op = opToWord8(OpSwap " ++ show i ++") in runOpcodeSwap (" ++ show i ++ " :: Int)"
+genOp (OpPush0)   = "let ?op = opToWord8(OpPush0) in runOpcodePush0"
+genOp (OpRevert)  = "let ?op = opToWord8(OpRevert) in runOpcodeRevert"
+genOp (OpStop)    = "let ?op = opToWord8(OpStop) in runOpcodeStop"
+genOp (OpAdd)     = "let ?op = opToWord8(OpAdd) in runOpcodeAdd"
+genOp (OpDup i)   = "let ?op = opToWord8(OpDup " ++ show i ++ ") in runOpcodeDup (" ++ show i ++ " :: Int)"
+genOp (OpSwap i)  = "let ?op = opToWord8(OpSwap " ++ show i ++ ") in runOpcodeSwap (" ++ show i ++ " :: Int)"
 genOp (OpMul)     = "let ?op = opToWord8(OpMul) in runOpcodeMul"
 genOp (OpSub)     = "let ?op = opToWord8(OpSub) in runOpcodeSub"
 genOp (OpDiv)     = "let ?op = opToWord8(OpDiv) in runOpcodeDiv"
@@ -451,13 +452,25 @@ neededExtensionFlags =
     , FlexibleInstances
     , ConstraintKinds
     , DisambiguateRecordFields
+    , MonoLocalBinds
     ]
 
+usefulDumpFlags :: [DumpFlag]
+usefulDumpFlags =
+    [ Opt_D_dump_simpl]
+
+usefulGeneralFlags :: [GeneralFlag]
+usefulGeneralFlags =
+    [ Opt_DumpToFile ]
+
 dynCompileAndRun :: forall t s. FilePath -> String -> IO (StateT (VM t s) (ST s) ())
 dynCompileAndRun filePath startBlockName = runGhc (Just libdir) $ do
   dflags0 <- getSessionDynFlags
   dflags1 <- updateDynFlagsWithStackDB dflags0
-  let dflags = foldl xopt_set dflags1 neededExtensionFlags
+
+  let dflags2 = foldl dopt_set dflags1 usefulDumpFlags
+  let dflags3 = foldl gopt_set dflags2 usefulGeneralFlags
+  let dflags = foldl xopt_set dflags3 neededExtensionFlags
   _ <- setSessionDynFlags $ updOptLevel 2 $ dflags {
     language = Just GHC2021,
     verbosity = 1,
diff --git a/src/EVM/Opcodes.hs b/src/EVM/Opcodes.hs
index 74a5fdd03..5ab6c8ea2 100644
--- a/src/EVM/Opcodes.hs
+++ b/src/EVM/Opcodes.hs
@@ -10,7 +10,7 @@ import Optics.Operators.Unsafe
 
 
 import Control.Monad.ST (ST)
-import Control.Monad.State.Strict (StateT, get, gets)
+import Control.Monad.State.Strict (StateT, get, put, gets)
 import Witch.From (From)
 import Witch (into, tryInto)
 import Data.Word (Word8)
@@ -23,18 +23,41 @@ import EVM.FeeSchedule (FeeSchedule (..))
 import EVM.Expr qualified as Expr
 import EVM.Effects (defaultConfig, maxDepth)
 
+--{-# INLINE modifyState #-}
+--modifyState :: (FrameState t s -> FrameState t s) -> VM t s -> VM t s
+--modifyState f vm = vm { state = f (vm.state) }
+
 runOpcodeAdd :: (VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()
 runOpcodeAdd = do
   vm <- get
-  let
-    FeeSchedule {..} = vm.block.schedule
-  stackOp2 g_verylow Expr.add
+  let FeeSchedule {..} = vm.block.schedule
+  let stk = vm.state.stack
+  case stk of
+    x:y:xs -> burn g_verylow $ do
+      next
+      vm' <- get
+      let add (Lit a) (Lit b) = Lit (a + b)
+          add a b = Expr.add a b
+      put $ modifyState (vm'.state { stack = add x y : xs }) vm'
+    _ -> underrun
+  where modifyState :: FrameState t s -> VM t s -> VM t s
+        modifyState st vm = vm { state = st }
 
 runOpcodeAddSrc :: String
 runOpcodeAddSrc = "do\n\
 \  vm <- get\n\
 \  let FeeSchedule {..} = vm.block.schedule\n\
-\  stackOp2 g_verylow Expr.add"
+\  let stk = vm.state.stack\n\
+\  case stk of\n\
+\    x:y:xs -> burn g_verylow $ do\n\
+\      next\n\
+\      vm' <- get\n\
+\      let add (Lit a) (Lit b) = Lit (a + b)\n\
+\          add a b = Expr.add a b\n\
+\      put $ modifyState (vm'.state { stack = add x y : xs }) vm'\n\
+\    _ -> underrun\n\
+\  where modifyState :: FrameState t s -> VM t s -> VM t s\n\
+\        modifyState st vm = vm { state = st }"
 
 runOpcodeAddType :: String
 runOpcodeAddType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
@@ -50,7 +73,17 @@ runOpcodeMulSrc :: String
 runOpcodeMulSrc = "do\n\
 \  vm <- get\n\
 \  let FeeSchedule {..} = vm.block.schedule\n\
-\  stackOp2 g_low Expr.mul"
+\  let stk = vm.state.stack\n\
+\  case stk of\n\
+\    x:y:xs -> burn g_low $ do\n\
+\      next\n\
+\      vm' <- get\n\
+\      let f (Lit a) (Lit b) = Lit (a * b)\n\
+\          f a b = Expr.mul a b\n\
+\      put $ modifyState (vm'.state { stack = f x y : xs }) vm'\n\
+\    _ -> underrun\n\
+\  where modifyState :: FrameState t s -> VM t s -> VM t s\n\
+\        modifyState st vm = vm { state = st }"
 
 runOpcodeMulType :: String
 runOpcodeMulType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
@@ -66,7 +99,17 @@ runOpcodeSubSrc :: String
 runOpcodeSubSrc = "do\n\
 \  vm <- get\n\
 \  let FeeSchedule {..} = vm.block.schedule\n\
-\  stackOp2 g_verylow Expr.sub"
+\  let stk = vm.state.stack\n\
+\  case stk of\n\
+\    x:y:xs -> burn g_low $ do\n\
+\      next\n\
+\      vm' <- get\n\
+\      let f (Lit a) (Lit b) = Lit (a - b)\n\
+\          f a b = Expr.sub a b\n\
+\      put $ modifyState (vm'.state { stack = f x y : xs }) vm'\n\
+\    _ -> underrun\n\
+\  where modifyState :: FrameState t s -> VM t s -> VM t s\n\
+\        modifyState st vm = vm { state = st }"
 
 runOpcodeSubType :: String
 runOpcodeSubType = "(VMOps t, ?op::Word8) => StateT (VM t s) (ST s) ()"
@@ -111,26 +154,26 @@ runOpcodeDup i = do
   let
     stk  = vm.state.stack
     FeeSchedule {..} = vm.block.schedule
-  case preview (ix (into i - 1)) stk of
-    Nothing -> underrun
-    Just y ->
-      limitStack 1 $
-        burn g_verylow $ do
-          next
-          pushSym y
+  let remainingStack = drop (into i - 1) stk
+  case remainingStack of
+    [] -> underrun
+    (x:_) -> limitStack 1 $
+      burn g_verylow $ do
+        next
+        pushSym x
 
 runOpcodeDupSrc :: String
 runOpcodeDupSrc = "do\n\
-\  vm <- get\n\
-\  let stk = vm.state.stack\n\
-\  let FeeSchedule {..} = vm.block.schedule\n\
-\  case preview (ix (into i - 1)) stk of\n\
-\    Nothing -> underrun\n\
-\    Just y ->\n\
-\      limitStack 1 $\n\
-\        burn g_verylow $ do\n\
-\          next\n\
-\          pushSym y"
+\ vm <- get\n\
+\ let stk = vm.state.stack\n\
+\ let FeeSchedule {..} = vm.block.schedule\n\
+\ let remainingStack = drop (into i - 1) stk\n\
+\ case remainingStack of\n\
+\   [] -> underrun\n\
+\   (x:_) -> limitStack 1 $\n\
+\     burn g_verylow $ do\n\
+\       next\n\
+\       pushSym x"
 
 runOpcodeDupType :: String
 runOpcodeDupType = "(From source Int, VMOps t, ?op::Word8) => source -> StateT (VM t s) (ST s) ()"
@@ -138,31 +181,37 @@ runOpcodeDupType = "(From source Int, VMOps t, ?op::Word8) => source -> StateT (
 runOpcodeSwap :: (?op::Word8, VMOps t, From source Int) => source -> StateT (VM t s) (ST s) ()
 runOpcodeSwap i = do
   vm <- get
-  let
-    stk  = vm.state.stack
-    FeeSchedule {..} = vm.block.schedule
-  if length stk < (into i) + 1
-    then underrun
-    else
+  let stk = vm.state.stack
+  let FeeSchedule {..} = vm.block.schedule
+  case (stk ^? ix_i, stk ^? ix_0) of
+    (Just ei, Just e0) ->
       burn g_verylow $ do
         next
         zoom (#state % #stack) $ do
-          assign (ix 0) (stk ^?! ix (into i))
-          assign (ix (into i)) (stk ^?! ix 0)
+          ix_i .= e0
+          ix_0 .= ei
+    _ -> underrun
+  where
+    (ix_i, ix_0) = (ix (into i), ix 0)
+  --where modifyState :: FrameState t s -> VM t s -> VM t s
+  --      modifyState st vm = vm { state = st }
 
 runOpcodeSwapSrc :: String
 runOpcodeSwapSrc = "do\n\
 \  vm <- get\n\
 \  let stk = vm.state.stack\n\
 \  let FeeSchedule {..} = vm.block.schedule\n\
-\  if length stk < (into i) + 1\n\
-\    then underrun\n\
-\    else\n\
+\  case (stk ^? ix_i, stk ^? ix_0) of\n\
+\    (Just ei, Just e0) ->\n\
 \      burn g_verylow $ do\n\
 \        next\n\
 \        zoom (#state % #stack) $ do\n\
-\          assign (ix 0) (stk ^?! ix (into i))\n\
-\          assign (ix (into i)) (stk ^?! ix 0)"
+\          ix_i .= e0\n\
+\          ix_0 .= ei\n\
+\    _ -> underrun\n\
+\  where\n\
+\    (ix_i, ix_0) = (ix (into i), ix 0)\n"
+
 
 runOpcodeSwapType :: String
 runOpcodeSwapType = "(?op::Word8, VMOps t, From source Int) => source -> StateT (VM t s) (ST s) ()"
@@ -517,6 +566,23 @@ runOpcodeStackOp2Src =
 runOpcodeStackOp2Type :: String
 runOpcodeStackOp2Type = "(?op :: Word8, VMOps t) => Word64 -> (Expr EWord -> Expr EWord -> Expr EWord) -> EVM t s ()"
 
+nextFast :: (?op :: Word8) => EVM t s ()
+nextFast = do
+  vm <- get
+  put $ modifyState (vm.state { pc = vm.state.pc + fromIntegral (opSize ?op) }) vm
+  where modifyState :: FrameState t s -> VM t s -> VM t s
+        modifyState st vm = vm { state = st }
+
+runOpcodeNextSrc :: String
+runOpcodeNextSrc = "do\n\
+\  vm <- get\n\
+\  put $ modifyState (vm.state { pc = vm.state.pc + fromIntegral (opSize ?op) }) vm\n\
+\  where modifyState :: FrameState t s -> VM t s -> VM t s\n\
+\        modifyState st vm = vm { state = st }"
+
+runOpcodeNextType :: String
+runOpcodeNextType = "(?op :: Word8) => EVM t s ()"
+
 opcodesImpl :: [(String, String, String, String, Bool)]
 opcodesImpl =
   [
@@ -541,4 +607,5 @@ opcodesImpl =
   , ("Jumpdest", "", runOpcodeJumpdestType, runOpcodeJumpdestSrc, True)
   , ("Slt", "", runOpcodeSltType, runOpcodeSltSrc, True)
   , ("stackOp2", " cost f", runOpcodeStackOp2Type, runOpcodeStackOp2Src, False)
+  , ("next", "", runOpcodeNextType, runOpcodeNextSrc, False)
   ]