packages feed

evm-opcodes (empty) → 0.1.0

raw patch · 12 files changed

+1654/−0 lines, 12 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, data-dword, evm-opcodes, hedgehog, hspec, tasty, tasty-discover, tasty-hedgehog, tasty-hspec, text

Files

+ LICENSE view
@@ -0,0 +1,7 @@+Copyright 2018-2021 Simon Shine++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,140 @@+# evm-opcodes++[![Haskell CI Status](https://github.com/sshine/evm-opcodes/workflows/Haskell%20CI/badge.svg)](https://github.com/sshine/evm-opcodes/actions?query=workflow%3A%22Haskell+CI%22)++This Haskell library provides opcode types for the Ethereum Virtual Machine (EVM).++The library has two purposes:++ - Provide interface between EVM-related libraries: Lower cost of interoperability.+ - Provide easy access to labelled jumps. Labelled jumps are most useful when+   generating EVM code, but actual EVM `jump` instructions pop the destination+   address from the stack.++The library has one parameterised type, `Opcode' j` where `j` is the annotation+for the jump-related instructions `JUMP`, `JUMPI` and `JUMPDEST`, and it has+three concrete variants:++ - `type Opcode = Opcode' ()`+ - `type PositionalOpcode = Opcode' Word`+ - `type LabelledOpcode = Opcode' Text`++The library has a fixpoint algorithm that translates labelled jumps into+positional jumps, and it has another function that translates those positional+jumps into plain EVM opcodes where a constant is pushed before a jump is made.++## Library conventions++When the documentation refers to a lowercase opcode (e.g. `push1`), then that+means the EVM opcode. When the documentation instead refers to an uppercase+opcode (e.g. `PUSH`), then that refers to the Haskell data constructor.++While `dup1`-`dup16`, `swap1`-`swap16` and `log1`-`log4` were implemented using+the data constructors `DUP`, `SWAP` and `LOG` that are not ergonomic to use but+convenient for the library maintainer, pattern synonyms were made:++ - `DUP1`, `DUP2`, ..., `DUP16`+ - `SWAP1`, `SWAP2`, ..., `SWAP16`+ - `LOG1`, `LOG2`, `LOG3`, `LOG4`++When pushing a constant to the stack, EVM uses `push1`, `push2`, ..., `push32`+where the number 1-32 refers to how many bytes the constant occupies. Instead+of having 32 unique push commands, this library has a single `PUSH !Word256`+constructor that serializes to the right `push1`, `push2`, etc.++## Example++Imagine translating the following C program to EVM opcodes:++```+int x = 1;+while (x != 0) { x *= 2 };+```++Since EVM is stack-based, let's put `x` on the stack.++```haskell+λ> import EVM.Opcode+λ> import EVM.Opcode.Labelled as L+λ> import EVM.Opcode.Positional as P++λ> let opcodes = [PUSH 1,JUMPDEST "loop",DUP1,ISZERO,JUMPI "end",PUSH 2,MUL,JUMP "loop",JUMPDEST "end"]++λ> L.translate opcodes+Right [PUSH 1,JUMPDEST 2,DUP1,ISZERO,JUMPI 14,PUSH 2,MUL,JUMP 2,JUMPDEST 14]++λ> P.translate <$> L.translate opcodes+Right [PUSH 1,JUMPDEST,DUP1,ISZERO,PUSH 14,JUMPI,PUSH 2,MUL,PUSH 2,JUMP,JUMPDEST]++λ> fmap opcodeText . P.translate <$> L.translate opcodes+Right ["push1 1","jumpdest","dup1","iszero","push1 14","jumpi","push1 2","mul","push1 2","jump","jumpdest"]+```++## Accounts for size of `PUSH`es when doing absolute jumps++EVM's `jump` and `jumpi` instructions are parameterless. Instead they pop and+jump to the address on the top of the stack. In order to perform absolute jumps+in the code, it is necessary to `PUSH` an address on the stack first.  This is+inconvenient, and so `PositionalOpcode` and `LabelledOpcode` are easier to use.++But what's more inconvenient is what happens to the offset of an absolute jump+when the address being jumped to crosses a boundary where its byte index can no+longer be represented by the same amount of bytes.++Take for example this EVM code:++```+0x00: push1 255+0x02: jump+0x03: stop+0x04: stop+0x05: stop+...+0xfe: stop+0xff: jumpdest+```++which can be represented with the following `LabelledOpcode`:++```haskell+λ> import EVM.Opcode+λ> import EVM.Opcode.Labelled as L+λ> import EVM.Opcode.Positional as P++λ> let opcodes = [JUMP "skip"] <> replicate 252 STOP <> [JUMPDEST "skip"]+λ> fmap (fmap opcodeText . P.translate) (L.translate opcodes)+Right ["push1 255","jump","stop","stop","stop",...,"jumpdest"]+```++Note especially the byte size of a `PUSH 255` vs. a `PUSH 256`:++```haskell+λ> opcodeSize (PUSH 255)+2+λ> opcodeSize (PUSH 256)+3+```++Then add another one-byte opcode between the `jump` and the `jumpdest`:++```haskell+λ> let opcodes = [JUMP "skip"] <> replicate 253 STOP <> [JUMPDEST "skip"]+λ> fmap (fmap opcodeText . P.translate) (L.translate opcodes)+Right ["push2 257","jump","stop","stop","stop",...,"jumpdest"]+```++Even though one byte was added, because the address of `jumpdest` is now+greater than 255, all references to it now take more than 2 bytes. Concretely,+one reference went from 2 bytes to 3 bytes, or rather, one `JUMP "skip"` became+a `push2 257` instead of a `push1 255`. And if there were many such `jump`s,+this amounts to a bit of book-keeping.++This happens at subsequent boundaries as well. While this library handles each+boundary the same way, it is unlikely to have EVM bytecode of more than a few+kilobytes at present time.++```haskell+λ> let opcodes = [JUMP "skip"] <> replicate 65532 STOP <> [JUMPDEST "skip"]+λ> fmap (fmap opcodeText . P.translate) (L.translate opcodes)+Right ["push3 65537","jump","stop","stop","stop",...,"jumpdest"]+```
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ evm-opcodes.cabal view
@@ -0,0 +1,71 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           evm-opcodes+version:        0.1.0+synopsis:       Opcode types for Ethereum Virtual Machine (EVM)+description:    This library provides opcode types for the Ethereum Virtual Machine.+category:       Ethereum, Finance, Network+homepage:       https://github.com/sshine/evm-opcodes+bug-reports:    https://github.com/sshine/evm-opcodes/issues+author:         Simon Shine+maintainer:     shreddedglory@gmail.com+copyright:      2020 Simon Shine+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/sshine/evm-opcodes++library+  exposed-modules:+      EVM.Opcode+      EVM.Opcode.Internal+      EVM.Opcode.Positional+      EVM.Opcode.Labelled+      EVM.Opcode.Traversal+  other-modules:+      Paths_evm_opcodes+  hs-source-dirs:+      src+  ghc-options: -Wall -Wnoncanonical-monad-instances -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >=4.12 && <4.16+    , bytestring >=0.10 && <0.12+    , cereal ==0.5.*+    , containers ==0.6.*+    , data-dword ==0.3.*+    , text ==1.2.*+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      OpcodeGenerators+      OpcodeTest+      Paths_evm_opcodes+  hs-source-dirs:+      test+  build-depends:+      base >=4.12 && <4.16+    , bytestring >=0.10 && <0.12+    , cereal ==0.5.*+    , containers ==0.6.*+    , data-dword ==0.3.*+    , evm-opcodes+    , hedgehog+    , hspec+    , tasty+    , tasty-discover+    , tasty-hedgehog+    , tasty-hspec+    , text ==1.2.*+  default-language: Haskell2010
+ src/EVM/Opcode.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-}++-- |+-- Module: EVM.Opcode+-- Copyright: 2018 Simon Shine+-- Maintainer: Simon Shine <shreddedglory@gmail.com>+-- License: MIT+--+-- This module exposes the 'Opcode' type for expressing Ethereum VM opcodes+-- as extracted from the Ethereum Yellow Paper with amendments from various+-- EIPs. The Yellow Paper is available at:+--+-- https://ethereum.github.io/yellowpaper/paper.pdf+--+-- The list of opcodes is found in appendix H.2.+--+-- But it is not always up-to-date, so keeping track of EIPs that add or+-- modify instructions is necessary. See comments in this module for the+-- references to these additions.++module EVM.Opcode +  ( -- * Types+    Opcode+  , Opcode'(..)+  , OpcodeSpec(..)+  , opcodeSpec++    -- ** Pseudo-instructions and helper functions+  , jump+  , jumpi+  , jumpdest++    -- Extraction+  , jumpAnnot+  , jumpdestAnnot++    -- ** Conversion and printing+  , concrete+  , opcodeText+  , opcodeSize+  , toHex+  , pack+  , toBytes++    -- ** Parse and validate instructions+  , isDUP+  , isSWAP+  , isLOG+  , isPUSH+  , readDUP+  , readSWAP+  , readLOG+  , readPUSH+  , readOp++    -- ** Pattern synonyms+  , pattern DUP1,  pattern DUP2,  pattern DUP3,  pattern DUP4+  , pattern DUP5,  pattern DUP6,  pattern DUP7,  pattern DUP8+  , pattern DUP9,  pattern DUP10, pattern DUP11, pattern DUP12+  , pattern DUP13, pattern DUP14, pattern DUP15, pattern DUP16++  , pattern SWAP1,  pattern SWAP2,  pattern SWAP3,  pattern SWAP4+  , pattern SWAP5,  pattern SWAP6,  pattern SWAP7,  pattern SWAP8+  , pattern SWAP9,  pattern SWAP10, pattern SWAP11, pattern SWAP12+  , pattern SWAP13, pattern SWAP14, pattern SWAP15, pattern SWAP16++  , pattern LOG0, pattern LOG1, pattern LOG2, pattern LOG3, pattern LOG4+  ) where++import Prelude hiding (LT, EQ, GT)++import           Control.Applicative ((<|>))+import           Control.Monad (guard)+import           Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import           Data.DoubleWord (Word256, fromHiAndLo)+import           Data.Maybe (isJust)+import qualified Data.Serialize.Get as Cereal+import           Data.String (IsString, fromString)+import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.List as List+import           Data.Word (Word8, Word64)+import           Text.Printf (printf)++import EVM.Opcode.Internal++-- | An 'Opcode' is a plain, parameterless Ethereum VM Opcode.+type Opcode = Opcode' ()++-- | Show 'PUSH' as the Haskell data constructor+instance {-# OVERLAPPING #-} Show Opcode where+  show (PUSH n) = "PUSH " <> show n+  show opcode = Text.unpack (Text.toUpper (opcodeText opcode))++-- | 'jump' is a plain parameterless 'Opcode'.+jump :: Opcode+jump = JUMP ()++-- | 'jumpi' is a plain parameterless 'Opcode'.+jumpi :: Opcode+jumpi = JUMPI ()++-- | 'jumpdest' is a plain parameterless 'Opcode'.+jumpdest :: Opcode+jumpdest = JUMPDEST ()++-- | Determine if a byte represents a 'DUP' opcode ('DUP1' -- 'DUP16').+isDUP  :: Word8 -> Bool+isDUP = isJust . readDUP++-- | Determine if a byte represents a 'SWAP' opcode ('SWAP1' -- 'SWAP16').+isSWAP  :: Word8 -> Bool+isSWAP = isJust . readSWAP++-- | Determine if a byte represents a 'LOG' opcode ('LOG1' -- 'LOG4').+isLOG  :: Word8 -> Bool+isLOG = isJust . readLOG++-- | Determine if a byte represents a 'PUSH' opcode.+isPUSH :: Word8 -> ByteString -> Bool+isPUSH b bs = isJust (readPUSH b bs)++-- | Read a 'DUP' opcode ('DUP1' -- 'DUP16') safely.+readDUP :: Word8 -> Maybe Opcode+readDUP b = do+  guard (b >= 0x80 && b <= 0x8f)+  pure (DUP (fromWord8 (b - 0x80)))++-- | Read a 'SWAP' opcode ('SWAP1' -- 'SWAP16') safely.+readSWAP :: Word8 -> Maybe Opcode+readSWAP b = do+  guard (b >= 0x90 && b <= 0x9f)+  pure (SWAP (fromWord8 (b - 0x90)))++-- | Read a 'LOG' opcode ('LOG1' -- 'LOG4') safely.+readLOG :: Word8 -> Maybe Opcode+readLOG b = do+  guard (b >= 0xa0 && b <= 0xa4)+  pure (LOG (fromWord8 (b - 0xa0)))++-- | Read a 'PUSH' opcode safely.+readPUSH :: Word8 -> ByteString -> Maybe Opcode+readPUSH b bs = do+  guard (b >= 0x60 && b <= 0x7f)+  let n = fromIntegral (b - 0x60 + 1)+  PUSH <$> word256 (BS.take n bs)++-- | Parse an 'Opcode' from a 'Word8'. In case of 'PUSH' instructions, read the+-- constant being pushed from a subsequent 'ByteString'.+readOp :: Word8 -> ByteString -> Maybe Opcode+readOp word bs+    = readDUP word+  <|> readSWAP word+  <|> readLOG word+  <|> readPUSH word bs+  <|> case word of+    -- 0s: Stop and Arithmetic Operations+    0x00 -> pure STOP+    0x01 -> pure ADD+    0x02 -> pure MUL+    0x03 -> pure SUB+    0x04 -> pure DIV+    0x05 -> pure SDIV+    0x06 -> pure MOD+    0x07 -> pure SMOD+    0x08 -> pure ADDMOD+    0x09 -> pure MULMOD+    0x0a -> pure EXP+    0x0b -> pure SIGNEXTEND++    -- 10s: Comparison & Bitwise Logic Operations+    0x10 -> pure LT+    0x11 -> pure GT+    0x12 -> pure SLT+    0x13 -> pure SGT+    0x14 -> pure EQ+    0x15 -> pure ISZERO+    0x16 -> pure AND+    0x17 -> pure OR+    0x18 -> pure XOR+    0x19 -> pure NOT+    0x1a -> pure BYTE+    0x1b -> pure SHL+    0x1c -> pure SHR+    0x1d -> pure SAR++    -- 20s: SHA3+    0x20 -> pure SHA3++    -- 30s: Environmental Information+    0x30 -> pure ADDRESS+    0x31 -> pure BALANCE+    0x32 -> pure ORIGIN+    0x33 -> pure CALLER+    0x34 -> pure CALLVALUE+    0x35 -> pure CALLDATALOAD+    0x36 -> pure CALLDATASIZE+    0x37 -> pure CALLDATACOPY+    0x38 -> pure CODESIZE+    0x39 -> pure CODECOPY+    0x3a -> pure GASPRICE+    0x3b -> pure EXTCODESIZE+    0x3c -> pure EXTCODECOPY+    0x3d -> pure RETURNDATASIZE+    0x3e -> pure RETURNDATACOPY+    0x3f -> pure EXTCODEHASH++    -- 40s: Block Information+    0x40 -> pure BLOCKHASH+    0x41 -> pure COINBASE+    0x42 -> pure TIMESTAMP+    0x43 -> pure NUMBER+    0x44 -> pure DIFFICULTY+    0x45 -> pure GASLIMIT+    0x46 -> pure CHAINID+    0x47 -> pure SELFBALANCE++    -- 50s: Stack, Memory, Storage and Flow Operations+    0x50 -> pure POP+    0x51 -> pure MLOAD+    0x52 -> pure MSTORE+    0x53 -> pure MSTORE8+    0x54 -> pure SLOAD+    0x55 -> pure SSTORE+    0x56 -> pure jump+    0x57 -> pure jumpi+    0x58 -> pure PC+    0x59 -> pure MSIZE+    0x5a -> pure GAS+    0x5b -> pure jumpdest++    -- f0s: System Operations+    0xf0 -> pure CREATE+    0xf1 -> pure CALL+    0xf2 -> pure CALLCODE+    0xf3 -> pure RETURN+    0xf4 -> pure DELEGATECALL+    0xf5 -> pure CREATE2+    0xfa -> pure STATICCALL+    0xfd -> pure REVERT+    0xfe -> pure INVALID+    0xff -> pure SELFDESTRUCT++    -- Unknown+    _    -> Nothing++-- | Get a 'Word256' from a 'ByteString'+--+-- Pads the ByteString with NULs up to 32 bytes.+word256 :: ByteString -> Maybe Word256+word256 = eitherToMaybe . getWord256 . padLeft 32+  where+    getWord256 :: ByteString -> Either String Word256+    getWord256 = Cereal.runGet $+      fromWord64s <$> Cereal.getWord64be+                  <*> Cereal.getWord64be+                  <*> Cereal.getWord64be+                  <*> Cereal.getWord64be++    fromWord64s :: Word64 -> Word64 -> Word64 -> Word64 -> Word256+    fromWord64s a b c d = fromHiAndLo (fromHiAndLo a b) (fromHiAndLo c d)++    padLeft :: Int -> ByteString -> ByteString+    padLeft n xs = BS.replicate (n - BS.length xs) 0 <> xs++    eitherToMaybe :: Either e a -> Maybe a+    eitherToMaybe = either (const Nothing) pure++-- | Show 'Opcode' as 'Text'.+opcodeText :: Opcode -> Text+opcodeText = opcodeName . opcodeSpec++-- | Calculate the size in bytes of an encoded opcode. The only 'Opcode'+-- that uses more than one byte is 'PUSH'. Sizes are trivially determined+-- for only 'Opcode' with unlabelled jumps, since we cannot know e.g. where+-- the label of a 'LabelledOpcode' points to before code generation has+-- completed.+opcodeSize :: Num i => Opcode -> i+opcodeSize (PUSH n) = List.genericLength . uncurry (:) $ push' n+opcodeSize _opcode = 1++-- | Convert a @['Opcode']@ to a string of ASCII hexadecimals.+toHex :: IsString s => [Opcode] -> s+toHex = fromString . List.concatMap (printf "%02x") . List.concatMap toBytes++-- | Convert a @['Opcode']@ to bytecode.+pack :: [Opcode] -> ByteString+pack = BS.pack . List.concatMap toBytes++-- | Convert an @'Opcode'@ to a @['Word8']@.+--+-- To convert many 'Opcode's to bytecode, use 'pack'.+toBytes :: Opcode -> [Word8]+toBytes (PUSH n) = uncurry (:) (push' n)+toBytes opcode = [ opcodeEncoding (opcodeSpec opcode) ]
+ src/EVM/Opcode/Internal.hs view
@@ -0,0 +1,505 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}++-- |+-- Module: EVM.Opcode.Internal+-- Copyright: 2018 Simon Shine+-- Maintainer: Simon Shine <shreddedglory@gmail.com>+-- License: MIT+--+-- This module exposes the 'Opcode'' abstract type.++module EVM.Opcode.Internal where++import Prelude hiding (LT, EQ, GT)++import           Control.Monad (void)+import           Data.Bits (shift)+import           Data.DoubleWord (Word256)+import           Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.List as List+import           Data.Word (Word8)++-- | An 'Opcode'' is an Ethereum VM Opcode with parameterised jumps.+--+-- For a plain opcode using the basic EVM stack-based jumps, use 'Opcode'+-- instead.+--+-- This type is used for defining and translating from annotated opcodes, e.g.+-- with labelled jumps.+data Opcode' j+  -- 0s: Stop and Arithmetic Operations+  = STOP              -- ^ 0x00+  | ADD               -- ^ 0x01+  | MUL               -- ^ 0x02+  | SUB               -- ^ 0x03+  | DIV               -- ^ 0x04+  | SDIV              -- ^ 0x05+  | MOD               -- ^ 0x06+  | SMOD              -- ^ 0x07+  | ADDMOD            -- ^ 0x08+  | MULMOD            -- ^ 0x09+  | EXP               -- ^ 0x0a+  | SIGNEXTEND        -- ^ 0x0b++  -- 10s: Comparison & Bitwise Logic Operations+  | LT                -- ^ 0x10+  | GT                -- ^ 0x11+  | SLT               -- ^ 0x12+  | SGT               -- ^ 0x13+  | EQ                -- ^ 0x14+  | ISZERO            -- ^ 0x15+  | AND               -- ^ 0x16+  | OR                -- ^ 0x17+  | XOR               -- ^ 0x18+  | NOT               -- ^ 0x19+  | BYTE              -- ^ 0x1a+  | SHL               -- ^ 0x1b, https://eips.ethereum.org/EIPS/eip-145+  | SHR               -- ^ 0x1c, https://eips.ethereum.org/EIPS/eip-145+  | SAR               -- ^ 0x1d, https://eips.ethereum.org/EIPS/eip-145++  -- 20s: SHA3+  | SHA3              -- ^ 0x20++  -- 30s: Environmental Information+  | ADDRESS           -- ^ 0x30+  | BALANCE           -- ^ 0x31+  | ORIGIN            -- ^ 0x32+  | CALLER            -- ^ 0x33+  | CALLVALUE         -- ^ 0x34+  | CALLDATALOAD      -- ^ 0x35+  | CALLDATASIZE      -- ^ 0x36+  | CALLDATACOPY      -- ^ 0x37+  | CODESIZE          -- ^ 0x38+  | CODECOPY          -- ^ 0x39+  | GASPRICE          -- ^ 0x3a+  | EXTCODESIZE       -- ^ 0x3b+  | EXTCODECOPY       -- ^ 0x3c+  | RETURNDATASIZE    -- ^ 0x3d, https://eips.ethereum.org/EIPS/eip-211+  | RETURNDATACOPY    -- ^ 0x3e, https://eips.ethereum.org/EIPS/eip-211+  | EXTCODEHASH       -- ^ 0x3f, https://eips.ethereum.org/EIPS/eip-1052++  -- 40s: Block Information+  | BLOCKHASH         -- ^ 0x40+  | COINBASE          -- ^ 0x41+  | TIMESTAMP         -- ^ 0x42+  | NUMBER            -- ^ 0x43+  | DIFFICULTY        -- ^ 0x44+  | GASLIMIT          -- ^ 0x45+  | CHAINID           -- ^ 0x46, https://eips.ethereum.org/EIPS/eip-1344+  | SELFBALANCE       -- ^ 0x47, https://eips.ethereum.org/EIPS/eip-1884++  -- 50s: Stack, Memory, Storage and Flow Operations+  | POP               -- ^ 0x50+  | MLOAD             -- ^ 0x51+  | MSTORE            -- ^ 0x52+  | MSTORE8           -- ^ 0x53+  | SLOAD             -- ^ 0x54+  | SSTORE            -- ^ 0x55+  | JUMP j            -- ^ 0x56+  | JUMPI j           -- ^ 0x57+  | PC                -- ^ 0x58+  | MSIZE             -- ^ 0x59+  | GAS               -- ^ 0x5a+  | JUMPDEST j        -- ^ 0x5b++  -- 60s & 70s: Push Operations+  | PUSH !Word256     -- ^ 0x60 - 0x7f (PUSH1 - PUSH32)+  | DUP !Ord16         -- ^ 0x80 - 0x8f ('DUP1' - 'DUP16')+  | SWAP !Ord16        -- ^ 0x90 - 0x9f ('SWAP1' - 'SWAP16')++  -- a0s: Logging Operations+  | LOG !Ord5         -- ^ 0xa0 - 0xa4 ('LOG0' - 'LOG4')++  -- f0s: System Operations+  | CREATE            -- ^ 0xf0+  | CALL              -- ^ 0xf1+  | CALLCODE          -- ^ 0xf2+  | RETURN            -- ^ 0xf3+  | DELEGATECALL      -- ^ 0xf4, https://eips.ethereum.org/EIPS/eip-7+  | CREATE2           -- ^ 0xf5, https://eips.ethereum.org/EIPS/eip-1014+  | STATICCALL        -- ^ 0xfa+  | REVERT            -- ^ 0xfd, https://eips.ethereum.org/EIPS/eip-140+  | INVALID           -- ^ 0xfe, https://eips.ethereum.org/EIPS/eip-141+  | SELFDESTRUCT      -- ^ 0xff, https://eips.ethereum.org/EIPS/eip-6+  deriving (Eq, Ord, Functor)++-- | Convert any @'Opcode'' a@ into an @'Opcode'' ()@.+concrete :: Opcode' a -> Opcode' ()+concrete = void++-- | Extract the @a@ from a @'JUMP' a@ or a @'JUMPI' a@.+jumpAnnot :: Opcode' a -> Maybe a+jumpAnnot = \case+  JUMP a -> Just a+  JUMPI a -> Just a+  _ -> Nothing++-- | Extract the @a@ from a @'JUMPDEST' a@.+jumpdestAnnot :: Opcode' a -> Maybe a+jumpdestAnnot = \case+  JUMPDEST a -> Just a+  _ -> Nothing++-- | Convert an 'Ord5' or an 'Ord16' to a 'Word8'.+toWord8 :: Enum e => e -> Word8+toWord8 = fromIntegral . fromEnum++-- | Convert a 'Word8' to an 'Ord5' or an 'Ord16'.+fromWord8 :: Enum e => Word8 -> e+fromWord8 = toEnum . fromIntegral++-- | Convenience type of cardinality 5 for 'LOG'.+data Ord5+  = Ord5_0+  | Ord5_1+  | Ord5_2+  | Ord5_3+  | Ord5_4+  deriving (Eq, Ord, Enum, Bounded)++-- | Convenience type of cardinality 16 for 'DUP' and 'SWAP'.+data Ord16+  = Ord16_1+  | Ord16_2+  | Ord16_3+  | Ord16_4+  | Ord16_5+  | Ord16_6+  | Ord16_7+  | Ord16_8+  | Ord16_9+  | Ord16_10+  | Ord16_11+  | Ord16_12+  | Ord16_13+  | Ord16_14+  | Ord16_15+  | Ord16_16+  deriving (Eq, Ord, Enum, Bounded)++-- | An 'OpcodeSpec' for a given 'Opcode' contains the numeric encoding of the+-- opcode, the number of items that this opcode removes from the stack (α),+-- and the number of items added to the stack (δ). These values are documented+-- in the Ethereum Yellow Paper.+--+-- Examples of 'OpcodeSpec's:+--+-- > --         Hex  α δ+-- > OpcodeSpec 0x01 2 1 "add"+-- > OpcodeSpec 0x60 0 1 "push1 255"+-- > OpcodeSpec 0x61 0 1 "push2 256"+data OpcodeSpec = OpcodeSpec+  { opcodeEncoding :: !Word8 -- ^ Numeric encoding of opcode+  , opcodeAlpha    :: !Word8 -- ^ Number of items opcode places on stack (α)+  , opcodeDelta    :: !Word8 -- ^ Number of items opcode removes from stack (δ)+  , opcodeName     :: !Text  -- ^ Printable name for opcode, e.g. @"add"@+  } deriving (Eq, Show)++-- | Given an 'Opcode'', produce its 'OpcodeSpec'.+--+-- For 'DUP', 'SWAP' and 'LOG' this depends on the specific variant, and for+-- 'PUSH' it depends on the size of the constant being pushed.+opcodeSpec :: Opcode' j -> OpcodeSpec+opcodeSpec opcode = case opcode of+  -- 0s: Stop and Arithmetic Operations+  --                   Hex  α δ+  STOP       -> OpcodeSpec 0x00 0 0 "stop"+  ADD        -> OpcodeSpec 0x01 2 1 "add"+  MUL        -> OpcodeSpec 0x02 2 1 "mul"+  SUB        -> OpcodeSpec 0x03 2 1 "sub"+  DIV        -> OpcodeSpec 0x04 2 1 "div"+  SDIV       -> OpcodeSpec 0x05 2 1 "sdiv"+  MOD        -> OpcodeSpec 0x06 2 1 "mod"+  SMOD       -> OpcodeSpec 0x07 2 1 "smod"+  ADDMOD     -> OpcodeSpec 0x08 3 1 "addmod"+  MULMOD     -> OpcodeSpec 0x09 3 1 "mulmod"+  EXP        -> OpcodeSpec 0x0a 2 1 "exp"+  SIGNEXTEND -> OpcodeSpec 0x0b 2 1 "signextend"++  -- 10s: Comparison & Bitwise Logic Operations+  --                Hex  α δ+  LT         -> OpcodeSpec 0x10 2 1 "lt"+  GT         -> OpcodeSpec 0x11 2 1 "gt"+  SLT        -> OpcodeSpec 0x12 2 1 "slt"+  SGT        -> OpcodeSpec 0x13 2 1 "sgt"+  EQ         -> OpcodeSpec 0x14 2 1 "eq"+  ISZERO     -> OpcodeSpec 0x15 1 1 "iszero"+  AND        -> OpcodeSpec 0x16 2 1 "and"+  OR         -> OpcodeSpec 0x17 2 1 "or"+  XOR        -> OpcodeSpec 0x18 2 1 "xor"+  NOT        -> OpcodeSpec 0x19 1 1 "not"+  BYTE       -> OpcodeSpec 0x1a 2 1 "byte"+  SHL        -> OpcodeSpec 0x1b 2 1 "shl"+  SHR        -> OpcodeSpec 0x1c 2 1 "shr"+  SAR        -> OpcodeSpec 0x1d 2 1 "sar"++  -- 20s: SHA3+  --               Hex  α δ+  SHA3       -> OpcodeSpec 0x20 2 1 "sha3"++  -- 30s: Environmental Information+  --     Opcode            Hex  α δ+  ADDRESS        -> OpcodeSpec 0x30 0 1 "address"+  BALANCE        -> OpcodeSpec 0x31 1 1 "balance"+  ORIGIN         -> OpcodeSpec 0x32 0 1 "origin"+  CALLER         -> OpcodeSpec 0x33 0 1 "caller"+  CALLVALUE      -> OpcodeSpec 0x34 0 1 "callvalue"+  CALLDATALOAD   -> OpcodeSpec 0x35 1 1 "calldataload"+  CALLDATASIZE   -> OpcodeSpec 0x36 0 1 "calldatasize"+  CALLDATACOPY   -> OpcodeSpec 0x37 3 0 "calldatacopy"+  CODESIZE       -> OpcodeSpec 0x38 0 1 "codesize"+  CODECOPY       -> OpcodeSpec 0x39 3 0 "codecopy"+  GASPRICE       -> OpcodeSpec 0x3a 0 1 "gasprice"+  EXTCODESIZE    -> OpcodeSpec 0x3b 1 1 "extcodesize"+  EXTCODECOPY    -> OpcodeSpec 0x3c 4 0 "extcodecopy"+  RETURNDATASIZE -> OpcodeSpec 0x3d 0 1 "returndatasize"+  RETURNDATACOPY -> OpcodeSpec 0x3e 3 0 "returndatacopy"+  EXTCODEHASH    -> OpcodeSpec 0x3f 1 1 "extcodehash"++  -- 40s: Block Information+  --                    Hex  α δ+  BLOCKHASH      -> OpcodeSpec 0x40 1 1 "blockhash"+  COINBASE       -> OpcodeSpec 0x41 0 1 "coinbase"+  TIMESTAMP      -> OpcodeSpec 0x42 0 1 "timestamp"+  NUMBER         -> OpcodeSpec 0x43 0 1 "number"+  DIFFICULTY     -> OpcodeSpec 0x44 0 1 "difficulty"+  GASLIMIT       -> OpcodeSpec 0x45 0 1 "gaslimit"+  CHAINID        -> OpcodeSpec 0x46 0 1 "chainid"+  SELFBALANCE    -> OpcodeSpec 0x47 0 1 "selfbalance"++  -- 50s: Stack, Memory, Storage and Flow Operations+  --                    Hex  α δ+  POP            -> OpcodeSpec 0x50 1 0 "pop"+  MLOAD          -> OpcodeSpec 0x51 1 1 "mload"+  MSTORE         -> OpcodeSpec 0x52 2 0 "mstore"+  MSTORE8        -> OpcodeSpec 0x53 2 0 "mstore8"+  SLOAD          -> OpcodeSpec 0x54 1 1 "sload"+  SSTORE         -> OpcodeSpec 0x55 2 0 "sstore"+  JUMP{}         -> OpcodeSpec 0x56 1 0 "jump"+  JUMPI{}        -> OpcodeSpec 0x57 2 0 "jumpi"+  PC             -> OpcodeSpec 0x58 0 1 "pc"+  MSIZE          -> OpcodeSpec 0x59 0 1 "msize"+  GAS            -> OpcodeSpec 0x5a 0 1 "gas"+  JUMPDEST{}     -> OpcodeSpec 0x5b 0 0 "jumpdest"++  -- 60s & 70s: Push Operations+  PUSH n ->+    let (pushHex, pushConst) = push' n+    in OpcodeSpec { opcodeEncoding = pushHex+                  , opcodeAlpha    = 0+                  , opcodeDelta    = 1+                  , opcodeName     = Text.concat+                    [ "push"+                    , Text.pack (show (List.length pushConst))+                    , " "+                    , Text.pack (show n) ]+                  }++  -- 80s: Duplication Operations (DUP)+  DUP i ->+    let wi = toWord8 i+    in OpcodeSpec { opcodeEncoding = 0x80 + wi+                  , opcodeAlpha    = wi + 1+                  , opcodeDelta    = wi + 2+                  , opcodeName     = "dup" <> Text.pack (show (wi + 1))+                  }++  -- 90s: Exchange operations (SWAP)+  SWAP i ->+    let wi = toWord8 i+    in OpcodeSpec { opcodeEncoding = 0x90 + wi+                  , opcodeAlpha    = wi + 1+                  , opcodeDelta    = wi + 1+                  , opcodeName     = "swap" <> Text.pack (show (wi + 1))+                  }++  -- a0s: Logging Operations (LOG)+  LOG i ->+    let wi = toWord8 i+    in OpcodeSpec { opcodeEncoding = 0xa0 + wi+                  , opcodeAlpha    = wi + 2+                  , opcodeDelta    = 0+                  , opcodeName     = "log" <> Text.pack (show wi)+                  }++  -- f0s: System Operations+  --                      Hex  α δ+  CREATE       -> OpcodeSpec 0xf0 3 1 "create"+  CALL         -> OpcodeSpec 0xf1 7 1 "call"+  CALLCODE     -> OpcodeSpec 0xf2 7 1 "callcode"+  RETURN       -> OpcodeSpec 0xf3 2 0 "return"+  DELEGATECALL -> OpcodeSpec 0xf4 6 1 "delegatecall"+  CREATE2      -> OpcodeSpec 0xf5 4 1 "create2"+  STATICCALL   -> OpcodeSpec 0xfa 6 1 "staticcall"+  REVERT       -> OpcodeSpec 0xfd 2 0 "revert"+  INVALID      -> OpcodeSpec 0xfe 0 0 "invalid" -- α, δ are ∅+  SELFDESTRUCT -> OpcodeSpec 0xff 1 0 "selfdestruct"++instance {-# OVERLAPPABLE #-} Show a => Show (Opcode' a) where+  show opcode = show (concrete opcode) <> showParam opcode+    where+      showParam (JUMP a) = " " <> show a+      showParam (JUMPI a) = " " <> show a+      showParam (JUMPDEST a) = " " <> show a+      showParam _opcode = ""++-- | Convert the constant argument of a 'PUSH' to the opcode encoding+-- (0x60--0x7f) and its constant split into 'Word8' segments.+push' :: Word256 -> (Word8, [Word8])+push' i | i < 256 = (0x60, [fromIntegral i])+push' i = (opcode + 1, arg <> [fromIntegral i])+  where (opcode, arg) = push' (i `shift` (-8))++-- | Use 'DUP1' instead of @'DUP' 'Ord16_1'@.+pattern DUP1 :: forall j. Opcode' j+pattern DUP1 = DUP Ord16_1++-- | Use 'DUP2' instead of @'DUP' 'Ord16_2'@.+pattern DUP2 :: forall j. Opcode' j+pattern DUP2 = DUP Ord16_2++-- | Use 'DUP3' instead of @'DUP' 'Ord16_3'@.+pattern DUP3 :: forall j. Opcode' j+pattern DUP3 = DUP Ord16_3++-- | Use 'DUP4' instead of @'DUP' 'Ord16_4'@.+pattern DUP4 :: forall j. Opcode' j+pattern DUP4 = DUP Ord16_4++-- | Use 'DUP5' instead of @'DUP' 'Ord16_5'@.+pattern DUP5 :: forall j. Opcode' j+pattern DUP5 = DUP Ord16_5++-- | Use 'DUP6' instead of @'DUP' 'Ord16_6'@.+pattern DUP6 :: forall j. Opcode' j+pattern DUP6 = DUP Ord16_6++-- | Use 'DUP7' instead of @'DUP' 'Ord16_7'@.+pattern DUP7 :: forall j. Opcode' j+pattern DUP7 = DUP Ord16_7++-- | Use 'DUP8' instead of @'DUP' 'Ord16_8'@.+pattern DUP8 :: forall j. Opcode' j+pattern DUP8 = DUP Ord16_8++-- | Use 'DUP9' instead of @'DUP' 'Ord16_9'@.+pattern DUP9 :: forall j. Opcode' j+pattern DUP9 = DUP Ord16_9++-- | Use 'DUP10' instead of @'DUP' 'Ord16_10'@.+pattern DUP10 :: forall j. Opcode' j+pattern DUP10 = DUP Ord16_10++-- | Use 'DUP11' instead of @'DUP' 'Ord16_11'@.+pattern DUP11 :: forall j. Opcode' j+pattern DUP11 = DUP Ord16_11++-- | Use 'DUP12' instead of @'DUP' 'Ord16_12'@.+pattern DUP12 :: forall j. Opcode' j+pattern DUP12 = DUP Ord16_12++-- | Use 'DUP13' instead of @'DUP' 'Ord16_13'@.+pattern DUP13 :: forall j. Opcode' j+pattern DUP13 = DUP Ord16_13++-- | Use 'DUP14' instead of @'DUP' 'Ord16_14'@.+pattern DUP14 :: forall j. Opcode' j+pattern DUP14 = DUP Ord16_14++-- | Use 'DUP15' instead of @'DUP' 'Ord16_15'@.+pattern DUP15 :: forall j. Opcode' j+pattern DUP15 = DUP Ord16_15++-- | Use 'DUP16' instead of @'DUP' 'Ord16_16'@.+pattern DUP16 :: forall j. Opcode' j+pattern DUP16 = DUP Ord16_16++-- | Use 'SWAP1' instead of @'SWAP' 'Ord16_1'@, etc.+pattern SWAP1 :: forall j. Opcode' j+pattern SWAP1 = SWAP Ord16_1++-- | Use 'SWAP2' instead of @'SWAP' 'Ord16_2'@, etc.+pattern SWAP2 :: forall j. Opcode' j+pattern SWAP2 = SWAP Ord16_2++-- | Use 'SWAP3' instead of @'SWAP' 'Ord16_3'@, etc.+pattern SWAP3 :: forall j. Opcode' j+pattern SWAP3 = SWAP Ord16_3++-- | Use 'SWAP4' instead of @'SWAP' 'Ord16_4'@, etc.+pattern SWAP4 :: forall j. Opcode' j+pattern SWAP4 = SWAP Ord16_4++-- | Use 'SWAP5' instead of @'SWAP' 'Ord16_5'@, etc.+pattern SWAP5 :: forall j. Opcode' j+pattern SWAP5 = SWAP Ord16_5++-- | Use 'SWAP6' instead of @'SWAP' 'Ord16_6'@, etc.+pattern SWAP6 :: forall j. Opcode' j+pattern SWAP6 = SWAP Ord16_6++-- | Use 'SWAP7' instead of @'SWAP' 'Ord16_7'@, etc.+pattern SWAP7 :: forall j. Opcode' j+pattern SWAP7 = SWAP Ord16_7++-- | Use 'SWAP8' instead of @'SWAP' 'Ord16_8'@, etc.+pattern SWAP8 :: forall j. Opcode' j+pattern SWAP8 = SWAP Ord16_8++-- | Use 'SWAP9' instead of @'SWAP' 'Ord16_9'@, etc.+pattern SWAP9 :: forall j. Opcode' j+pattern SWAP9 = SWAP Ord16_9++-- | Use 'SWAP10' instead of @'SWAP' 'Ord16_10'@, etc.+pattern SWAP10 :: forall j. Opcode' j+pattern SWAP10 = SWAP Ord16_10++-- | Use 'SWAP11' instead of @'SWAP' 'Ord16_11'@, etc.+pattern SWAP11 :: forall j. Opcode' j+pattern SWAP11 = SWAP Ord16_11++-- | Use 'SWAP12' instead of @'SWAP' 'Ord16_12'@, etc.+pattern SWAP12 :: forall j. Opcode' j+pattern SWAP12 = SWAP Ord16_12++-- | Use 'SWAP13' instead of @'SWAP' 'Ord16_13'@, etc.+pattern SWAP13 :: forall j. Opcode' j+pattern SWAP13 = SWAP Ord16_13++-- | Use 'SWAP14' instead of @'SWAP' 'Ord16_14'@, etc.+pattern SWAP14 :: forall j. Opcode' j+pattern SWAP14 = SWAP Ord16_14++-- | Use 'SWAP15' instead of @'SWAP' 'Ord16_15'@, etc.+pattern SWAP15 :: forall j. Opcode' j+pattern SWAP15 = SWAP Ord16_15++-- | Use 'SWAP16' instead of @'SWAP' 'Ord16_16'@, etc.+pattern SWAP16 :: forall j. Opcode' j+pattern SWAP16 = SWAP Ord16_16++-- | Use 'LOG0' instead of @'LOG' 'Ord5_0'@.+pattern LOG0 :: forall j. Opcode' j+pattern LOG0 = LOG Ord5_0++-- | Use 'LOG1' instead of @'LOG' 'Ord5_1'@.+pattern LOG1 :: forall j. Opcode' j+pattern LOG1 = LOG Ord5_1++-- | Use 'LOG2' instead of @'LOG' 'Ord5_2'@.+pattern LOG2 :: forall j. Opcode' j+pattern LOG2 = LOG Ord5_2++-- | Use 'LOG3' instead of @'LOG' 'Ord5_3'@.+pattern LOG3 :: forall j. Opcode' j+pattern LOG3 = LOG Ord5_3++-- | Use 'LOG4' instead of @'LOG' 'Ord5_4'@.+pattern LOG4 :: forall j. Opcode' j+pattern LOG4 = LOG Ord5_4
+ src/EVM/Opcode/Labelled.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module: EVM.Opcode.Labelled+-- Copyright: 2018 Simon Shine+-- Maintainer: Simon Shine <shreddedglory@gmail.com>+-- License: MIT+--+-- This module exposes the 'LabelledOpcode' type for expressing Ethereum VM+-- opcodes with labelled jumps. Plain Ethereum VM Opcodes are not so ergonomic+-- because one has to know the exact byte offset of the target 'JUMPDEST'.+--+-- With 'Opcode' the byte offset is pushed to the stack via 'PUSH', but the+-- offset to the 'JUMPDEST' depends on all occurrences of 'PUSH' prior to+-- the label, including the 'PUSH' to the label itself.++module EVM.Opcode.Labelled+  ( Label+  , LabelledOpcode+  , TranslateError(..)+  , translate+  , labelPositions+  ) where++import           Data.Function (fix)+import           Data.List (group, sort, foldl')+import qualified Data.Map as Map+import           Data.Map (Map)+import           Data.Maybe (mapMaybe)+import qualified Data.Set as Set+import           Data.Text (Text)++import           EVM.Opcode (Opcode'(..), opcodeSize, jumpdest, concrete, jumpAnnot, jumpdestAnnot)+import           EVM.Opcode.Positional (Position, PositionalOpcode, jumpSize)+import           EVM.Opcode.Traversal (OpcodeMapper(..), mapOpcodeM)++-- | For now, all labels are 'Text'.+type Label = Text++-- | 'LabelledOpcode's use 'Label' to represent jumps.+--+-- In particular, @'JUMP' "name"@, @'JUMPI' "name"@ and @'JUMPDEST' "name"@.+--+-- All other opcodes remain the same.+type LabelledOpcode = Opcode' Label++-- | Translation of 'LabelledOpcode's into 'PositionalOpcode's may fail if+-- a jump is made to a non-occurring 'JUMPDEST' or a 'JUMPDEST' occurs twice.++data TranslateError = TranslateError+  { translateErrorMissingJumpdests   :: [Label]+  , translateErrorDuplicateJumpdests :: [Label]+  } deriving (Eq, Show)++-- | Replace all labels with absolute positions.+--+-- Positions are calculated by fixed-point iteration to account for variable+-- sizes of jumps. Labelled jumps don't have a size defined, the size of a+-- positional jump depends on the address being jumped to.+--+-- For example, if jumping to the 'JUMPDEST' on the 256th position in a+-- @['LabelledOpcode']@, this requires a 'PUSH2' instruction which uses an+-- additional byte, which pushes the 'JUMPDEST' one byte ahead.++translate :: [LabelledOpcode] -> Either TranslateError [PositionalOpcode]+translate opcodes = do+  labelMap <- labelPositions opcodes+  traverse (replaceLabel labelMap) opcodes+  where+    replaceLabel = mapOpcodeM . jumpMapper . lookupLabel++    -- Apply @f@ to the parameter of 'JUMP's, 'JUMPI's and 'JUMPDEST's+    jumpMapper f = OpcodeMapper+      { mapOnJump = fmap JUMP . f+      , mapOnJumpi = fmap JUMPI . f+      , mapOnJumpdest = fmap JUMPDEST . f+      , mapOnOther = const (pure Nothing)+      }++    -- Let @f@ be @'lookupLabel' labelMap@.+    lookupLabel labelMap label =+      case Map.lookup label labelMap of+        Just pos -> Right pos+        Nothing -> Left (TranslateError [label] [])+++-- | Extract a @'Map' 'Label' 'Position'@ that describes where each 'JUMPDEST'+-- is located, taking into account the sizes of all prior opcodes.++labelPositions :: [LabelledOpcode] -> Either TranslateError (Map Label Position)+labelPositions opcodes+  | null wildJumps && null duplicateDests = Right (fixpoint opcodes)+  | otherwise = Left (TranslateError wildJumps duplicateDests)+  where+    wildJumps :: [Label]+    wildJumps = jumps `missing` dests++    duplicateDests :: [Label]+    duplicateDests = duplicate dests++    jumps :: [Label]+    jumps = mapMaybe jumpAnnot opcodes++    dests :: [Label]+    dests = mapMaybe jumpdestAnnot opcodes++    missing :: Ord a => [a] -> [a] -> [a]+    missing xs ys = Set.toList (Set.difference (Set.fromList xs) (Set.fromList ys))++    duplicate :: Ord a => [a] -> [a]+    duplicate = concatMap (take 1) . filter ((> 1) . length) . group . sort++-- | Extract a 'Map' the position of every 'JUMPDEST'.+--+-- Do this by keeping track of the current position.+--+-- This function may not terminate for all inputs!++fixpoint :: [LabelledOpcode] -> Map Label Position+fixpoint opcodes = flip fix Map.empty $ \go labelMap ->+  case step labelMap opcodes of+    (True, _, labelMap') -> labelMap'+    (False, _, labelMap') -> go labelMap'++-- | A single step in the fixpoint function is going over every opcode and+-- checking if its position is already aligned and updating the map of+-- positions otherwise.+step :: Map Label Position+     -> [LabelledOpcode]+     -> (Bool, Position, Map Label Position)+step labelMap = foldl' align (True, 0, labelMap)++align :: (Bool, Position, Map Label Position)+      -> LabelledOpcode+      -> (Bool, Position, Map Label Position)++-- When encountering a 'JUMPDEST' that was either not seen before, or was seen+-- at another offset, it hasn't been aligned. In that case, update the 'Map'+-- and signal that another iteration of 'fixpoint' is necessary.+align (done, currentBytePos, labelMap) (JUMPDEST label) =+  let aligned = Map.lookup label labelMap == Just currentBytePos+  in ( done && aligned+     , currentBytePos + opcodeSize jumpdest+     , Map.insert label currentBytePos labelMap+     )++-- When encountering a 'JUMP' or a 'JUMPI', check if the destination 'JUMPDEST'+-- was seen before. If so, increment the running offset with the size of a jump+-- to that 'JUMPDEST'. If not, the offset is still approximate.+align (done, currentBytePos, labelMap) (jumpAnnot -> Just label) =+  case Map.lookup label labelMap of+    Just bytePos -> ( done, currentBytePos + jumpSize bytePos, labelMap )+    Nothing      -> ( False, currentBytePos + jumpSize 0,      labelMap )++-- For any straight-line opcode, just increment the offset with its size.+align (done, currentBytePos, labelMap) opcode =+  ( done, currentBytePos + opcodeSize (concrete opcode), labelMap )
+ src/EVM/Opcode/Positional.hs view
@@ -0,0 +1,47 @@+-- |+-- Module: EVM.Opcode.Positional+-- Copyright: 2018 Simon Shine+-- Maintainer: Simon Shine <shreddedglory@gmail.com>+-- License: MIT+--+-- This module exposes the `PositionalOpcode` type for expressing Ethereum+-- VM opcodes where jumps and jumpdests are annotated with the byte position+-- of the translated opcode.+--+-- This representation is useful for when generating code that refers to the+-- size of itself or other chunks of code.  E.g. the CODECOPY segment of an+-- Ethereum contract must refer to the size of the code being copied, and+-- determining the size of a jump is trivial when it's annotated with the+-- destination address.++module EVM.Opcode.Positional+  ( Position+  , PositionalOpcode+  , translate+  , jumpSize+  ) where++import EVM.Opcode (Opcode, Opcode'(..), jump, jumpi, jumpdest, concrete, opcodeSize)++-- | The position of an Opcode.+type Position = Word++-- | A 'PositionalOpcode' has byte positions annotated at 'JUMP', 'JUMPI'+-- and 'JUMPDEST'; on 'JUMP' and 'JUMPI' the positions denote where they+-- jump to, and on 'JUMPDEST' they denote the position of the opcode itself.+type PositionalOpcode = Opcode' Position++-- | Translate a 'PositionalOpcode' into an 'Opcode' by converting the position+-- into a 'PUSH' instruction.+translate :: [PositionalOpcode] -> [Opcode]+translate = concatMap inline+  where+    inline :: PositionalOpcode -> [Opcode]+    inline (JUMP addr) = [ PUSH (fromIntegral addr), jump ]+    inline (JUMPI addr) = [ PUSH (fromIntegral addr), jumpi ]+    inline (JUMPDEST _) = [ jumpdest ]+    inline opcode = [ concrete opcode ]++-- | The size of a jump to some absolute position.+jumpSize :: Num i => Position -> i+jumpSize pos = opcodeSize (PUSH (fromIntegral pos)) + opcodeSize jump
+ src/EVM/Opcode/Traversal.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: EVM.Opcode.Traversal+-- Copyright: 2018 Simon Shine+-- Maintainer: Simon Shine <shreddedglory@gmail.com>+-- License: MIT+--+-- This module exposes a generic method of traversing 'Opcode''s.++module EVM.Opcode.Traversal+  ( OpcodeMapper(..)+  , mapOpcodeM+  ) where++import Prelude hiding (LT, EQ, GT)+import EVM.Opcode++-- | An 'OpcodeMapper' is a collection of four mapping functions that can+-- map any @'Opcode'' a@ to an @'Opcode'' b@. For each of the three opcodes+-- that are annotated, 'JUMP', 'JUMPI' and 'JUMPDEST', a separate mapping+-- function is specified, and for any other opcode, a general mapping function+-- is specified that falls back to the same opcode of type @'Opcode'' b@.+--+-- See 'EVM.Opcode.Labelled.translate' for an example of usage.+data OpcodeMapper m a b = OpcodeMapper+  { mapOnJump     :: a -> m (Opcode' b)+  , mapOnJumpi    :: a -> m (Opcode' b)+  , mapOnJumpdest :: a -> m (Opcode' b)+  , mapOnOther    :: Opcode' a -> m (Maybe (Opcode' b))+  }++-- | Given an 'OpcodeMapper' and an @'Opcode'' a@, produce @m ('Opcode'' b)@.+mapOpcodeM :: forall m a b. Monad m => OpcodeMapper m a b -> Opcode' a -> m (Opcode' b)+mapOpcodeM mapper opcode = case opcode of+  JUMP a     -> mapOnJump mapper a+  JUMPI a    -> mapOnJumpi mapper a+  JUMPDEST a -> mapOnJumpdest mapper a++  -- 0s: Stop and Arithmetic Operations+  STOP       -> mapOnOther' STOP STOP+  ADD        -> mapOnOther' ADD ADD+  MUL        -> mapOnOther' MUL MUL+  SUB        -> mapOnOther' SUB SUB+  DIV        -> mapOnOther' DIV DIV+  SDIV       -> mapOnOther' SDIV SDIV+  MOD        -> mapOnOther' MOD MOD+  SMOD       -> mapOnOther' SMOD SMOD+  ADDMOD     -> mapOnOther' ADDMOD ADDMOD+  MULMOD     -> mapOnOther' MULMOD MULMOD+  EXP        -> mapOnOther' EXP EXP+  SIGNEXTEND -> mapOnOther' SIGNEXTEND SIGNEXTEND++  -- 10s: Comparison & Bitwise Logic Operations+  LT      -> mapOnOther' LT LT+  GT      -> mapOnOther' GT GT+  SLT     -> mapOnOther' SLT SLT+  SGT     -> mapOnOther' SGT SGT+  EQ      -> mapOnOther' EQ EQ+  ISZERO  -> mapOnOther' ISZERO ISZERO+  AND     -> mapOnOther' AND AND+  OR      -> mapOnOther' OR OR+  XOR     -> mapOnOther' XOR XOR+  NOT     -> mapOnOther' NOT NOT+  BYTE    -> mapOnOther' BYTE BYTE+  SHL     -> mapOnOther' SHL SHL+  SHR     -> mapOnOther' SHR SHR+  SAR     -> mapOnOther' SAR SAR++  -- 20s: SHA3+  SHA3 -> mapOnOther' SHA3 SHA3++  -- 30s: Environmental Information+  ADDRESS        -> mapOnOther' ADDRESS ADDRESS+  BALANCE        -> mapOnOther' BALANCE BALANCE+  ORIGIN         -> mapOnOther' ORIGIN ORIGIN+  CALLER         -> mapOnOther' CALLER CALLER+  CALLVALUE      -> mapOnOther' CALLVALUE CALLVALUE+  CALLDATALOAD   -> mapOnOther' CALLDATALOAD CALLDATALOAD+  CALLDATASIZE   -> mapOnOther' CALLDATASIZE CALLDATASIZE+  CALLDATACOPY   -> mapOnOther' CALLDATACOPY CALLDATACOPY+  CODESIZE       -> mapOnOther' CODESIZE CODESIZE+  CODECOPY       -> mapOnOther' CODECOPY CODECOPY+  GASPRICE       -> mapOnOther' GASPRICE GASPRICE+  EXTCODESIZE    -> mapOnOther' EXTCODESIZE EXTCODESIZE+  EXTCODECOPY    -> mapOnOther' EXTCODECOPY EXTCODECOPY+  RETURNDATASIZE -> mapOnOther' RETURNDATASIZE RETURNDATASIZE+  RETURNDATACOPY -> mapOnOther' RETURNDATACOPY RETURNDATACOPY+  EXTCODEHASH    -> mapOnOther' EXTCODEHASH EXTCODEHASH++  -- 40s: Block Information+  BLOCKHASH   -> mapOnOther' BLOCKHASH BLOCKHASH+  COINBASE    -> mapOnOther' COINBASE COINBASE+  TIMESTAMP   -> mapOnOther' TIMESTAMP TIMESTAMP+  NUMBER      -> mapOnOther' NUMBER NUMBER+  DIFFICULTY  -> mapOnOther' DIFFICULTY DIFFICULTY+  GASLIMIT    -> mapOnOther' GASLIMIT GASLIMIT+  CHAINID     -> mapOnOther' CHAINID CHAINID+  SELFBALANCE -> mapOnOther' SELFBALANCE SELFBALANCE++  -- 50s: Stack, Memory, Storage and Flow Operations+  POP       -> mapOnOther' POP POP+  MLOAD     -> mapOnOther' MLOAD MLOAD+  MSTORE    -> mapOnOther' MSTORE MSTORE+  MSTORE8   -> mapOnOther' MSTORE8 MSTORE8+  SLOAD     -> mapOnOther' SLOAD SLOAD+  SSTORE    -> mapOnOther' SSTORE SSTORE+  PC        -> mapOnOther' PC PC+  MSIZE     -> mapOnOther' MSIZE MSIZE+  GAS       -> mapOnOther' GAS GAS++  -- 60s & 70s: Push Operations+  PUSH n    -> mapOnOther' (PUSH n) (PUSH n)++  -- 80s: Duplication Operations (DUP)+  DUP i     -> mapOnOther' (DUP i) (DUP i)++  -- 90s: Exchange operations (SWAP)+  SWAP i    -> mapOnOther' (SWAP i) (SWAP i)++  -- a0s: Logging Operations (LOG)+  LOG i     -> mapOnOther' (LOG i) (LOG i)++  -- f0s: System Operations+  CREATE       -> mapOnOther' CREATE CREATE+  CALL         -> mapOnOther' CALL CALL+  CALLCODE     -> mapOnOther' CALLCODE CALLCODE+  RETURN       -> mapOnOther' RETURN RETURN+  DELEGATECALL -> mapOnOther' DELEGATECALL DELEGATECALL+  CREATE2      -> mapOnOther' CREATE2 CREATE2+  STATICCALL   -> mapOnOther' STATICCALL STATICCALL+  REVERT       -> mapOnOther' REVERT REVERT+  INVALID      -> mapOnOther' INVALID INVALID+  SELFDESTRUCT -> mapOnOther' SELFDESTRUCT SELFDESTRUCT+  where+    mapOnOther' :: Opcode' a -> Opcode' b -> m (Opcode' b)+    mapOnOther' opa opbDefault = do+      res <- mapOnOther mapper opa+      case res of+        Just opb -> return opb+        Nothing  -> return opbDefault
+ test/OpcodeGenerators.hs view
@@ -0,0 +1,137 @@++module OpcodeGenerators where++import Prelude hiding (LT, EQ, GT)++import           Data.Bits (shift)+import           Data.Containers.ListUtils (nubOrd)+import           Data.DoubleWord (Word256)+import           Data.Text (Text)+import qualified Data.Text as Text++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import           EVM.Opcode as Opcode+import           EVM.Opcode.Positional+import           EVM.Opcode.Labelled+import           EVM.Opcode.Traversal++-- | Here are the three main strategies for generating testable opcodes:+--+--  1. 'genOpcode' will generate any 'Opcode'.+--+--  2. 'genOpcode'1' will generate any jump-free 'Opcode'' of 'opcodeSize' 1.+--+--  3. 'genLabelledOpcodes' will generate a sequence of opcodes for which+--     all jumps are labelled and all jumps have valid jumpdests. Many jumps+--     to the same jumpdest may occur, but the same jumpdest may not occur+--     twice.+--++-- | Generate any 'Opcode'.+genOpcode :: Gen Opcode+genOpcode = Opcode.concrete <$> Gen.frequency+  [ (3, genOpcode'1)+  , (1, genPushOpcode)+  , (1, genJumpyOpcode)+  ]++-- | Generate a jump-free 'Opcode'' of 'opcodeSize' 1.+--+-- That means, no 'JUMP', 'JUMPI', 'JUMPDEST' or 'PUSH'.+--+-- Only jumps of type 'Opcode' have a clearly defined size.+genOpcode'1 :: Gen (Opcode' a)+genOpcode'1 = Gen.element opcode1++-- | Generate a list of 'LabelledOpcode' where all 'JUMP' and 'JUMPI' have a 'JUMPDEST'.+genLabelledOpcodes :: Gen [LabelledOpcode]+genLabelledOpcodes = do+  opcodes <- Gen.list (Range.linear 0 40) genLabelledOpcode+  let jumpdests = JUMPDEST <$> (nubOrd . foldMap extractLabel) opcodes+  Gen.shuffle (opcodes <> jumpdests)+  where+    extractLabel :: LabelledOpcode -> [Label]+    extractLabel (JUMP label) = [label]+    extractLabel (JUMPI label) = [label]+    extractLabel _ = []++-- | Generate a 'LabelledOpcode' that isn't 'JUMPDEST'.+genLabelledOpcode :: Gen LabelledOpcode+genLabelledOpcode = Gen.frequency+  [ (3, genOpcode'1)+  , (1, genPushOpcode)+  , (1, genLabelledJumpOpcode)+  ]++-- | Generate any jump-free 'Opcode''.+--+-- That means, no 'JUMP', 'JUMPI', 'JUMPDEST'.+genOpcodeN :: Gen (Opcode' a)+genOpcodeN = Gen.frequency+  [ (length opcode1, genOpcode'1)+  , (1, genPushOpcode)+  ]++-- | A list of opcodes of byte size 1.+--+-- That means, no 'JUMP', 'JUMPI', 'JUMPDEST' or 'PUSH'.+opcode1 :: [Opcode' a]+opcode1 =+  [ STOP, ADD, MUL, SUB, DIV, SDIV, MOD, SMOD, ADDMOD, MULMOD, EXP, SIGNEXTEND+  , LT, GT, SLT, SGT, EQ, ISZERO, AND, OR, XOR, NOT, BYTE, SHL, SHR, SAR+  , SHA3++  , ADDRESS, BALANCE, ORIGIN+  , CALLER, CALLVALUE, CALLDATALOAD, CALLDATASIZE, CALLDATACOPY+  , CODESIZE, CODECOPY+  , GASPRICE, EXTCODESIZE, EXTCODECOPY, RETURNDATASIZE, RETURNDATACOPY, EXTCODEHASH++  , BLOCKHASH, COINBASE, TIMESTAMP, NUMBER, DIFFICULTY, GASLIMIT, CHAINID, SELFBALANCE++  , POP, MLOAD, MSTORE, MSTORE8, SLOAD, SSTORE {- , JUMP, JUMPI -}, PC, MSIZE, GAS {- , JUMPDEST -}+    {- , PUSH -}+  , CREATE, CALL, CALLCODE, RETURN, DELEGATECALL, CREATE2, STATICCALL, REVERT, INVALID, SELFDESTRUCT+  ] <> map DUP [minBound..maxBound]+    <> map SWAP [minBound..maxBound]+    <> map LOG [minBound..maxBound]++genPushOpcode :: Gen (Opcode' a)+genPushOpcode = PUSH <$> genWord256++genJumpyOpcode :: Gen Opcode+genJumpyOpcode = Gen.element+  [ jump+  , jumpi+  , jumpdest+  ]++genLabelledJumpOpcode :: Gen LabelledOpcode+genLabelledJumpOpcode = Gen.choice+  [ JUMP <$> genLabel+  , JUMPI <$> genLabel+  ]++genLabel :: Gen Label+genLabel = Gen.text (Range.singleton 5) (Gen.element "aeiomnr")++-- | Generate a 'Word256' that needs N (1-32) bytes to represent itself, where+-- N is linearly dependent on the generator's size. The value is distributed+-- uniformly in that range.+--+-- For example, size 0 gives a value in the range 0-255, size 1 gives a value+-- in the range 256-65535, and so on.+genWord256 :: Gen Word256+genWord256 = snd <$> genWord256'++-- | Generate a @(n, k)@ pair where @n@ is 0-31 and @k@ is a 'Word256' that is+-- @n + 1@ bytes.+genWord256' :: Gen (Int, Word256)+genWord256' = do+  n <- Gen.integral (Range.linear 0 31)+  let lo = (1 `shift` (8 * n)) - 1+      hi = (1 `shift` (8 * (n + 1))) - 1+  k <- Gen.integral_ (Range.constant lo hi)+  pure (n, k)
+ test/OpcodeTest.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}++module OpcodeTest where++import Prelude hiding (LT, EQ, GT)++import           Data.Char (isSpace)+import qualified Data.ByteString as BS+import           Data.DoubleWord (Word256)+import           Data.Foldable (for_)+import           Data.List (permutations)+import           Data.Maybe (mapMaybe)+import           Data.Text (Text)+import qualified Data.Text as Text++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import           Test.Tasty.Hspec+import           Test.Hspec++import EVM.Opcode as Opcode+import EVM.Opcode.Positional as P+import EVM.Opcode.Labelled as L++import OpcodeGenerators++-- Property: Jump-free non-PUSH opcodes have size 1.+hprop_opcodeSize_1 :: Property+hprop_opcodeSize_1 = property $ do+  opcode <- forAll genOpcode'1+  opcodeSize opcode === 1++-- Property: When n is 0-31, PUSH opcodes have size n + 2.+hprop_opcodeSize_PUSH :: Property+hprop_opcodeSize_PUSH = property $ do+  (n, k) <- forAll genWord256'+  opcodeSize (PUSH k) === n + 1 + 1++hprop_opcodeText_for_PUSH_matches :: Property+hprop_opcodeText_for_PUSH_matches = property $ do+  (n, k) <- forAll genWord256'+  let text = opcodeText (PUSH k)+      exp = "push" <> Text.pack (show (n + 1))+      got = Text.takeWhile (not . isSpace) text+  got === exp++hprop_opcodeName_unique :: Property+hprop_opcodeName_unique = property $ do+  opcode1 <- forAll genOpcode+  opcode2 <- forAll genOpcode+  if opcode1 == opcode2+    then opcodeName (opcodeSpec opcode1) === opcodeName (opcodeSpec opcode2)+    else opcodeName (opcodeSpec opcode1) /== opcodeName (opcodeSpec opcode2)++hprop_pack_readOp_inverses :: Property+hprop_pack_readOp_inverses = property $ do+  opcode1 <- forAll genOpcode+  let bytecode = pack [opcode1]++  -- Property: Opcodes are packed to /non-empty/ ByteStrings.+  (c, cs) <- evalMaybe (BS.uncons bytecode)++  -- Property: 'pack' and 'readOp' are inverses.+  opcode2 <- evalMaybe (readOp c cs)+  opcode1 === opcode2++hprop_translate_LabelledOpcode :: Property+hprop_translate_LabelledOpcode = withTests 10000 $ property $ do+  labelledOpcodes <- forAll genLabelledOpcodes++  -- Property: Labelled opcodes, for which valid jumpdests occur, translate.+  positionalOpcodes <- evalEither (L.translate labelledOpcodes)++  -- Property: Translating labels to positions is structure-preserving.+  let pairs = zip labelledOpcodes positionalOpcodes+  fmap Opcode.concrete labelledOpcodes === fmap Opcode.concrete positionalOpcodes++  -- Property: For every positional jump the corresponding index in the translated+  -- bytecode is a JUMPDEST. FIXME: bytestring-0.11.0.0 has `indexMaybe` / `!?`.+  let positions = mapMaybe jumpAnnot positionalOpcodes+  let opcodes = P.translate positionalOpcodes+  let bytecode = Opcode.pack opcodes+  for_ (fromIntegral <$> positions) $ \pos ->+    [ bytecode `BS.index` pos ] === toBytes jumpdest++-- Negative tests to assert that broken labels don't cause infinite recursion++spec_EVM_Opcode_Labelled :: Spec+spec_EVM_Opcode_Labelled = do+  describe "translate" $ do+    it "handles empty lists" $+      L.translate [] `shouldBe` Right []++    it "handles empty labels" $+      L.translate [JUMP "", JUMPDEST ""] `shouldBe` Right [JUMP 3, JUMPDEST 3]++    it "handles jumpdests with no pointers to it" $+      L.translate [JUMPDEST "foo"] `shouldBe` Right [JUMPDEST 0]++    it "fails on jumps without destinations" $ do+      L.translate [JUMP "off"] `shouldMissErr` ["off"]+      L.translate [JUMPI "off"] `shouldMissErr` ["off"]+      L.translate [JUMP "a", JUMPI "b"] `shouldMissErr` ["a", "b"]++      for_ (permutations [JUMP "a", JUMPDEST "a", JUMP "b"]) $+        \instructions -> L.translate instructions `shouldMissErr` ["b"]++    it "fails on single duplicate destination" $+      L.translate [JUMPDEST "foo", JUMPDEST "foo"] `shouldDupErr` ["foo"]++    it "fails on duplicate destination in presence of non-duplicate destination" $+      for_ (permutations [JUMPDEST "foo", JUMPDEST "foo", JUMPDEST "bar"]) $+        \instructions -> L.translate instructions `shouldDupErr` ["foo"]++    it "fails on multiple duplicate destinations" $+      let instructions = [JUMPDEST "foo", JUMPDEST "bar", JUMPDEST "foo", JUMPDEST "bar"]+      in L.translate instructions `shouldDupErr` ["bar", "foo"]++    it "fails and reports both jumps without destinations and duplicate destinations" $+      let instructions = [JUMP "foo", JUMPDEST "bar", JUMPDEST "bar"]+      in L.translate instructions `shouldBe` Left (TranslateError ["foo"] ["bar"])++    it "fails and reports multiple jumps without destination and multiple duplicate destinations" $+      let instructions =+            [ JUMP "a"+            , JUMP "b"+            , JUMP "good"+            , JUMPI "c"+            , JUMPI "d"+            , JUMPI "good"+            , JUMPDEST "x"+            , JUMPDEST "x"+            , JUMPDEST "y"+            , JUMPDEST "y"+            , JUMPDEST "good"+            ]+          wildJumps = [ "a", "b", "c", "d" ]+          duplicateDests = [ "x", "y" ]++      in L.translate instructions `shouldBe` Left (TranslateError wildJumps duplicateDests)++shouldMissErr :: (Show b, Eq b) => Either TranslateError b -> [Label] -> Expectation+shouldMissErr x y = x `shouldBe` Left (TranslateError y [])++shouldDupErr :: (Show b, Eq b) => Either TranslateError b -> [Label] -> Expectation+shouldDupErr x y = x `shouldBe` Left (TranslateError [] y)
+ test/test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}