From 7d6db3c54b1e28cc43204e49a5c1cf4c040707dd Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 12 Aug 2020 18:24:36 +0200 Subject: [PATCH 01/36] dynamic buffers WIP --- src/hevm/src/EVM.hs | 38 ++++++++------- src/hevm/src/EVM/Symbolic.hs | 91 +++++++++++++++++++++++++----------- src/hevm/src/EVM/Types.hs | 30 ++++++------ 3 files changed, 103 insertions(+), 56 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index df266bf32..af86d6a2b 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -665,7 +665,7 @@ exec1 = do -- (similarly to sha3Crack), and simply assert that injectivity holds for these -- particular invocations. - SymbolicBuffer bs -> do + StaticSymBuffer bs -> do let hash' = symkeccak' bs previousUsed = view (env . keccakUsed) vm env . keccakUsed <>= [(bs, hash')] @@ -714,9 +714,9 @@ exec1 = do limitStack 1 . burn g_base $ next >> pushSym (the state callvalue) - -- op: CALLDATALOAD - 0x35 -> stackOp1 (const g_verylow) $ - \(S _ x) -> uncurry (readSWordWithBound (sFromIntegral x)) (the state calldata) + -- -- op: CALLDATALOAD + -- 0x35 -> stackOp1 (const g_verylow) $ + -- \(S _ x) -> uncurry (readSWordWithBound (sFromIntegral x)) (the state calldata) -- op: CALLDATASIZE 0x36 -> @@ -732,7 +732,7 @@ exec1 = do next assign (state . stack) xs case the state calldata of - (SymbolicBuffer cd, cdlen) -> copyBytesToMemory (SymbolicBuffer [ite (i .<= cdlen) x 0 | (x, i) <- zip cd [1..]]) xSize xFrom xTo + (StaticSymBuffer cd, cdlen) -> copyBytesToMemory (StaticSymBuffer [ite (i .<= cdlen) x 0 | (x, i) <- zip cd [1..]]) xSize xFrom xTo -- when calldata is concrete, -- the bound should always be equal to the bytestring length (cd, _) -> copyBytesToMemory cd xSize xFrom xTo @@ -1351,7 +1351,7 @@ executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = let hash = case input of ConcreteBuffer input' -> ConcreteBuffer $ BS.pack $ BA.unpack $ (Crypto.hash input' :: Digest SHA256) - SymbolicBuffer input' -> SymbolicBuffer $ symSHA256 input' + StaticSymBuffer input' -> StaticSymBuffer $ symSHA256 input' in do assign (state . stack) (1 : xs) assign (state . returndata) hash @@ -1769,7 +1769,7 @@ forceConcrete6 (k,l,m,n,o,p) continue = case (maybeLitWord k, maybeLitWord l, ma _ -> vmError UnexpectedSymbolicArg forceConcreteBuffer :: Buffer -> (ByteString -> EVM ()) -> EVM () -forceConcreteBuffer (SymbolicBuffer b) continue = case maybeLitBytes b of +forceConcreteBuffer (StaticSymBuffer b) continue = case maybeLitBytes b of Nothing -> vmError UnexpectedSymbolicArg Just bs -> continue bs forceConcreteBuffer (ConcreteBuffer b) continue = continue b @@ -1820,7 +1820,7 @@ cheat (inOffset, inSize) (outOffset, outSize) = do vmError (BadCheatCode (Just abi)) Just (argTypes, action) -> case input of - SymbolicBuffer _ -> vmError UnexpectedSymbolicArg + StaticSymBuffer _ -> vmError UnexpectedSymbolicArg ConcreteBuffer input' -> case runGetOrFail (getAbiSeq (length argTypes) argTypes) @@ -2066,7 +2066,7 @@ finishFrame how = do ErrorTrace e FrameReverted (ConcreteBuffer output) -> ErrorTrace (Revert output) - FrameReverted (SymbolicBuffer output) -> + FrameReverted (StaticSymBuffer output) -> ErrorTrace (Revert (forceLitBytes output)) FrameReturned output -> ReturnTrace output (view frameContext nextFrame) @@ -2188,13 +2188,17 @@ accessMemoryWord accessMemoryWord fees x = accessMemoryRange fees x 32 copyBytesToMemory - :: Buffer -> Word -> Word -> Word -> EVM () + :: Buffer -> SymWord -> SymWord -> SymWord -> EVM () copyBytesToMemory bs size xOffset yOffset = - if size == 0 then noop - else do - mem <- use (state . memory) - assign (state . memory) $ - writeMemory bs size xOffset yOffset mem + case maybeLitWord size of + Just size' -> + if size' == 0 then noop + else copyBytes + Nothing -> copyBytes + where copyBytes = do + mem <- use (state . memory) + assign (state . memory) $ + writeMemory bs size xOffset yOffset mem copyCallBytesToMemory :: Buffer -> Word -> Word -> Word -> EVM () @@ -2544,7 +2548,7 @@ costOfPrecompile (FeeSchedule {..}) precompileAddr input = -- MODEXP 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) where input' = case input of - SymbolicBuffer _ -> error "unsupported: symbolic MODEXP gas cost calc" + StaticSymBuffer _ -> error "unsupported: symbolic MODEXP gas cost calc" ConcreteBuffer b -> b (lenb, lene, lenm) = parseModexpLength input' lene' | lene <= 32 && ez = 0 @@ -2568,7 +2572,7 @@ costOfPrecompile (FeeSchedule {..}) precompileAddr input = 0x8 -> num $ ((len input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) -- BLAKE2 0x9 -> let input' = case input of - SymbolicBuffer _ -> error "unsupported: symbolic BLAKE2B gas cost calc" + StaticSymBuffer _ -> error "unsupported: symbolic BLAKE2B gas cost calc" ConcreteBuffer b -> b in g_fround * (num $ asInteger $ lazySlice 0 4 input') _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 606bc6438..4acb804e5 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -10,7 +10,6 @@ import qualified Data.ByteString as BS import Data.ByteString (ByteString) import Control.Lens hiding (op, (:<), (|>), (.>)) import Data.Maybe (fromMaybe, fromJust) - import EVM.Types import EVM.Concrete (Word (..), Whiff(..)) import qualified EVM.Concrete as Concrete @@ -99,7 +98,7 @@ shiftRight' (S _ a') b@(S _ b') = case (num <$> unliteral a', b) of in S (FromBytes (SymbolicBuffer bs)) (fromBytes bs) _ -> sw256 $ sShiftRight b' a' --- | Operations over symbolic memory (list of symbolic bytes) +-- | Operations over static symbolic memory (list of symbolic bytes) swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs @@ -141,11 +140,27 @@ readSWord' (C _ i) x = then 0 else swordAt (num i) x +-- | Operations over dynamic symbolic memory (smt array of symbolic bytes) +swordAt'' :: SWord 32 -> SArray (WordN 32) (WordN 8) -> SymWord +swordAt'' i bs = sw256 . fromBytes $ zipWith readArray bs [i + b | b <- [0..31]] + +readByteOrZero'' :: SWord 32 -> [SWord 8] -> SWord 8 +readByteOrZero'' i bs = readArray bs i -select' :: (Ord b, Num b, SymVal b, Mergeable a) => [a] -> a -> SBV b -> a -select' xs err ind = walk xs ind err - where walk [] _ acc = acc - walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) +-- sliceWithZero'' :: Int -> Int -> [SWord 8] -> [SWord 8] +-- sliceWithZero'' o s m = truncpad s $ drop o m + +dynWriteMemory :: SArray (WordN 32) (WordN 8) -> SymWord -> SymWord -> Word -> [SWord 8] -> [SWord 8] +dynWriteMemory bs1 (C _ n) (C _ src) (C _ dst) bs0 = + let + (a, b) = splitAt (num dst) bs0 + a' = replicate (num dst - length a) 0 + c = if src > num (length bs1) + then replicate (num n) 0 + else sliceWithZero' (num src) (num n) bs1 + b' = drop (num (n)) b + in + a <> a' <> c <> b' -- Generates a ridiculously large set of constraints (roughly 25k) when -- the index is symbolic, but it still seems (kind of) manageable @@ -167,59 +182,83 @@ readSWordWithBound ind (ConcreteBuffer xs) bound = -- so we should be able to safely ignore it here litWord $ Concrete.readMemoryWord (num x') xs +readMemoryWord' :: Word -> [SWord 8] -> SymWord +readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) + +readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 +readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) + +setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] +setMemoryWord' (C _ i) (S _ x) = + writeMemory' (toBytes x) 32 0 (num i) + +setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] +setMemoryByte' (C _ i) x = + writeMemory' [x] 1 0 (num i) + +readSWord' :: Word -> [SWord 8] -> SymWord +readSWord' (C _ i) x = + if i > num (length x) + then 0 + else swordAt (num i) x + -- a whole foldable instance seems overkill, but length is always good to have! -len :: Buffer -> Int -len (SymbolicBuffer bs) = length bs -len (ConcreteBuffer bs) = BS.length bs +len :: Buffer -> SWord 32 +len (DynamicSymBuffer (a, b)) = b +len (StaticSymBuffer bs) = literal . num $ length bs +len (ConcreteBuffer bs) = literal . num $ BS.length bs grab :: Int -> Buffer -> Buffer -grab n (SymbolicBuffer bs) = SymbolicBuffer $ take n bs +grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs +grab _ = error "oops: tried to grab dynamic buffer" ditch :: Int -> Buffer -> Buffer -ditch n (SymbolicBuffer bs) = SymbolicBuffer $ drop n bs +ditch n (StaticSymBuffer bs) = StaticSymBuffer $ drop n bs ditch n (ConcreteBuffer bs) = ConcreteBuffer $ BS.drop n bs +ditch _ = error "oops: tried to ditch dynamic buffer" readByteOrZero :: Int -> Buffer -> SWord 8 -readByteOrZero i (SymbolicBuffer bs) = readByteOrZero' i bs +readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs +readByteOrZero i (DynamicSymBuffer (a, b)) = ite (i < b) (readArray a i) 0 sliceWithZero :: Int -> Int -> Buffer -> Buffer -sliceWithZero o s (SymbolicBuffer m) = SymbolicBuffer (sliceWithZero' o s m) +sliceWithZero o s (StaticSymBuffer m) = StaticSymBuffer (sliceWithZero' o s m) sliceWithZero o s (ConcreteBuffer m) = ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes o s m) writeMemory :: Buffer -> Word -> Word -> Word -> Buffer -> Buffer writeMemory (ConcreteBuffer bs1) n src dst (ConcreteBuffer bs0) = ConcreteBuffer (Concrete.writeMemory bs1 n src dst bs0) -writeMemory (ConcreteBuffer bs1) n src dst (SymbolicBuffer bs0) = - SymbolicBuffer (writeMemory' (litBytes bs1) n src dst bs0) -writeMemory (SymbolicBuffer bs1) n src dst (ConcreteBuffer bs0) = - SymbolicBuffer (writeMemory' bs1 n src dst (litBytes bs0)) -writeMemory (SymbolicBuffer bs1) n src dst (SymbolicBuffer bs0) = - SymbolicBuffer (writeMemory' bs1 n src dst bs0) +writeMemory (ConcreteBuffer bs1) n src dst (StaticSymBuffer bs0) = + StaticSymBuffer (writeMemory' (litBytes bs1) n src dst bs0) +writeMemory (StaticSymBuffer bs1) n src dst (ConcreteBuffer bs0) = + StaticSymBuffer (writeMemory' bs1 n src dst (litBytes bs0)) +writeMemory (StaticSymBuffer bs1) n src dst (StaticSymBuffer bs0) = + StaticSymBuffer (writeMemory' bs1 n src dst bs0) readMemoryWord :: Word -> Buffer -> SymWord -readMemoryWord i (SymbolicBuffer m) = readMemoryWord' i m +readMemoryWord i (StaticSymBuffer m) = readMemoryWord' i m readMemoryWord i (ConcreteBuffer m) = litWord $ Concrete.readMemoryWord i m readMemoryWord32 :: Word -> Buffer -> SWord 32 -readMemoryWord32 i (SymbolicBuffer m) = readMemoryWord32' i m +readMemoryWord32 i (StaticSymBuffer m) = readMemoryWord32' i m readMemoryWord32 i (ConcreteBuffer m) = num $ Concrete.readMemoryWord32 i m setMemoryWord :: Word -> SymWord -> Buffer -> Buffer -setMemoryWord i x (SymbolicBuffer z) = SymbolicBuffer $ setMemoryWord' i x z +setMemoryWord i x (StaticSymBuffer z) = StaticSymBuffer $ setMemoryWord' i x z setMemoryWord i x (ConcreteBuffer z) = case maybeLitWord x of Just x' -> ConcreteBuffer $ Concrete.setMemoryWord i x' z - Nothing -> SymbolicBuffer $ setMemoryWord' i x (litBytes z) + Nothing -> StaticSymBuffer $ setMemoryWord' i x (litBytes z) setMemoryByte :: Word -> SWord 8 -> Buffer -> Buffer -setMemoryByte i x (SymbolicBuffer m) = SymbolicBuffer $ setMemoryByte' i x m +setMemoryByte i x (StaticSymBuffer m) = StaticSymBuffer $ setMemoryByte' i x m setMemoryByte i x (ConcreteBuffer m) = case fromSized <$> unliteral x of - Nothing -> SymbolicBuffer $ setMemoryByte' i x (litBytes m) + Nothing -> StaticSymBuffer $ setMemoryByte' i x (litBytes m) Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i x' m readSWord :: Word -> Buffer -> SymWord -readSWord i (SymbolicBuffer x) = readSWord' i x +readSWord i (StaticSymBuffer x) = readSWord' i x readSWord i (ConcreteBuffer x) = num $ Concrete.readMemoryWord i x -- | Custom instances for SymWord, many of which have direct diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index 7bfefeb14..dcba87c98 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -91,26 +91,30 @@ litBytes bs = fmap (toSized . literal) (BS.unpack bs) -- | Operations over buffers (concrete or symbolic) -- | A buffer is a list of bytes. For concrete execution, this is simply `ByteString`. --- In symbolic settings, it is a list of symbolic bitvectors of size 8. +-- In symbolic settings, its structure is sometimes known statically, +-- and sometimes only determined dynamically. +-- In the static case, it's a simple list of symbolic bitvectors of size 8. +-- In the dynamic case, it's a pair of an SMT array and a symbolic word representing +-- the buffer length. data Buffer = ConcreteBuffer ByteString - | SymbolicBuffer [SWord 8] + | StaticSymBuffer [SWord 8] + | DynamicSymBuffer (SArray (WordN 32) (WordN 8), SWord 32) deriving (Show) -instance Semigroup Buffer where - ConcreteBuffer a <> ConcreteBuffer b = ConcreteBuffer (a <> b) - ConcreteBuffer a <> SymbolicBuffer b = SymbolicBuffer (litBytes a <> b) - SymbolicBuffer a <> ConcreteBuffer b = SymbolicBuffer (a <> litBytes b) - SymbolicBuffer a <> SymbolicBuffer b = SymbolicBuffer (a <> b) - -instance Monoid Buffer where - mempty = ConcreteBuffer mempty +dynamize :: Buffer -> Buffer +dynamize (ConcreteBuffer a) = dynamize $ StaticSymBuffer (litBytes a) +dynamize (DynamicSymBuffer a) = DynamicSymBuffer a +dynamize (StaticSymBuffer a) = + DynamicSymBuffer (sListArray (Just 0) $ zip [0..] a, literal . num $ length a) instance EqSymbolic Buffer where ConcreteBuffer a .== ConcreteBuffer b = literal (a == b) - ConcreteBuffer a .== SymbolicBuffer b = litBytes a .== b - SymbolicBuffer a .== ConcreteBuffer b = a .== litBytes b - SymbolicBuffer a .== SymbolicBuffer b = a .== b + ConcreteBuffer a .== StaticSymBuffer b = litBytes a .== b + StaticSymBuffer a .== ConcreteBuffer b = a .== litBytes b + StaticSymBuffer a .== StaticSymBuffer b = a .== b + DynamicSymBuffer a .== DynamicSymBuffer b = a .== b + a .== b = dynamize a .== dynamize b newtype Addr = Addr { addressWord160 :: Word160 } deriving (Num, Integral, Real, Ord, Enum, Eq, Bits, Generic) From a0ffadb000675921991325364cd1b05bfecd2e85 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Sun, 16 Aug 2020 19:27:26 +0200 Subject: [PATCH 02/36] using smt lists instead! --- src/hevm/src/EVM/Symbolic.hs | 108 +++++++++++++++++++++++------------ src/hevm/src/EVM/Types.hs | 5 -- src/hevm/test/test.hs | 17 ++++++ 3 files changed, 87 insertions(+), 43 deletions(-) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 4acb804e5..6e8829337 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -14,7 +14,8 @@ import EVM.Types import EVM.Concrete (Word (..), Whiff(..)) import qualified EVM.Concrete as Concrete import Data.SBV hiding (runSMT, newArray_, addAxiom, Word) - +import qualified Data.SBV.List as SL +import Data.SBV.List ((.++), (.!!)) -- | Symbolic words of 256 bits, possibly annotated with additional -- "insightful" information @@ -99,6 +100,25 @@ shiftRight' (S _ a') b@(S _ b') = case (num <$> unliteral a', b) of _ -> sw256 $ sShiftRight b' a' -- | Operations over static symbolic memory (list of symbolic bytes) +truncpad :: Int -> [SWord 8] -> [SWord 8] +truncpad n xs = if m > n then take n xs + else mappend xs (replicate (n - m) 0) + where m = length xs + +-- returns undefined stuff when you try to take too much +takeStatic :: (SymVal a) => Int -> SList a -> [SBV a] +takeStatic n ls = + let (x, xs) = SL.uncons ls + in x:(takeStatic (n - 1) xs) + +truncpad' :: Int -> SList (WordN 8) -> [SWord 8] +truncpad' n xs = + ite + (m .> (literal (num n))) + (takeStatic n xs) + (takeStatic n (xs .++ SL.implode (replicate n 0))) + where m = SL.length xs + swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs @@ -137,30 +157,39 @@ setMemoryByte' (C _ i) x = readSWord' :: Word -> [SWord 8] -> SymWord readSWord' (C _ i) x = if i > num (length x) - then 0 + then sw256 $ 0 else swordAt (num i) x --- | Operations over dynamic symbolic memory (smt array of symbolic bytes) -swordAt'' :: SWord 32 -> SArray (WordN 32) (WordN 8) -> SymWord -swordAt'' i bs = sw256 . fromBytes $ zipWith readArray bs [i + b | b <- [0..31]] - -readByteOrZero'' :: SWord 32 -> [SWord 8] -> SWord 8 -readByteOrZero'' i bs = readArray bs i - --- sliceWithZero'' :: Int -> Int -> [SWord 8] -> [SWord 8] --- sliceWithZero'' o s m = truncpad s $ drop o m - -dynWriteMemory :: SArray (WordN 32) (WordN 8) -> SymWord -> SymWord -> Word -> [SWord 8] -> [SWord 8] -dynWriteMemory bs1 (C _ n) (C _ src) (C _ dst) bs0 = +-- | Operations over dynamic symbolic memory (smt list of bytes) +swordAt'' :: SWord 32 -> SList (WordN 8) -> SymWord +swordAt'' i bs = sw256 . fromBytes $ truncpad' 32 $ SL.drop (sFromIntegral i) bs + +readByteOrZero'' :: SWord 32 -> SList (WordN 8) -> SWord 8 +readByteOrZero'' i bs = + ite (SL.length bs .> (sFromIntegral i + 1)) + (bs .!! (sFromIntegral i)) + (literal 0) + +-- Warning: if (length bs0) < dst or (length bs1) < src + n we can get `havoc` garbage in the resulting +-- list. It should really be 0. If we could write the following function, we could pad appropriately: +-- replicate :: (SymVal a) => SInteger -> SBV a -> SList a +-- but I can't really write this... +-- +-- TODO: make sure we enforce this condition before calling this +dynWriteMemory :: SList (WordN 8) -> SymWord -> SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) +dynWriteMemory bs1 (S _ n) (S _ src) (S _ dst) bs0 = let - (a, b) = splitAt (num dst) bs0 - a' = replicate (num dst - length a) 0 - c = if src > num (length bs1) - then replicate (num n) 0 - else sliceWithZero' (num src) (num n) bs1 - b' = drop (num (n)) b + n' = sFromIntegral n + src' = sFromIntegral src + dst' = sFromIntegral dst + + a = SL.take dst' bs0 + b = SL.subList bs1 src' n' + c = ite (dst' + n' .> SL.length bs0) + (SL.nil) + (SL.drop (dst' + n') bs0) in - a <> a' <> c <> b' + a .++ b .++ c -- Generates a ridiculously large set of constraints (roughly 25k) when -- the index is symbolic, but it still seems (kind of) manageable @@ -185,43 +214,46 @@ readSWordWithBound ind (ConcreteBuffer xs) bound = readMemoryWord' :: Word -> [SWord 8] -> SymWord readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) -readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 -readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) +-- readMemoryWord' :: Word -> [SWord 8] -> SymWord +-- readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) -setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] -setMemoryWord' (C _ i) (S _ x) = - writeMemory' (toBytes x) 32 0 (num i) +-- readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 +-- readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) -setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] -setMemoryByte' (C _ i) x = - writeMemory' [x] 1 0 (num i) +-- setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] +-- setMemoryWord' (C _ i) (S _ x) = +-- writeMemory' (toBytes x) 32 0 (num i) -readSWord' :: Word -> [SWord 8] -> SymWord -readSWord' (C _ i) x = - if i > num (length x) - then 0 - else swordAt (num i) x +-- setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] +-- setMemoryByte' (C _ i) x = +-- writeMemory' [x] 1 0 (num i) + +-- readSWord' :: Word -> [SWord 8] -> SymWord +-- readSWord' (C _ i) x = +-- if i > num (length x) +-- then 0 +-- else swordAt (num i) x -- a whole foldable instance seems overkill, but length is always good to have! len :: Buffer -> SWord 32 -len (DynamicSymBuffer (a, b)) = b +len (DynamicSymBuffer a) = sFromIntegral $ SL.length a len (StaticSymBuffer bs) = literal . num $ length bs len (ConcreteBuffer bs) = literal . num $ BS.length bs grab :: Int -> Buffer -> Buffer grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs -grab _ = error "oops: tried to grab dynamic buffer" +grab n (DynamicSymBuffer bs) = DynamicSymBuffer $ SL.take (literal $ num n) bs ditch :: Int -> Buffer -> Buffer ditch n (StaticSymBuffer bs) = StaticSymBuffer $ drop n bs ditch n (ConcreteBuffer bs) = ConcreteBuffer $ BS.drop n bs -ditch _ = error "oops: tried to ditch dynamic buffer" +ditch n (DynamicSymBuffer bs) = DynamicSymBuffer $ SL.drop (literal $ num n) bs readByteOrZero :: Int -> Buffer -> SWord 8 readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs -readByteOrZero i (DynamicSymBuffer (a, b)) = ite (i < b) (readArray a i) 0 +readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (literal $ num i) bs sliceWithZero :: Int -> Int -> Buffer -> Buffer sliceWithZero o s (StaticSymBuffer m) = StaticSymBuffer (sliceWithZero' o s m) diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index dcba87c98..963575bc9 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -246,11 +246,6 @@ padLeft n xs = BS.replicate (n - BS.length xs) 0 <> xs padRight :: Int -> ByteString -> ByteString padRight n xs = xs <> BS.replicate (n - BS.length xs) 0 -truncpad :: Int -> [SWord 8] -> [SWord 8] -truncpad n xs = if m > n then take n xs - else mappend xs (replicate (n - m) 0) - where m = length xs - word256 :: ByteString -> Word256 word256 xs = case Cereal.runGet m (padLeft 32 xs) of Left _ -> error "internal error" diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index df7d20671..1ead85573 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -148,6 +148,23 @@ main = defaultMain $ testGroup "hevm" === (Just $ Literal Patricia.Empty) ] + , testGroup "Symbolic buffers" + [ testProperty "dynWriteMemory works like writeMemory" $ \(src, offset, dst) -> + runSMT $ query $ do + cd <- sbytes128 + mem <- sbytes128 + let staticWriting = writeMemory' cd src offset dst mem + let dynamicWriting = + dynWriteMemory + (implode cd) + (literal src) + (literal offset) + (literal dst) + (implode mem) + implode staticWriting + + ] + , testGroup "Symbolic execution" [ -- Somewhat tautological since we are asserting the precondition From c91ad37b9717475bd2899e20143201a985168428 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 18 Aug 2020 12:02:00 +0200 Subject: [PATCH 03/36] WIP --- src/hevm/src/EVM.hs | 84 +++++++++++++++++++----------------- src/hevm/src/EVM/Symbolic.hs | 23 ++++++---- 2 files changed, 59 insertions(+), 48 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index af86d6a2b..ce5828bd3 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -128,7 +128,11 @@ data TraceData data Query where PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query PleaseFetchSlot :: Addr -> Word -> (Word -> EVM ()) -> Query +<<<<<<< HEAD PleaseAskSMT :: SBool -> [SBool] -> (BranchCondition -> EVM ()) -> Query +======= + PleaseAskSMT :: SymWord -> [SBool] -> (SBool -> EVM ()) -> Query +>>>>>>> fd83741a... WIP data Choose where PleaseChoosePath :: (Bool -> EVM ()) -> Choose @@ -170,7 +174,7 @@ data Cache = Cache -- | A way to specify an initial VM state data VMOpts = VMOpts { vmoptContract :: Contract - , vmoptCalldata :: (Buffer, (SWord 32)) -- maximum size of uint32 as per eip 1985 + , vmoptCalldata :: Buffer -- maximum size of uint32 as per eip 1985 , vmoptValue :: SymWord , vmoptAddress :: Addr , vmoptCaller :: SAddr @@ -225,7 +229,7 @@ data FrameState = FrameState , _stack :: [SymWord] , _memory :: Buffer , _memorySize :: Int - , _calldata :: (Buffer, (SWord 32)) + , _calldata :: Buffer , _callvalue :: SymWord , _caller :: SAddr , _gas :: Word @@ -342,7 +346,7 @@ blankState = FrameState , _stack = mempty , _memory = mempty , _memorySize = 0 - , _calldata = (mempty, 0) + , _calldata = mempty , _callvalue = 0 , _caller = 0 , _gas = 0 @@ -498,28 +502,23 @@ exec1 = do if self > 0x0 && self <= 0x9 then do -- call to precompile let ?op = 0x00 -- dummy value - let - calldatasize = snd (the state calldata) - case unliteral calldatasize of + copyBytesToMemory (the state calldata) (num len (the state calldata)) 0 0 + executePrecompile self (the state gas) 0 (num (len (the state calldata))) 0 0 [] + vmx <- get + case view (state.stack) vmx of + (x:_) -> case maybeLitWord x of + Just 0 -> do + fetchAccount self $ \_ -> do + touchAccount self + vmError PrecompileFailure + Just _ -> + fetchAccount self $ \_ -> do + touchAccount self + out <- use (state . returndata) + finishFrame (FrameReturned out) Nothing -> vmError UnexpectedSymbolicArg - Just calldatasize' -> do - copyBytesToMemory (fst $ the state calldata) (num calldatasize') 0 0 - executePrecompile self (the state gas) 0 (num calldatasize') 0 0 [] - vmx <- get - case view (state.stack) vmx of - (x:_) -> case maybeLitWord x of - Just 0 -> do - fetchAccount self $ \_ -> do - touchAccount self - vmError PrecompileFailure - Just _ -> - fetchAccount self $ \_ -> do - touchAccount self - out <- use (state . returndata) - finishFrame (FrameReturned out) - Nothing -> vmError UnexpectedSymbolicArg - _ -> - underrun + _ -> + underrun else if the state pc >= num (BS.length (the state code)) then doStop @@ -721,12 +720,12 @@ exec1 = do -- op: CALLDATASIZE 0x36 -> limitStack 1 . burn g_base $ - next >> pushSym (sw256 . zeroExtend . snd $ (the state calldata)) + next >> pushSym (sw256 . sFromIntegral . len $ the state calldata) -- op: CALLDATACOPY 0x37 -> case stk of - (xTo' : xFrom' : xSize' : xs) -> forceConcrete3 (xTo',xFrom',xSize') $ \(xTo,xFrom,xSize) -> + (xTo : xFrom : xSize : xs) -> burn (g_verylow + g_copy * ceilDiv xSize 32) $ accessUnboundedMemoryRange fees xTo xSize $ do next @@ -1529,7 +1528,7 @@ askSMT codeloc condition continue = do where -- Only one path is possible choosePath :: BranchCondition -> EVM () choosePath (Case v) = do assign result Nothing - pushTo pathConditions (if v then condition else sNot condition) + pushTo pathConditions v iteration <- use (iterations . at codeloc . non 0) assign (cache . path . at (codeloc, iteration)) (Just v) assign (iterations . at codeloc) (Just (iteration + 1)) @@ -2158,30 +2157,37 @@ finishFrame how = do accessUnboundedMemoryRange :: FeeSchedule Word - -> Word - -> Word + -> SymWord + -> SymWord -> EVM () -> EVM () accessUnboundedMemoryRange _ _ 0 continue = continue -accessUnboundedMemoryRange fees f l continue = do - m0 <- num <$> use (state . memorySize) - do - let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 - burn (memoryCost fees m1 - memoryCost fees m0) $ do +accessUnboundedMemoryRange fees f l continue = + + case (maybeLitWord f, maybeLitWord l) of + (Just f', Just l') -> do + let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 + burn (memoryCost fees m1 - memoryCost fees m0) $ do assign (state . memorySize) (num m1) continue accessMemoryRange :: FeeSchedule Word - -> Word - -> Word + -> SymWord + -> SymWord -> EVM () -> EVM () accessMemoryRange _ _ 0 continue = continue accessMemoryRange fees f l continue = - if f + l < l - then vmError IllegalOverflow - else accessUnboundedMemoryRange fees f l continue + case (maybeLitWord f, maybeLitWord l) of + (Just f', Just l') -> + if f' + l' < l' + then vmError IllegalOverflow + else accessUnboundedMemoryRange fees f l continue + + -- we optimistically neglect the check for overflow here as we'd + -- have to branch on basically every memory access otherwise + _ -> accessUnboundedMemoryRange fees f l continue accessMemoryWord :: FeeSchedule Word -> Word -> EVM () -> EVM () diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 6e8829337..102ec77a3 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -259,15 +259,20 @@ sliceWithZero :: Int -> Int -> Buffer -> Buffer sliceWithZero o s (StaticSymBuffer m) = StaticSymBuffer (sliceWithZero' o s m) sliceWithZero o s (ConcreteBuffer m) = ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes o s m) -writeMemory :: Buffer -> Word -> Word -> Word -> Buffer -> Buffer -writeMemory (ConcreteBuffer bs1) n src dst (ConcreteBuffer bs0) = - ConcreteBuffer (Concrete.writeMemory bs1 n src dst bs0) -writeMemory (ConcreteBuffer bs1) n src dst (StaticSymBuffer bs0) = - StaticSymBuffer (writeMemory' (litBytes bs1) n src dst bs0) -writeMemory (StaticSymBuffer bs1) n src dst (ConcreteBuffer bs0) = - StaticSymBuffer (writeMemory' bs1 n src dst (litBytes bs0)) -writeMemory (StaticSymBuffer bs1) n src dst (StaticSymBuffer bs0) = - StaticSymBuffer (writeMemory' bs1 n src dst bs0) +writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer +writeMemory bs1 n src dst bs0 = + case (maybeLitWord n, maybeLitWord src, maybeLitWord dst, bs0, bs1) of + (Just n', Just src', Just dst', ConcreteBuffer bs0', ConcreteBuffer bs1') -> + ConcreteBuffer $ Concrete.writeMemory bs0' n' src' dst' bs1' + (Just n', Just src', Just dst', StaticSymBuffer bs0', ConcreteBuffer bs1') -> + StaticSymBuffer $ writeMemory' bs0' n' src' dst' (litBytes bs1') + (Just n', Just src', Just dst', ConcreteBuffer bs0', StaticSymBuffer bs1') -> + StaticSymBuffer $ writeMemory' (litBytes bs0') n' src' dst' bs1' + (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> + StaticSymBuffer $ writeMemory' bs0' n' src' dst' bs1' + _ -> let DynamicSymBuffer bs0' = dynamize bs0 + DynamicSymBuffer bs1' = dynamize bs1 + in DynamicSymBuffer $ dynWriteMemory bs0' n src dst bs1' readMemoryWord :: Word -> Buffer -> SymWord readMemoryWord i (StaticSymBuffer m) = readMemoryWord' i m From 9053505b2c2959e6dc0407cd1fbcf7084e0a7259 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 19 Aug 2020 23:42:03 +0200 Subject: [PATCH 04/36] more WIP --- src/hevm/src/EVM.hs | 479 ++++++++++++++++++----------------- src/hevm/src/EVM/Symbolic.hs | 40 ++- src/hevm/src/EVM/Types.hs | 45 ++-- 3 files changed, 301 insertions(+), 263 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index ce5828bd3..6b75671c4 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -128,11 +128,7 @@ data TraceData data Query where PleaseFetchContract :: Addr -> (Contract -> EVM ()) -> Query PleaseFetchSlot :: Addr -> Word -> (Word -> EVM ()) -> Query -<<<<<<< HEAD PleaseAskSMT :: SBool -> [SBool] -> (BranchCondition -> EVM ()) -> Query -======= - PleaseAskSMT :: SymWord -> [SBool] -> (SBool -> EVM ()) -> Query ->>>>>>> fd83741a... WIP data Choose where PleaseChoosePath :: (Bool -> EVM ()) -> Choose @@ -228,7 +224,7 @@ data FrameState = FrameState , _pc :: Int , _stack :: [SymWord] , _memory :: Buffer - , _memorySize :: Int + , _memorySize :: SWord 32 , _calldata :: Buffer , _callvalue :: SymWord , _caller :: SAddr @@ -561,28 +557,28 @@ exec1 = do assign (ix 0) (stk ^?! ix i) assign (ix i) (stk ^?! ix 0) - -- op: LOG - x | x >= 0xa0 && x <= 0xa4 -> - notStatic $ - let n = (num x - 0xa0) in - case stk of - (xOffset':xSize':xs) -> - if length xs < n - then underrun - else - forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> do - let (topics, xs') = splitAt n xs - bytes = readMemory (num xOffset) (num xSize) vm - log = Log self bytes topics - - burn (g_log + g_logdata * xSize + num n * g_logtopic) $ - accessMemoryRange fees xOffset xSize $ do - traceLog log - next - assign (state . stack) xs' - pushToSequence logs log - _ -> - underrun + -- -- op: LOG + -- x | x >= 0xa0 && x <= 0xa4 -> + -- notStatic $ + -- let n = (num x - 0xa0) in + -- case stk of + -- (xOffset':xSize':xs) -> + -- if length xs < n + -- then underrun + -- else + -- forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> do + -- let (topics, xs') = splitAt n xs + -- bytes = readMemory (num xOffset) (num xSize) vm + -- log = Log self bytes topics + + -- burn (g_log + g_logdata * xSize + num n * g_logtopic) $ + -- accessMemoryRange fees xOffset xSize $ do + -- traceLog log + -- next + -- assign (state . stack) xs' + -- pushToSequence logs log + -- _ -> + -- underrun -- op: STOP 0x00 -> doStop @@ -646,72 +642,72 @@ exec1 = do -- op: SAR 0x1d -> stackOp2 (const g_verylow) $ \((S _ n), (S _ x)) -> sw256 $ sSignedShiftArithRight x n - -- op: SHA3 - -- more accurately refered to as KECCAK - 0x20 -> - case stk of - (xOffset' : xSize' : xs) -> - forceConcrete xOffset' $ - \xOffset -> forceConcrete xSize' $ \xSize -> do - (hash, invMap) <- case readMemory xOffset xSize vm of - ConcreteBuffer bs -> pure (litWord $ keccakBlob bs, Map.singleton (keccakBlob bs) bs) - - -- Although we would like to simply assert that the uninterpreted function symkeccak' - -- is injective, this proves to cause a lot of concern for our smt solvers, probably - -- due to the introduction of universal quantifiers into the queries. - - -- Instead, we keep track of all of the particular invocations of symkeccak' we see - -- (similarly to sha3Crack), and simply assert that injectivity holds for these - -- particular invocations. - - StaticSymBuffer bs -> do - let hash' = symkeccak' bs - previousUsed = view (env . keccakUsed) vm - env . keccakUsed <>= [(bs, hash')] - pathConditions <>= fmap (\(preimage, image) -> - image .== hash' .=> preimage .== bs) - previousUsed - return (sw256 hash', mempty) - - burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ - accessMemoryRange fees xOffset xSize $ do - next - assign (state . stack) (hash : xs) - (env . sha3Crack) <>= invMap - _ -> underrun - - -- op: ADDRESS - 0x30 -> - limitStack 1 $ - burn g_base (next >> push (num self)) - - -- op: BALANCE - 0x31 -> - case stk of - (x':xs) -> forceConcrete x' $ \x -> - burn g_balance $ - fetchAccount (num x) $ \c -> do - next - assign (state . stack) xs - push (view balance c) - [] -> - underrun - - -- op: ORIGIN - 0x32 -> - limitStack 1 . burn g_base $ - next >> push (num (the tx origin)) - - -- op: CALLER - 0x33 -> - limitStack 1 . burn g_base $ - let toSymWord = sw256 . sFromIntegral . saddressWord160 - in next >> pushSym (toSymWord (the state caller)) - - -- op: CALLVALUE - 0x34 -> - limitStack 1 . burn g_base $ - next >> pushSym (the state callvalue) + -- -- op: SHA3 + -- -- more accurately refered to as KECCAK + -- 0x20 -> + -- case stk of + -- (xOffset' : xSize' : xs) -> + -- forceConcrete xOffset' $ + -- \xOffset -> forceConcrete xSize' $ \xSize -> do + -- (hash, invMap) <- case readMemory xOffset xSize vm of + -- ConcreteBuffer bs -> pure (litWord $ keccakBlob bs, Map.singleton (keccakBlob bs) bs) + + -- -- Although we would like to simply assert that the uninterpreted function symkeccak' + -- -- is injective, this proves to cause a lot of concern for our smt solvers, probably + -- -- due to the introduction of universal quantifiers into the queries. + + -- -- Instead, we keep track of all of the particular invocations of symkeccak' we see + -- -- (similarly to sha3Crack), and simply assert that injectivity holds for these + -- -- particular invocations. + + -- StaticSymBuffer bs -> do + -- let hash' = symkeccak' bs + -- previousUsed = view (env . keccakUsed) vm + -- env . keccakUsed <>= [(bs, hash')] + -- pathConditions <>= fmap (\(preimage, image) -> + -- image .== hash' .=> preimage .== bs) + -- previousUsed + -- return (sw256 hash', mempty) + + -- burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ + -- accessMemoryRange fees xOffset xSize $ do + -- next + -- assign (state . stack) (hash : xs) + -- (env . sha3Crack) <>= invMap + -- _ -> underrun + + -- -- op: ADDRESS + -- 0x30 -> + -- limitStack 1 $ + -- burn g_base (next >> push (num self)) + + -- -- op: BALANCE + -- 0x31 -> + -- case stk of + -- (x':xs) -> forceConcrete x' $ \x -> + -- burn g_balance $ + -- fetchAccount (num x) $ \c -> do + -- next + -- assign (state . stack) xs + -- push (view balance c) + -- [] -> + -- underrun + + -- -- op: ORIGIN + -- 0x32 -> + -- limitStack 1 . burn g_base $ + -- next >> push (num (the tx origin)) + + -- -- op: CALLER + -- 0x33 -> + -- limitStack 1 . burn g_base $ + -- let toSymWord = sw256 . sFromIntegral . saddressWord160 + -- in next >> pushSym (toSymWord (the state caller)) + + -- -- op: CALLVALUE + -- 0x34 -> + -- limitStack 1 . burn g_base $ + -- next >> pushSym (the state callvalue) -- -- op: CALLDATALOAD -- 0x35 -> stackOp1 (const g_verylow) $ @@ -1528,7 +1524,7 @@ askSMT codeloc condition continue = do where -- Only one path is possible choosePath :: BranchCondition -> EVM () choosePath (Case v) = do assign result Nothing - pushTo pathConditions v + pushTo pathConditions (if v then condition else sNot condition) iteration <- use (iterations . at codeloc . non 0) assign (cache . path . at (codeloc, iteration)) (Just v) assign (iterations . at codeloc) (Just (iteration + 1)) @@ -1720,8 +1716,13 @@ notStatic continue = do then vmError StateChangeWhileStatic else continue +burnSym :: SymWord -> EVM () -> EVM () +burnSym n continue = case maybeLitWord n of + Nothing -> _ -- smt query (TODO: no gas mode) + Just n' -> burn n' continue + -- | Burn gas, failing if insufficient gas is available -burn :: Word -> EVM () -> EVM () +burn :: Word -> EVM () -> EVM() burn n continue = do available <- use (state . gas) if n <= available @@ -1801,41 +1802,41 @@ selfdestruct = pushTo ((tx . substate) . selfdestructs) cheatCode :: Addr cheatCode = num (keccak "hevm cheat code") -cheat - :: (?op :: Word8) - => (Word, Word) -> (Word, Word) - -> EVM () -cheat (inOffset, inSize) (outOffset, outSize) = do - mem <- use (state . memory) - vm <- get - let - abi = readMemoryWord32 inOffset mem - input = readMemory (inOffset + 4) (inSize - 4) vm - case fromSized <$> unliteral abi of - Nothing -> vmError UnexpectedSymbolicArg - Just abi -> - case Map.lookup abi cheatActions of - Nothing -> - vmError (BadCheatCode (Just abi)) - Just (argTypes, action) -> - case input of - StaticSymBuffer _ -> vmError UnexpectedSymbolicArg - ConcreteBuffer input' -> - case runGetOrFail - (getAbiSeq (length argTypes) argTypes) - (LS.fromStrict input') of - Right ("", _, args) -> - action (toList args) >>= \case - Nothing -> do - next - push 1 - Just (encodeAbiValue -> bs) -> do - next - modifying (state . memory) - (writeMemory (ConcreteBuffer bs) outSize 0 outOffset) - push 1 - _ -> - vmError (BadCheatCode (Just abi)) +-- cheat +-- :: (?op :: Word8) +-- => (Word, Word) -> (Word, Word) +-- -> EVM () +-- cheat (inOffset, inSize) (outOffset, outSize) = do +-- mem <- use (state . memory) +-- vm <- get +-- let +-- abi = readMemoryWord32 inOffset mem +-- input = readMemory (inOffset + 4) (inSize - 4) vm +-- case fromSized <$> unliteral abi of +-- Nothing -> vmError UnexpectedSymbolicArg +-- Just abi -> +-- case Map.lookup abi cheatActions of +-- Nothing -> +-- vmError (BadCheatCode (Just abi)) +-- Just (argTypes, action) -> +-- case input of +-- StaticSymBuffer _ -> vmError UnexpectedSymbolicArg +-- ConcreteBuffer input' -> +-- case runGetOrFail +-- (getAbiSeq (length argTypes) argTypes) +-- (LS.fromStrict input') of +-- Right ("", _, args) -> +-- action (toList args) >>= \case +-- Nothing -> do +-- next +-- push 1 +-- Just (encodeAbiValue -> bs) -> do +-- next +-- modifying (state . memory) +-- (writeMemory (ConcreteBuffer bs) outSize 0 outOffset) +-- push 1 +-- _ -> +-- vmError (BadCheatCode (Just abi)) type CheatAction = ([AbiType], [AbiValue] -> EVM (Maybe AbiValue)) @@ -1861,58 +1862,58 @@ cheatActions = where action s ts f = (abiKeccak s, (ts, f)) --- * General call implementation ("delegateCall") -delegateCall - :: (?op :: Word8) - => Contract -> Word -> Addr -> Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] - -> EVM () - -> EVM () -delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = - callChecks this gasGiven xContext xValue xInOffset xInSize xOutOffset xOutSize xs $ - \xGas -> do - vm0 <- get - fetchAccount xTo . const $ - preuse (env . contracts . ix xTo) >>= \case - Nothing -> - vmError (NoSuchContract xTo) - Just target -> - burn xGas $ do - let newContext = CallContext - { callContextOffset = xOutOffset - , callContextSize = xOutSize - , callContextCodehash = view codehash target - , callContextReversion = view (env . contracts) vm0 - , callContextSubState = view (tx . substate) vm0 - , callContextAbi = - if xInSize >= 4 - then case unliteral $ readMemoryWord32 xInOffset (view (state . memory) vm0) - of Nothing -> Nothing - Just abi -> Just . w256 $ num abi - else Nothing - , callContextData = (readMemory (num xInOffset) (num xInSize) vm0) - } - - pushTrace (FrameTrace newContext) - next - vm1 <- get - - pushTo frames $ Frame - { _frameState = (set stack xs) (view state vm1) - , _frameContext = newContext - } - - zoom state $ do - assign gas xGas - assign pc 0 - assign code (view bytecode target) - assign codeContract xTo - assign stack mempty - assign memory mempty - assign memorySize 0 - assign returndata mempty - assign calldata (readMemory (num xInOffset) (num xInSize) vm0, literal (num xInSize)) - - continue +-- -- * General call implementation ("delegateCall") +-- delegateCall +-- :: (?op :: Word8) +-- => Contract -> Word -> Addr -> Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] +-- -> EVM () +-- -> EVM () +-- delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = +-- callChecks this gasGiven xContext xValue xInOffset xInSize xOutOffset xOutSize xs $ +-- \xGas -> do +-- vm0 <- get +-- fetchAccount xTo . const $ +-- preuse (env . contracts . ix xTo) >>= \case +-- Nothing -> +-- vmError (NoSuchContract xTo) +-- Just target -> +-- burn xGas $ do +-- let newContext = CallContext +-- { callContextOffset = xOutOffset +-- , callContextSize = xOutSize +-- , callContextCodehash = view codehash target +-- , callContextReversion = view (env . contracts) vm0 +-- , callContextSubState = view (tx . substate) vm0 +-- , callContextAbi = +-- if xInSize >= 4 +-- then case unliteral $ readMemoryWord32 xInOffset (view (state . memory) vm0) +-- of Nothing -> Nothing +-- Just abi -> Just . w256 $ num abi +-- else Nothing +-- , callContextData = (readMemory (num xInOffset) (num xInSize) vm0) +-- } + +-- pushTrace (FrameTrace newContext) +-- next +-- vm1 <- get + +-- pushTo frames $ Frame +-- { _frameState = (set stack xs) (view state vm1) +-- , _frameContext = newContext +-- } + +-- zoom state $ do +-- assign gas xGas +-- assign pc 0 +-- assign code (view bytecode target) +-- assign codeContract xTo +-- assign stack mempty +-- assign memory mempty +-- assign memorySize 0 +-- assign returndata mempty +-- assign calldata (readMemory (num xInOffset) (num xInSize) vm0, literal (num xInSize)) + +-- continue -- -- * Contract creation @@ -2162,14 +2163,20 @@ accessUnboundedMemoryRange -> EVM () -> EVM () accessUnboundedMemoryRange _ _ 0 continue = continue -accessUnboundedMemoryRange fees f l continue = - +accessUnboundedMemoryRange fees f l continue = do + m0 <- num <$> use (state . memorySize) case (maybeLitWord f, maybeLitWord l) of (Just f', Just l') -> do - let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 - burn (memoryCost fees m1 - memoryCost fees m0) $ do - assign (state . memorySize) (num m1) - continue + let m1 = 32 * ceilDiv (smax m0 (f + l)) 32 + burn (memoryCost fees m1 - memoryCost fees m0) $ do + assign (state . memorySize) (num m1) + continue + _ -> do + let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 + -- todo: consult smt here + assign (state . memorySize) (num m1) + continue + accessMemoryRange :: FeeSchedule Word @@ -2185,12 +2192,11 @@ accessMemoryRange fees f l continue = then vmError IllegalOverflow else accessUnboundedMemoryRange fees f l continue - -- we optimistically neglect the check for overflow here as we'd - -- have to branch on basically every memory access otherwise + -- todo: consult smt here _ -> accessUnboundedMemoryRange fees f l continue accessMemoryWord - :: FeeSchedule Word -> Word -> EVM () -> EVM () + :: FeeSchedule Word -> SymWord -> EVM () -> EVM () accessMemoryWord fees x = accessMemoryRange fees x 32 copyBytesToMemory @@ -2213,10 +2219,10 @@ copyCallBytesToMemory bs size xOffset yOffset = else do mem <- use (state . memory) assign (state . memory) $ - writeMemory bs (min size (num (len bs))) xOffset yOffset mem + writeMemory bs (sw256 $ smin (literal (num size)) (sFromIntegral (len bs))) (litWord xOffset) (litWord yOffset) mem -readMemory :: Word -> Word -> VM -> Buffer -readMemory offset size vm = sliceWithZero (num offset) (num size) (view (state . memory) vm) +readMemory :: SymWord -> SymWord -> VM -> Buffer +readMemory offset size vm = sliceWithZero offset size (view (state . memory) vm) word256At :: Functor f @@ -2541,47 +2547,47 @@ costOfCreate (FeeSchedule {..}) availableGas hashSize = -- Gas cost of precompiles costOfPrecompile :: FeeSchedule Word -> Addr -> Buffer -> Word -costOfPrecompile (FeeSchedule {..}) precompileAddr input = - case precompileAddr of - -- ECRECOVER - 0x1 -> 3000 - -- SHA2-256 - 0x2 -> num $ (((len input + 31) `div` 32) * 12) + 60 - -- RIPEMD-160 - 0x3 -> num $ (((len input + 31) `div` 32) * 120) + 600 - -- IDENTITY - 0x4 -> num $ (((len input + 31) `div` 32) * 3) + 15 - -- MODEXP - 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) - where input' = case input of - StaticSymBuffer _ -> error "unsupported: symbolic MODEXP gas cost calc" - ConcreteBuffer b -> b - (lenb, lene, lenm) = parseModexpLength input' - lene' | lene <= 32 && ez = 0 - | lene <= 32 = num (log2 e') - | e' == 0 = 8 * (lene - 32) - | otherwise = num (log2 e') + 8 * (lene - 32) - - ez = isZero (96 + lenb) lene input' - e' = w256 $ word $ LS.toStrict $ - lazySlice (96 + lenb) (min 32 lene) input' - - f :: Integer -> Integer - f x | x <= 64 = x * x - | x <= 1024 = (x * x) `div` 4 + 96 * x - 3072 - | otherwise = (x * x) `div` 16 + 480 * x - 199680 - -- ECADD - 0x6 -> g_ecadd - -- ECMUL - 0x7 -> g_ecmul - -- ECPAIRING - 0x8 -> num $ ((len input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) - -- BLAKE2 - 0x9 -> let input' = case input of - StaticSymBuffer _ -> error "unsupported: symbolic BLAKE2B gas cost calc" - ConcreteBuffer b -> b - in g_fround * (num $ asInteger $ lazySlice 0 4 input') - _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) +costOfPrecompile (FeeSchedule {..}) precompileAddr input = _ + -- case precompileAddr of + -- -- ECRECOVER + -- 0x1 -> 3000 + -- -- SHA2-256 + -- 0x2 -> num $ (((len input + 31) `div` 32) * 12) + 60 + -- -- RIPEMD-160 + -- 0x3 -> num $ (((len input + 31) `div` 32) * 120) + 600 + -- -- IDENTITY + -- 0x4 -> num $ (((len input + 31) `div` 32) * 3) + 15 + -- -- MODEXP + -- 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) + -- where input' = case input of + -- StaticSymBuffer _ -> error "unsupported: symbolic MODEXP gas cost calc" + -- ConcreteBuffer b -> b + -- (lenb, lene, lenm) = parseModexpLength input' + -- lene' | lene <= 32 && ez = 0 + -- | lene <= 32 = num (log2 e') + -- | e' == 0 = 8 * (lene - 32) + -- | otherwise = num (log2 e') + 8 * (lene - 32) + + -- ez = isZero (96 + lenb) lene input' + -- e' = w256 $ word $ LS.toStrict $ + -- lazySlice (96 + lenb) (min 32 lene) input' + + -- f :: Integer -> Integer + -- f x | x <= 64 = x * x + -- | x <= 1024 = (x * x) `div` 4 + 96 * x - 3072 + -- | otherwise = (x * x) `div` 16 + 480 * x - 199680 + -- -- ECADD + -- 0x6 -> g_ecadd + -- -- ECMUL + -- 0x7 -> g_ecmul + -- -- ECPAIRING + -- 0x8 -> num $ ((len input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) + -- -- BLAKE2 + -- 0x9 -> let input' = case input of + -- StaticSymBuffer _ -> error "unsupported: symbolic BLAKE2B gas cost calc" + -- ConcreteBuffer b -> b + -- in g_fround * (num $ asInteger $ lazySlice 0 4 input') + -- _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) -- Gas cost of memory expansion memoryCost :: FeeSchedule Word -> Word -> Word @@ -2624,6 +2630,9 @@ symSHA256 bytes = case length bytes of ceilDiv :: (Num a, Integral a) => a -> a -> a ceilDiv m n = div (m + n - 1) n +-- ceilSDiv :: (Num a, Integral a) => a -> a -> a +-- ceilSDiv m n = (m + n - 1) `sDiv` n + allButOne64th :: (Num a, Integral a) => a -> a allButOne64th n = n - div n 64 diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 102ec77a3..e98a12f8b 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -122,6 +122,9 @@ truncpad' n xs = swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs +swordAt' :: SInteger -> SList (WordN 8) -> SymWord +swordAt' i bs = sw256 . fromBytes $ truncpad' 32 $ SL.drop i bs + readByteOrZero' :: Int -> [SWord 8] -> SWord 8 readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) @@ -214,6 +217,11 @@ readSWordWithBound ind (ConcreteBuffer xs) bound = readMemoryWord' :: Word -> [SWord 8] -> SymWord readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) +-- TODO: ensure we actually pad with zeros +sliceWithZero'' :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) +sliceWithZero'' (S _ o) (S _ s) m = SL.subList m (sFromIntegral s) (sFromIntegral o) + + -- readMemoryWord' :: Word -> [SWord 8] -> SymWord -- readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) @@ -228,11 +236,11 @@ readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) -- setMemoryByte' (C _ i) x = -- writeMemory' [x] 1 0 (num i) --- readSWord' :: Word -> [SWord 8] -> SymWord --- readSWord' (C _ i) x = --- if i > num (length x) --- then 0 --- else swordAt (num i) x +readSWord'' :: SymWord -> SList (WordN 8) -> SymWord +readSWord'' (S _ i) x = + ite (sFromIntegral i .> SL.length x) + 0 + (swordAt' (sFromIntegral i) x) -- a whole foldable instance seems overkill, but length is always good to have! len :: Buffer -> SWord 32 @@ -255,9 +263,13 @@ readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (literal $ num i) bs -sliceWithZero :: Int -> Int -> Buffer -> Buffer -sliceWithZero o s (StaticSymBuffer m) = StaticSymBuffer (sliceWithZero' o s m) -sliceWithZero o s (ConcreteBuffer m) = ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes o s m) +sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer +sliceWithZero o s bf = case (maybeLitWord o, maybeLitWord s, bf) of + (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) + (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) +sliceWithZero o s (StaticSymBuffer bf) = DynamicSymBuffer $ sliceWithZero'' o s (SL.implode bf) +sliceWithZero o s (ConcreteBuffer bf) = DynamicSymBuffer $ sliceWithZero'' o s (SL.implode (litBytes bf)) +sliceWithZero o s (DynamicSymBuffer bf) = DynamicSymBuffer $ sliceWithZero'' o s bf writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer writeMemory bs1 n src dst bs0 = @@ -270,8 +282,8 @@ writeMemory bs1 n src dst bs0 = StaticSymBuffer $ writeMemory' (litBytes bs0') n' src' dst' bs1' (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> StaticSymBuffer $ writeMemory' bs0' n' src' dst' bs1' - _ -> let DynamicSymBuffer bs0' = dynamize bs0 - DynamicSymBuffer bs1' = dynamize bs1 + _ -> let bs0' = dynamize bs0 + bs1' = dynamize bs1 in DynamicSymBuffer $ dynWriteMemory bs0' n src dst bs1' readMemoryWord :: Word -> Buffer -> SymWord @@ -294,9 +306,11 @@ setMemoryByte i x (ConcreteBuffer m) = case fromSized <$> unliteral x of Nothing -> StaticSymBuffer $ setMemoryByte' i x (litBytes m) Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i x' m -readSWord :: Word -> Buffer -> SymWord -readSWord i (StaticSymBuffer x) = readSWord' i x -readSWord i (ConcreteBuffer x) = num $ Concrete.readMemoryWord i x +readSWord :: SymWord -> Buffer -> SymWord +readSWord i bf = case (maybeLitWord i, bf) of + (Just i', StaticSymBuffer x) -> readSWord' i' x + (Just i', ConcreteBuffer x) -> num $ Concrete.readMemoryWord i' x + _ -> readSWord'' i (dynamize bf) -- | Custom instances for SymWord, many of which have direct -- analogues for concrete words defined in Concrete.hs diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index 963575bc9..d2c7a97eb 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -88,34 +88,49 @@ instance (FromSizzleBV (WordN 160)) litBytes :: ByteString -> [SWord 8] litBytes bs = fmap (toSized . literal) (BS.unpack bs) --- | Operations over buffers (concrete or symbolic) - --- | A buffer is a list of bytes. For concrete execution, this is simply `ByteString`. --- In symbolic settings, its structure is sometimes known statically, --- and sometimes only determined dynamically. --- In the static case, it's a simple list of symbolic bitvectors of size 8. --- In the dynamic case, it's a pair of an SMT array and a symbolic word representing --- the buffer length. +-- * Operations over buffers (concrete or symbolic) + +-- | A buffer is a list of bytes, and is used to model EVM memory or calldata. +-- During concrete execution, this is simply `ByteString`. +-- In symbolic settings, the structure of a buffer is sometimes known statically, +-- in which case simply use a list of symbolic bytes. +-- When we are dealing with dynamically determined calldata or memory (such as if +-- we are interpreting a function which a `memory bytes` argument), +-- we use smt lists. Note that smt lists are not yet supported by cvc4! data Buffer = ConcreteBuffer ByteString | StaticSymBuffer [SWord 8] - | DynamicSymBuffer (SArray (WordN 32) (WordN 8), SWord 32) + | DynamicSymBuffer (SList (WordN 8)) deriving (Show) -dynamize :: Buffer -> Buffer -dynamize (ConcreteBuffer a) = dynamize $ StaticSymBuffer (litBytes a) -dynamize (DynamicSymBuffer a) = DynamicSymBuffer a -dynamize (StaticSymBuffer a) = - DynamicSymBuffer (sListArray (Just 0) $ zip [0..] a, literal . num $ length a) +dynamize :: Buffer -> SList (WordN 8) +dynamize (ConcreteBuffer a) = SL.implode $ litBytes a +dynamize (StaticSymBuffer a) = SL.implode a +dynamize (DynamicSymBuffer a) = a instance EqSymbolic Buffer where ConcreteBuffer a .== ConcreteBuffer b = literal (a == b) ConcreteBuffer a .== StaticSymBuffer b = litBytes a .== b StaticSymBuffer a .== ConcreteBuffer b = a .== litBytes b StaticSymBuffer a .== StaticSymBuffer b = a .== b - DynamicSymBuffer a .== DynamicSymBuffer b = a .== b a .== b = dynamize a .== dynamize b + +instance Semigroup Buffer where + ConcreteBuffer a <> ConcreteBuffer b = ConcreteBuffer (a <> b) + ConcreteBuffer a <> StaticSymBuffer b = StaticSymBuffer (litBytes a <> b) + c@(ConcreteBuffer a) <> DynamicSymBuffer b = DynamicSymBuffer (dynamize c .++ b) + + StaticSymBuffer a <> ConcreteBuffer b = StaticSymBuffer (a <> litBytes b) + StaticSymBuffer a <> StaticSymBuffer b = StaticSymBuffer (a <> b) + c@(StaticSymBuffer a) <> DynamicSymBuffer b = DynamicSymBuffer (dynamize c .++ b) + + a <> b = DynamicSymBuffer (dynamize a .++ dynamize b) + +instance Monoid Buffer where + mempty = ConcreteBuffer mempty + + newtype Addr = Addr { addressWord160 :: Word160 } deriving (Num, Integral, Real, Ord, Enum, Eq, Bits, Generic) From 2776c03d8d0cdb2787bbd2c790163ffe3e230214 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Thu, 20 Aug 2020 20:26:59 +0200 Subject: [PATCH 05/36] wip dynbuffer --- src/hevm/src/EVM.hs | 398 ++++++++++++++++++----------------- src/hevm/src/EVM/Emacs.hs | 12 +- src/hevm/src/EVM/Exec.hs | 2 +- src/hevm/src/EVM/Format.hs | 12 +- src/hevm/src/EVM/SymExec.hs | 84 ++++---- src/hevm/src/EVM/Symbolic.hs | 15 ++ src/hevm/src/EVM/TTY.hs | 6 +- src/hevm/src/EVM/UnitTest.hs | 4 +- src/hevm/src/EVM/VMTest.hs | 6 +- src/hevm/test/test.hs | 83 ++++++-- 10 files changed, 345 insertions(+), 277 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 6b75671c4..56a319e6b 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -497,24 +497,25 @@ exec1 = do if self > 0x0 && self <= 0x9 then do -- call to precompile - let ?op = 0x00 -- dummy value - copyBytesToMemory (the state calldata) (num len (the state calldata)) 0 0 - executePrecompile self (the state gas) 0 (num (len (the state calldata))) 0 0 [] - vmx <- get - case view (state.stack) vmx of - (x:_) -> case maybeLitWord x of - Just 0 -> do - fetchAccount self $ \_ -> do - touchAccount self - vmError PrecompileFailure - Just _ -> - fetchAccount self $ \_ -> do - touchAccount self - out <- use (state . returndata) - finishFrame (FrameReturned out) - Nothing -> vmError UnexpectedSymbolicArg - _ -> - underrun + error "hold off precompile for now" + -- let ?op = 0x00 -- dummy value + -- copyBytesToMemory (the state calldata) (num len (the state calldata)) 0 0 + -- executePrecompile self (the state gas) 0 (num (len (the state calldata))) 0 0 [] + -- vmx <- get + -- case view (state.stack) vmx of + -- (x:_) -> case maybeLitWord x of + -- Just 0 -> do + -- fetchAccount self $ \_ -> do + -- touchAccount self + -- vmError PrecompileFailure + -- Just _ -> + -- fetchAccount self $ \_ -> do + -- touchAccount self + -- out <- use (state . returndata) + -- finishFrame (FrameReturned out) + -- Nothing -> vmError UnexpectedSymbolicArg + -- _ -> + -- underrun else if the state pc >= num (BS.length (the state code)) then doStop @@ -1249,27 +1250,28 @@ callChecks -> (Word -> EVM ()) -> EVM () callChecks this xGas xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = do - vm <- get - let fees = view (block . schedule) vm - accessMemoryRange fees xInOffset xInSize $ - accessMemoryRange fees xOutOffset xOutSize $ do - availableGas <- use (state . gas) - let recipientExists = accountExists xContext vm - (cost, gas') = costOfCall fees recipientExists xValue availableGas xGas - burn (cost - gas') $ do - if xValue > view balance this - then do - assign (state . stack) (0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) - next - else if length (view frames vm) >= 1024 - then do - assign (state . stack) (0 : xs) - assign (state . returndata) mempty - pushTrace $ ErrorTrace $ CallDepthLimitReached - next - else continue gas' + error "no calls for now" + -- vm <- get + -- let fees = view (block . schedule) vm + -- accessMemoryRange fees xInOffset xInSize $ + -- accessMemoryRange fees xOutOffset xOutSize $ do + -- availableGas <- use (state . gas) + -- let recipientExists = accountExists xContext vm + -- (cost, gas') = costOfCall fees recipientExists xValue availableGas xGas + -- burn (cost - gas') $ do + -- if xValue > view balance this + -- then do + -- assign (state . stack) (0 : xs) + -- assign (state . returndata) mempty + -- pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + -- next + -- else if length (view frames vm) >= 1024 + -- then do + -- assign (state . stack) (0 : xs) + -- assign (state . returndata) mempty + -- pushTrace $ ErrorTrace $ CallDepthLimitReached + -- next + -- else continue gas' precompiledContract :: (?op :: Word8) @@ -1308,157 +1310,157 @@ executePrecompile => Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] -> EVM () -executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do - vm <- get - let input = readMemory (num inOffset) (num inSize) vm - fees = view (block . schedule) vm - cost = costOfPrecompile fees preCompileAddr input - notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" - precompileFail = burn (gasCap - cost) $ do - assign (state . stack) (0 : xs) - pushTrace $ ErrorTrace $ PrecompileFailure - next - if cost > gasCap then - burn gasCap $ do - assign (state . stack) (0 : xs) - next - else - burn cost $ - case preCompileAddr of - -- ECRECOVER - 0x1 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of - Nothing -> do - -- return no output for invalid signature - assign (state . stack) (1 : xs) - assign (state . returndata) mempty - next - Just output -> do - assign (state . stack) (1 : xs) - assign (state . returndata) (ConcreteBuffer output) - copyBytesToMemory (ConcreteBuffer output) outSize 0 outOffset - next - - -- SHA2-256 - 0x2 -> - let - hash = case input of - ConcreteBuffer input' -> ConcreteBuffer $ BS.pack $ BA.unpack $ (Crypto.hash input' :: Digest SHA256) - StaticSymBuffer input' -> StaticSymBuffer $ symSHA256 input' - in do - assign (state . stack) (1 : xs) - assign (state . returndata) hash - copyBytesToMemory hash outSize 0 outOffset - next - - -- RIPEMD-160 - 0x3 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - let - padding = BS.pack $ replicate 12 0 - hash' = BS.pack $ BA.unpack (Crypto.hash input' :: Digest RIPEMD160) - hash = ConcreteBuffer $ padding <> hash' - in do - assign (state . stack) (1 : xs) - assign (state . returndata) hash - copyBytesToMemory hash outSize 0 outOffset - next - - -- IDENTITY - 0x4 -> do - assign (state . stack) (1 : xs) - assign (state . returndata) input - copyCallBytesToMemory input outSize 0 outOffset - next - - -- MODEXP - 0x5 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - let - (lenb, lene, lenm) = parseModexpLength input' - - output = ConcreteBuffer $ - case (isZero (96 + lenb + lene) lenm input') of - True -> - truncpadlit (num lenm) (asBE (0 :: Int)) - False -> - let - b = asInteger $ lazySlice 96 lenb $ input' - e = asInteger $ lazySlice (96 + lenb) lene $ input' - m = asInteger $ lazySlice (96 + lenb + lene) lenm $ input' - in - padLeft (num lenm) (asBE (expFast b e m)) - in do - assign (state . stack) (1 : xs) - assign (state . returndata) output - copyBytesToMemory output outSize 0 outOffset - next - - -- ECADD - 0x6 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - - -- ECMUL - 0x7 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - - -- ECPAIRING - 0x8 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> - - case EVM.Precompiled.execute 0x8 input' 32 of - Nothing -> precompileFail - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 32 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - - -- BLAKE2 - 0x9 -> - -- TODO: support symbolic variant - forceConcreteBuffer input $ \input' -> do - - case (BS.length input', 1 >= BS.last input') of - (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of - Just output -> do - let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - assign (state . stack) (1 : xs) - assign (state . returndata) truncpaddedOutput - copyBytesToMemory truncpaddedOutput outSize 0 outOffset - next - Nothing -> precompileFail - _ -> precompileFail - +executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = error "no precompile rn" --do _ + -- vm <- get + -- let input = readMemory (num inOffset) (num inSize) vm + -- fees = view (block . schedule) vm + -- cost = costOfPrecompile fees preCompileAddr input + -- notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" + -- precompileFail = burn (gasCap - cost) $ do + -- assign (state . stack) (0 : xs) + -- pushTrace $ ErrorTrace $ PrecompileFailure + -- next + -- if cost > gasCap then + -- burn gasCap $ do + -- assign (state . stack) (0 : xs) + -- next + -- else + -- burn cost $ + -- case preCompileAddr of + -- -- ECRECOVER + -- 0x1 -> + -- -- TODO: support symbolic variant + -- forceConcreteBuffer input $ \input' -> + -- case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of + -- Nothing -> do + -- -- return no output for invalid signature + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) mempty + -- next + -- Just output -> do + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) (ConcreteBuffer output) + -- copyBytesToMemory (ConcreteBuffer output) outSize 0 outOffset + -- next + + -- -- SHA2-256 + -- 0x2 -> + -- let + -- hash = case input of + -- ConcreteBuffer input' -> ConcreteBuffer $ BS.pack $ BA.unpack $ (Crypto.hash input' :: Digest SHA256) + -- StaticSymBuffer input' -> StaticSymBuffer $ symSHA256 input' + -- in do + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) hash + -- copyBytesToMemory hash outSize 0 outOffset + -- next + + -- -- RIPEMD-160 + -- 0x3 -> + -- -- TODO: support symbolic variant + -- forceConcreteBuffer input $ \input' -> + + -- let + -- padding = BS.pack $ replicate 12 0 + -- hash' = BS.pack $ BA.unpack (Crypto.hash input' :: Digest RIPEMD160) + -- hash = ConcreteBuffer $ padding <> hash' + -- in do + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) hash + -- copyBytesToMemory hash outSize 0 outOffset + -- next + + -- -- IDENTITY + -- 0x4 -> do + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) input + -- copyCallBytesToMemory input outSize 0 outOffset + -- next + + -- -- MODEXP + -- 0x5 -> + -- -- TODO: support symbolic variant + -- forceConcreteBuffer input $ \input' -> + + -- let + -- (lenb, lene, lenm) = parseModexpLength input' - _ -> notImplemented + -- output = ConcreteBuffer $ + -- case (isZero (96 + lenb + lene) lenm input') of + -- True -> + -- truncpadlit (num lenm) (asBE (0 :: Int)) + -- False -> + -- let + -- b = asInteger $ lazySlice 96 lenb $ input' + -- e = asInteger $ lazySlice (96 + lenb) lene $ input' + -- m = asInteger $ lazySlice (96 + lenb + lene) lenm $ input' + -- in + -- padLeft (num lenm) (asBE (expFast b e m)) + -- in do + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) output + -- copyBytesToMemory output outSize 0 outOffset + -- next + + -- -- ECADD + -- 0x6 -> + -- -- TODO: support symbolic variant + -- forceConcreteBuffer input $ \input' -> + -- case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of + -- Nothing -> precompileFail + -- Just output -> do + -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) truncpaddedOutput + -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset + -- next + + -- -- ECMUL + -- 0x7 -> + -- -- TODO: support symbolic variant + -- forceConcreteBuffer input $ \input' -> + + -- case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of + -- Nothing -> precompileFail + -- Just output -> do + -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) truncpaddedOutput + -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset + -- next + + -- -- ECPAIRING + -- 0x8 -> + -- -- TODO: support symbolic variant + -- forceConcreteBuffer input $ \input' -> + + -- case EVM.Precompiled.execute 0x8 input' 32 of + -- Nothing -> precompileFail + -- Just output -> do + -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 32 output + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) truncpaddedOutput + -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset + -- next + + -- -- BLAKE2 + -- 0x9 -> + -- -- TODO: support symbolic variant + -- forceConcreteBuffer input $ \input' -> do + + -- case (BS.length input', 1 >= BS.last input') of + -- (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of + -- Just output -> do + -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + -- assign (state . stack) (1 : xs) + -- assign (state . returndata) truncpaddedOutput + -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset + -- next + -- Nothing -> precompileFail + -- _ -> precompileFail + + + -- _ -> notImplemented truncpadlit :: Int -> ByteString -> ByteString truncpadlit n xs = if m > n then BS.take n xs @@ -1718,7 +1720,7 @@ notStatic continue = do burnSym :: SymWord -> EVM () -> EVM () burnSym n continue = case maybeLitWord n of - Nothing -> _ -- smt query (TODO: no gas mode) + Nothing -> continue -- smt query (TODO: no gas mode) Just n' -> burn n' continue -- | Burn gas, failing if insufficient gas is available @@ -2164,17 +2166,17 @@ accessUnboundedMemoryRange -> EVM () accessUnboundedMemoryRange _ _ 0 continue = continue accessUnboundedMemoryRange fees f l continue = do - m0 <- num <$> use (state . memorySize) - case (maybeLitWord f, maybeLitWord l) of - (Just f', Just l') -> do - let m1 = 32 * ceilDiv (smax m0 (f + l)) 32 - burn (memoryCost fees m1 - memoryCost fees m0) $ do + m0 <- use (state . memorySize) + case (maybeLitWord f, maybeLitWord l, unliteral m0) of + (Just f', Just l', Just (num -> m0')) -> do + let m1 = 32 * ceilDiv (max m0' (f' + l')) 32 + burn (memoryCost fees m1 - memoryCost fees m0') $ do assign (state . memorySize) (num m1) continue _ -> do - let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 + -- let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 -- todo: consult smt here - assign (state . memorySize) (num m1) + -- assign (state . memorySize) (num m1) continue @@ -2547,7 +2549,7 @@ costOfCreate (FeeSchedule {..}) availableGas hashSize = -- Gas cost of precompiles costOfPrecompile :: FeeSchedule Word -> Addr -> Buffer -> Word -costOfPrecompile (FeeSchedule {..}) precompileAddr input = _ +costOfPrecompile (FeeSchedule {..}) precompileAddr input = error "wait" -- case precompileAddr of -- -- ECRECOVER -- 0x1 -> 3000 diff --git a/src/hevm/src/EVM/Emacs.hs b/src/hevm/src/EVM/Emacs.hs index 788f47e74..e348d11ae 100644 --- a/src/hevm/src/EVM/Emacs.hs +++ b/src/hevm/src/EVM/Emacs.hs @@ -42,6 +42,7 @@ import qualified Data.Set as Set import qualified Data.Vector as Vector import qualified EVM.Fetch as Fetch import qualified EVM.Stepper as Stepper +import qualified Data.ByteString as BS data UiVmState = UiVmState { _uiVm :: VM @@ -462,7 +463,7 @@ instance SDisplay (SWord 8) where -- no idea what's going on here instance SDisplay Buffer where - sexp (SymbolicBuffer x) = sexp x + sexp (StaticSymBuffer x) = sexp x sexp (ConcreteBuffer x) = sexp x instance (SDisplay k, SDisplay v) => SDisplay (Map k v) where @@ -509,10 +510,11 @@ instance SDisplay ByteString where sexp = A . txt . pack . show . ByteStringS sexpMemory :: Buffer -> SExpr Text -sexpMemory bs = - if len bs > 1024 - then L [A "large-memory", A (txt (len bs))] - else sexp bs +sexpMemory (ConcreteBuffer bs) = + if BS.length bs > 1024 + then L [A "large-memory", A (txt (BS.length bs))] + else sexp (ConcreteBuffer bs) +sexpMemory bs = sexp bs defaultUnitTestOptions :: MonadIO m => m UnitTestOptions defaultUnitTestOptions = do diff --git a/src/hevm/src/EVM/Exec.hs b/src/hevm/src/EVM/Exec.hs index 20954dd06..d960b87ea 100644 --- a/src/hevm/src/EVM/Exec.hs +++ b/src/hevm/src/EVM/Exec.hs @@ -22,7 +22,7 @@ vmForEthrunCreation :: ByteString -> VM vmForEthrunCreation creationCode = (makeVm $ VMOpts { vmoptContract = initialContract (InitCode creationCode) - , vmoptCalldata = (mempty, 0) + , vmoptCalldata = mempty , vmoptValue = 0 , vmoptAddress = createAddress ethrunAddress 1 , vmoptCaller = litAddr ethrunAddress diff --git a/src/hevm/src/EVM/Format.hs b/src/hevm/src/EVM/Format.hs index 393d42a6c..dcd08adae 100644 --- a/src/hevm/src/EVM/Format.hs +++ b/src/hevm/src/EVM/Format.hs @@ -114,7 +114,7 @@ formatBytes b = else formatBinary b formatSBytes :: Buffer -> Text -formatSBytes (SymbolicBuffer b) = "<" <> pack (show (length b)) <> " symbolic bytes>" +formatSBytes (StaticSymBuffer b) = "<" <> pack (show (length b)) <> " symbolic bytes>" formatSBytes (ConcreteBuffer b) = formatBytes b formatQString :: ByteString -> Text @@ -124,7 +124,7 @@ formatString :: ByteString -> Text formatString bs = decodeUtf8 (fst (BS.spanEnd (== 0) bs)) formatSString :: Buffer -> Text -formatSString (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes (string)>" +formatSString (StaticSymBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes (string)>" formatSString (ConcreteBuffer bs) = formatString bs formatBinary :: ByteString -> Text @@ -132,7 +132,7 @@ formatBinary = (<>) "0x" . decodeUtf8 . toStrict . toLazyByteString . byteStringHex formatSBinary :: Buffer -> Text -formatSBinary (SymbolicBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes>" +formatSBinary (StaticSymBuffer bs) = "<" <> pack (show (length bs)) <> " symbolic bytes>" formatSBinary (ConcreteBuffer bs) = formatBinary bs showTraceTree :: DappInfo -> VM -> Text @@ -250,7 +250,7 @@ getAbiTypes abi = map (parseTypeName mempty) types splitOn "," (dropEnd 1 (last (splitOn "(" abi))) showCall :: [AbiType] -> Buffer -> Text -showCall ts (SymbolicBuffer bs) = showValues ts $ SymbolicBuffer (drop 4 bs) +showCall ts (StaticSymBuffer bs) = showValues ts $ StaticSymBuffer (drop 4 bs) showCall ts (ConcreteBuffer bs) = showValues ts $ ConcreteBuffer (BS.drop 4 bs) showError :: ByteString -> Text @@ -260,14 +260,14 @@ showError bs = case BS.take 4 bs of _ -> formatBinary bs showValues :: [AbiType] -> Buffer -> Text -showValues ts (SymbolicBuffer sbs) = "symbolic: " <> (pack . show $ AbiTupleType (fromList ts)) +showValues ts (StaticSymBuffer sbs) = "symbolic: " <> (pack . show $ AbiTupleType (fromList ts)) showValues ts (ConcreteBuffer bs) = case runGetOrFail (getAbiSeq (length ts) ts) (fromStrict bs) of Right (_, _, xs) -> showAbiValues xs Left (_, _, _) -> formatBinary bs showValue :: AbiType -> Buffer -> Text -showValue t (SymbolicBuffer _) = "symbolic: " <> (pack $ show t) +showValue t (StaticSymBuffer _) = "symbolic: " <> (pack $ show t) showValue t (ConcreteBuffer bs) = case runGetOrFail (getAbi t) (fromStrict bs) of Right (_, _, x) -> showAbiValue x diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index dac85ad83..87c38ba9d 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -45,33 +45,31 @@ sbytes1024 = liftA2 (++) sbytes512 sbytes512 -- We don't assume input types are restricted to their proper range here; -- such assumptions should instead be given as preconditions. -- This could catch some interesting calldata mismanagement errors. -symAbiArg :: AbiType -> Query ([SWord 8], SWord 32) -symAbiArg (AbiUIntType n) | n `mod` 8 == 0 && n <= 256 = do x <- sbytes32 - return (x, 32) - | otherwise = error "bad type" +staticAbiArg :: AbiType -> Query [SWord 8] +staticAbiArg (AbiUIntType n) + | n `mod` 8 == 0 && n <= 256 = sbytes32 + | otherwise = error "bad type" -symAbiArg (AbiIntType n) | n `mod` 8 == 0 && n <= 256 = do x <- sbytes32 - return (x, 32) - | otherwise = error "bad type" -symAbiArg AbiBoolType = do x <- sbytes32 - return (x, 32) +staticAbiArg (AbiIntType n) + | n `mod` 8 == 0 && n <= 256 = sbytes32 + | otherwise = error "bad type" -symAbiArg AbiAddressType = do x <- sbytes32 - return (x, 32) +staticAbiArg AbiBoolType = sbytes32 -symAbiArg (AbiBytesType n) | n <= 32 = do x <- sbytes32 - return (x, 32) - | otherwise = error "bad type" +staticAbiArg AbiAddressType = sbytes32 + +staticAbiArg (AbiBytesType n) + | n <= 32 = sbytes32 + | otherwise = error "bad type" -- TODO: is this encoding correct? symAbiArg (AbiArrayType len typ) = - do args <- mapM symAbiArg (replicate len typ) - return (litBytes (encodeAbiValue (AbiUInt 256 (fromIntegral len))) <> (concat $ fst <$> args), - 32 + (sum $ snd <$> args)) + do args <- mconcat <$> mapM symAbiArg (replicate len typ) + return $ litBytes (encodeAbiValue (AbiUInt 256 (fromIntegral len))) <> args symAbiArg (AbiTupleType tuple) = - do args <- mapM symAbiArg (toList tuple) - return (concat $ fst <$> args, sum $ snd <$> args) + mconcat <$> mapM symAbiArg (toList tuple) + symAbiArg n = error $ "Unsupported symbolic abiencoding for" <> show n @@ -81,34 +79,34 @@ symAbiArg n = -- with concrete arguments. -- Any argument given as "" or omitted at the tail of the list are -- kept symbolic. -symCalldata :: Text -> [AbiType] -> [String] -> Query ([SWord 8], SWord 32) -symCalldata sig typesignature concreteArgs = - let args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" - mkArg typ "" = symAbiArg typ - mkArg typ arg = let n = litBytes . encodeAbiValue $ makeAbiValue typ arg - in return (n, num (length n)) - sig' = litBytes $ selector sig - in do calldatas <- zipWithM mkArg typesignature args - return (sig' <> concat (fst <$> calldatas), 4 + (sum $ snd <$> calldatas)) +staticCalldata :: Text -> [AbiType] -> [String] -> Query [SWord 8] +staticCalldata sig typesignature concreteArgs = + concat <$> zipWithM mkArg typesignature args + where + -- ensure arg length is long enough + args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" + + mkArg :: AbiType -> String -> Query [SWord 8] + mkArg typ "" = symAbiArg typ + mkArg typ arg = return $ litBytes . encodeAbiValue $ makeAbiValue typ arg + + sig' = litBytes $ selector sig abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel -> Query VM abstractVM typesignature concreteArgs x storagemodel = do - (cd', cdlen, cdconstraint) <- - case typesignature of - Nothing -> do cd <- sbytes256 - len <- freshVar_ - return (cd, len, len .<= 256) - Just (name, typs) -> do (cd, cdlen) <- symCalldata name typs concreteArgs - return (cd, cdlen, sTrue) + cd' <- case typesignature of + Nothing -> sbytes256 + Just (name, typs) -> staticCalldata name typs concreteArgs + symstore <- case storagemodel of SymbolicS -> Symbolic <$> freshArray_ Nothing InitialS -> Symbolic <$> freshArray_ (Just 0) ConcreteS -> return $ Concrete mempty c <- SAddr <$> freshVar_ value' <- sw256 <$> freshVar_ - return $ loadSymVM (RuntimeCode x) symstore storagemodel c value' (SymbolicBuffer cd', cdlen) & over pathConditions ((<>) [cdconstraint]) + return $ loadSymVM (RuntimeCode x) symstore storagemodel c value' (StaticSymBuffer cd') -loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> (Buffer, SWord 32) -> VM +loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> Buffer -> VM loadSymVM x initStore model addr callvalue' calldata' = (makeVm $ VMOpts { vmoptContract = contractWithStore x initStore @@ -262,9 +260,9 @@ equivalenceCheck bytecodeA bytecodeB maxiter signature' = do precaller = preStateA ^. state . caller callvalue' = preStateA ^. state . callvalue prestorage = preStateA ^?! env . contracts . ix preself . storage - (calldata', cdlen) = view (state . calldata) preStateA + calldata' = view (state . calldata) preStateA pathconds = view pathConditions preStateA - preStateB = loadSymVM (RuntimeCode bytecodeB) prestorage SymbolicS precaller callvalue' (calldata', cdlen) & set pathConditions pathconds + preStateB = loadSymVM (RuntimeCode bytecodeB) prestorage SymbolicS precaller callvalue' calldata' & set pathConditions pathconds smtState <- queryState push 1 @@ -313,13 +311,13 @@ both' f (x, y) = (f x, f y) showCounterexample :: VM -> Maybe (Text, [AbiType]) -> Query () showCounterexample vm maybesig = do - let (calldata', cdlen) = view (EVM.state . EVM.calldata) vm + let calldata' = view (EVM.state . EVM.calldata) vm S _ cvalue = view (EVM.state . EVM.callvalue) vm SAddr caller' = view (EVM.state . EVM.caller) vm - cdlen' <- num <$> getValue cdlen +-- cdlen' <- num <$> getValue cdlen calldatainput <- case calldata' of - SymbolicBuffer cd -> mapM (getValue.fromSized) (take cdlen' cd) >>= return . pack - ConcreteBuffer cd -> return $ BS.take cdlen' cd + StaticSymBuffer cd -> mapM (getValue.fromSized) cd >>= return . pack + ConcreteBuffer cd -> return $ cd callvalue' <- num <$> getValue cvalue caller'' <- num <$> getValue caller' io $ do diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index e98a12f8b..5abf181ba 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -217,6 +217,21 @@ readSWordWithBound ind (ConcreteBuffer xs) bound = readMemoryWord' :: Word -> [SWord 8] -> SymWord readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) +dynWriteMemoryPadding :: SList (WordN 8) -> SList (WordN 8) -> SymWord -> SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) +dynWriteMemoryPadding zeroList bs1 (S _ n) (S _ src) (S _ dst) bs0 = + let + bs0' = bs0 .++ zeroList + bs1' = bs1 .++ zeroList + n' = sFromIntegral n + src' = sFromIntegral src + dst' = sFromIntegral dst + + a = SL.take dst' bs0' + b = SL.subList bs1' src' n' + c = SL.drop (dst' + n') bs0' + in + a .++ b .++ c + -- TODO: ensure we actually pad with zeros sliceWithZero'' :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) sliceWithZero'' (S _ o) (S _ s) m = SL.subList m (sFromIntegral s) (sFromIntegral o) diff --git a/src/hevm/src/EVM/TTY.hs b/src/hevm/src/EVM/TTY.hs index 8a606a26b..6116fb6b7 100644 --- a/src/hevm/src/EVM/TTY.hs +++ b/src/hevm/src/EVM/TTY.hs @@ -778,7 +778,7 @@ updateUiVmState ui vm = case view result vm of Just (VMSuccess (ConcreteBuffer msg)) -> Just ("VMSuccess: " <> (show $ ByteStringS msg)) - Just (VMSuccess (SymbolicBuffer msg)) -> + Just (VMSuccess (StaticSymBuffer msg)) -> Just ("VMSuccess: " <> (show msg)) Just (VMFailure (Revert msg)) -> Just ("VMFailure: " <> (show . ByteStringS $ msg)) @@ -864,7 +864,7 @@ withHighlight False = withDefAttr dimAttr withHighlight True = withDefAttr boldAttr prettyIfConcrete :: Buffer -> String -prettyIfConcrete (SymbolicBuffer x) = show x +prettyIfConcrete (StaticSymBuffer x) = show x prettyIfConcrete (ConcreteBuffer x) = prettyHex 40 x drawTracePane :: UiVmState -> UiWidget @@ -872,7 +872,7 @@ drawTracePane s = case view uiShowMemory s of True -> hBorderWithLabel (txt "Calldata") - <=> str (prettyIfConcrete $ fst (view (uiVm . state . calldata) s)) + <=> str (prettyIfConcrete $ view (uiVm . state . calldata) s) <=> hBorderWithLabel (txt "Returndata") <=> str (prettyIfConcrete (view (uiVm . state . returndata) s)) <=> hBorderWithLabel (txt "Output") diff --git a/src/hevm/src/EVM/UnitTest.hs b/src/hevm/src/EVM/UnitTest.hs index 61fec4efb..6f9a7d015 100644 --- a/src/hevm/src/EVM/UnitTest.hs +++ b/src/hevm/src/EVM/UnitTest.hs @@ -553,7 +553,7 @@ setupCall TestVMParams{..} sig args = do use (env . contracts) >>= assign (tx . txReversion) assign (tx . isCreate) False loadContract testAddress - assign (state . calldata) $ (ConcreteBuffer $ abiMethod sig args, literal . num . BS.length $ abiMethod sig args) + assign (state . calldata) (ConcreteBuffer $ abiMethod sig args) assign (state . caller) (litAddr testCaller) assign (state . gas) (w256 testGasCall) @@ -563,7 +563,7 @@ initialUnitTestVm (UnitTestOptions {..}) theContract = TestVMParams {..} = testParams vm = makeVm $ VMOpts { vmoptContract = initialContract (InitCode (view creationCode theContract)) - , vmoptCalldata = (mempty, 0) + , vmoptCalldata = mempty , vmoptValue = 0 , vmoptAddress = testAddress , vmoptCaller = litAddr testCaller diff --git a/src/hevm/src/EVM/VMTest.hs b/src/hevm/src/EVM/VMTest.hs index f087d4c50..cb0e20db9 100644 --- a/src/hevm/src/EVM/VMTest.hs +++ b/src/hevm/src/EVM/VMTest.hs @@ -255,7 +255,7 @@ parseVmOpts v = (JSON.Object env, JSON.Object exec) -> EVM.VMOpts <$> (dataField exec "code" >>= pure . EVM.initialContract . EVM.RuntimeCode) - <*> (dataField exec "data" >>= \a -> pure ( (ConcreteBuffer a), literal . num $ BS.length a)) + <*> (dataField exec "data" >>= pure . ConcreteBuffer) <*> (w256lit <$> wordField exec "value") <*> addrField exec "address" <*> (litAddr <$> addrField exec "caller") @@ -380,7 +380,7 @@ fromCreateBlockchainCase block tx preState postState = in Right $ Case (EVM.VMOpts { vmoptContract = EVM.initialContract (EVM.InitCode (txData tx)) - , vmoptCalldata = (mempty, 0) + , vmoptCalldata = mempty , vmoptValue = w256lit $ txValue tx , vmoptAddress = createdAddr , vmoptCaller = (litAddr origin) @@ -419,7 +419,7 @@ fromNormalBlockchainCase block tx preState postState = (_, _, Just origin, Just checkState) -> Right $ Case (EVM.VMOpts { vmoptContract = EVM.initialContract theCode - , vmoptCalldata = (ConcreteBuffer $ txData tx, literal . num . BS.length $ txData tx) + , vmoptCalldata = ConcreteBuffer $ txData tx , vmoptValue = litWord (EVM.w256 $ txValue tx) , vmoptAddress = toAddr , vmoptCaller = (litAddr origin) diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 1ead85573..1400c2d0a 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -149,21 +149,63 @@ main = defaultMain $ testGroup "hevm" ] , testGroup "Symbolic buffers" - [ testProperty "dynWriteMemory works like writeMemory" $ \(src, offset, dst) -> - runSMT $ query $ do - cd <- sbytes128 - mem <- sbytes128 - let staticWriting = writeMemory' cd src offset dst mem - let dynamicWriting = - dynWriteMemory - (implode cd) - (literal src) - (literal offset) - (literal dst) - (implode mem) - implode staticWriting + [ testProperty "dynWriteMemory works like writeMemory" $ forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> + let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args + in ioProperty $ runSMTWith z3 $ query $ do + cd <- sbytes32 + mem <- sbytes32 + + let + zeroList = literal (replicate 1000 0) + src = w256 $ W256 src' + dst = w256 $ W256 dst' + len = w256 $ W256 len' + -- getAt :: SList (WordN 8) -> SInt8 + -- getAt = uninterpret "zerolistisZero" + staticWriting = writeMemory' cd src len dst mem + dynamicWriting = + dynWriteMemoryPadding + zeroList + (implode' cd) + (litWord src) + (litWord len) + (litWord dst) + (implode' mem) + -- constrain (SL.length zeroList .== 2^32-1) + -- addAxiom "zero list is all zeros" + -- [ "(assert (forall ((i Int)) (= (seq.nth s2 i) #x00)))" + -- ] + -- -- (SL.length zeroList .== 2^32-1) + io $ print $ length staticWriting + when ((length staticWriting) < 10000) $ + let staticVer = implode staticWriting + in checkSatAssuming [staticVer ./= dynamicWriting] >>= \case + Unsat -> return () + Sat -> do getValue dynamicWriting >>= io . print + getValue dynamicWriting >>= io . print + error "oh no!" + + + -- , testCase "dynWriteMemory pads with zeros appropriately" $ + -- ioProperty $ runSMT $ query $ do + -- cd <- sbytes128 + -- mem <- sbytes128 + -- let src = w256 $ W256 src' + -- dst = w256 $ W256 dst' + -- offset = w256 $ W256 offset' + -- staticWriting = writeMemory' cd src offset dst mem + -- dynamicWriting = + -- dynWriteMemory + -- (implode cd) + -- (litWord src) + -- (litWord offset) + -- (litWord dst) + -- (implode mem) + -- checkSatAssuming [implode staticWriting ./= dynamicWriting] >>= \case + -- Unsat -> return () + -- _ -> error "fail!" - ] + ] , testGroup "Symbolic execution" [ @@ -530,8 +572,8 @@ main = defaultMain $ testGroup "hevm" runSimpleVM :: ByteString -> ByteString -> Maybe ByteString runSimpleVM x ins = case loadVM x of Nothing -> Nothing - Just vm -> let calldata' = (ConcreteBuffer ins, literal . num $ BS.length ins) - in case runState (assign (state.calldata) calldata' >> exec) vm of + Just vm -> + case runState (assign (state.calldata) (ConcreteBuffer ins) >> exec) vm of (VMSuccess (ConcreteBuffer bs), _) -> Just bs _ -> Nothing @@ -640,3 +682,12 @@ assertSolidityComputation (SolidityCall s args) x = assertEqual (Text.unpack s) (fmap Bytes (Just (encodeAbiValue x))) (fmap Bytes y) + + +-- implode :: SymVal a => [SBV a] -> SList a +-- implode = foldr ((.++) . singleton) (literal []) + +implode' :: [SWord 8] -> SList (WordN 8) +implode' xs = case mapM unliteral xs of + Just xs -> literal xs + Nothing -> implode xs From 120376c218d57d6e6484667ae2f3d7639456f989 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Fri, 21 Aug 2020 01:02:27 +0200 Subject: [PATCH 06/36] more wip --- src/hevm/src/EVM/Symbolic.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 5abf181ba..4f357e3e5 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -228,7 +228,9 @@ dynWriteMemoryPadding zeroList bs1 (S _ n) (S _ src) (S _ dst) bs0 = a = SL.take dst' bs0' b = SL.subList bs1' src' n' - c = SL.drop (dst' + n') bs0' + c = ite (dst' + n' .> SL.length bs0) + (SL.nil) + (SL.subList bs0 (dst' + n') (dst' + n' - SL.length bs0)) in a .++ b .++ c From b1b9d431711b20743743f80f76c75ab2e78f8851 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 25 Aug 2020 19:19:02 +0200 Subject: [PATCH 07/36] optimize as many static cases as possible --- src/hevm/src/EVM.hs | 475 +++++++++++++++++------------------ src/hevm/src/EVM/Symbolic.hs | 112 ++++----- src/hevm/test/test.hs | 63 +++-- 3 files changed, 320 insertions(+), 330 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 56a319e6b..441af9483 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -677,42 +677,42 @@ exec1 = do -- (env . sha3Crack) <>= invMap -- _ -> underrun - -- -- op: ADDRESS - -- 0x30 -> - -- limitStack 1 $ - -- burn g_base (next >> push (num self)) + -- op: ADDRESS + 0x30 -> + limitStack 1 $ + burn g_base (next >> push (num self)) - -- -- op: BALANCE - -- 0x31 -> - -- case stk of - -- (x':xs) -> forceConcrete x' $ \x -> - -- burn g_balance $ - -- fetchAccount (num x) $ \c -> do - -- next - -- assign (state . stack) xs - -- push (view balance c) - -- [] -> - -- underrun + -- op: BALANCE + 0x31 -> + case stk of + (x':xs) -> forceConcrete x' $ \x -> + burn g_balance $ + fetchAccount (num x) $ \c -> do + next + assign (state . stack) xs + push (view balance c) + [] -> + underrun - -- -- op: ORIGIN - -- 0x32 -> - -- limitStack 1 . burn g_base $ - -- next >> push (num (the tx origin)) + -- op: ORIGIN + 0x32 -> + limitStack 1 . burn g_base $ + next >> push (num (the tx origin)) - -- -- op: CALLER - -- 0x33 -> - -- limitStack 1 . burn g_base $ - -- let toSymWord = sw256 . sFromIntegral . saddressWord160 - -- in next >> pushSym (toSymWord (the state caller)) + -- op: CALLER + 0x33 -> + limitStack 1 . burn g_base $ + let toSymWord = sw256 . sFromIntegral . saddressWord160 + in next >> pushSym (toSymWord (the state caller)) - -- -- op: CALLVALUE - -- 0x34 -> - -- limitStack 1 . burn g_base $ - -- next >> pushSym (the state callvalue) + -- op: CALLVALUE + 0x34 -> + limitStack 1 . burn g_base $ + next >> pushSym (the state callvalue) - -- -- op: CALLDATALOAD - -- 0x35 -> stackOp1 (const g_verylow) $ - -- \(S _ x) -> uncurry (readSWordWithBound (sFromIntegral x)) (the state calldata) + -- op: CALLDATALOAD + 0x35 -> stackOp1 (const g_verylow) $ + flip readSWord (the state calldata) -- op: CALLDATASIZE 0x36 -> @@ -723,15 +723,11 @@ exec1 = do 0x37 -> case stk of (xTo : xFrom : xSize : xs) -> - burn (g_verylow + g_copy * ceilDiv xSize 32) $ + burnSym (litWord g_verylow + litWord g_copy * ceilSDiv xSize 32) $ accessUnboundedMemoryRange fees xTo xSize $ do next assign (state . stack) xs - case the state calldata of - (StaticSymBuffer cd, cdlen) -> copyBytesToMemory (StaticSymBuffer [ite (i .<= cdlen) x 0 | (x, i) <- zip cd [1..]]) xSize xFrom xTo - -- when calldata is concrete, - -- the bound should always be equal to the bytestring length - (cd, _) -> copyBytesToMemory cd xSize xFrom xTo + copyBytesToMemory (the state calldata) xSize xFrom xTo _ -> underrun -- op: CODESIZE @@ -742,13 +738,13 @@ exec1 = do -- op: CODECOPY 0x39 -> case stk of - (memOffset' : codeOffset' : n' : xs) -> forceConcrete3 (memOffset',codeOffset',n') $ \(memOffset,codeOffset,n) -> do + (memOffset : codeOffset' : n' : xs) -> forceConcrete2 (codeOffset',n') $ \(codeOffset,n) -> do burn (g_verylow + g_copy * ceilDiv (num n) 32) $ - accessUnboundedMemoryRange fees memOffset n $ do + accessUnboundedMemoryRange fees memOffset (litWord n) $ do next assign (state . stack) xs copyBytesToMemory (ConcreteBuffer (the state code)) - n codeOffset memOffset + (litWord n) (litWord codeOffset) memOffset _ -> underrun -- op: GASPRICE @@ -778,38 +774,38 @@ exec1 = do 0x3c -> case stk of ( extAccount' - : memOffset' + : memOffset : codeOffset' : codeSize' : xs ) -> - forceConcrete4 (extAccount', memOffset', codeOffset', codeSize') $ - \(extAccount, memOffset, codeOffset, codeSize) -> + forceConcrete3 (extAccount', codeOffset', codeSize') $ + \(extAccount, codeOffset, codeSize) -> burn (g_extcode + g_copy * ceilDiv (num codeSize) 32) $ - accessUnboundedMemoryRange fees memOffset codeSize $ + accessUnboundedMemoryRange fees memOffset (litWord codeSize) $ fetchAccount (num extAccount) $ \c -> do next assign (state . stack) xs copyBytesToMemory (ConcreteBuffer (view bytecode c)) - codeSize codeOffset memOffset + (litWord codeSize) (litWord codeOffset) memOffset _ -> underrun -- op: RETURNDATASIZE 0x3d -> limitStack 1 . burn g_base $ - next >> push (num $ len (the state returndata)) + next >> pushSym (sw256 $ sFromIntegral $ len (the state returndata)) -- op: RETURNDATACOPY 0x3e -> case stk of - (xTo' : xFrom' : xSize' :xs) -> forceConcrete3 (xTo', xFrom', xSize') $ - \(xTo, xFrom, xSize) -> - burn (g_verylow + g_copy * ceilDiv xSize 32) $ + (xTo : xFrom : xSize :xs) -> + burnSym (litWord g_verylow + litWord g_copy * ceilSDiv xSize 32) $ accessUnboundedMemoryRange fees xTo xSize $ do next assign (state . stack) xs - if len (the state returndata) < num xFrom + num xSize - then vmError InvalidMemoryAccess - else copyBytesToMemory (the state returndata) xSize xFrom xTo + -- TODO: consult smt about possible failure here + -- if len (the state returndata) < num xFrom + num xSize + -- then vmError InvalidMemoryAccess + copyBytesToMemory (the state returndata) xSize xFrom xTo _ -> underrun -- op: EXTCODEHASH @@ -882,35 +878,35 @@ exec1 = do -- op: MLOAD 0x51 -> case stk of - (x':xs) -> forceConcrete x' $ \x -> + (x'@(S _ x):xs) -> burn g_verylow $ - accessMemoryWord fees x $ do + accessMemoryWord fees x' $ do next - assign (state . stack) (view (word256At (num x)) mem : xs) + assign (state . stack) (view (word256At (sFromIntegral x)) mem : xs) _ -> underrun -- op: MSTORE 0x52 -> case stk of - (x':y:xs) -> forceConcrete x' $ \x -> + (x'@(S _ x):y:xs) -> burn g_verylow $ - accessMemoryWord fees x $ do + accessMemoryWord fees x' $ do next - assign (state . memory . word256At (num x)) y + assign (state . memory . word256At (sFromIntegral x)) y assign (state . stack) xs _ -> underrun - -- op: MSTORE8 - 0x53 -> - case stk of - (x':(S _ y):xs) -> forceConcrete x' $ \x -> - burn g_verylow $ - accessMemoryRange fees x 1 $ do - let yByte = bvExtract (Proxy :: Proxy 7) (Proxy :: Proxy 0) y - next - modifying (state . memory) (setMemoryByte x yByte) - assign (state . stack) xs - _ -> underrun + -- -- op: MSTORE8 + -- 0x53 -> + -- case stk of + -- (x':(S _ y):xs) -> forceConcrete x' $ \x -> + -- burn g_verylow $ + -- accessMemoryRange fees x 1 $ do + -- let yByte = bvExtract (Proxy :: Proxy 7) (Proxy :: Proxy 0) y + -- next + -- modifying (state . memory) (setMemoryByte x yByte) + -- assign (state . stack) xs + -- _ -> underrun -- op: SLOAD 0x54 -> @@ -1003,7 +999,7 @@ exec1 = do -- op: MSIZE 0x59 -> limitStack 1 . burn g_base $ - next >> push (num (the state memorySize)) + next >> pushSym (sw256 $ sFromIntegral $ the state memorySize) -- op: GAS 0x5a -> @@ -1030,210 +1026,212 @@ exec1 = do (x .|. complement (bit n - 1)) (x .&. (bit n - 1)) - -- op: CREATE - 0xf0 -> - notStatic $ - case stk of - (xValue' : xOffset' : xSize' : xs) -> forceConcrete3 (xValue', xOffset', xSize') $ - \(xValue, xOffset, xSize) -> do - accessMemoryRange fees xOffset xSize $ do - availableGas <- use (state . gas) - let - newAddr = createAddress self (wordValue (view nonce this)) - (cost, gas') = costOfCreate fees availableGas 0 - burn (cost - gas') $ forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> - create self this gas' xValue xs newAddr initCode - _ -> underrun + -- -- op: CREATE + -- 0xf0 -> + -- notStatic $ + -- case stk of + -- (xValue' : xOffset' : xSize' : xs) -> forceConcrete3 (xValue', xOffset', xSize') $ + -- \(xValue, xOffset, xSize) -> do + -- accessMemoryRange fees xOffset xSize $ do + -- availableGas <- use (state . gas) + -- let + -- newAddr = createAddress self (wordValue (view nonce this)) + -- (cost, gas') = costOfCreate fees availableGas 0 + -- burn (cost - gas') $ forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> + -- create self this gas' xValue xs newAddr initCode + -- _ -> underrun - -- op: CALL - 0xf1 -> - case stk of - ( xGas' - : xTo' - : (forceLit -> xValue) - : xInOffset' - : xInSize' - : xOutOffset' - : xOutSize' - : xs - ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - (if xValue > 0 then notStatic else id) $ - case xTo of - n | n > 0 && n <= 9 -> - precompiledContract this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs - n | num n == cheatCode -> - do - assign (state . stack) xs - cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - _ -> delegateCall this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ do - zoom state $ do - assign callvalue (litWord xValue) - assign caller (litAddr self) - assign contract xTo - zoom (env . contracts) $ do - ix self . balance -= xValue - ix xTo . balance += xValue - touchAccount self - touchAccount xTo - _ -> - underrun + -- -- op: CALL + -- 0xf1 -> + -- case stk of + -- ( xGas' + -- : xTo' + -- : (forceLit -> xValue) + -- : xInOffset' + -- : xInSize' + -- : xOutOffset' + -- : xOutSize' + -- : xs + -- ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + -- (if xValue > 0 then notStatic else id) $ + -- case xTo of + -- n | n > 0 && n <= 9 -> + -- precompiledContract this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs + -- n | num n == cheatCode -> + -- do + -- assign (state . stack) xs + -- cheat (xInOffset, xInSize) (xOutOffset, xOutSize) + -- _ -> delegateCall this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ do + -- zoom state $ do + -- assign callvalue (litWord xValue) + -- assign caller (litAddr self) + -- assign contract xTo + -- zoom (env . contracts) $ do + -- ix self . balance -= xValue + -- ix xTo . balance += xValue + -- touchAccount self + -- touchAccount xTo + -- _ -> + -- underrun - -- op: CALLCODE - 0xf2 -> - case stk of - ( xGas' - : xTo' - : (forceLit -> xValue) - : xInOffset' - : xInSize' - : xOutOffset' - : xOutSize' - : xs - ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - case xTo of - n | n > 0 && n <= 9 -> - precompiledContract this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs - _ -> delegateCall this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs $ do - zoom state $ do - assign callvalue (litWord xValue) - assign caller (litAddr self) - touchAccount self - _ -> - underrun + -- -- op: CALLCODE + -- 0xf2 -> + -- case stk of + -- ( xGas' + -- : xTo' + -- : (forceLit -> xValue) + -- : xInOffset' + -- : xInSize' + -- : xOutOffset' + -- : xOutSize' + -- : xs + -- ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + -- case xTo of + -- n | n > 0 && n <= 9 -> + -- precompiledContract this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs + -- _ -> delegateCall this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs $ do + -- zoom state $ do + -- assign callvalue (litWord xValue) + -- assign caller (litAddr self) + -- touchAccount self + -- _ -> + -- underrun -- op: RETURN 0xf3 -> case stk of - (xOffset' : xSize' :_) -> forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> + (xOffset : xSize :_) -> accessMemoryRange fees xOffset xSize $ do let output = readMemory xOffset xSize vm - codesize = num (len output) - maxsize = the block maxCodeSize case view frames vm of [] -> case (the tx isCreate) of - True -> + True -> forceConcreteBuffer output $ \output' -> do + let codesize = num $ BS.length output' + maxsize = the block maxCodeSize if codesize > maxsize then finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) else burn (g_codedeposit * codesize) $ - finishFrame (FrameReturned output) + finishFrame (FrameReturned $ ConcreteBuffer output') False -> finishFrame (FrameReturned output) (frame: _) -> do let context = view frameContext frame case context of - CreationContext {} -> + CreationContext {} -> forceConcreteBuffer output $ \output' -> do + let codesize = num $ BS.length output' + maxsize = the block maxCodeSize if codesize > maxsize then finishFrame (FrameErrored (MaxCodeSizeExceeded maxsize codesize)) else burn (g_codedeposit * codesize) $ - finishFrame (FrameReturned output) + finishFrame (FrameReturned $ ConcreteBuffer output') CallContext {} -> finishFrame (FrameReturned output) _ -> underrun - -- op: DELEGATECALL - 0xf4 -> - case stk of - (xGas' - :xTo' - :xInOffset' - :xInSize' - :xOutOffset' - :xOutSize' - :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - case xTo of - n | n > 0 && n <= 9 -> - precompiledContract this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs - n | num n == cheatCode -> do - assign (state . stack) xs - cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - _ -> do - delegateCall this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs $ do - touchAccount self - _ -> underrun + -- -- op: DELEGATECALL + -- 0xf4 -> + -- case stk of + -- (xGas' + -- :xTo' + -- :xInOffset' + -- :xInSize' + -- :xOutOffset' + -- :xOutSize' + -- :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + -- case xTo of + -- n | n > 0 && n <= 9 -> + -- precompiledContract this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs + -- n | num n == cheatCode -> do + -- assign (state . stack) xs + -- cheat (xInOffset, xInSize) (xOutOffset, xOutSize) + -- _ -> do + -- delegateCall this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs $ do + -- touchAccount self + -- _ -> underrun - -- op: CREATE2 - 0xf5 -> notStatic $ - case stk of - (xValue' - :xOffset' - :xSize' - :xSalt' - :xs) -> forceConcrete4 (xValue', xOffset', xSize', xSalt') $ - \(xValue, xOffset, xSize, xSalt) -> - accessMemoryRange fees xOffset xSize $ do - availableGas <- use (state . gas) - forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> - let - newAddr = create2Address self (num xSalt) initCode - (cost, gas') = costOfCreate fees availableGas xSize - in burn (cost - gas') $ - create self this gas' xValue xs newAddr initCode - _ -> underrun + -- -- op: CREATE2 + -- 0xf5 -> notStatic $ + -- case stk of + -- (xValue' + -- :xOffset' + -- :xSize' + -- :xSalt' + -- :xs) -> forceConcrete4 (xValue', xOffset', xSize', xSalt') $ + -- \(xValue, xOffset, xSize, xSalt) -> + -- accessMemoryRange fees xOffset xSize $ do + -- availableGas <- use (state . gas) + -- forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> + -- let + -- newAddr = create2Address self (num xSalt) initCode + -- (cost, gas') = costOfCreate fees availableGas xSize + -- in burn (cost - gas') $ + -- create self this gas' xValue xs newAddr initCode + -- _ -> underrun - -- op: STATICCALL - 0xfa -> - case stk of - (xGas' - :xTo' - :xInOffset' - :xInSize' - :xOutOffset' - :xOutSize' - :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - case xTo of - n | n > 0 && n <= 9 -> - precompiledContract this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs - _ -> delegateCall this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ do - zoom state $ do - assign callvalue 0 - assign caller (litAddr self) - assign contract xTo - assign static True - touchAccount self - touchAccount xTo - _ -> - underrun + -- -- op: STATICCALL + -- 0xfa -> + -- case stk of + -- (xGas' + -- :xTo' + -- :xInOffset' + -- :xInSize' + -- :xOutOffset' + -- :xOutSize' + -- :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ + -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> + -- case xTo of + -- n | n > 0 && n <= 9 -> + -- precompiledContract this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs + -- _ -> delegateCall this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ do + -- zoom state $ do + -- assign callvalue 0 + -- assign caller (litAddr self) + -- assign contract xTo + -- assign static True + -- touchAccount self + -- touchAccount xTo + -- _ -> + -- underrun - -- op: SELFDESTRUCT - 0xff -> - notStatic $ - case stk of - [] -> underrun - (xTo':_) -> forceConcrete xTo' $ \(num -> xTo) -> - let - funds = view balance this - recipientExists = accountExists xTo vm - c_new = if not recipientExists && funds /= 0 - then num g_selfdestruct_newaccount - else 0 - in burn (g_selfdestruct + c_new) $ do - destructs <- use (tx . substate . selfdestructs) - unless (elem self destructs) $ refund r_selfdestruct - selfdestruct self - touchAccount xTo - - if funds /= 0 - then fetchAccount xTo $ \_ -> do - env . contracts . ix xTo . balance += funds - assign (env . contracts . ix self . balance) 0 - doStop - else doStop + -- -- op: SELFDESTRUCT + -- 0xff -> + -- notStatic $ + -- case stk of + -- [] -> underrun + -- (xTo':_) -> forceConcrete xTo' $ \(num -> xTo) -> + -- let + -- funds = view balance this + -- recipientExists = accountExists xTo vm + -- c_new = if not recipientExists && funds /= 0 + -- then num g_selfdestruct_newaccount + -- else 0 + -- in burn (g_selfdestruct + c_new) $ do + -- destructs <- use (tx . substate . selfdestructs) + -- unless (elem self destructs) $ refund r_selfdestruct + -- selfdestruct self + -- touchAccount xTo + + -- if funds /= 0 + -- then fetchAccount xTo $ \_ -> do + -- env . contracts . ix xTo . balance += funds + -- assign (env . contracts . ix self . balance) 0 + -- doStop + -- else doStop -- op: REVERT 0xfd -> case stk of - (xOffset':xSize':_) -> forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> + (xOffset:xSize:_) -> accessMemoryRange fees xOffset xSize $ do let output = readMemory xOffset xSize vm finishFrame (FrameReverted output) @@ -2164,7 +2162,6 @@ accessUnboundedMemoryRange -> SymWord -> EVM () -> EVM () -accessUnboundedMemoryRange _ _ 0 continue = continue accessUnboundedMemoryRange fees f l continue = do m0 <- use (state . memorySize) case (maybeLitWord f, maybeLitWord l, unliteral m0) of @@ -2228,7 +2225,7 @@ readMemory offset size vm = sliceWithZero offset size (view (state . memory) vm) word256At :: Functor f - => Word -> (SymWord -> f (SymWord)) + => SWord 32 -> (SymWord -> f (SymWord)) -> Buffer -> f Buffer word256At i = lens getter setter where getter = readMemoryWord i @@ -2632,8 +2629,8 @@ symSHA256 bytes = case length bytes of ceilDiv :: (Num a, Integral a) => a -> a -> a ceilDiv m n = div (m + n - 1) n --- ceilSDiv :: (Num a, Integral a) => a -> a -> a --- ceilSDiv m n = (m + n - 1) `sDiv` n +ceilSDiv :: (Num a, SDivisible a) => a -> a -> a +ceilSDiv m n = (m + n - 1) `sDiv` n allButOne64th :: (Num a, Integral a) => a -> a allButOne64th n = n - div n 64 diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 4f357e3e5..a74de671f 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -105,25 +105,33 @@ truncpad n xs = if m > n then take n xs else mappend xs (replicate (n - m) 0) where m = length xs --- returns undefined stuff when you try to take too much takeStatic :: (SymVal a) => Int -> SList a -> [SBV a] takeStatic n ls = let (x, xs) = SL.uncons ls in x:(takeStatic (n - 1) xs) +dropStatic :: (SymVal a) => Int -> SList a -> [SBV a] +dropStatic n ls = + let (x, xs) = SL.uncons ls + in x:(takeStatic (n - 1) xs) + +-- special case of sliceWithZero when size is known truncpad' :: Int -> SList (WordN 8) -> [SWord 8] -truncpad' n xs = - ite - (m .> (literal (num n))) - (takeStatic n xs) - (takeStatic n (xs .++ SL.implode (replicate n 0))) - where m = SL.length xs +truncpad' n xs = case unliteral $ SL.length xs of + Just (num -> l) -> if l > n + then takeStatic n xs + else takeStatic n (xs .++ literal (replicate (n - l) 0)) + + Nothing -> ite + (SL.length xs .> (literal (num n))) + (takeStatic n xs) + (takeStatic n (xs .++ literal (replicate n 0))) swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs -swordAt' :: SInteger -> SList (WordN 8) -> SymWord -swordAt' i bs = sw256 . fromBytes $ truncpad' 32 $ SL.drop i bs +swordAt' :: SWord 32 -> SList (WordN 8) -> SymWord +swordAt' i bs = sw256 . fromBytes $ truncpad' 32 $ SL.drop (sFromIntegral i) bs readByteOrZero' :: Int -> [SWord 8] -> SWord 8 readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) @@ -139,7 +147,7 @@ writeMemory' bs1 (C _ n) (C _ src) (C _ dst) bs0 = c = if src > num (length bs1) then replicate (num n) 0 else sliceWithZero' (num src) (num n) bs1 - b' = drop (num (n)) b + b' = drop (num n) b in a <> a' <> c <> b' @@ -173,26 +181,6 @@ readByteOrZero'' i bs = (bs .!! (sFromIntegral i)) (literal 0) --- Warning: if (length bs0) < dst or (length bs1) < src + n we can get `havoc` garbage in the resulting --- list. It should really be 0. If we could write the following function, we could pad appropriately: --- replicate :: (SymVal a) => SInteger -> SBV a -> SList a --- but I can't really write this... --- --- TODO: make sure we enforce this condition before calling this -dynWriteMemory :: SList (WordN 8) -> SymWord -> SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) -dynWriteMemory bs1 (S _ n) (S _ src) (S _ dst) bs0 = - let - n' = sFromIntegral n - src' = sFromIntegral src - dst' = sFromIntegral dst - - a = SL.take dst' bs0 - b = SL.subList bs1 src' n' - c = ite (dst' + n' .> SL.length bs0) - (SL.nil) - (SL.drop (dst' + n') bs0) - in - a .++ b .++ c -- Generates a ridiculously large set of constraints (roughly 25k) when -- the index is symbolic, but it still seems (kind of) manageable @@ -217,37 +205,30 @@ readSWordWithBound ind (ConcreteBuffer xs) bound = readMemoryWord' :: Word -> [SWord 8] -> SymWord readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) -dynWriteMemoryPadding :: SList (WordN 8) -> SList (WordN 8) -> SymWord -> SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) -dynWriteMemoryPadding zeroList bs1 (S _ n) (S _ src) (S _ dst) bs0 = +dynWriteMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer +dynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = let - bs0' = bs0 .++ zeroList - bs1' = bs1 .++ zeroList - n' = sFromIntegral n - src' = sFromIntegral src - dst' = sFromIntegral dst - - a = SL.take dst' bs0' - b = SL.subList bs1' src' n' - c = ite (dst' + n' .> SL.length bs0) - (SL.nil) - (SL.subList bs0 (dst' + n') (dst' + n' - SL.length bs0)) + a = sliceWithZero 0 dst bs0 + b = sliceWithZero src n bs1 + c = sliceWithZero (dst + n) + (sw256 (sFromIntegral (len bs0)) - (dst + n)) + bs0 in - a .++ b .++ c + a <> b <> c -- TODO: ensure we actually pad with zeros sliceWithZero'' :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) sliceWithZero'' (S _ o) (S _ s) m = SL.subList m (sFromIntegral s) (sFromIntegral o) - -- readMemoryWord' :: Word -> [SWord 8] -> SymWord -- readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) -- readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 -- readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) --- setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] --- setMemoryWord' (C _ i) (S _ x) = --- writeMemory' (toBytes x) 32 0 (num i) +setMemoryWord'' :: SWord 32 -> SymWord -> Buffer -> Buffer +setMemoryWord'' i (S _ x) = + dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 (sw256 (sFromIntegral i)) -- setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] -- setMemoryByte' (C _ i) x = @@ -280,13 +261,13 @@ readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (literal $ num i) bs +-- pad up to 10000 bytes in the dynamic case sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer -sliceWithZero o s bf = case (maybeLitWord o, maybeLitWord s, bf) of - (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) - (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) -sliceWithZero o s (StaticSymBuffer bf) = DynamicSymBuffer $ sliceWithZero'' o s (SL.implode bf) -sliceWithZero o s (ConcreteBuffer bf) = DynamicSymBuffer $ sliceWithZero'' o s (SL.implode (litBytes bf)) -sliceWithZero o s (DynamicSymBuffer bf) = DynamicSymBuffer $ sliceWithZero'' o s bf +sliceWithZero (S _ o) (S _ s) bf = case (unliteral o, unliteral s, bf) of + (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) + (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) + (_, Just s', m) -> StaticSymBuffer $ truncpad' (num s') $ SL.drop (sFromIntegral o) (dynamize m) + _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 10000 0)) (sFromIntegral o) (sFromIntegral s) writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer writeMemory bs1 n src dst bs0 = @@ -299,23 +280,24 @@ writeMemory bs1 n src dst bs0 = StaticSymBuffer $ writeMemory' (litBytes bs0') n' src' dst' bs1' (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> StaticSymBuffer $ writeMemory' bs0' n' src' dst' bs1' - _ -> let bs0' = dynamize bs0 - bs1' = dynamize bs1 - in DynamicSymBuffer $ dynWriteMemory bs0' n src dst bs1' + _ -> dynWriteMemory bs0 n src dst bs1 -readMemoryWord :: Word -> Buffer -> SymWord -readMemoryWord i (StaticSymBuffer m) = readMemoryWord' i m -readMemoryWord i (ConcreteBuffer m) = litWord $ Concrete.readMemoryWord i m +readMemoryWord :: SWord 32 -> Buffer -> SymWord +readMemoryWord i bf = case (unliteral i, bf) of + (Just i', StaticSymBuffer m) -> readMemoryWord' (num i') m + (Just i', ConcreteBuffer m) -> litWord $ Concrete.readMemoryWord (num i') m + _ -> swordAt' i (dynamize bf) readMemoryWord32 :: Word -> Buffer -> SWord 32 readMemoryWord32 i (StaticSymBuffer m) = readMemoryWord32' i m readMemoryWord32 i (ConcreteBuffer m) = num $ Concrete.readMemoryWord32 i m -setMemoryWord :: Word -> SymWord -> Buffer -> Buffer -setMemoryWord i x (StaticSymBuffer z) = StaticSymBuffer $ setMemoryWord' i x z -setMemoryWord i x (ConcreteBuffer z) = case maybeLitWord x of - Just x' -> ConcreteBuffer $ Concrete.setMemoryWord i x' z - Nothing -> StaticSymBuffer $ setMemoryWord' i x (litBytes z) +setMemoryWord :: SWord 32 -> SymWord -> Buffer -> Buffer +setMemoryWord i x bf = case (unliteral i, maybeLitWord x, bf) of + (Just i', Just x', ConcreteBuffer z) -> ConcreteBuffer $ Concrete.setMemoryWord (num i') x' z + (Just i', _, ConcreteBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x (litBytes z) + (Just i', _, StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x z + _ -> setMemoryWord'' i x bf setMemoryByte :: Word -> SWord 8 -> Buffer -> Buffer setMemoryByte i x (StaticSymBuffer m) = StaticSymBuffer $ setMemoryByte' i x m diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 1400c2d0a..3fe527f1c 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -149,40 +149,60 @@ main = defaultMain $ testGroup "hevm" ] , testGroup "Symbolic buffers" - [ testProperty "dynWriteMemory works like writeMemory" $ forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> + + [ testCase "dynWriteMemory works" $ runSMTWith z3{verbose=True} $ query $ do + cd <- sbytes32 + mem <- sbytes32 + + let + staticWriting = writeMemory' cd 2 2 2 mem + dynamicWriting = + dynWriteMemory + (implode cd) + (litWord 2) + (litWord 2) + (litWord 2) + (implode mem) + -- constrain (SL.length zeroList .== 2^32-1) + -- addAxiom "zero list is all zeros" + -- [ "(assert (forall ((i Int)) (= (seq.nth s2 i) #x00)))" + -- ] + -- -- (SL.length zeroList .== 2^32-1) + io $ print $ length staticWriting + when ((length staticWriting) < 10000) $ + let staticVer = implode staticWriting + in io (putStrLn "solving") >> checkSatAssuming [staticVer ./= dynamicWriting] >>= \case + Unsat -> return () + Sat -> do getValue dynamicWriting >>= io . print + getValue staticVer >>= io . print + error "oh no!" + + , testProperty "dynWriteMemory works like writeMemory" $ forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args in ioProperty $ runSMTWith z3 $ query $ do cd <- sbytes32 mem <- sbytes32 let - zeroList = literal (replicate 1000 0) src = w256 $ W256 src' dst = w256 $ W256 dst' len = w256 $ W256 len' - -- getAt :: SList (WordN 8) -> SInt8 - -- getAt = uninterpret "zerolistisZero" + staticWriting = writeMemory' cd src len dst mem dynamicWriting = - dynWriteMemoryPadding - zeroList - (implode' cd) + dynWriteMemory + (implode cd) (litWord src) (litWord len) (litWord dst) - (implode' mem) - -- constrain (SL.length zeroList .== 2^32-1) - -- addAxiom "zero list is all zeros" - -- [ "(assert (forall ((i Int)) (= (seq.nth s2 i) #x00)))" - -- ] - -- -- (SL.length zeroList .== 2^32-1) - io $ print $ length staticWriting - when ((length staticWriting) < 10000) $ + (implode mem) + + when ((length staticWriting) < 10000 && len' < 10000) $ let staticVer = implode staticWriting in checkSatAssuming [staticVer ./= dynamicWriting] >>= \case - Unsat -> return () + Unsat -> io $ putStrLn "Success!" Sat -> do getValue dynamicWriting >>= io . print - getValue dynamicWriting >>= io . print + getValue staticVer >>= io . print error "oh no!" @@ -682,12 +702,3 @@ assertSolidityComputation (SolidityCall s args) x = assertEqual (Text.unpack s) (fmap Bytes (Just (encodeAbiValue x))) (fmap Bytes y) - - --- implode :: SymVal a => [SBV a] -> SList a --- implode = foldr ((.++) . singleton) (literal []) - -implode' :: [SWord 8] -> SList (WordN 8) -implode' xs = case mapM unliteral xs of - Just xs -> literal xs - Nothing -> implode xs From 3a36f12eb0903a123dfbf0206f4f9b0d586d4b24 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 26 Aug 2020 03:00:24 +0200 Subject: [PATCH 08/36] things are getting better --- src/hevm/src/EVM.hs | 1 - src/hevm/src/EVM/Symbolic.hs | 73 +++++++++++++++++++++----------- src/hevm/test/test.hs | 81 +++++++++++++++++------------------- 3 files changed, 87 insertions(+), 68 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 441af9483..5827db18c 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -2183,7 +2183,6 @@ accessMemoryRange -> SymWord -> EVM () -> EVM () -accessMemoryRange _ _ 0 continue = continue accessMemoryRange fees f l continue = case (maybeLitWord f, maybeLitWord l) of (Just f', Just l') -> diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index a74de671f..16e578b0e 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -105,33 +105,55 @@ truncpad n xs = if m > n then take n xs else mappend xs (replicate (n - m) 0) where m = length xs -takeStatic :: (SymVal a) => Int -> SList a -> [SBV a] -takeStatic n ls = - let (x, xs) = SL.uncons ls - in x:(takeStatic (n - 1) xs) +-- | Is the list concretely known empty? +isConcretelyEmpty :: SymVal a => SList a -> Bool +isConcretelyEmpty sl | Just l <- unliteral sl = null l + | True = False +-- must only be called when list length is concrete +takeStatic :: (SymVal a) => Int -> SList a -> [SBV a] +takeStatic 0 ls = [] +takeStatic n ls = + if isConcretelyEmpty ls + then [] + else case unliteral $ SL.length ls of + Nothing -> error "takeStatic must know the length of the list" + Just l -> if l == 0 then [] else + let (x, xs) = SL.uncons ls + in x:(takeStatic (n - 1) xs) + +-- must only be called when list length is concrete dropStatic :: (SymVal a) => Int -> SList a -> [SBV a] dropStatic n ls = - let (x, xs) = SL.uncons ls - in x:(takeStatic (n - 1) xs) + if isConcretelyEmpty ls + then [] + else case unliteral $ SL.length ls of + Nothing -> error "dropStatic must know the length of the list" + Just l -> if l == 0 then [] else + if n == 0 + then takeStatic (num l) ls + else let (_, xs) = SL.uncons ls + in (dropStatic (n - 1) xs) -- special case of sliceWithZero when size is known -truncpad' :: Int -> SList (WordN 8) -> [SWord 8] +truncpad' :: Int -> SList (WordN 8) -> Buffer truncpad' n xs = case unliteral $ SL.length xs of - Just (num -> l) -> if l > n - then takeStatic n xs - else takeStatic n (xs .++ literal (replicate (n - l) 0)) + Just (num -> l) -> StaticSymBuffer $ if l > n + then takeStatic n xs + else takeStatic n (xs .++ literal (replicate (n - l) 0)) - Nothing -> ite - (SL.length xs .> (literal (num n))) - (takeStatic n xs) - (takeStatic n (xs .++ literal (replicate n 0))) + Nothing -> DynamicSymBuffer $ ite + (SL.length xs .> literal (num n)) + (SL.take (literal (num n)) xs) + (SL.take (literal (num n)) (xs .++ literal (replicate n 0))) swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs swordAt' :: SWord 32 -> SList (WordN 8) -> SymWord -swordAt' i bs = sw256 . fromBytes $ truncpad' 32 $ SL.drop (sFromIntegral i) bs +swordAt' i bs = case truncpad' 32 $ SL.drop (sFromIntegral i) bs of + StaticSymBuffer s -> sw256 $ fromBytes s + DynamicSymBuffer s -> error "todo" readByteOrZero' :: Int -> [SWord 8] -> SWord 8 readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) @@ -172,9 +194,6 @@ readSWord' (C _ i) x = else swordAt (num i) x -- | Operations over dynamic symbolic memory (smt list of bytes) -swordAt'' :: SWord 32 -> SList (WordN 8) -> SymWord -swordAt'' i bs = sw256 . fromBytes $ truncpad' 32 $ SL.drop (sFromIntegral i) bs - readByteOrZero'' :: SWord 32 -> SList (WordN 8) -> SWord 8 readByteOrZero'' i bs = ite (SL.length bs .> (sFromIntegral i + 1)) @@ -210,9 +229,8 @@ dynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = let a = sliceWithZero 0 dst bs0 b = sliceWithZero src n bs1 - c = sliceWithZero (dst + n) - (sw256 (sFromIntegral (len bs0)) - (dst + n)) - bs0 + c = ditchS (sFromIntegral $ dst' + n') bs0 + in a <> b <> c @@ -256,6 +274,11 @@ ditch n (StaticSymBuffer bs) = StaticSymBuffer $ drop n bs ditch n (ConcreteBuffer bs) = ConcreteBuffer $ BS.drop n bs ditch n (DynamicSymBuffer bs) = DynamicSymBuffer $ SL.drop (literal $ num n) bs +ditchS :: SInteger -> Buffer -> Buffer +ditchS n bs = case unliteral n of + Nothing -> DynamicSymBuffer $ SL.drop n (dynamize bs) + Just n -> ditch (num n) bs + readByteOrZero :: Int -> Buffer -> SWord 8 readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs @@ -264,10 +287,10 @@ readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (literal $ num i) bs -- pad up to 10000 bytes in the dynamic case sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer sliceWithZero (S _ o) (S _ s) bf = case (unliteral o, unliteral s, bf) of - (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) - (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) - (_, Just s', m) -> StaticSymBuffer $ truncpad' (num s') $ SL.drop (sFromIntegral o) (dynamize m) - _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 10000 0)) (sFromIntegral o) (sFromIntegral s) + (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) + (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) + (Just o', Just s', m) -> DynamicSymBuffer $ SL.subList (dynamize m .++ literal (replicate (num (s' + o')) 0)) (sFromIntegral o) (sFromIntegral s) + _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 10000 0)) (sFromIntegral o) (sFromIntegral s) writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer writeMemory bs1 n src dst bs0 = diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 3fe527f1c..934045056 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -60,21 +60,21 @@ main = defaultMain $ testGroup "hevm" Right ("", _, x') -> x' == x _ -> False ] - , testGroup "Solidity expressions" - [ testCase "Trivial" $ - SolidityCall "x = 3;" [] - ===> AbiUInt 256 3 - - , testCase "Arithmetic" $ do - SolidityCall "x = a + 1;" - [AbiUInt 256 1] ===> AbiUInt 256 2 - SolidityCall "x = a - 1;" - [AbiUInt 8 0] ===> AbiUInt 8 255 - - , testCase "keccak256()" $ - SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" - [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 - ] + -- , testGroup "Solidity expressions" + -- [ testCase "Trivial" $ + -- SolidityCall "x = 3;" [] + -- ===> AbiUInt 256 3 + + -- , testCase "Arithmetic" $ do + -- SolidityCall "x = a + 1;" + -- [AbiUInt 256 1] ===> AbiUInt 256 2 + -- SolidityCall "x = a - 1;" + -- [AbiUInt 8 0] ===> AbiUInt 8 255 + + -- , testCase "keccak256()" $ + -- SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" + -- [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 + -- ] , testGroup "Precompiled contracts" [ testGroup "Example (reverse)" @@ -155,29 +155,27 @@ main = defaultMain $ testGroup "hevm" mem <- sbytes32 let - staticWriting = writeMemory' cd 2 2 2 mem + staticWriting = writeMemory' cd 18 111 63 mempty dynamicWriting = dynWriteMemory - (implode cd) - (litWord 2) - (litWord 2) - (litWord 2) - (implode mem) - -- constrain (SL.length zeroList .== 2^32-1) - -- addAxiom "zero list is all zeros" - -- [ "(assert (forall ((i Int)) (= (seq.nth s2 i) #x00)))" - -- ] - -- -- (SL.length zeroList .== 2^32-1) - io $ print $ length staticWriting - when ((length staticWriting) < 10000) $ - let staticVer = implode staticWriting - in io (putStrLn "solving") >> checkSatAssuming [staticVer ./= dynamicWriting] >>= \case - Unsat -> return () - Sat -> do getValue dynamicWriting >>= io . print - getValue staticVer >>= io . print - error "oh no!" - - , testProperty "dynWriteMemory works like writeMemory" $ forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> + (DynamicSymBuffer (implode cd)) + (litWord 18) + (litWord 111) + (litWord 63) + mempty + io $ print dynamicWriting + io (putStrLn "solving") >> checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case + Unsat -> return () + Sat -> do getList dynamicWriting >>= io . print + getList (StaticSymBuffer staticWriting) >>= io . print + error "oh no!" + where getList :: Buffer -> Query [WordN 8] + getList (StaticSymBuffer bf) = mapM getValue bf + getList (DynamicSymBuffer bf) = getValue bf + + , testProperty "dynWriteMemory works like writeMemory" $ + withMaxSuccess 10000 $ + forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args in ioProperty $ runSMTWith z3 $ query $ do cd <- sbytes32 @@ -191,18 +189,17 @@ main = defaultMain $ testGroup "hevm" staticWriting = writeMemory' cd src len dst mem dynamicWriting = dynWriteMemory - (implode cd) + (DynamicSymBuffer (implode cd)) (litWord src) (litWord len) (litWord dst) - (implode mem) + (DynamicSymBuffer (implode mem)) when ((length staticWriting) < 10000 && len' < 10000) $ - let staticVer = implode staticWriting - in checkSatAssuming [staticVer ./= dynamicWriting] >>= \case + checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case Unsat -> io $ putStrLn "Success!" - Sat -> do getValue dynamicWriting >>= io . print - getValue staticVer >>= io . print + Sat -> do -- getValue dynamicWriting >>= io . print + -- getValue staticVer >>= io . print error "oh no!" From 029a00338da11db46289b0713e0000fd8cc597ec Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 26 Aug 2020 16:55:06 +0200 Subject: [PATCH 09/36] correcter --- src/hevm/hevm-cli/hevm-cli.hs | 30 +++++++++----------- src/hevm/src/EVM.hs | 36 ++++++++++++------------ src/hevm/src/EVM/Symbolic.hs | 27 ++++++++++-------- src/hevm/test/test.hs | 53 ++++++++++++++++++----------------- 4 files changed, 75 insertions(+), 71 deletions(-) diff --git a/src/hevm/hevm-cli/hevm-cli.hs b/src/hevm/hevm-cli/hevm-cli.hs index 7dbd6608c..4e3234173 100644 --- a/src/hevm/hevm-cli/hevm-cli.hs +++ b/src/hevm/hevm-cli/hevm-cli.hs @@ -519,7 +519,7 @@ assert cmd = do "Stopped" else io $ putStrLn $ "Returned: " <> show (ByteStringS msg) - Just (EVM.VMSuccess (SymbolicBuffer msg)) -> do + Just (EVM.VMSuccess (StaticSymBuffer msg)) -> do out <- mapM (getValue.fromSized) msg io . putStrLn $ "Returned: " <> show (ByteStringS (ByteString.pack out)) @@ -582,7 +582,7 @@ launchExec cmd = do exitWith (ExitFailure 2) Just (EVM.VMSuccess buf) -> do let msg = case buf of - SymbolicBuffer msg' -> forceLitBytes msg' + StaticSymBuffer msg' -> forceLitBytes msg' ConcreteBuffer msg' -> msg' print $ ByteStringS msg case state cmd of @@ -687,7 +687,7 @@ vmFromCommand cmd = do vm1 c = EVM.makeVm $ EVM.VMOpts { EVM.vmoptContract = c - , EVM.vmoptCalldata = (calldata', literal . num $ len calldata') + , EVM.vmoptCalldata = calldata' , EVM.vmoptValue = w256lit value' , EVM.vmoptAddress = address' , EVM.vmoptCaller = litAddr caller' @@ -714,22 +714,18 @@ symvmFromCommand :: Command Options.Unwrapped -> Query EVM.VM symvmFromCommand cmd = do caller' <- maybe (SAddr <$> freshVar_) (return . litAddr) (caller cmd) callvalue' <- maybe (sw256 <$> freshVar_) (return . w256lit) (value cmd) - (calldata', cdlen, pathCond) <- case (calldata cmd, sig cmd) of - -- fully abstract calldata (up to 1024 bytes) + calldata' <- case (calldata cmd, sig cmd) of + -- static calldata (up to 256 bytes) (Nothing, Nothing) -> do - cd <- sbytes256 - len <- freshVar_ - return (SymbolicBuffer cd, len, len .<= 256) + StaticSymBuffer <$> sbytes256 -- fully concrete calldata (Just c, Nothing) -> - let cd = ConcreteBuffer $ decipher c - in return (cd, num (len cd), sTrue) + return $ ConcreteBuffer $ decipher c -- calldata according to given abi with possible specializations from the `arg` list (Nothing, Just sig') -> do method' <- io $ functionAbi sig' let typs = snd <$> view methodInputs method' - (cd, cdlen) <- symCalldata (view methodSignature method') typs (arg cmd) - return (SymbolicBuffer cd, cdlen, sTrue) + StaticSymBuffer <$> staticCalldata (view methodSignature method') typs (arg cmd) _ -> error "incompatible options: calldata and abi" @@ -750,7 +746,7 @@ symvmFromCommand cmd = do error $ "contract not found." Just contract' -> return $ - vm1 cdlen calldata' callvalue' caller' (contract'' & set EVM.storage store) + vm1 calldata' callvalue' caller' (contract'' & set EVM.storage store) where contract'' = case code cmd of Nothing -> contract' @@ -765,12 +761,12 @@ symvmFromCommand cmd = do (_, _, Just c) -> return $ - vm1 cdlen calldata' callvalue' caller' $ + vm1 calldata' callvalue' caller' $ (EVM.initialContract . codeType $ decipher c) & set EVM.storage store (_, _, Nothing) -> error $ "must provide at least (rpc + address) or code" - return $ vm & over EVM.pathConditions (<> [pathCond]) + return vm where decipher = hexByteString "bytes" . strip0x @@ -780,9 +776,9 @@ symvmFromCommand cmd = do address' = if create cmd then createAddress origin' (word nonce 0) else addr address 0xacab - vm1 cdlen calldata' callvalue' caller' c = EVM.makeVm $ EVM.VMOpts + vm1 calldata' callvalue' caller' c = EVM.makeVm $ EVM.VMOpts { EVM.vmoptContract = c - , EVM.vmoptCalldata = (calldata', cdlen) + , EVM.vmoptCalldata = calldata' , EVM.vmoptValue = callvalue' , EVM.vmoptAddress = address' , EVM.vmoptCaller = caller' diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 5827db18c..5d5840952 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -738,13 +738,13 @@ exec1 = do -- op: CODECOPY 0x39 -> case stk of - (memOffset : codeOffset' : n' : xs) -> forceConcrete2 (codeOffset',n') $ \(codeOffset,n) -> do - burn (g_verylow + g_copy * ceilDiv (num n) 32) $ - accessUnboundedMemoryRange fees memOffset (litWord n) $ do + (memOffset : codeOffset : n : xs) -> + burnSym (litWord g_verylow + litWord g_copy * ceilSDiv n 32) $ + accessUnboundedMemoryRange fees memOffset n $ do next assign (state . stack) xs copyBytesToMemory (ConcreteBuffer (the state code)) - (litWord n) (litWord codeOffset) memOffset + n codeOffset memOffset _ -> underrun -- op: GASPRICE @@ -896,17 +896,17 @@ exec1 = do assign (state . stack) xs _ -> underrun - -- -- op: MSTORE8 - -- 0x53 -> - -- case stk of - -- (x':(S _ y):xs) -> forceConcrete x' $ \x -> - -- burn g_verylow $ - -- accessMemoryRange fees x 1 $ do - -- let yByte = bvExtract (Proxy :: Proxy 7) (Proxy :: Proxy 0) y - -- next - -- modifying (state . memory) (setMemoryByte x yByte) - -- assign (state . stack) xs - -- _ -> underrun + -- op: MSTORE8 + 0x53 -> + case stk of + (x:(S _ y):xs) -> + burn g_verylow $ + accessMemoryRange fees x 1 $ do + let yByte = bvExtract (Proxy :: Proxy 7) (Proxy :: Proxy 0) y + next + modifying (state . memory) (setMemoryByte x yByte) + assign (state . stack) xs + _ -> underrun -- op: SLOAD 0x54 -> @@ -1109,7 +1109,7 @@ exec1 = do case view frames vm of [] -> case (the tx isCreate) of - True -> forceConcreteBuffer output $ \output' -> do + True -> forceConcreteBuffer output $ \output' -> do let codesize = num $ BS.length output' maxsize = the block maxCodeSize if codesize > maxsize @@ -1237,8 +1237,8 @@ exec1 = do finishFrame (FrameReverted output) _ -> underrun - xxx -> - vmError (UnrecognizedOpcode xxx) + xxx -> error $ "unimplemented opcode: " <> show xxx +-- vmError (UnrecognizedOpcode xxx) -- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. callChecks diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 16e578b0e..77a334e99 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -153,7 +153,7 @@ swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs swordAt' :: SWord 32 -> SList (WordN 8) -> SymWord swordAt' i bs = case truncpad' 32 $ SL.drop (sFromIntegral i) bs of StaticSymBuffer s -> sw256 $ fromBytes s - DynamicSymBuffer s -> error "todo" + DynamicSymBuffer s -> sw256 $ fromBytes [s .!! literal i | i <- [0..31]] readByteOrZero' :: Int -> [SWord 8] -> SWord 8 readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) @@ -187,6 +187,9 @@ setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] setMemoryByte' (C _ i) x = writeMemory' [x] 1 0 (num i) +setMemoryByte'' :: SymWord -> SWord 8 -> Buffer -> Buffer +setMemoryByte'' i x = dynWriteMemory (StaticSymBuffer [x]) 1 0 i + readSWord' :: Word -> [SWord 8] -> SymWord readSWord' (C _ i) x = if i > num (length x) @@ -296,14 +299,14 @@ writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer writeMemory bs1 n src dst bs0 = case (maybeLitWord n, maybeLitWord src, maybeLitWord dst, bs0, bs1) of (Just n', Just src', Just dst', ConcreteBuffer bs0', ConcreteBuffer bs1') -> - ConcreteBuffer $ Concrete.writeMemory bs0' n' src' dst' bs1' + ConcreteBuffer $ Concrete.writeMemory bs1' n' src' dst' bs0' (Just n', Just src', Just dst', StaticSymBuffer bs0', ConcreteBuffer bs1') -> - StaticSymBuffer $ writeMemory' bs0' n' src' dst' (litBytes bs1') + StaticSymBuffer $ writeMemory' (litBytes bs1') n' src' dst' bs0' (Just n', Just src', Just dst', ConcreteBuffer bs0', StaticSymBuffer bs1') -> - StaticSymBuffer $ writeMemory' (litBytes bs0') n' src' dst' bs1' + StaticSymBuffer $ writeMemory' bs1' n' src' dst' (litBytes bs0') (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> - StaticSymBuffer $ writeMemory' bs0' n' src' dst' bs1' - _ -> dynWriteMemory bs0 n src dst bs1 + StaticSymBuffer $ writeMemory' bs1' n' src' dst' bs0' + _ -> dynWriteMemory bs1 n src dst bs0 readMemoryWord :: SWord 32 -> Buffer -> SymWord readMemoryWord i bf = case (unliteral i, bf) of @@ -322,11 +325,13 @@ setMemoryWord i x bf = case (unliteral i, maybeLitWord x, bf) of (Just i', _, StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x z _ -> setMemoryWord'' i x bf -setMemoryByte :: Word -> SWord 8 -> Buffer -> Buffer -setMemoryByte i x (StaticSymBuffer m) = StaticSymBuffer $ setMemoryByte' i x m -setMemoryByte i x (ConcreteBuffer m) = case fromSized <$> unliteral x of - Nothing -> StaticSymBuffer $ setMemoryByte' i x (litBytes m) - Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i x' m +setMemoryByte :: SymWord -> SWord 8 -> Buffer -> Buffer +setMemoryByte i x m = case (maybeLitWord i, m) of + (Just i', StaticSymBuffer m) -> StaticSymBuffer $ setMemoryByte' i' x m + (Just i', ConcreteBuffer m) -> case fromSized <$> unliteral x of + Nothing -> StaticSymBuffer $ setMemoryByte' i' x (litBytes m) + Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i' x' m + _ -> setMemoryByte'' i x m readSWord :: SymWord -> Buffer -> SymWord readSWord i bf = case (maybeLitWord i, bf) of diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 934045056..5419eea99 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -60,21 +60,21 @@ main = defaultMain $ testGroup "hevm" Right ("", _, x') -> x' == x _ -> False ] - -- , testGroup "Solidity expressions" - -- [ testCase "Trivial" $ - -- SolidityCall "x = 3;" [] - -- ===> AbiUInt 256 3 - - -- , testCase "Arithmetic" $ do - -- SolidityCall "x = a + 1;" - -- [AbiUInt 256 1] ===> AbiUInt 256 2 - -- SolidityCall "x = a - 1;" - -- [AbiUInt 8 0] ===> AbiUInt 8 255 - - -- , testCase "keccak256()" $ - -- SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" - -- [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 - -- ] + , testGroup "Solidity expressions" + [ testCase "Trivial" $ + SolidityCall "x = 3;" [] + ===> AbiUInt 256 3 + + , testCase "Arithmetic" $ do + SolidityCall "x = a + 1;" + [AbiUInt 256 1] ===> AbiUInt 256 2 + SolidityCall "x = a - 1;" + [AbiUInt 8 0] ===> AbiUInt 8 255 + + , testCase "keccak256()" $ + SolidityCall "x = uint(keccak256(abi.encodePacked(a)));" + [AbiString ""] ===> AbiUInt 256 0xc5d2460186f7233c927e7db2dcc703c0e500b653ca82273b7bfad8045d85a470 + ] , testGroup "Precompiled contracts" [ testGroup "Example (reverse)" @@ -150,7 +150,7 @@ main = defaultMain $ testGroup "hevm" , testGroup "Symbolic buffers" - [ testCase "dynWriteMemory works" $ runSMTWith z3{verbose=True} $ query $ do + [ testCase "dynWriteMemory works" $ runSMTWith z3 $ query $ do cd <- sbytes32 mem <- sbytes32 @@ -174,7 +174,7 @@ main = defaultMain $ testGroup "hevm" getList (DynamicSymBuffer bf) = getValue bf , testProperty "dynWriteMemory works like writeMemory" $ - withMaxSuccess 10000 $ +-- withMaxSuccess 10000 $ forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args in ioProperty $ runSMTWith z3 $ query $ do @@ -198,10 +198,13 @@ main = defaultMain $ testGroup "hevm" when ((length staticWriting) < 10000 && len' < 10000) $ checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case Unsat -> io $ putStrLn "Success!" - Sat -> do -- getValue dynamicWriting >>= io . print - -- getValue staticVer >>= io . print + Sat -> do getList dynamicWriting >>= io . print + getList (StaticSymBuffer staticWriting) >>= io . print error "oh no!" - + where getList :: Buffer -> Query [WordN 8] + getList (StaticSymBuffer bf) = mapM getValue bf + getList (DynamicSymBuffer bf) = getValue bf + -- , testCase "dynWriteMemory pads with zeros appropriately" $ -- ioProperty $ runSMT $ query $ do @@ -588,11 +591,11 @@ main = defaultMain $ testGroup "hevm" runSimpleVM :: ByteString -> ByteString -> Maybe ByteString runSimpleVM x ins = case loadVM x of - Nothing -> Nothing - Just vm -> - case runState (assign (state.calldata) (ConcreteBuffer ins) >> exec) vm of - (VMSuccess (ConcreteBuffer bs), _) -> Just bs - _ -> Nothing + Nothing -> Nothing + Just vm -> + case runState (assign (state.calldata) (ConcreteBuffer ins) >> exec) vm of + (VMSuccess (ConcreteBuffer bs), _) -> Just bs + _ -> Nothing loadVM :: ByteString -> Maybe VM loadVM x = From 8d91c147540b7251738cfbb7a29eac20d909e133 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Thu, 27 Aug 2020 16:08:17 +0200 Subject: [PATCH 10/36] callsemantics are back; more accurate SSTORE accounting; almost all tests passing --- src/hevm/src/EVM.hs | 1179 +++++++++++++++++----------------- src/hevm/src/EVM/Fetch.hs | 16 +- src/hevm/src/EVM/SymExec.hs | 14 +- src/hevm/src/EVM/Symbolic.hs | 77 ++- src/hevm/src/EVM/VMTest.hs | 18 +- src/hevm/test/test.hs | 111 ++-- 6 files changed, 704 insertions(+), 711 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 5d5840952..5cc07213a 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -207,8 +207,8 @@ data FrameContext , creationContextSubstate :: SubState } | CallContext - { callContextOffset :: Word - , callContextSize :: Word + { callContextOffset :: SymWord + , callContextSize :: SymWord , callContextCodehash :: W256 , callContextAbi :: Maybe Word , callContextData :: Buffer @@ -249,7 +249,7 @@ data TxState = TxState data SubState = SubState { _selfdestructs :: [Addr] , _touchedAccounts :: [Addr] - , _refunds :: [(Addr, Word)] + , _refunds :: [(Addr, Word)] -- TODO: make symbolic as well -- in principle we should include logs here, but do not for now } @@ -288,7 +288,7 @@ data Contract = Contract , _opIxMap :: Vector Int , _codeOps :: RegularVector.Vector (Int, Op) , _external :: Bool - , _origStorage :: Map Word Word + , _origStorage :: Storage } deriving instance Show Contract @@ -459,7 +459,7 @@ initialContract theContractCode = Contract , _opIxMap = mkOpIxMap theCode , _codeOps = mkCodeOps theCode , _external = False - , _origStorage = mempty + , _origStorage = Concrete mempty } where theCode = case theContractCode of InitCode b -> b RuntimeCode b -> b @@ -497,25 +497,25 @@ exec1 = do if self > 0x0 && self <= 0x9 then do -- call to precompile - error "hold off precompile for now" - -- let ?op = 0x00 -- dummy value - -- copyBytesToMemory (the state calldata) (num len (the state calldata)) 0 0 - -- executePrecompile self (the state gas) 0 (num (len (the state calldata))) 0 0 [] - -- vmx <- get - -- case view (state.stack) vmx of - -- (x:_) -> case maybeLitWord x of - -- Just 0 -> do - -- fetchAccount self $ \_ -> do - -- touchAccount self - -- vmError PrecompileFailure - -- Just _ -> - -- fetchAccount self $ \_ -> do - -- touchAccount self - -- out <- use (state . returndata) - -- finishFrame (FrameReturned out) - -- Nothing -> vmError UnexpectedSymbolicArg - -- _ -> - -- underrun + + let ?op = 0x00 -- dummy value + copyBytesToMemory (the state calldata) (sw256 $ sFromIntegral $ len (the state calldata)) 0 0 + executePrecompile self (the state gas) 0 (sw256 $ sFromIntegral $ len (the state calldata)) 0 0 [] + vmx <- get + case view (state.stack) vmx of + (x:_) -> case maybeLitWord x of + Just 0 -> do + fetchAccount self $ \_ -> do + touchAccount self + vmError PrecompileFailure + Just _ -> + fetchAccount self $ \_ -> do + touchAccount self + out <- use (state . returndata) + finishFrame (FrameReturned out) + Nothing -> vmError UnexpectedSymbolicArg + _ -> + underrun else if the state pc >= num (BS.length (the state code)) then doStop @@ -558,28 +558,27 @@ exec1 = do assign (ix 0) (stk ^?! ix i) assign (ix i) (stk ^?! ix 0) - -- -- op: LOG - -- x | x >= 0xa0 && x <= 0xa4 -> - -- notStatic $ - -- let n = (num x - 0xa0) in - -- case stk of - -- (xOffset':xSize':xs) -> - -- if length xs < n - -- then underrun - -- else - -- forceConcrete2 (xOffset', xSize') $ \(xOffset, xSize) -> do - -- let (topics, xs') = splitAt n xs - -- bytes = readMemory (num xOffset) (num xSize) vm - -- log = Log self bytes topics - - -- burn (g_log + g_logdata * xSize + num n * g_logtopic) $ - -- accessMemoryRange fees xOffset xSize $ do - -- traceLog log - -- next - -- assign (state . stack) xs' - -- pushToSequence logs log - -- _ -> - -- underrun + -- op: LOG + x | x >= 0xa0 && x <= 0xa4 -> + notStatic $ + let n = (num x - 0xa0) in + case stk of + (xOffset:xSize:xs) -> + if length xs < n + then underrun + else do + let (topics, xs') = splitAt n xs + bytes = readMemory xOffset xSize vm + log = Log self bytes topics + + burnSym (litWord g_log + litWord g_logdata * xSize + litWord (num n * g_logtopic)) $ + accessMemoryRange fees xOffset xSize $ do + traceLog log + next + assign (state . stack) xs' + pushToSequence logs log + _ -> + underrun -- op: STOP 0x00 -> doStop @@ -643,39 +642,38 @@ exec1 = do -- op: SAR 0x1d -> stackOp2 (const g_verylow) $ \((S _ n), (S _ x)) -> sw256 $ sSignedShiftArithRight x n - -- -- op: SHA3 - -- -- more accurately refered to as KECCAK - -- 0x20 -> - -- case stk of - -- (xOffset' : xSize' : xs) -> - -- forceConcrete xOffset' $ - -- \xOffset -> forceConcrete xSize' $ \xSize -> do - -- (hash, invMap) <- case readMemory xOffset xSize vm of - -- ConcreteBuffer bs -> pure (litWord $ keccakBlob bs, Map.singleton (keccakBlob bs) bs) - - -- -- Although we would like to simply assert that the uninterpreted function symkeccak' - -- -- is injective, this proves to cause a lot of concern for our smt solvers, probably - -- -- due to the introduction of universal quantifiers into the queries. - - -- -- Instead, we keep track of all of the particular invocations of symkeccak' we see - -- -- (similarly to sha3Crack), and simply assert that injectivity holds for these - -- -- particular invocations. - - -- StaticSymBuffer bs -> do - -- let hash' = symkeccak' bs - -- previousUsed = view (env . keccakUsed) vm - -- env . keccakUsed <>= [(bs, hash')] - -- pathConditions <>= fmap (\(preimage, image) -> - -- image .== hash' .=> preimage .== bs) - -- previousUsed - -- return (sw256 hash', mempty) - - -- burn (g_sha3 + g_sha3word * ceilDiv (num xSize) 32) $ - -- accessMemoryRange fees xOffset xSize $ do - -- next - -- assign (state . stack) (hash : xs) - -- (env . sha3Crack) <>= invMap - -- _ -> underrun + -- op: SHA3 + -- more accurately refered to as KECCAK + 0x20 -> + case stk of + (xOffset : xSize : xs) -> do + + (hash, invMap) <- case readMemory xOffset xSize vm of + + DynamicSymBuffer bs -> error "currently unsupported: KECCAK of dynamic bytes" + ConcreteBuffer bs -> pure (litWord $ keccakBlob bs, Map.singleton (keccakBlob bs) bs) + + -- Although we would like to simply assert that the uninterpreted function symkeccak' + -- is injective, this proves to cause a lot of concern for our smt solvers, probably + -- due to the introduction of universal quantifiers into the queries. + + -- Instead, we keep track of all of the particular invocations of symkeccak' we see + -- (similarly to sha3Crack), and simply assert that injectivity holds for these + -- particular invocations. + + StaticSymBuffer bs -> do + let hash' = symkeccak' bs + previousUsed = view (env . keccakUsed) vm + env . keccakUsed <>= [(bs, hash')] + pathConditions <>= flip fmap previousUsed (\(preimg, img) -> img .== hash' .=> preimg .== bs) + return (sw256 hash', mempty) + + burnSym (litWord g_sha3 + litWord g_sha3word * ceilSDiv xSize 32) $ + accessMemoryRange fees xOffset xSize $ do + next + assign (state . stack) (hash : xs) + (env . sha3Crack) <>= invMap + _ -> underrun -- op: ADDRESS 0x30 -> @@ -929,44 +927,38 @@ exec1 = do if availableGas <= g_callstipend then finishFrame (FrameErrored (OutOfGas availableGas g_callstipend)) else do - let original = case view storage this of - Concrete _ -> fromMaybe 0 (Map.lookup (forceLit x) (view origStorage this)) - Symbolic _ -> 0 -- we don't use this value anywhere anyway - cost = case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - if (current' == new') then g_sload - else if (current' == original) && (original == 0) then g_sset - else if (current' == original) then g_sreset - else g_sload - - -- if any of the arguments are symbolic, - -- assume worst case scenario - _ -> g_sset - - burn cost $ do + let original = fromMaybe 0 (readStorage (view origStorage this) x) + + cost = ite (current .== new) (litWord g_sload) + (ite (current .== original .&& original .== 0) (litWord g_sset) + (ite (current .== original) (litWord g_sreset) + (litWord g_sload))) + + anticost = ite (current .== new) 0 + (ite (current .== original) + (ite (original ./= 0 .&& new .== 0) (litWord r_sclear) 0) + (ite (original ./= 0) + (ite (new .== 0) (litWord r_sclear) 0) + (ite (original .== 0) + (litWord (g_sset - g_sload)) + (litWord (g_sreset - g_sload))))) + + unrefund = ite (current ./= new .&& + current ./= original .&& + original ./= 0 .&& + new ./= 0) + (litWord r_sclear) + 0 + + burnSym cost $ do next assign (state . stack) xs modifying (env . contracts . ix self . storage) (writeStorage x new) - case (maybeLitWord current, maybeLitWord new) of - (Just current', Just new') -> - unless (current' == new') $ - if current' == original - then when (original /= 0 && new' == 0) $ - refund r_sclear - else do - when (original /= 0) $ - if new' == 0 - then refund r_sclear - else unRefund r_sclear - when (original == new') $ - if original == 0 - then refund (g_sset - g_sload) - else refund (g_sreset - g_sload) - -- if any of the arguments are symbolic, - -- don't change the refund counter - _ -> noop + refundSym anticost + unRefundSym unrefund + _ -> underrun -- op: JUMP @@ -1026,78 +1018,77 @@ exec1 = do (x .|. complement (bit n - 1)) (x .&. (bit n - 1)) - -- -- op: CREATE - -- 0xf0 -> - -- notStatic $ - -- case stk of - -- (xValue' : xOffset' : xSize' : xs) -> forceConcrete3 (xValue', xOffset', xSize') $ - -- \(xValue, xOffset, xSize) -> do - -- accessMemoryRange fees xOffset xSize $ do - -- availableGas <- use (state . gas) - -- let - -- newAddr = createAddress self (wordValue (view nonce this)) - -- (cost, gas') = costOfCreate fees availableGas 0 - -- burn (cost - gas') $ forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> - -- create self this gas' xValue xs newAddr initCode - -- _ -> underrun - - -- -- op: CALL - -- 0xf1 -> - -- case stk of - -- ( xGas' - -- : xTo' - -- : (forceLit -> xValue) - -- : xInOffset' - -- : xInSize' - -- : xOutOffset' - -- : xOutSize' - -- : xs - -- ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - -- (if xValue > 0 then notStatic else id) $ - -- case xTo of - -- n | n > 0 && n <= 9 -> - -- precompiledContract this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs - -- n | num n == cheatCode -> - -- do - -- assign (state . stack) xs - -- cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - -- _ -> delegateCall this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ do - -- zoom state $ do - -- assign callvalue (litWord xValue) - -- assign caller (litAddr self) - -- assign contract xTo - -- zoom (env . contracts) $ do - -- ix self . balance -= xValue - -- ix xTo . balance += xValue - -- touchAccount self - -- touchAccount xTo - -- _ -> - -- underrun - - -- -- op: CALLCODE - -- 0xf2 -> - -- case stk of - -- ( xGas' - -- : xTo' - -- : (forceLit -> xValue) - -- : xInOffset' - -- : xInSize' - -- : xOutOffset' - -- : xOutSize' - -- : xs - -- ) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - -- case xTo of - -- n | n > 0 && n <= 9 -> - -- precompiledContract this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs - -- _ -> delegateCall this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs $ do - -- zoom state $ do - -- assign callvalue (litWord xValue) - -- assign caller (litAddr self) - -- touchAccount self - -- _ -> - -- underrun + -- op: CREATE + 0xf0 -> + notStatic $ + case stk of + (xValue : xOffset : xSize : xs) -> forceConcrete xValue $ \xValue' -> + accessMemoryRange fees xOffset xSize $ do + availableGas <- use (state . gas) + let + newAddr = createAddress self (wordValue (view nonce this)) + (cost, gas') = costOfCreate fees availableGas 0 + burn (cost - gas') $ forceConcreteBuffer (readMemory xOffset xSize vm) $ \initCode -> + create self this gas' xValue' xs newAddr initCode + _ -> underrun + + -- op: CALL + 0xf1 -> + case stk of + ( xGas' + : xTo' + : xValue' + : xInOffset + : xInSize + : xOutOffset + : xOutSize + : xs + ) -> forceConcrete3 (xGas', xTo', xValue') $ + \(xGas, (num -> xTo), xValue) -> + (if xValue > 0 then notStatic else id) $ + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs + n | num n == cheatCode -> + do + assign (state . stack) xs + cheat xInOffset xInSize xOutOffset xOutSize + _ -> delegateCall this xGas xTo xTo xValue xInOffset xInSize xOutOffset xOutSize xs $ do + zoom state $ do + assign callvalue (litWord xValue) + assign caller (litAddr self) + assign contract xTo + zoom (env . contracts) $ do + ix self . balance -= xValue + ix xTo . balance += xValue + touchAccount self + touchAccount xTo + _ -> + underrun + + -- op: CALLCODE + 0xf2 -> + case stk of + ( xGas' + : xTo' + : (forceLit -> xValue) + : xInOffset + : xInSize + : xOutOffset + : xOutSize + : xs + ) -> forceConcrete2 (xGas', xTo') $ + \(xGas, (num -> xTo)) -> + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs + _ -> delegateCall this xGas xTo self xValue xInOffset xInSize xOutOffset xOutSize xs $ do + zoom state $ do + assign callvalue (litWord xValue) + assign caller (litAddr self) + touchAccount self + _ -> + underrun -- op: RETURN 0xf3 -> @@ -1137,96 +1128,96 @@ exec1 = do finishFrame (FrameReturned output) _ -> underrun - -- -- op: DELEGATECALL - -- 0xf4 -> - -- case stk of - -- (xGas' - -- :xTo' - -- :xInOffset' - -- :xInSize' - -- :xOutOffset' - -- :xOutSize' - -- :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - -- case xTo of - -- n | n > 0 && n <= 9 -> - -- precompiledContract this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs - -- n | num n == cheatCode -> do - -- assign (state . stack) xs - -- cheat (xInOffset, xInSize) (xOutOffset, xOutSize) - -- _ -> do - -- delegateCall this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs $ do - -- touchAccount self - -- _ -> underrun - - -- -- op: CREATE2 - -- 0xf5 -> notStatic $ - -- case stk of - -- (xValue' - -- :xOffset' - -- :xSize' - -- :xSalt' - -- :xs) -> forceConcrete4 (xValue', xOffset', xSize', xSalt') $ - -- \(xValue, xOffset, xSize, xSalt) -> - -- accessMemoryRange fees xOffset xSize $ do - -- availableGas <- use (state . gas) - -- forceConcreteBuffer (readMemory (num xOffset) (num xSize) vm) $ \initCode -> - -- let - -- newAddr = create2Address self (num xSalt) initCode - -- (cost, gas') = costOfCreate fees availableGas xSize - -- in burn (cost - gas') $ - -- create self this gas' xValue xs newAddr initCode - -- _ -> underrun - - -- -- op: STATICCALL - -- 0xfa -> - -- case stk of - -- (xGas' - -- :xTo' - -- :xInOffset' - -- :xInSize' - -- :xOutOffset' - -- :xOutSize' - -- :xs) -> forceConcrete6 (xGas', xTo', xInOffset', xInSize', xOutOffset', xOutSize') $ - -- \(xGas, (num -> xTo), xInOffset, xInSize, xOutOffset, xOutSize) -> - -- case xTo of - -- n | n > 0 && n <= 9 -> - -- precompiledContract this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs - -- _ -> delegateCall this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ do - -- zoom state $ do - -- assign callvalue 0 - -- assign caller (litAddr self) - -- assign contract xTo - -- assign static True - -- touchAccount self - -- touchAccount xTo - -- _ -> - -- underrun - - -- -- op: SELFDESTRUCT - -- 0xff -> - -- notStatic $ - -- case stk of - -- [] -> underrun - -- (xTo':_) -> forceConcrete xTo' $ \(num -> xTo) -> - -- let - -- funds = view balance this - -- recipientExists = accountExists xTo vm - -- c_new = if not recipientExists && funds /= 0 - -- then num g_selfdestruct_newaccount - -- else 0 - -- in burn (g_selfdestruct + c_new) $ do - -- destructs <- use (tx . substate . selfdestructs) - -- unless (elem self destructs) $ refund r_selfdestruct - -- selfdestruct self - -- touchAccount xTo - - -- if funds /= 0 - -- then fetchAccount xTo $ \_ -> do - -- env . contracts . ix xTo . balance += funds - -- assign (env . contracts . ix self . balance) 0 - -- doStop - -- else doStop + -- op: DELEGATECALL + 0xf4 -> + case stk of + (xGas' + :xTo' + :xInOffset + :xInSize + :xOutOffset + :xOutSize + :xs) -> forceConcrete2 (xGas', xTo') $ + \(xGas, (num -> xTo)) -> + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs + n | num n == cheatCode -> do + assign (state . stack) xs + cheat xInOffset xInSize xOutOffset xOutSize + _ -> do + delegateCall this xGas xTo self 0 xInOffset xInSize xOutOffset xOutSize xs $ do + touchAccount self + _ -> underrun + + -- op: CREATE2 + 0xf5 -> notStatic $ + case stk of + (xValue' + :xOffset + :xSize' + :xSalt' + :xs) -> forceConcrete3 (xValue', xSalt', xSize') $ + \(xValue, xSalt, xSize) -> + accessMemoryRange fees xOffset (litWord xSize) $ do + availableGas <- use (state . gas) + forceConcreteBuffer (readMemory xOffset (litWord xSize) vm) $ \initCode -> + let + newAddr = create2Address self (num xSalt) initCode + (cost, gas') = costOfCreate fees availableGas xSize + in burn (cost - gas') $ + create self this gas' xValue xs newAddr initCode + _ -> underrun + + -- op: STATICCALL + 0xfa -> + case stk of + (xGas' + :xTo' + :xInOffset + :xInSize + :xOutOffset + :xOutSize + :xs) -> forceConcrete2 (xGas', xTo') $ + \(xGas, (num -> xTo)) -> + case xTo of + n | n > 0 && n <= 9 -> + precompiledContract this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs + _ -> delegateCall this xGas xTo xTo 0 xInOffset xInSize xOutOffset xOutSize xs $ do + zoom state $ do + assign callvalue 0 + assign caller (litAddr self) + assign contract xTo + assign static True + touchAccount self + touchAccount xTo + _ -> + underrun + + -- op: SELFDESTRUCT + 0xff -> + notStatic $ + case stk of + [] -> underrun + (xTo':_) -> forceConcrete xTo' $ \(num -> xTo) -> + let + funds = view balance this + recipientExists = accountExists xTo vm + c_new = if not recipientExists && funds /= 0 + then num g_selfdestruct_newaccount + else 0 + in burn (g_selfdestruct + c_new) $ do + destructs <- use (tx . substate . selfdestructs) + unless (elem self destructs) $ refund r_selfdestruct + selfdestruct self + touchAccount xTo + + if funds /= 0 + then fetchAccount xTo $ \_ -> do + env . contracts . ix xTo . balance += funds + assign (env . contracts . ix self . balance) 0 + doStop + else doStop -- op: REVERT 0xfd -> @@ -1237,39 +1228,37 @@ exec1 = do finishFrame (FrameReverted output) _ -> underrun - xxx -> error $ "unimplemented opcode: " <> show xxx --- vmError (UnrecognizedOpcode xxx) + xxx -> vmError (UnrecognizedOpcode xxx) -- | Checks a *CALL for failure; OOG, too many callframes, memory access etc. callChecks :: (?op :: Word8) - => Contract -> Word -> Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] + => Contract -> Word -> Addr -> Word -> SymWord -> SymWord -> SymWord -> SymWord -> [SymWord] -- continuation with gas avail for call -> (Word -> EVM ()) -> EVM () callChecks this xGas xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = do - error "no calls for now" - -- vm <- get - -- let fees = view (block . schedule) vm - -- accessMemoryRange fees xInOffset xInSize $ - -- accessMemoryRange fees xOutOffset xOutSize $ do - -- availableGas <- use (state . gas) - -- let recipientExists = accountExists xContext vm - -- (cost, gas') = costOfCall fees recipientExists xValue availableGas xGas - -- burn (cost - gas') $ do - -- if xValue > view balance this - -- then do - -- assign (state . stack) (0 : xs) - -- assign (state . returndata) mempty - -- pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) - -- next - -- else if length (view frames vm) >= 1024 - -- then do - -- assign (state . stack) (0 : xs) - -- assign (state . returndata) mempty - -- pushTrace $ ErrorTrace $ CallDepthLimitReached - -- next - -- else continue gas' + vm <- get + let fees = view (block . schedule) vm + accessMemoryRange fees xInOffset xInSize $ + accessMemoryRange fees xOutOffset xOutSize $ do + availableGas <- use (state . gas) + let recipientExists = accountExists xContext vm + (cost, gas') = costOfCall fees recipientExists xValue availableGas xGas + burn (cost - gas') $ do + if xValue > view balance this + then do + assign (state . stack) (0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ BalanceTooLow xValue (view balance this) + next + else if length (view frames vm) >= 1024 + then do + assign (state . stack) (0 : xs) + assign (state . returndata) mempty + pushTrace $ ErrorTrace $ CallDepthLimitReached + next + else continue gas' precompiledContract :: (?op :: Word8) @@ -1278,7 +1267,7 @@ precompiledContract -> Addr -> Addr -> Word - -> Word -> Word -> Word -> Word + -> SymWord -> SymWord -> SymWord -> SymWord -> [SymWord] -> EVM () precompiledContract this xGas precompileAddr recipient xValue inOffset inSize outOffset outSize xs = @@ -1306,159 +1295,159 @@ precompiledContract this xGas precompileAddr recipient xValue inOffset inSize ou executePrecompile :: (?op :: Word8) => Addr - -> Word -> Word -> Word -> Word -> Word -> [SymWord] + -> Word -> SymWord -> SymWord -> SymWord -> SymWord -> [SymWord] -> EVM () -executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = error "no precompile rn" --do _ - -- vm <- get - -- let input = readMemory (num inOffset) (num inSize) vm - -- fees = view (block . schedule) vm - -- cost = costOfPrecompile fees preCompileAddr input - -- notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" - -- precompileFail = burn (gasCap - cost) $ do - -- assign (state . stack) (0 : xs) - -- pushTrace $ ErrorTrace $ PrecompileFailure - -- next - -- if cost > gasCap then - -- burn gasCap $ do - -- assign (state . stack) (0 : xs) - -- next - -- else - -- burn cost $ - -- case preCompileAddr of - -- -- ECRECOVER - -- 0x1 -> - -- -- TODO: support symbolic variant - -- forceConcreteBuffer input $ \input' -> - -- case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of - -- Nothing -> do - -- -- return no output for invalid signature - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) mempty - -- next - -- Just output -> do - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) (ConcreteBuffer output) - -- copyBytesToMemory (ConcreteBuffer output) outSize 0 outOffset - -- next - - -- -- SHA2-256 - -- 0x2 -> - -- let - -- hash = case input of - -- ConcreteBuffer input' -> ConcreteBuffer $ BS.pack $ BA.unpack $ (Crypto.hash input' :: Digest SHA256) - -- StaticSymBuffer input' -> StaticSymBuffer $ symSHA256 input' - -- in do - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) hash - -- copyBytesToMemory hash outSize 0 outOffset - -- next - - -- -- RIPEMD-160 - -- 0x3 -> - -- -- TODO: support symbolic variant - -- forceConcreteBuffer input $ \input' -> - - -- let - -- padding = BS.pack $ replicate 12 0 - -- hash' = BS.pack $ BA.unpack (Crypto.hash input' :: Digest RIPEMD160) - -- hash = ConcreteBuffer $ padding <> hash' - -- in do - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) hash - -- copyBytesToMemory hash outSize 0 outOffset - -- next - - -- -- IDENTITY - -- 0x4 -> do - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) input - -- copyCallBytesToMemory input outSize 0 outOffset - -- next - - -- -- MODEXP - -- 0x5 -> - -- -- TODO: support symbolic variant - -- forceConcreteBuffer input $ \input' -> - - -- let - -- (lenb, lene, lenm) = parseModexpLength input' - - -- output = ConcreteBuffer $ - -- case (isZero (96 + lenb + lene) lenm input') of - -- True -> - -- truncpadlit (num lenm) (asBE (0 :: Int)) - -- False -> - -- let - -- b = asInteger $ lazySlice 96 lenb $ input' - -- e = asInteger $ lazySlice (96 + lenb) lene $ input' - -- m = asInteger $ lazySlice (96 + lenb + lene) lenm $ input' - -- in - -- padLeft (num lenm) (asBE (expFast b e m)) - -- in do - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) output - -- copyBytesToMemory output outSize 0 outOffset - -- next - - -- -- ECADD - -- 0x6 -> - -- -- TODO: support symbolic variant - -- forceConcreteBuffer input $ \input' -> - -- case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of - -- Nothing -> precompileFail - -- Just output -> do - -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) truncpaddedOutput - -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset - -- next - - -- -- ECMUL - -- 0x7 -> - -- -- TODO: support symbolic variant - -- forceConcreteBuffer input $ \input' -> - - -- case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of - -- Nothing -> precompileFail - -- Just output -> do - -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) truncpaddedOutput - -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset - -- next - - -- -- ECPAIRING - -- 0x8 -> - -- -- TODO: support symbolic variant - -- forceConcreteBuffer input $ \input' -> - - -- case EVM.Precompiled.execute 0x8 input' 32 of - -- Nothing -> precompileFail - -- Just output -> do - -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 32 output - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) truncpaddedOutput - -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset - -- next - - -- -- BLAKE2 - -- 0x9 -> - -- -- TODO: support symbolic variant - -- forceConcreteBuffer input $ \input' -> do - - -- case (BS.length input', 1 >= BS.last input') of - -- (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of - -- Just output -> do - -- let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output - -- assign (state . stack) (1 : xs) - -- assign (state . returndata) truncpaddedOutput - -- copyBytesToMemory truncpaddedOutput outSize 0 outOffset - -- next - -- Nothing -> precompileFail - -- _ -> precompileFail - - - -- _ -> notImplemented +executePrecompile preCompileAddr gasCap inOffset inSize outOffset outSize xs = do + vm <- get + let input = readMemory inOffset inSize vm + fees = view (block . schedule) vm + cost = costOfPrecompile fees preCompileAddr input + notImplemented = error $ "precompile at address " <> show preCompileAddr <> " not yet implemented" + precompileFail = burn (gasCap - cost) $ do + assign (state . stack) (0 : xs) + pushTrace $ ErrorTrace $ PrecompileFailure + next + if cost > gasCap then + burn gasCap $ do + assign (state . stack) (0 : xs) + next + else + burn cost $ + case preCompileAddr of + -- ECRECOVER + 0x1 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + case EVM.Precompiled.execute 0x1 (truncpadlit 128 input') 32 of + Nothing -> do + -- return no output for invalid signature + assign (state . stack) (1 : xs) + assign (state . returndata) mempty + next + Just output -> do + assign (state . stack) (1 : xs) + assign (state . returndata) (ConcreteBuffer output) + copyBytesToMemory (ConcreteBuffer output) outSize 0 outOffset + next + + -- SHA2-256 + 0x2 -> + let + hash = case input of + ConcreteBuffer input' -> ConcreteBuffer $ BS.pack $ BA.unpack $ (Crypto.hash input' :: Digest SHA256) + StaticSymBuffer input' -> StaticSymBuffer $ symSHA256 input' + in do + assign (state . stack) (1 : xs) + assign (state . returndata) hash + copyBytesToMemory hash outSize 0 outOffset + next + + -- RIPEMD-160 + 0x3 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + let + padding = BS.pack $ replicate 12 0 + hash' = BS.pack $ BA.unpack (Crypto.hash input' :: Digest RIPEMD160) + hash = ConcreteBuffer $ padding <> hash' + in do + assign (state . stack) (1 : xs) + assign (state . returndata) hash + copyBytesToMemory hash outSize 0 outOffset + next + + -- IDENTITY + 0x4 -> do + assign (state . stack) (1 : xs) + assign (state . returndata) input + copyCallBytesToMemory input outSize 0 outOffset + next + + -- MODEXP + 0x5 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + let + (lenb, lene, lenm) = parseModexpLength input' + + output = ConcreteBuffer $ + case (isZero (96 + lenb + lene) lenm input') of + True -> + truncpadlit (num lenm) (asBE (0 :: Int)) + False -> + let + b = asInteger $ lazySlice 96 lenb $ input' + e = asInteger $ lazySlice (96 + lenb) lene $ input' + m = asInteger $ lazySlice (96 + lenb + lene) lenm $ input' + in + padLeft (num lenm) (asBE (expFast b e m)) + in do + assign (state . stack) (1 : xs) + assign (state . returndata) output + copyBytesToMemory output outSize 0 outOffset + next + + -- ECADD + 0x6 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + case EVM.Precompiled.execute 0x6 (truncpadlit 128 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 outOffset + next + + -- ECMUL + 0x7 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + case EVM.Precompiled.execute 0x7 (truncpadlit 96 input') 64 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 outOffset + next + + -- ECPAIRING + 0x8 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> + + case EVM.Precompiled.execute 0x8 input' 32 of + Nothing -> precompileFail + Just output -> do + let truncpaddedOutput = ConcreteBuffer $ truncpadlit 32 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 outOffset + next + + -- BLAKE2 + 0x9 -> + -- TODO: support symbolic variant + forceConcreteBuffer input $ \input' -> do + + case (BS.length input', 1 >= BS.last input') of + (213, True) -> case EVM.Precompiled.execute 0x9 input' 64 of + Just output -> do + let truncpaddedOutput = ConcreteBuffer $ truncpadlit 64 output + assign (state . stack) (1 : xs) + assign (state . returndata) truncpaddedOutput + copyBytesToMemory truncpaddedOutput outSize 0 outOffset + next + Nothing -> precompileFail + _ -> precompileFail + + + _ -> notImplemented truncpadlit :: Int -> ByteString -> ByteString truncpadlit n xs = if m > n then BS.take n xs @@ -1775,11 +1764,21 @@ forceConcreteBuffer (StaticSymBuffer b) continue = case maybeLitBytes b of forceConcreteBuffer (ConcreteBuffer b) continue = continue b -- * Substate manipulation +refundSym :: SymWord -> EVM () +refundSym n = case maybeLitWord n of + Nothing -> refund 0 -- TODO: make refunds symbolic + Just n' -> refund n' + refund :: Word -> EVM () refund n = do self <- use (state . contract) pushTo (tx . substate . refunds) (self, n) +unRefundSym :: SymWord -> EVM () +unRefundSym n = case maybeLitWord n of + Nothing -> unRefund 0 --TODO: make refunds symbolic + Just n' -> unRefund n' + unRefund :: Word -> EVM () unRefund n = do self <- use (state . contract) @@ -1802,41 +1801,39 @@ selfdestruct = pushTo ((tx . substate) . selfdestructs) cheatCode :: Addr cheatCode = num (keccak "hevm cheat code") --- cheat --- :: (?op :: Word8) --- => (Word, Word) -> (Word, Word) --- -> EVM () --- cheat (inOffset, inSize) (outOffset, outSize) = do --- mem <- use (state . memory) --- vm <- get --- let --- abi = readMemoryWord32 inOffset mem --- input = readMemory (inOffset + 4) (inSize - 4) vm --- case fromSized <$> unliteral abi of --- Nothing -> vmError UnexpectedSymbolicArg --- Just abi -> --- case Map.lookup abi cheatActions of --- Nothing -> --- vmError (BadCheatCode (Just abi)) --- Just (argTypes, action) -> --- case input of --- StaticSymBuffer _ -> vmError UnexpectedSymbolicArg --- ConcreteBuffer input' -> --- case runGetOrFail --- (getAbiSeq (length argTypes) argTypes) --- (LS.fromStrict input') of --- Right ("", _, args) -> --- action (toList args) >>= \case --- Nothing -> do --- next --- push 1 --- Just (encodeAbiValue -> bs) -> do --- next --- modifying (state . memory) --- (writeMemory (ConcreteBuffer bs) outSize 0 outOffset) --- push 1 --- _ -> --- vmError (BadCheatCode (Just abi)) +cheat + :: (?op :: Word8) + => SymWord -> SymWord -> SymWord -> SymWord + -> EVM () +cheat inOffset' inSize' outOffset' outSize' = + case (maybeLitWord inOffset', maybeLitWord inSize', maybeLitWord outOffset', maybeLitWord outSize') of + (Just inOffset, Just inSize, Just outOffset, Just outSize) -> do + mem <- use (state . memory) + vm <- get + let + abi' = readMemoryWord32 inOffset' mem + input = readMemory (inOffset' + 4) (inSize' - 4) vm + forceConcrete (sw256 $ sFromIntegral abi') $ \(num -> abi) -> forceConcreteBuffer input $ \input' -> + case Map.lookup abi cheatActions of + Nothing -> + vmError (BadCheatCode (Just abi)) + Just (argTypes, action) -> + case runGetOrFail + (getAbiSeq (length argTypes) argTypes) + (LS.fromStrict input') of + Right ("", _, args) -> + action (toList args) >>= \case + Nothing -> do + next + push 1 + Just (encodeAbiValue -> bs) -> do + next + modifying (state . memory) + (writeMemory (ConcreteBuffer bs) outSize' 0 outOffset') + push 1 + _ -> + vmError (BadCheatCode (Just abi)) + _ -> vmError UnexpectedSymbolicArg type CheatAction = ([AbiType], [AbiValue] -> EVM (Maybe AbiValue)) @@ -1862,60 +1859,59 @@ cheatActions = where action s ts f = (abiKeccak s, (ts, f)) --- -- * General call implementation ("delegateCall") --- delegateCall --- :: (?op :: Word8) --- => Contract -> Word -> Addr -> Addr -> Word -> Word -> Word -> Word -> Word -> [SymWord] --- -> EVM () --- -> EVM () --- delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = --- callChecks this gasGiven xContext xValue xInOffset xInSize xOutOffset xOutSize xs $ --- \xGas -> do --- vm0 <- get --- fetchAccount xTo . const $ --- preuse (env . contracts . ix xTo) >>= \case --- Nothing -> --- vmError (NoSuchContract xTo) --- Just target -> --- burn xGas $ do --- let newContext = CallContext --- { callContextOffset = xOutOffset --- , callContextSize = xOutSize --- , callContextCodehash = view codehash target --- , callContextReversion = view (env . contracts) vm0 --- , callContextSubState = view (tx . substate) vm0 --- , callContextAbi = --- if xInSize >= 4 --- then case unliteral $ readMemoryWord32 xInOffset (view (state . memory) vm0) --- of Nothing -> Nothing --- Just abi -> Just . w256 $ num abi --- else Nothing --- , callContextData = (readMemory (num xInOffset) (num xInSize) vm0) --- } - --- pushTrace (FrameTrace newContext) --- next --- vm1 <- get - --- pushTo frames $ Frame --- { _frameState = (set stack xs) (view state vm1) --- , _frameContext = newContext --- } - --- zoom state $ do --- assign gas xGas --- assign pc 0 --- assign code (view bytecode target) --- assign codeContract xTo --- assign stack mempty --- assign memory mempty --- assign memorySize 0 --- assign returndata mempty --- assign calldata (readMemory (num xInOffset) (num xInSize) vm0, literal (num xInSize)) - --- continue - --- -- * Contract creation +-- * General call implementation ("delegateCall") +delegateCall + :: (?op :: Word8) + => Contract -> Word -> Addr -> Addr -> Word -> SymWord -> SymWord -> SymWord -> SymWord -> [SymWord] + -> EVM () + -> EVM () +delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOutSize xs continue = + callChecks this gasGiven xContext xValue xInOffset xInSize xOutOffset xOutSize xs $ + \xGas -> do + vm0 <- get + fetchAccount xTo . const $ + preuse (env . contracts . ix xTo) >>= \case + Nothing -> + vmError (NoSuchContract xTo) + Just target -> + burn xGas $ do + let newContext = CallContext + { callContextOffset = xOutOffset + , callContextSize = xOutSize + , callContextCodehash = view codehash target + , callContextReversion = view (env . contracts) vm0 + , callContextSubState = view (tx . substate) vm0 + , callContextAbi = + if maybe False (<= 4) $ maybeLitWord xInSize + then do abi <- unliteral $ readMemoryWord32 xInOffset (view (state . memory) vm0) + return $ w256 $ num abi + else Nothing + , callContextData = (readMemory xInOffset xInSize vm0) + } + + pushTrace (FrameTrace newContext) + next + vm1 <- get + + pushTo frames $ Frame + { _frameState = (set stack xs) (view state vm1) + , _frameContext = newContext + } + + zoom state $ do + assign gas xGas + assign pc 0 + assign code (view bytecode target) + assign codeContract xTo + assign stack mempty + assign memory mempty + assign memorySize 0 + assign returndata mempty + assign calldata (readMemory xInOffset xInSize vm0) + + continue + +-- * Contract creation -- EIP 684 collision :: Maybe Contract -> Bool @@ -2088,7 +2084,7 @@ finishFrame how = do case view frameContext nextFrame of -- Were we calling? - CallContext (num -> outOffset) (num -> outSize) _ _ _ reversion substate' -> do + CallContext outOffset outSize _ _ _ reversion substate' -> do let revertContracts = assign (env . contracts) reversion @@ -2211,13 +2207,11 @@ copyBytesToMemory bs size xOffset yOffset = writeMemory bs size xOffset yOffset mem copyCallBytesToMemory - :: Buffer -> Word -> Word -> Word -> EVM () -copyCallBytesToMemory bs size xOffset yOffset = - if size == 0 then noop - else do - mem <- use (state . memory) - assign (state . memory) $ - writeMemory bs (sw256 $ smin (literal (num size)) (sFromIntegral (len bs))) (litWord xOffset) (litWord yOffset) mem + :: Buffer -> SymWord -> SymWord -> SymWord -> EVM () +copyCallBytesToMemory bs size xOffset yOffset = do + mem <- use (state . memory) + assign (state . memory) $ + writeMemory bs (smin size (sw256 $ sFromIntegral $ len bs)) xOffset yOffset mem readMemory :: SymWord -> SymWord -> VM -> Buffer readMemory offset size vm = sliceWithZero offset size (view (state . memory) vm) @@ -2545,47 +2539,52 @@ costOfCreate (FeeSchedule {..}) availableGas hashSize = -- Gas cost of precompiles costOfPrecompile :: FeeSchedule Word -> Addr -> Buffer -> Word -costOfPrecompile (FeeSchedule {..}) precompileAddr input = error "wait" - -- case precompileAddr of - -- -- ECRECOVER - -- 0x1 -> 3000 - -- -- SHA2-256 - -- 0x2 -> num $ (((len input + 31) `div` 32) * 12) + 60 - -- -- RIPEMD-160 - -- 0x3 -> num $ (((len input + 31) `div` 32) * 120) + 600 - -- -- IDENTITY - -- 0x4 -> num $ (((len input + 31) `div` 32) * 3) + 15 - -- -- MODEXP - -- 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) - -- where input' = case input of - -- StaticSymBuffer _ -> error "unsupported: symbolic MODEXP gas cost calc" - -- ConcreteBuffer b -> b - -- (lenb, lene, lenm) = parseModexpLength input' - -- lene' | lene <= 32 && ez = 0 - -- | lene <= 32 = num (log2 e') - -- | e' == 0 = 8 * (lene - 32) - -- | otherwise = num (log2 e') + 8 * (lene - 32) - - -- ez = isZero (96 + lenb) lene input' - -- e' = w256 $ word $ LS.toStrict $ - -- lazySlice (96 + lenb) (min 32 lene) input' - - -- f :: Integer -> Integer - -- f x | x <= 64 = x * x - -- | x <= 1024 = (x * x) `div` 4 + 96 * x - 3072 - -- | otherwise = (x * x) `div` 16 + 480 * x - 199680 - -- -- ECADD - -- 0x6 -> g_ecadd - -- -- ECMUL - -- 0x7 -> g_ecmul - -- -- ECPAIRING - -- 0x8 -> num $ ((len input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) - -- -- BLAKE2 - -- 0x9 -> let input' = case input of - -- StaticSymBuffer _ -> error "unsupported: symbolic BLAKE2B gas cost calc" - -- ConcreteBuffer b -> b - -- in g_fround * (num $ asInteger $ lazySlice 0 4 input') - -- _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) +costOfPrecompile (FeeSchedule {..}) precompileAddr input = + case precompileAddr of + -- ECRECOVER + 0x1 -> 3000 + -- SHA2-256 + 0x2 -> num $ (((l input + 31) `div` 32) * 12) + 60 + where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + -- RIPEMD-160 + 0x3 -> num $ (((l input + 31) `div` 32) * 120) + 600 + where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + -- IDENTITY + 0x4 -> num $ (((l input + 31) `div` 32) * 3) + 15 + where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + -- MODEXP + 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) + where input' = case input of + ConcreteBuffer b -> b + _ -> error "unsupported: symbolic MODEXP gas cost calc" + (lenb, lene, lenm) = parseModexpLength input' + lene' | lene <= 32 && ez = 0 + | lene <= 32 = num (log2 e') + | e' == 0 = 8 * (lene - 32) + | otherwise = num (log2 e') + 8 * (lene - 32) + + ez = isZero (96 + lenb) lene input' + e' = w256 $ word $ LS.toStrict $ + lazySlice (96 + lenb) (min 32 lene) input' + + f :: Integer -> Integer + f x | x <= 64 = x * x + | x <= 1024 = (x * x) `div` 4 + 96 * x - 3072 + | otherwise = (x * x) `div` 16 + 480 * x - 199680 + -- ECADD + 0x6 -> g_ecadd + -- ECMUL + 0x7 -> g_ecmul + -- ECPAIRING + 0x8 -> num $ ((l input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) + where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + -- BLAKE2 + 0x9 -> let input' = case input of + ConcreteBuffer b -> b + _ -> error "unsupported: symbolic BLAKE2B gas cost calc" + + in g_fround * (num $ asInteger $ lazySlice 0 4 input') + _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) -- Gas cost of memory expansion memoryCost :: FeeSchedule Word -> Word -> Word diff --git a/src/hevm/src/EVM/Fetch.hs b/src/hevm/src/EVM/Fetch.hs index 443940148..faf284185 100644 --- a/src/hevm/src/EVM/Fetch.hs +++ b/src/hevm/src/EVM/Fetch.hs @@ -152,15 +152,13 @@ oracle smtstate info model ensureConsistency q = do EVM.ConcreteS -> return $ continue x EVM.InitialS -> return $ continue $ x & set EVM.storage (EVM.Symbolic $ SBV.sListArray 0 []) - EVM.SymbolicS -> case smtstate of - Nothing -> return (continue $ x - & set EVM.storage (EVM.Symbolic $ SBV.sListArray 0 [])) - - Just state -> - flip runReaderT state $ SBV.runQueryT $ do - store <- freshArray_ Nothing - return $ continue $ x - & set EVM.storage (EVM.Symbolic store) + & set EVM.origStorage (EVM.Symbolic $ SBV.sListArray 0 []) + EVM.SymbolicS -> + flip runReaderT state $ SBV.runQueryT $ do + store <- freshArray_ Nothing + return $ continue $ x + & set EVM.storage (EVM.Symbolic store) + & set EVM.origStorage (EVM.Symbolic store) Nothing -> error ("oracle error: " ++ show q) --- for other queries (there's only slot left right now) we default to zero or http diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index 87c38ba9d..cea9fd016 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -45,20 +45,20 @@ sbytes1024 = liftA2 (++) sbytes512 sbytes512 -- We don't assume input types are restricted to their proper range here; -- such assumptions should instead be given as preconditions. -- This could catch some interesting calldata mismanagement errors. -staticAbiArg :: AbiType -> Query [SWord 8] -staticAbiArg (AbiUIntType n) +symAbiArg :: AbiType -> Query [SWord 8] +symAbiArg (AbiUIntType n) | n `mod` 8 == 0 && n <= 256 = sbytes32 | otherwise = error "bad type" -staticAbiArg (AbiIntType n) +symAbiArg (AbiIntType n) | n `mod` 8 == 0 && n <= 256 = sbytes32 | otherwise = error "bad type" -staticAbiArg AbiBoolType = sbytes32 +symAbiArg AbiBoolType = sbytes32 -staticAbiArg AbiAddressType = sbytes32 +symAbiArg AbiAddressType = sbytes32 -staticAbiArg (AbiBytesType n) +symAbiArg (AbiBytesType n) | n <= 32 = sbytes32 | otherwise = error "bad type" @@ -81,7 +81,7 @@ symAbiArg n = -- kept symbolic. staticCalldata :: Text -> [AbiType] -> [String] -> Query [SWord 8] staticCalldata sig typesignature concreteArgs = - concat <$> zipWithM mkArg typesignature args + fmap (sig' <>) $ concat <$> zipWithM mkArg typesignature args where -- ensure arg length is long enough args = concreteArgs <> replicate (length typesignature - length concreteArgs) "" diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 77a334e99..8dfbc7bd1 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -122,36 +122,41 @@ takeStatic n ls = let (x, xs) = SL.uncons ls in x:(takeStatic (n - 1) xs) --- must only be called when list length is concrete -dropStatic :: (SymVal a) => Int -> SList a -> [SBV a] -dropStatic n ls = +-- tries to create a static list whenever possible +dropS :: SymWord -> SList (WordN 8) -> Buffer +dropS n@(S _ i) ls = if isConcretelyEmpty ls - then [] - else case unliteral $ SL.length ls of - Nothing -> error "dropStatic must know the length of the list" - Just l -> if l == 0 then [] else + then mempty + else case (maybeLitWord n, unliteral $ SL.length ls) of + (Just n', Just l) -> if n == 0 - then takeStatic (num l) ls + then StaticSymBuffer $ takeStatic (num l) ls else let (_, xs) = SL.uncons ls - in (dropStatic (n - 1) xs) + in dropS (litWord $ n' - 1) xs + _ -> DynamicSymBuffer $ SL.drop (sFromIntegral i) ls -- special case of sliceWithZero when size is known -truncpad' :: Int -> SList (WordN 8) -> Buffer -truncpad' n xs = case unliteral $ SL.length xs of - Just (num -> l) -> StaticSymBuffer $ if l > n - then takeStatic n xs - else takeStatic n (xs .++ literal (replicate (n - l) 0)) +truncpad' :: Int -> Buffer -> Buffer +truncpad' n m = case m of + ConcreteBuffer xs -> ConcreteBuffer $ Concrete.byteStringSliceWithDefaultZeroes 0 n xs + StaticSymBuffer xs -> StaticSymBuffer $ truncpad n xs + DynamicSymBuffer xs -> + case unliteral $ SL.length xs of - Nothing -> DynamicSymBuffer $ ite - (SL.length xs .> literal (num n)) - (SL.take (literal (num n)) xs) - (SL.take (literal (num n)) (xs .++ literal (replicate n 0))) + Just (num -> l) -> StaticSymBuffer $ + + if l > n + then takeStatic n xs + else takeStatic n (xs .++ literal (replicate (n - l) 0)) + + Nothing -> grab n (DynamicSymBuffer $ xs .++ literal (replicate n 0)) swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs swordAt' :: SWord 32 -> SList (WordN 8) -> SymWord -swordAt' i bs = case truncpad' 32 $ SL.drop (sFromIntegral i) bs of +swordAt' i bs = case truncpad' 32 $ dropS (sw256 $ sFromIntegral i) bs of + ConcreteBuffer s -> litWord $ Concrete.w256 $ Concrete.wordAt 0 s StaticSymBuffer s -> sw256 $ fromBytes s DynamicSymBuffer s -> sw256 $ fromBytes [s .!! literal i | i <- [0..31]] @@ -270,17 +275,25 @@ len (ConcreteBuffer bs) = literal . num $ BS.length bs grab :: Int -> Buffer -> Buffer grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs -grab n (DynamicSymBuffer bs) = DynamicSymBuffer $ SL.take (literal $ num n) bs +grab n (DynamicSymBuffer bs) = + case unliteral $ SL.length bs of + Nothing -> DynamicSymBuffer $ SL.take (literal $ num n) bs + _ -> StaticSymBuffer $ takeStatic n bs ditch :: Int -> Buffer -> Buffer ditch n (StaticSymBuffer bs) = StaticSymBuffer $ drop n bs ditch n (ConcreteBuffer bs) = ConcreteBuffer $ BS.drop n bs -ditch n (DynamicSymBuffer bs) = DynamicSymBuffer $ SL.drop (literal $ num n) bs +ditch n (DynamicSymBuffer bs) = dropS (litWord $ num n) bs ditchS :: SInteger -> Buffer -> Buffer ditchS n bs = case unliteral n of - Nothing -> DynamicSymBuffer $ SL.drop n (dynamize bs) - Just n -> ditch (num n) bs + Nothing -> dropS (sw256 $ sFromIntegral n) (dynamize bs) + Just n' -> ditch (num n') bs + +grabS :: SInteger -> Buffer -> Buffer +grabS n bs = case unliteral n of + Nothing -> DynamicSymBuffer $ SL.take n (dynamize bs) + Just n' -> grab (num n') bs readByteOrZero :: Int -> Buffer -> SWord 8 readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs @@ -314,15 +327,21 @@ readMemoryWord i bf = case (unliteral i, bf) of (Just i', ConcreteBuffer m) -> litWord $ Concrete.readMemoryWord (num i') m _ -> swordAt' i (dynamize bf) -readMemoryWord32 :: Word -> Buffer -> SWord 32 -readMemoryWord32 i (StaticSymBuffer m) = readMemoryWord32' i m -readMemoryWord32 i (ConcreteBuffer m) = num $ Concrete.readMemoryWord32 i m +readMemoryWord32 :: SymWord -> Buffer -> SWord 32 +readMemoryWord32 i m = case (maybeLitWord i, m) of + (Just i', StaticSymBuffer m') -> readMemoryWord32' i' m' + (Just i', ConcreteBuffer m') -> num $ Concrete.readMemoryWord32 i' m' + (_, DynamicSymBuffer m') -> case truncpad' 4 $ dropS i m' of + ConcreteBuffer s -> literal $ num $ Concrete.readMemoryWord32 0 s + StaticSymBuffer s -> readMemoryWord32' 0 s + DynamicSymBuffer s -> fromBytes [s .!! literal k | k <- [0..3]] + setMemoryWord :: SWord 32 -> SymWord -> Buffer -> Buffer setMemoryWord i x bf = case (unliteral i, maybeLitWord x, bf) of - (Just i', Just x', ConcreteBuffer z) -> ConcreteBuffer $ Concrete.setMemoryWord (num i') x' z - (Just i', _, ConcreteBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x (litBytes z) - (Just i', _, StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x z + (Just i', Just x', ConcreteBuffer z) -> ConcreteBuffer $ Concrete.setMemoryWord (num i') x' z + (Just i', _ , ConcreteBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x (litBytes z) + (Just i', _ , StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x z _ -> setMemoryWord'' i x bf setMemoryByte :: SymWord -> SWord 8 -> Buffer -> Buffer diff --git a/src/hevm/src/EVM/VMTest.hs b/src/hevm/src/EVM/VMTest.hs index cb0e20db9..b31d4a10d 100644 --- a/src/hevm/src/EVM/VMTest.hs +++ b/src/hevm/src/EVM/VMTest.hs @@ -185,7 +185,7 @@ checkExpectedContracts vm expected = ) clearOrigStorage :: EVM.Contract -> EVM.Contract -clearOrigStorage = set EVM.origStorage mempty +clearOrigStorage = set EVM.origStorage (EVM.Concrete mempty) clearZeroStorage :: EVM.Contract -> EVM.Contract clearZeroStorage c = case EVM._storage c of @@ -325,16 +325,12 @@ realizeContract x = EVM.initialContract (x ^. code) & EVM.balance .~ EVM.w256 (x ^. balance) & EVM.nonce .~ EVM.w256 (x ^. nonce) - & EVM.storage .~ EVM.Concrete ( - Map.fromList . - map (bimap EVM.w256 (litWord . EVM.w256)) . - Map.toList $ x ^. storage - ) - & EVM.origStorage .~ ( - Map.fromList . - map (bimap EVM.w256 EVM.w256) . - Map.toList $ x ^. storage - ) + & EVM.storage .~ store + & EVM.origStorage .~ store + where store = EVM.Concrete $ + Map.fromList . + map (bimap EVM.w256 (litWord . EVM.w256)) . + Map.toList $ x ^. storage data BlockchainError = TooManyBlocks diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 5419eea99..3b2794563 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -173,58 +173,41 @@ main = defaultMain $ testGroup "hevm" getList (StaticSymBuffer bf) = mapM getValue bf getList (DynamicSymBuffer bf) = getValue bf - , testProperty "dynWriteMemory works like writeMemory" $ --- withMaxSuccess 10000 $ - forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> - let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args - in ioProperty $ runSMTWith z3 $ query $ do - cd <- sbytes32 - mem <- sbytes32 - - let - src = w256 $ W256 src' - dst = w256 $ W256 dst' - len = w256 $ W256 len' - - staticWriting = writeMemory' cd src len dst mem - dynamicWriting = - dynWriteMemory - (DynamicSymBuffer (implode cd)) - (litWord src) - (litWord len) - (litWord dst) - (DynamicSymBuffer (implode mem)) - - when ((length staticWriting) < 10000 && len' < 10000) $ - checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case - Unsat -> io $ putStrLn "Success!" - Sat -> do getList dynamicWriting >>= io . print - getList (StaticSymBuffer staticWriting) >>= io . print - error "oh no!" - where getList :: Buffer -> Query [WordN 8] - getList (StaticSymBuffer bf) = mapM getValue bf - getList (DynamicSymBuffer bf) = getValue bf - - - -- , testCase "dynWriteMemory pads with zeros appropriately" $ - -- ioProperty $ runSMT $ query $ do - -- cd <- sbytes128 - -- mem <- sbytes128 - -- let src = w256 $ W256 src' - -- dst = w256 $ W256 dst' - -- offset = w256 $ W256 offset' - -- staticWriting = writeMemory' cd src offset dst mem - -- dynamicWriting = - -- dynWriteMemory - -- (implode cd) - -- (litWord src) - -- (litWord offset) - -- (litWord dst) - -- (implode mem) - -- checkSatAssuming [implode staticWriting ./= dynamicWriting] >>= \case - -- Unsat -> return () - -- _ -> error "fail!" - +-- , testProperty "dynWriteMemory works like writeMemory" $ +-- -- withMaxSuccess 10000 $ +-- forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> +-- let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args +-- in ioProperty $ runSMTWith z3 $ do +-- setTimeOut 5000 +-- query $ do +-- cd <- sbytes32 +-- mem <- sbytes32 + +-- let +-- src = w256 $ W256 src' +-- dst = w256 $ W256 dst' +-- len = w256 $ W256 len' + +-- staticWriting = writeMemory' cd src len dst mem +-- dynamicWriting = +-- dynWriteMemory +-- (DynamicSymBuffer (implode cd)) +-- (litWord src) +-- (litWord len) +-- (litWord dst) +-- (DynamicSymBuffer (implode mem)) + +-- when ((length staticWriting) < 10000 && len' < 10000) $ +-- checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case +-- Unk -> io $ putStrLn "timeout" +-- Unsat -> io $ putStrLn "Success!" +-- Sat -> do getList dynamicWriting >>= io . print +-- getList (StaticSymBuffer staticWriting) >>= io . print +-- error "oh no!" +-- where getList :: Buffer -> Query [WordN 8] +-- getList (StaticSymBuffer bf) = mapM getValue bf +-- getList (DynamicSymBuffer bf) = getValue bf + ] , testGroup "Symbolic execution" @@ -246,7 +229,7 @@ main = defaultMain $ testGroup "hevm" post = Just $ \(prestate, poststate) -> let [x, y] = getStaticAbiArgs prestate in case view result poststate of - Just (VMSuccess (SymbolicBuffer out)) -> (fromBytes out) .== x + y + Just (VMSuccess (StaticSymBuffer out)) -> (fromBytes out) .== x + y _ -> sFalse Left (_, res) <- runSMT $ query $ verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre post putStrLn $ "successfully explored: " <> show (length res) <> " paths" @@ -268,7 +251,7 @@ main = defaultMain $ testGroup "hevm" post (prestate, poststate) = let [_, y] = getStaticAbiArgs prestate in case view result poststate of - Just (VMSuccess (SymbolicBuffer out)) -> fromBytes out .== 2 * y + Just (VMSuccess (StaticSymBuffer out)) -> fromBytes out .== 2 * y _ -> sFalse Left (_, res) <- runSMTWith z3 $ query $ verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) @@ -287,8 +270,8 @@ main = defaultMain $ testGroup "hevm" bs <- runSMTWith cvc4 $ query $ do Right vm <- checkAssert factor (Just ("factor(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] case view (state . calldata . _1) vm of - SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer _ -> error "unexpected" + StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + _ -> error "unexpected" let [AbiUInt 256 x, AbiUInt 256 y] = decodeAbiValues [AbiUIntType 256, AbiUIntType 256] bs assertEqual "" True (x == 953 && y == 1021 || x == 1021 && y == 953) @@ -352,8 +335,8 @@ main = defaultMain $ testGroup "hevm" bs <- runSMT $ query $ do Right vm <- verifyContract c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) case view (state . calldata . _1) vm of - SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer bs -> error "unexpected" + StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + _ -> error "unexpected" let [AbiUInt 256 x, AbiUInt 256 y] = decodeAbiValues [AbiUIntType 256, AbiUIntType 256] bs assertEqual "Catch storage collisions" x y @@ -424,8 +407,8 @@ main = defaultMain $ testGroup "hevm" bs <- runSMT $ query $ do Right vm <- checkAssert c (Just ("deposit(uint8)", [AbiUIntType 8])) [] case view (state . calldata . _1) vm of - SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer _ -> error "unexpected" + StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + _ -> error "unexpected" let [deposit] = decodeAbiValues [AbiUIntType 8] bs assertEqual "overflowing uint8" deposit (AbiUInt 8 255) @@ -482,8 +465,8 @@ main = defaultMain $ testGroup "hevm" bs <- runSMTWith z3 $ query $ do Right vm <- checkAssert c (Just ("f(uint256,uint256,uint256,uint256)", replicate 4 (AbiUIntType 256))) [] case view (state . calldata . _1) vm of - SymbolicBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs - ConcreteBuffer _ -> error "unexpected" + StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + _ -> error "unexpected" let [AbiUInt 256 x, AbiUInt 256 y, @@ -510,9 +493,7 @@ main = defaultMain $ testGroup "hevm" } } |] - Left (_, res) <- runSMTWith z3 $ do - setTimeOut 5000 - query $ checkAssert c Nothing [] + Left (_, res) <- runSMTWith z3 $ query $ checkAssert c Nothing [] putStrLn $ "successfully explored: " <> show (length res) <> " paths" , From d84f4cf9fe958429133249332bb05dd1b54add86 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Thu, 27 Aug 2020 17:42:17 +0200 Subject: [PATCH 11/36] all tests passing, things seem pretty good --- src/hevm/src/EVM.hs | 4 +- src/hevm/src/EVM/Symbolic.hs | 37 +++++------------- src/hevm/test/test.hs | 73 ++++++++++++++++++------------------ 3 files changed, 49 insertions(+), 65 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 5cc07213a..f00a19060 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -466,7 +466,9 @@ initialContract theContractCode = Contract contractWithStore :: ContractCode -> Storage -> Contract contractWithStore theContractCode store = - initialContract theContractCode & set storage store + initialContract theContractCode + & set storage store + & set origStorage store -- * Opcode dispatch (exec1) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 8dfbc7bd1..5826a5afc 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -110,17 +110,12 @@ isConcretelyEmpty :: SymVal a => SList a -> Bool isConcretelyEmpty sl | Just l <- unliteral sl = null l | True = False --- must only be called when list length is concrete +-- WARNING: only works when (n <= list length) takeStatic :: (SymVal a) => Int -> SList a -> [SBV a] takeStatic 0 ls = [] takeStatic n ls = - if isConcretelyEmpty ls - then [] - else case unliteral $ SL.length ls of - Nothing -> error "takeStatic must know the length of the list" - Just l -> if l == 0 then [] else - let (x, xs) = SL.uncons ls - in x:(takeStatic (n - 1) xs) + let (x, xs) = SL.uncons ls + in x:(takeStatic (n - 1) xs) -- tries to create a static list whenever possible dropS :: SymWord -> SList (WordN 8) -> Buffer @@ -129,8 +124,8 @@ dropS n@(S _ i) ls = then mempty else case (maybeLitWord n, unliteral $ SL.length ls) of (Just n', Just l) -> - if n == 0 - then StaticSymBuffer $ takeStatic (num l) ls + if n' == 0 + then StaticSymBuffer $ takeStatic (num $ max n' (num l)) ls else let (_, xs) = SL.uncons ls in dropS (litWord $ n' - 1) xs _ -> DynamicSymBuffer $ SL.drop (sFromIntegral i) ls @@ -145,11 +140,11 @@ truncpad' n m = case m of Just (num -> l) -> StaticSymBuffer $ - if l > n + if n <= l then takeStatic n xs else takeStatic n (xs .++ literal (replicate (n - l) 0)) - Nothing -> grab n (DynamicSymBuffer $ xs .++ literal (replicate n 0)) + Nothing -> StaticSymBuffer $ takeStatic n (xs .++ literal (replicate n 0)) swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs @@ -242,24 +237,10 @@ dynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = in a <> b <> c --- TODO: ensure we actually pad with zeros -sliceWithZero'' :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) -sliceWithZero'' (S _ o) (S _ s) m = SL.subList m (sFromIntegral s) (sFromIntegral o) - --- readMemoryWord' :: Word -> [SWord 8] -> SymWord --- readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) - --- readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 --- readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) - setMemoryWord'' :: SWord 32 -> SymWord -> Buffer -> Buffer setMemoryWord'' i (S _ x) = dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 (sw256 (sFromIntegral i)) --- setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] --- setMemoryByte' (C _ i) x = --- writeMemory' [x] 1 0 (num i) - readSWord'' :: SymWord -> SList (WordN 8) -> SymWord readSWord'' (S _ i) x = ite (sFromIntegral i .> SL.length x) @@ -278,7 +259,7 @@ grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs grab n (DynamicSymBuffer bs) = case unliteral $ SL.length bs of Nothing -> DynamicSymBuffer $ SL.take (literal $ num n) bs - _ -> StaticSymBuffer $ takeStatic n bs + Just l' -> StaticSymBuffer $ takeStatic (num $ max n (num l')) bs ditch :: Int -> Buffer -> Buffer ditch n (StaticSymBuffer bs) = StaticSymBuffer $ drop n bs @@ -305,7 +286,7 @@ sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer sliceWithZero (S _ o) (S _ s) bf = case (unliteral o, unliteral s, bf) of (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) - (Just o', Just s', m) -> DynamicSymBuffer $ SL.subList (dynamize m .++ literal (replicate (num (s' + o')) 0)) (sFromIntegral o) (sFromIntegral s) + (Just o', Just s', m) -> truncpad' (num s') (ditch (num o') m) _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 10000 0)) (sFromIntegral o) (sFromIntegral s) writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 3b2794563..d83bad93a 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -155,14 +155,14 @@ main = defaultMain $ testGroup "hevm" mem <- sbytes32 let - staticWriting = writeMemory' cd 18 111 63 mempty + staticWriting = writeMemory' cd 18 111 63 mem --mempty dynamicWriting = dynWriteMemory (DynamicSymBuffer (implode cd)) (litWord 18) (litWord 111) (litWord 63) - mempty + (DynamicSymBuffer (implode mem)) io $ print dynamicWriting io (putStrLn "solving") >> checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case Unsat -> return () @@ -173,40 +173,41 @@ main = defaultMain $ testGroup "hevm" getList (StaticSymBuffer bf) = mapM getValue bf getList (DynamicSymBuffer bf) = getValue bf --- , testProperty "dynWriteMemory works like writeMemory" $ --- -- withMaxSuccess 10000 $ --- forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> --- let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args --- in ioProperty $ runSMTWith z3 $ do --- setTimeOut 5000 --- query $ do --- cd <- sbytes32 --- mem <- sbytes32 - --- let --- src = w256 $ W256 src' --- dst = w256 $ W256 dst' --- len = w256 $ W256 len' - --- staticWriting = writeMemory' cd src len dst mem --- dynamicWriting = --- dynWriteMemory --- (DynamicSymBuffer (implode cd)) --- (litWord src) --- (litWord len) --- (litWord dst) --- (DynamicSymBuffer (implode mem)) - --- when ((length staticWriting) < 10000 && len' < 10000) $ --- checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case --- Unk -> io $ putStrLn "timeout" --- Unsat -> io $ putStrLn "Success!" --- Sat -> do getList dynamicWriting >>= io . print --- getList (StaticSymBuffer staticWriting) >>= io . print --- error "oh no!" --- where getList :: Buffer -> Query [WordN 8] --- getList (StaticSymBuffer bf) = mapM getValue bf --- getList (DynamicSymBuffer bf) = getValue bf + , testProperty "dynWriteMemory works like writeMemory" $ +-- withMaxSuccess 10000 $ + forAll (genAbiValue (AbiTupleType $ Vector.fromList [AbiUIntType 16, AbiUIntType 16, AbiUIntType 16])) $ \(AbiTuple args) -> + let [AbiUInt 16 src', AbiUInt 16 dst', AbiUInt 16 len'] = Vector.toList args + in ioProperty $ when (len' < 1000) $ runSMTWith z3 $ do + setTimeOut 5000 + query $ do + cd <- sbytes32 + mem <- sbytes32 + + let + src = w256 $ W256 src' + dst = w256 $ W256 dst' + len = w256 $ W256 len' + + staticWriting = writeMemory' cd src len dst mem + dynamicWriting = + dynWriteMemory + (DynamicSymBuffer (implode cd)) + (litWord src) + (litWord len) + (litWord dst) + (DynamicSymBuffer (implode mem)) + + when (length staticWriting < 1000) $ do + io $ putStrLn "solving..." + checkSatAssuming [StaticSymBuffer staticWriting ./= dynamicWriting] >>= \case + Unk -> io $ putStrLn "timeout" + Unsat -> io $ putStrLn "Success!" + Sat -> do getList dynamicWriting >>= io . print + getList (StaticSymBuffer staticWriting) >>= io . print + error "oh no!" + where getList :: Buffer -> Query [WordN 8] + getList (StaticSymBuffer bf) = mapM getValue bf + getList (DynamicSymBuffer bf) = getValue bf ] From 6c3784442a5a211b2e30820a757b41f06038ed86 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Thu, 27 Aug 2020 18:50:03 +0200 Subject: [PATCH 12/36] tests passing --- src/hevm/src/EVM/SymExec.hs | 6 +++--- src/hevm/src/EVM/Symbolic.hs | 11 +++++++---- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index cea9fd016..61eb5b75b 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -95,8 +95,8 @@ staticCalldata sig typesignature concreteArgs = abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel -> Query VM abstractVM typesignature concreteArgs x storagemodel = do cd' <- case typesignature of - Nothing -> sbytes256 - Just (name, typs) -> staticCalldata name typs concreteArgs + Nothing -> DynamicSymBuffer <$> freshVar_ + Just (name, typs) -> StaticSymBuffer <$> staticCalldata name typs concreteArgs symstore <- case storagemodel of SymbolicS -> Symbolic <$> freshArray_ Nothing @@ -104,7 +104,7 @@ abstractVM typesignature concreteArgs x storagemodel = do ConcreteS -> return $ Concrete mempty c <- SAddr <$> freshVar_ value' <- sw256 <$> freshVar_ - return $ loadSymVM (RuntimeCode x) symstore storagemodel c value' (StaticSymBuffer cd') + return $ loadSymVM (RuntimeCode x) symstore storagemodel c value' cd' loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> Buffer -> VM loadSymVM x initStore model addr callvalue' calldata' = diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 5826a5afc..a5dcba16a 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -150,10 +150,13 @@ swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs swordAt' :: SWord 32 -> SList (WordN 8) -> SymWord -swordAt' i bs = case truncpad' 32 $ dropS (sw256 $ sFromIntegral i) bs of - ConcreteBuffer s -> litWord $ Concrete.w256 $ Concrete.wordAt 0 s - StaticSymBuffer s -> sw256 $ fromBytes s - DynamicSymBuffer s -> sw256 $ fromBytes [s .!! literal i | i <- [0..31]] +swordAt' i bs = + ite (SL.length bs .<= sFromIntegral i) + (sw256 0) + (case truncpad' 32 $ dropS (sw256 $ sFromIntegral i) bs of + ConcreteBuffer s -> litWord $ Concrete.w256 $ Concrete.wordAt 0 s + StaticSymBuffer s -> sw256 $ fromBytes s + DynamicSymBuffer s -> sw256 $ fromBytes [s .!! literal i | i <- [0..31]]) readByteOrZero' :: Int -> [SWord 8] -> SWord 8 readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) From 0bd6a32973fd78312913bd13af2fcbd6c4763b02 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Thu, 27 Aug 2020 20:00:59 +0200 Subject: [PATCH 13/36] bump origstorage --- src/hevm/hevm-cli/hevm-cli.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/hevm/hevm-cli/hevm-cli.hs b/src/hevm/hevm-cli/hevm-cli.hs index 4e3234173..a923a421f 100644 --- a/src/hevm/hevm-cli/hevm-cli.hs +++ b/src/hevm/hevm-cli/hevm-cli.hs @@ -746,7 +746,10 @@ symvmFromCommand cmd = do error $ "contract not found." Just contract' -> return $ - vm1 calldata' callvalue' caller' (contract'' & set EVM.storage store) + vm1 calldata' callvalue' caller' + (contract'' + & set EVM.storage store + & set EVM.origStorage store) where contract'' = case code cmd of Nothing -> contract' @@ -762,7 +765,9 @@ symvmFromCommand cmd = do (_, _, Just c) -> return $ vm1 calldata' callvalue' caller' $ - (EVM.initialContract . codeType $ decipher c) & set EVM.storage store + (EVM.initialContract . codeType $ decipher c) + & set EVM.storage store + & set EVM.origStorage store (_, _, Nothing) -> error $ "must provide at least (rpc + address) or code" From 3f8ed9c659674388fb6d8522c0ffec841c8ac892 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Mon, 31 Aug 2020 19:10:33 +0200 Subject: [PATCH 14/36] generalize EXP to admit symbolic args --- src/hevm/src/EVM.hs | 55 ++++++++++++++++++++++------------------- src/hevm/src/EVM/TTY.hs | 1 + 2 files changed, 30 insertions(+), 26 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index f00a19060..58d3232bc 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -586,63 +586,63 @@ exec1 = do 0x00 -> doStop -- op: ADD - 0x01 -> stackOp2 (const g_verylow) (uncurry (+)) + 0x01 -> stackOp2 (const (litWord g_verylow)) (uncurry (+)) -- op: MUL - 0x02 -> stackOp2 (const g_low) (uncurry (*)) + 0x02 -> stackOp2 (const (litWord g_low)) (uncurry (*)) -- op: SUB - 0x03 -> stackOp2 (const g_verylow) (uncurry (-)) + 0x03 -> stackOp2 (const (litWord g_verylow)) (uncurry (-)) -- op: DIV - 0x04 -> stackOp2 (const g_low) (uncurry (sDiv)) + 0x04 -> stackOp2 (const (litWord g_low)) (uncurry (sDiv)) -- op: SDIV 0x05 -> - stackOp2 (const g_low) (uncurry sdiv) + stackOp2 (const (litWord g_low)) (uncurry sdiv) -- op: MOD - 0x06 -> stackOp2 (const g_low) $ \(x, y) -> ite (y .== 0) 0 (x `sMod` y) + 0x06 -> stackOp2 (const (litWord g_low)) $ \(x, y) -> ite (y .== 0) 0 (x `sMod` y) -- op: SMOD - 0x07 -> stackOp2 (const g_low) $ uncurry smod + 0x07 -> stackOp2 (const (litWord g_low)) $ uncurry smod -- op: ADDMOD 0x08 -> stackOp3 (const g_mid) (\(x, y, z) -> addmod x y z) -- op: MULMOD 0x09 -> stackOp3 (const g_mid) (\(x, y, z) -> mulmod x y z) -- op: LT - 0x10 -> stackOp2 (const g_verylow) $ \(x, y) -> ite (x .< y) 1 0 + 0x10 -> stackOp2 (const (litWord g_verylow)) $ \(x, y) -> ite (x .< y) 1 0 -- op: GT - 0x11 -> stackOp2 (const g_verylow) $ \(x, y) -> ite (x .> y) 1 0 + 0x11 -> stackOp2 (const (litWord g_verylow)) $ \(x, y) -> ite (x .> y) 1 0 -- op: SLT - 0x12 -> stackOp2 (const g_verylow) $ uncurry slt + 0x12 -> stackOp2 (const (litWord g_verylow)) $ uncurry slt -- op: SGT - 0x13 -> stackOp2 (const g_verylow) $ uncurry sgt + 0x13 -> stackOp2 (const (litWord g_verylow)) $ uncurry sgt -- op: EQ - 0x14 -> stackOp2 (const g_verylow) $ \(x, y) -> ite (x .== y) 1 0 + 0x14 -> stackOp2 (const (litWord g_verylow)) $ \(x, y) -> ite (x .== y) 1 0 -- op: ISZERO 0x15 -> stackOp1 (const g_verylow) $ \x -> ite (x .== 0) 1 0 -- op: AND - 0x16 -> stackOp2 (const g_verylow) $ uncurry (.&.) + 0x16 -> stackOp2 (const (litWord g_verylow)) $ uncurry (.&.) -- op: OR - 0x17 -> stackOp2 (const g_verylow) $ uncurry (.|.) + 0x17 -> stackOp2 (const (litWord g_verylow)) $ uncurry (.|.) -- op: XOR - 0x18 -> stackOp2 (const g_verylow) $ uncurry xor + 0x18 -> stackOp2 (const (litWord g_verylow)) $ uncurry xor -- op: NOT 0x19 -> stackOp1 (const g_verylow) complement -- op: BYTE - 0x1a -> stackOp2 (const g_verylow) $ \case + 0x1a -> stackOp2 (const (litWord g_verylow)) $ \case (n, _) | (forceLit n) >= 32 -> 0 (n, x) | otherwise -> 0xff .&. shiftR x (8 * (31 - num (forceLit n))) -- op: SHL - 0x1b -> stackOp2 (const g_verylow) $ \((S _ n), (S _ x)) -> sw256 $ sShiftLeft x n + 0x1b -> stackOp2 (const (litWord g_verylow)) $ \((S _ n), (S _ x)) -> sw256 $ sShiftLeft x n -- op: SHR - 0x1c -> stackOp2 (const g_verylow) $ uncurry shiftRight' + 0x1c -> stackOp2 (const (litWord g_verylow)) $ uncurry shiftRight' -- op: SAR - 0x1d -> stackOp2 (const g_verylow) $ \((S _ n), (S _ x)) -> sw256 $ sSignedShiftArithRight x n + 0x1d -> stackOp2 (const (litWord g_verylow)) $ \((S _ n), (S _ x)) -> sw256 $ sSignedShiftArithRight x n -- op: SHA3 -- more accurately refered to as KECCAK @@ -1005,15 +1005,15 @@ exec1 = do -- op: EXP 0x0a -> - let cost (_ ,(forceLit -> exponent)) = - if exponent == 0 - then g_exp - else g_exp + g_expbyte * num (ceilDiv (1 + log2 exponent) 8) + let cost (_ ,exponent) = + ite (exponent .== 0) + (litWord g_exp) + (litWord g_exp + litWord g_expbyte * (ceilSDiv (litWord 1 + sw256 (sFromIntegral $ log2S exponent)) (litWord 8))) in stackOp2 cost $ \((S _ x),(S _ y)) -> sw256 $ x .^ y -- op: SIGNEXTEND 0x0b -> - stackOp2 (const g_low) $ \((forceLit -> bytes), w@(S _ x)) -> + stackOp2 (const (litWord g_low)) $ \((forceLit -> bytes), w@(S _ x)) -> if bytes >= 32 then w else let n = num bytes * 8 + 7 in sw256 $ ite (sTestBit x n) @@ -2301,13 +2301,13 @@ stackOp1 cost f = stackOp2 :: (?op :: Word8) - => (((SymWord), (SymWord)) -> Word) + => (((SymWord), (SymWord)) -> SymWord) -> (((SymWord), (SymWord)) -> (SymWord)) -> EVM () stackOp2 cost f = use (state . stack) >>= \case (x:y:xs) -> - burn (cost (x, y)) $ do + burnSym (cost (x, y)) $ do next state . stack .= f (x, y) : xs _ -> @@ -2638,6 +2638,9 @@ allButOne64th n = n - div n 64 log2 :: FiniteBits b => b -> Int log2 x = finiteBitSize x - 1 - countLeadingZeros x +log2S :: SymWord -> SWord8 +log2S (S _ x) = 255 - sCountLeadingZeros x + -- * Emacs setup diff --git a/src/hevm/src/EVM/TTY.hs b/src/hevm/src/EVM/TTY.hs index 6116fb6b7..0fbf76aa9 100644 --- a/src/hevm/src/EVM/TTY.hs +++ b/src/hevm/src/EVM/TTY.hs @@ -865,6 +865,7 @@ withHighlight True = withDefAttr boldAttr prettyIfConcrete :: Buffer -> String prettyIfConcrete (StaticSymBuffer x) = show x +prettyIfConcrete (DynamicSymBuffer x) = show x prettyIfConcrete (ConcreteBuffer x) = prettyHex 40 x drawTracePane :: UiVmState -> UiWidget From 86a771f17068bb308c37c2101cf9147b869ec2c5 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 1 Sep 2020 16:51:55 +0200 Subject: [PATCH 15/36] clean up of test.hs, refactor EVM.Fetch.oracle --- src/hevm/src/EVM/Fetch.hs | 17 +++++++++++------ src/hevm/src/EVM/SymExec.hs | 3 ++- src/hevm/test/test.hs | 2 +- 3 files changed, 14 insertions(+), 8 deletions(-) diff --git a/src/hevm/src/EVM/Fetch.hs b/src/hevm/src/EVM/Fetch.hs index faf284185..33c8788a9 100644 --- a/src/hevm/src/EVM/Fetch.hs +++ b/src/hevm/src/EVM/Fetch.hs @@ -153,12 +153,17 @@ oracle smtstate info model ensureConsistency q = do EVM.InitialS -> return $ continue $ x & set EVM.storage (EVM.Symbolic $ SBV.sListArray 0 []) & set EVM.origStorage (EVM.Symbolic $ SBV.sListArray 0 []) - EVM.SymbolicS -> - flip runReaderT state $ SBV.runQueryT $ do - store <- freshArray_ Nothing - return $ continue $ x - & set EVM.storage (EVM.Symbolic store) - & set EVM.origStorage (EVM.Symbolic store) + EVM.SymbolicS -> case smtstate of + Nothing -> return (continue $ x + & set EVM.storage (EVM.Symbolic $ SBV.sListArray 0 []) + & set EVM.origStorage (EVM.Symbolic $ SBV.sListArray 0 [])) + + Just state -> + flip runReaderT state $ SBV.runQueryT $ do + store <- freshArray_ Nothing + return $ continue $ x + & set EVM.storage (EVM.Symbolic store) + & set EVM.origStorage (EVM.Symbolic store) Nothing -> error ("oracle error: " ++ show q) --- for other queries (there's only slot left right now) we default to zero or http diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index 61eb5b75b..50f9f0583 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -302,7 +302,8 @@ equivalenceCheck bytecodeA bytecodeB maxiter signature' = do constrain $ sOr differingEndStates checkSat >>= \case - Unk -> error "solver said unknown!" + Unk -> do io $ putStrLn "postcondition query timed out" + return $ Left (pruneDeadPaths aVMs, pruneDeadPaths bVMs) Sat -> return $ Right preStateA Unsat -> return $ Left (pruneDeadPaths aVMs, pruneDeadPaths bVMs) diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index d83bad93a..59d19f047 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -155,7 +155,7 @@ main = defaultMain $ testGroup "hevm" mem <- sbytes32 let - staticWriting = writeMemory' cd 18 111 63 mem --mempty + staticWriting = writeMemory' cd 18 111 63 mem dynamicWriting = dynWriteMemory (DynamicSymBuffer (implode cd)) From d5b070f36ed6b197b83f0ff5d531b3e05fd61dbb Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 2 Sep 2020 18:26:01 +0200 Subject: [PATCH 16/36] fix --- src/hevm/hevm-cli/hevm-cli.hs | 16 +++++++++------- src/hevm/src/EVM.hs | 8 ++++---- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/hevm/hevm-cli/hevm-cli.hs b/src/hevm/hevm-cli/hevm-cli.hs index a923a421f..26dc8faec 100644 --- a/src/hevm/hevm-cli/hevm-cli.hs +++ b/src/hevm/hevm-cli/hevm-cli.hs @@ -57,6 +57,7 @@ import Data.Text.IO (hPutStr) import Data.Maybe (fromMaybe, fromJust) import Data.Version (showVersion) import Data.SBV hiding (Word, solver, verbose, name) +import qualified Data.SBV as SBV import Data.SBV.Control hiding (Version, timeout, create) import System.IO (hFlush, hPrint, stdout, stderr) import System.Directory (withCurrentDirectory, listDirectory) @@ -119,6 +120,7 @@ data Command w , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 20000)" , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" + , smtoutput :: w ::: Bool "Print verbose smt output" } | Equivalence -- prove equivalence between two programs { codeA :: w ::: ByteString "Bytecode of the first program" @@ -387,7 +389,7 @@ equivalence cmd = Just sig' -> do method' <- functionAbi sig' return $ Just (view methodSignature method', snd <$> view methodInputs method') - void . runSMTWithTimeOut (solver cmd) (smttimeout cmd) . query $ + void . runSMTWithTimeOut (solver cmd) (smttimeout cmd) (smtoutput cmd) . query $ equivalenceCheck bytecodeA bytecodeB (maxIterations cmd) maybeSignature >>= \case Right vm -> do io $ putStrLn "Not equal!" io $ putStrLn "Counterexample:" @@ -401,18 +403,18 @@ equivalence cmd = -- cvc4 sets timeout via a commandline option instead of smtlib `(set-option)` -runSMTWithTimeOut :: Maybe Text -> Maybe Integer -> Symbolic a -> IO a -runSMTWithTimeOut solver maybeTimeout sym +runSMTWithTimeOut :: Maybe Text -> Maybe Integer -> Bool -> Symbolic a -> IO a +runSMTWithTimeOut solver maybeTimeout verbose' sym | solver == Just "cvc4" = do setEnv "SBV_CVC4_OPTIONS" ("--lang=smt --incremental --interactive --no-interactive-prompt --model-witness-value --tlimit-per=" <> show timeout) - a <- runSMTWith cvc4 sym + a <- runSMTWith cvc4{SBV.verbose=verbose'} sym setEnv "SBV_CVC4_OPTIONS" "" return a | solver == Just "z3" = runwithz3 | solver == Nothing = runwithz3 | otherwise = error "Unknown solver. Currently supported solvers; z3, cvc4" where timeout = fromMaybe 20000 maybeTimeout - runwithz3 = runSMTWith z3 $ (setTimeOut timeout) >> sym + runwithz3 = runSMTWith z3{SBV.verbose=verbose'} $ (setTimeOut timeout) >> sym checkForVMErrors :: [EVM.VM] -> [String] @@ -463,7 +465,7 @@ assert cmd = do name = view methodSignature method' return $ Just (name,typ) if debug cmd then - runSMTWithTimeOut (solver cmd) (smttimeout cmd) $ query $ do + runSMTWithTimeOut (solver cmd) (smttimeout cmd) (smtoutput cmd) $ query $ do preState <- symvmFromCommand cmd smtState <- queryState io $ void $ EVM.TTY.runFromVM @@ -473,7 +475,7 @@ assert cmd = do preState else - runSMTWithTimeOut (solver cmd) (smttimeout cmd) $ query $ do + runSMTWithTimeOut (solver cmd) (smttimeout cmd) (smtoutput cmd) $ query $ do preState <- symvmFromCommand cmd verify preState (maxIterations cmd) rpcinfo (Just checkAssertions) >>= \case Right _ -> do diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 58d3232bc..1348fc64c 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -2547,13 +2547,13 @@ costOfPrecompile (FeeSchedule {..}) precompileAddr input = 0x1 -> 3000 -- SHA2-256 0x2 -> num $ (((l input + 31) `div` 32) * 12) + 60 - where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len i) -- RIPEMD-160 0x3 -> num $ (((l input + 31) `div` 32) * 120) + 600 - where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + where l i = fromMaybe (error "unsupported: dynamic data to RIPEMD-160") (unliteral $ len i) -- IDENTITY 0x4 -> num $ (((l input + 31) `div` 32) * 3) + 15 - where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + where l i = fromMaybe (error "unsupported: dynamic data to IDENTITY") (unliteral $ len i) -- MODEXP 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) where input' = case input of @@ -2579,7 +2579,7 @@ costOfPrecompile (FeeSchedule {..}) precompileAddr input = 0x7 -> g_ecmul -- ECPAIRING 0x8 -> num $ ((l input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) - where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len input) + where l i = fromMaybe (error "unsupported: dynamic data to ECPAIRING") (unliteral $ len i) -- BLAKE2 0x9 -> let input' = case input of ConcreteBuffer b -> b From 1ed023301c056affb51f6e7b6d55749698842bc5 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 2 Sep 2020 19:24:15 +0200 Subject: [PATCH 17/36] dynamic bytes testcase --- src/hevm/test/test.hs | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 59d19f047..604612063 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -546,6 +546,24 @@ main = defaultMain $ testGroup "hevm" verify vm Nothing Nothing (Just checkAssertions) putStrLn $ "found counterexample:" + , + testCase "dynamic bytes" $ do + Just c <- solcRuntime "C" + [i| + contract C + { + function f(bytes memory b1, bytes memory b2) public pure { + b1 = b2; + assert(b1[1] == b2[1]); + } + } + |] + -- should find a counterexample + Left (_, res) <- runSMTWith z3{verbose=True} $ do + setTimeOut 5000 + query $ checkAssert c Nothing [] + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + ] , testGroup "Equivalence checking" [ From d16bc07946da4fe891ca19d4db368d3bb7e8cbd4 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 2 Sep 2020 22:59:32 +0200 Subject: [PATCH 18/36] fix readsWord --- src/hevm/src/EVM/Symbolic.hs | 49 ++++++++++++++++++++++++++---------- 1 file changed, 36 insertions(+), 13 deletions(-) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index a5dcba16a..309dd5f11 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -25,6 +25,10 @@ data SymWord = S Whiff (SWord 256) sw256 :: SWord 256 -> SymWord sw256 = S Dull +bv2int :: SymWord -> SInteger +bv2int (S _ i) = sFromIntegral i +--snum = sFromIntegral + litWord :: Word -> (SymWord) litWord (C whiff a) = S whiff (literal $ toSizzle a) @@ -119,7 +123,7 @@ takeStatic n ls = -- tries to create a static list whenever possible dropS :: SymWord -> SList (WordN 8) -> Buffer -dropS n@(S _ i) ls = +dropS n ls = if isConcretelyEmpty ls then mempty else case (maybeLitWord n, unliteral $ SL.length ls) of @@ -128,7 +132,7 @@ dropS n@(S _ i) ls = then StaticSymBuffer $ takeStatic (num $ max n' (num l)) ls else let (_, xs) = SL.uncons ls in dropS (litWord $ n' - 1) xs - _ -> DynamicSymBuffer $ SL.drop (sFromIntegral i) ls + _ -> DynamicSymBuffer $ SL.drop (bv2int n) ls -- special case of sliceWithZero when size is known truncpad' :: Int -> Buffer -> Buffer @@ -149,11 +153,11 @@ truncpad' n m = case m of swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs -swordAt' :: SWord 32 -> SList (WordN 8) -> SymWord +swordAt' :: SymWord -> SList (WordN 8) -> SymWord swordAt' i bs = - ite (SL.length bs .<= sFromIntegral i) + ite (SL.length bs .<= bv2int i) (sw256 0) - (case truncpad' 32 $ dropS (sw256 $ sFromIntegral i) bs of + (case truncpad' 32 $ dropS i bs of ConcreteBuffer s -> litWord $ Concrete.w256 $ Concrete.wordAt 0 s StaticSymBuffer s -> sw256 $ fromBytes s DynamicSymBuffer s -> sw256 $ fromBytes [s .!! literal i | i <- [0..31]]) @@ -230,6 +234,25 @@ readSWordWithBound ind (ConcreteBuffer xs) bound = readMemoryWord' :: Word -> [SWord 8] -> SymWord readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) +-- pad up to 1000 bytes +sslice :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) +sslice (S _ o) (S _ l) bs = case (unliteral $ SL.length bs, unliteral (o + l)) of + (Just le, Just (num -> max)) -> + SL.subList (if le < max then bs .++ literal (replicate (num (max - le)) 0) else bs) o' l' + _ -> SL.subList (bs .++ literal (replicate 10000 0)) o' l' + where o' = sFromIntegral o + l' = sFromIntegral l + +sdynWriteMemory :: SList (WordN 8) -> SymWord -> SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) +sdynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = + let + a = sslice 0 dst bs0 + b = sslice src n bs1 + c = SL.drop (sFromIntegral $ dst' + n') bs0 + + in + a .++ b .++ c + dynWriteMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer dynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = let @@ -245,10 +268,10 @@ setMemoryWord'' i (S _ x) = dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 (sw256 (sFromIntegral i)) readSWord'' :: SymWord -> SList (WordN 8) -> SymWord -readSWord'' (S _ i) x = - ite (sFromIntegral i .> SL.length x) +readSWord'' i x = + ite (bv2int i .> SL.length x) 0 - (swordAt' (sFromIntegral i) x) + (swordAt' i x) -- a whole foldable instance seems overkill, but length is always good to have! len :: Buffer -> SWord 32 @@ -303,12 +326,12 @@ writeMemory bs1 n src dst bs0 = StaticSymBuffer $ writeMemory' bs1' n' src' dst' (litBytes bs0') (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> StaticSymBuffer $ writeMemory' bs1' n' src' dst' bs0' - _ -> dynWriteMemory bs1 n src dst bs0 + _ -> DynamicSymBuffer $ sdynWriteMemory (dynamize bs1) n src dst (dynamize bs0) -readMemoryWord :: SWord 32 -> Buffer -> SymWord -readMemoryWord i bf = case (unliteral i, bf) of - (Just i', StaticSymBuffer m) -> readMemoryWord' (num i') m - (Just i', ConcreteBuffer m) -> litWord $ Concrete.readMemoryWord (num i') m +readMemoryWord :: SymWord -> Buffer -> SymWord +readMemoryWord i bf = case (maybeLitWord i, bf) of + (Just i', StaticSymBuffer m) -> readMemoryWord' i' m + (Just i', ConcreteBuffer m) -> litWord $ Concrete.readMemoryWord i' m _ -> swordAt' i (dynamize bf) readMemoryWord32 :: SymWord -> Buffer -> SWord 32 From 561d7719d2ceaf41078849dc67369f7792aad93b Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Fri, 4 Sep 2020 14:07:46 +0200 Subject: [PATCH 19/36] assumptions to improve smt performance --- src/hevm/src/EVM.hs | 14 +++++++------- src/hevm/src/EVM/SymExec.hs | 16 +++++++++++++--- src/hevm/src/EVM/Symbolic.hs | 30 ++++++++++++++++++------------ 3 files changed, 38 insertions(+), 22 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 1348fc64c..72dfc6ab0 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -878,21 +878,21 @@ exec1 = do -- op: MLOAD 0x51 -> case stk of - (x'@(S _ x):xs) -> + (x:xs) -> burn g_verylow $ - accessMemoryWord fees x' $ do + accessMemoryWord fees x $ do next - assign (state . stack) (view (word256At (sFromIntegral x)) mem : xs) + assign (state . stack) (view (word256At x) mem : xs) _ -> underrun -- op: MSTORE 0x52 -> case stk of - (x'@(S _ x):y:xs) -> + (x:y:xs) -> burn g_verylow $ - accessMemoryWord fees x' $ do + accessMemoryWord fees x $ do next - assign (state . memory . word256At (sFromIntegral x)) y + assign (state . memory . word256At x) y assign (state . stack) xs _ -> underrun @@ -2220,7 +2220,7 @@ readMemory offset size vm = sliceWithZero offset size (view (state . memory) vm) word256At :: Functor f - => SWord 32 -> (SymWord -> f (SymWord)) + => SymWord -> (SymWord -> f (SymWord)) -> Buffer -> f Buffer word256At i = lens getter setter where getter = readMemoryWord i diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index 50f9f0583..bb67d1e86 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -20,6 +20,7 @@ import EVM.Symbolic (SymWord(..), sw256) import EVM.Concrete (createAddress, Word) import qualified EVM.FeeSchedule as FeeSchedule import Data.SBV.Trans.Control +import qualified Data.SBV.List as SList import Data.SBV.Trans hiding (distinct, Word) import Data.SBV hiding (runSMT, newArray_, addAxiom, distinct, sWord8s, Word) import Data.Vector (toList, fromList) @@ -94,9 +95,17 @@ staticCalldata sig typesignature concreteArgs = abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel -> Query VM abstractVM typesignature concreteArgs x storagemodel = do - cd' <- case typesignature of - Nothing -> DynamicSymBuffer <$> freshVar_ - Just (name, typs) -> StaticSymBuffer <$> staticCalldata name typs concreteArgs + (cd',pathCond) <- case typesignature of + Nothing -> do list <- freshVar_ + return (DynamicSymBuffer list, + -- due to some current z3 shenanegans (possibly related to: https://github.com/Z3Prover/z3/issues/4635) + -- we assume the list length to be shorter than max_length both as a bitvector and as an integer. + -- The latter implies the former as long as max_length fits in a bitvector, but assuming it explitly + -- improves z3 (4.8.8) performance. + SList.length list .< 1000 .&& + sw256 (sFromIntegral (SList.length list)) .< sw256 1000) + Just (name, typs) -> do symbytes <- staticCalldata name typs concreteArgs + return (StaticSymBuffer symbytes, sTrue) symstore <- case storagemodel of SymbolicS -> Symbolic <$> freshArray_ Nothing @@ -105,6 +114,7 @@ abstractVM typesignature concreteArgs x storagemodel = do c <- SAddr <$> freshVar_ value' <- sw256 <$> freshVar_ return $ loadSymVM (RuntimeCode x) symstore storagemodel c value' cd' + & over pathConditions (<> [pathCond]) loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> Buffer -> VM loadSymVM x initStore model addr callvalue' calldata' = diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 309dd5f11..3fa8c640e 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -263,15 +263,19 @@ dynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = in a <> b <> c -setMemoryWord'' :: SWord 32 -> SymWord -> Buffer -> Buffer +setMemoryWord'' :: SymWord -> SymWord -> Buffer -> Buffer setMemoryWord'' i (S _ x) = - dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 (sw256 (sFromIntegral i)) + dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 i readSWord'' :: SymWord -> SList (WordN 8) -> SymWord -readSWord'' i x = - ite (bv2int i .> SL.length x) - 0 - (swordAt' i x) +readSWord'' i x = altReadSWord i x -- swordAt' i x + +altReadSWord :: SymWord -> SList (WordN 8) -> SymWord +altReadSWord (S _ i) x = aReadSWord (sFromIntegral i) x + +aReadSWord :: SInteger -> SList (WordN 8) -> SymWord +aReadSWord i x = let ls = SL.drop i x .++ literal (replicate 32 0) + in sw256 $ fromBytes $ [ls .!! literal i | i <- [0..31]] -- a whole foldable instance seems overkill, but length is always good to have! len :: Buffer -> SWord 32 @@ -326,7 +330,9 @@ writeMemory bs1 n src dst bs0 = StaticSymBuffer $ writeMemory' bs1' n' src' dst' (litBytes bs0') (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> StaticSymBuffer $ writeMemory' bs1' n' src' dst' bs0' - _ -> DynamicSymBuffer $ sdynWriteMemory (dynamize bs1) n src dst (dynamize bs0) +-- TODO: figure whether dynWriteMemory or sdynWriteMemory is better + _ -> dynWriteMemory bs1 n src dst bs0 +-- _ -> DynamicSymBuffer $ sdynWriteMemory (dynamize bs1) n src dst (dynamize bs0) readMemoryWord :: SymWord -> Buffer -> SymWord readMemoryWord i bf = case (maybeLitWord i, bf) of @@ -344,11 +350,11 @@ readMemoryWord32 i m = case (maybeLitWord i, m) of DynamicSymBuffer s -> fromBytes [s .!! literal k | k <- [0..3]] -setMemoryWord :: SWord 32 -> SymWord -> Buffer -> Buffer -setMemoryWord i x bf = case (unliteral i, maybeLitWord x, bf) of - (Just i', Just x', ConcreteBuffer z) -> ConcreteBuffer $ Concrete.setMemoryWord (num i') x' z - (Just i', _ , ConcreteBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x (litBytes z) - (Just i', _ , StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' (num i') x z +setMemoryWord :: SymWord -> SymWord -> Buffer -> Buffer +setMemoryWord i x bf = case (maybeLitWord i, maybeLitWord x, bf) of + (Just i', Just x', ConcreteBuffer z) -> ConcreteBuffer $ Concrete.setMemoryWord i' x' z + (Just i', _ , ConcreteBuffer z) -> StaticSymBuffer $ setMemoryWord' i' x (litBytes z) + (Just i', _ , StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' i' x z _ -> setMemoryWord'' i x bf setMemoryByte :: SymWord -> SWord 8 -> Buffer -> Buffer From 3f93f09ee2a6e582535ca303aed7d9a8ea27e093 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Fri, 4 Sep 2020 17:02:05 +0200 Subject: [PATCH 20/36] optimize concrete case --- src/hevm/src/EVM/Symbolic.hs | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 3fa8c640e..43949fb37 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -154,8 +154,8 @@ swordAt :: Int -> [SWord 8] -> SymWord swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs swordAt' :: SymWord -> SList (WordN 8) -> SymWord -swordAt' i bs = - ite (SL.length bs .<= bv2int i) +swordAt' i@(S _ i') bs = + ite (sFromIntegral (SL.length bs) .<= i') (sw256 0) (case truncpad' 32 $ dropS i bs of ConcreteBuffer s -> litWord $ Concrete.w256 $ Concrete.wordAt 0 s @@ -206,7 +206,7 @@ readSWord' (C _ i) x = -- | Operations over dynamic symbolic memory (smt list of bytes) readByteOrZero'' :: SWord 32 -> SList (WordN 8) -> SWord 8 readByteOrZero'' i bs = - ite (SL.length bs .> (sFromIntegral i + 1)) + ite (sFromIntegral (SL.length bs) .> i + 1) (bs .!! (sFromIntegral i)) (literal 0) @@ -268,14 +268,21 @@ setMemoryWord'' i (S _ x) = dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 i readSWord'' :: SymWord -> SList (WordN 8) -> SymWord -readSWord'' i x = altReadSWord i x -- swordAt' i x +readSWord'' i x = case (maybeLitWord i, unliteral (SL.length x)) of + (Just i', Just l) -> + if num l <= i' + then 0 + else read32At (literal $ num $ Concrete.wordValue i') (x .++ literal (replicate (num $ l + 32 - num i') 0)) + _ -> altReadSWord i x altReadSWord :: SymWord -> SList (WordN 8) -> SymWord -altReadSWord (S _ i) x = aReadSWord (sFromIntegral i) x +altReadSWord (S _ i) x = + ite (i .< sFromIntegral (SL.length x)) + (read32At (sFromIntegral i) (x .++ literal (replicate 32 0))) + (sw256 0) -aReadSWord :: SInteger -> SList (WordN 8) -> SymWord -aReadSWord i x = let ls = SL.drop i x .++ literal (replicate 32 0) - in sw256 $ fromBytes $ [ls .!! literal i | i <- [0..31]] +read32At :: SInteger -> SList (WordN 8) -> SymWord +read32At i x = sw256 $ fromBytes $ [x .!! literal i | i <- [0..31]] -- a whole foldable instance seems overkill, but length is always good to have! len :: Buffer -> SWord 32 From c1376dcc0965920e2144770c24cdf2bbe19fcf7a Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Sun, 6 Sep 2020 17:45:09 +0200 Subject: [PATCH 21/36] simplifications and more testing --- src/hevm/src/EVM.hs | 18 +++--- src/hevm/src/EVM/Fetch.hs | 6 +- src/hevm/src/EVM/SymExec.hs | 4 +- src/hevm/src/EVM/Symbolic.hs | 8 +-- src/hevm/test/test.hs | 121 ++++++++++++++++++++++++++--------- 5 files changed, 112 insertions(+), 45 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 72dfc6ab0..3f47c4078 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -501,8 +501,8 @@ exec1 = do -- call to precompile let ?op = 0x00 -- dummy value - copyBytesToMemory (the state calldata) (sw256 $ sFromIntegral $ len (the state calldata)) 0 0 - executePrecompile self (the state gas) 0 (sw256 $ sFromIntegral $ len (the state calldata)) 0 0 [] + copyBytesToMemory (the state calldata) (len $ the state calldata) 0 0 + executePrecompile self (the state gas) 0 (len $ the state calldata) 0 0 [] vmx <- get case view (state.stack) vmx of (x:_) -> case maybeLitWord x of @@ -717,7 +717,7 @@ exec1 = do -- op: CALLDATASIZE 0x36 -> limitStack 1 . burn g_base $ - next >> pushSym (sw256 . sFromIntegral . len $ the state calldata) + next >> pushSym (len $ the state calldata) -- op: CALLDATACOPY 0x37 -> @@ -792,7 +792,7 @@ exec1 = do -- op: RETURNDATASIZE 0x3d -> limitStack 1 . burn g_base $ - next >> pushSym (sw256 $ sFromIntegral $ len (the state returndata)) + next >> pushSym (len $ the state returndata) -- op: RETURNDATACOPY 0x3e -> @@ -2213,7 +2213,7 @@ copyCallBytesToMemory copyCallBytesToMemory bs size xOffset yOffset = do mem <- use (state . memory) assign (state . memory) $ - writeMemory bs (smin size (sw256 $ sFromIntegral $ len bs)) xOffset yOffset mem + writeMemory bs (smin size (len bs)) xOffset yOffset mem readMemory :: SymWord -> SymWord -> VM -> Buffer readMemory offset size vm = sliceWithZero offset size (view (state . memory) vm) @@ -2547,13 +2547,13 @@ costOfPrecompile (FeeSchedule {..}) precompileAddr input = 0x1 -> 3000 -- SHA2-256 0x2 -> num $ (((l input + 31) `div` 32) * 12) + 60 - where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (unliteral $ len i) + where l i = fromMaybe (error "unsupported: dynamic data to SHA256") (maybeLitWord $ len i) -- RIPEMD-160 0x3 -> num $ (((l input + 31) `div` 32) * 120) + 600 - where l i = fromMaybe (error "unsupported: dynamic data to RIPEMD-160") (unliteral $ len i) + where l i = fromMaybe (error "unsupported: dynamic data to RIPEMD-160") (maybeLitWord $ len i) -- IDENTITY 0x4 -> num $ (((l input + 31) `div` 32) * 3) + 15 - where l i = fromMaybe (error "unsupported: dynamic data to IDENTITY") (unliteral $ len i) + where l i = fromMaybe (error "unsupported: dynamic data to IDENTITY") (maybeLitWord $ len i) -- MODEXP 0x5 -> num $ (f (num (max lenm lenb)) * num (max lene' 1)) `div` (num g_quaddivisor) where input' = case input of @@ -2579,7 +2579,7 @@ costOfPrecompile (FeeSchedule {..}) precompileAddr input = 0x7 -> g_ecmul -- ECPAIRING 0x8 -> num $ ((l input) `div` 192) * (num g_pairing_point) + (num g_pairing_base) - where l i = fromMaybe (error "unsupported: dynamic data to ECPAIRING") (unliteral $ len i) + where l i = fromMaybe (error "unsupported: dynamic data to ECPAIRING") (maybeLitWord $ len i) -- BLAKE2 0x9 -> let input' = case input of ConcreteBuffer b -> b diff --git a/src/hevm/src/EVM/Fetch.hs b/src/hevm/src/EVM/Fetch.hs index 33c8788a9..c59912ac1 100644 --- a/src/hevm/src/EVM/Fetch.hs +++ b/src/hevm/src/EVM/Fetch.hs @@ -184,7 +184,11 @@ type Fetcher = EVM.Query -> IO (EVM ()) checksat :: SBool -> Query CheckSatResult checksat b = do push 1 constrain b - m <- checkSat + b <- getInfo Name + m <- case b of + -- some custom strategies for z3 which have proven to be quite useful (can still be tweaked) + Resp_Name "Z3" -> checkSatUsing "(check-sat-using (then (using-params simplify :cache-all true) smt))" + _ -> checkSat pop 1 return m diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index bb67d1e86..b67fad92d 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -143,8 +143,8 @@ loadSymVM x initStore model addr callvalue' calldata' = -- | Interpreter which explores all paths at --- | branching points. --- | returns a list of possible final evm states +-- branching points. +-- returns a list of possible final evm states interpret :: Fetch.Fetcher -> Maybe Integer --max iterations diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 43949fb37..fb465e6b0 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -285,10 +285,10 @@ read32At :: SInteger -> SList (WordN 8) -> SymWord read32At i x = sw256 $ fromBytes $ [x .!! literal i | i <- [0..31]] -- a whole foldable instance seems overkill, but length is always good to have! -len :: Buffer -> SWord 32 -len (DynamicSymBuffer a) = sFromIntegral $ SL.length a -len (StaticSymBuffer bs) = literal . num $ length bs -len (ConcreteBuffer bs) = literal . num $ BS.length bs +len :: Buffer -> SymWord --SWord 32 +len (DynamicSymBuffer a) = sw256 $ sFromIntegral $ SL.length a +len (StaticSymBuffer bs) = litWord . num $ length bs +len (ConcreteBuffer bs) = litWord . num $ BS.length bs grab :: Int -> Buffer -> Buffer grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 604612063..81f2ed005 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -147,7 +147,47 @@ main = defaultMain $ testGroup "hevm" (r, mempty), (s, mempty), (t, mempty)] === (Just $ Literal Patricia.Empty) ] + , testGroup "symbolic properties" [ + -- testCase "calldata beyond length must be 0" $ runSMTWith z3 + -- $ query $ do calldatalist <- freshVar_ + -- -- works with length .< 10, but not 100... + -- constrain $ SL.length calldatalist .< 10 + -- let cd = DynamicSymBuffer calldatalist + -- constrain $ 0 ./= readSWord (sw256 $ sFromIntegral $ len cd) cd + -- checkSat >>= \case + -- Sat -> error "should be false" + -- Unsat -> return () + -- Unk -> error "timed out!" + +-- , + testCase "calldata beyond length must be 0" $ runSMTWith z3 + $ query $ do calldatalist <- freshVar_ + -- works with length .< 100 + constrain $ SL.length calldatalist .< 100 + constrain $ sw256 (sFromIntegral $ SL.length calldatalist) .< sw256 100 + let cd = DynamicSymBuffer calldatalist + constrain $ 0 ./= readSWord (len cd) cd + checkSat >>= \case + Sat -> error "should be false" + Unsat -> return () + Unk -> error "timed out!" + , + testCase "comparing function selector" $ runSMTWith z3{transcript=Just "sameno.smt2"} $ do + setTimeOut 5000 + query $ do calldatalist <- freshVar_ + -- works with length .< 100 + constrain $ SL.length calldatalist .< 100 + constrain $ sw256 (sFromIntegral $ SL.length calldatalist) .< sw256 100 + let cd = DynamicSymBuffer calldatalist + let S _ v = readSWord (sw256 0) cd + constrain $ 1337 .== (sShiftRight v (224 :: SWord 256)) + checkSat >>= \case + Sat -> return () + Unsat -> error "should be sat" + Unk -> error "timed out!" + + ] , testGroup "Symbolic buffers" [ testCase "dynWriteMemory works" $ runSMTWith z3 $ query $ do @@ -225,6 +265,7 @@ main = defaultMain $ testGroup "hevm" } |] let pre preVM = let [x, y] = getStaticAbiArgs preVM + z = x + y in x .<= x + y .&& view (state . callvalue) preVM .== 0 post = Just $ \(prestate, poststate) -> @@ -234,30 +275,31 @@ main = defaultMain $ testGroup "hevm" _ -> sFalse Left (_, res) <- runSMT $ query $ verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre post putStrLn $ "successfully explored: " <> show (length res) <> " paths" + , - testCase "x == y => x + y == 2 * y" $ do - Just safeAdd <- solcRuntime "SafeAdd" - [i| - contract SafeAdd { - function add(uint x, uint y) public pure returns (uint z) { - require((z = x + y) >= x); - } - } - |] - let pre preVM = let [x, y] = getStaticAbiArgs preVM - in (x .<= x + y) - .&& (x .== y) - .&& view (state . callvalue) preVM .== 0 - post (prestate, poststate) = - let [_, y] = getStaticAbiArgs prestate - in case view result poststate of - Just (VMSuccess (StaticSymBuffer out)) -> fromBytes out .== 2 * y - _ -> sFalse - Left (_, res) <- runSMTWith z3 $ query $ - verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) - putStrLn $ "successfully explored: " <> show (length res) <> " paths" - , + -- testCase "x == y => x + y == 2 * y" $ do + -- Just safeAdd <- solcRuntime "SafeAdd" + -- [i| + -- contract SafeAdd { + -- function add(uint x, uint y) public pure returns (uint z) { + -- require((z = x + y) >= x); + -- } + -- } + -- |] + -- let pre preVM = let [x, y] = getStaticAbiArgs preVM + -- in (x .<= x + y) + -- .&& (x .== y) + -- .&& view (state . callvalue) preVM .== 0 + -- post (prestate, poststate) = + -- let [_, y] = getStaticAbiArgs prestate + -- in case view result poststate of + -- Just (VMSuccess (StaticSymBuffer out)) -> fromBytes out .== 2 * y + -- _ -> sFalse + -- Left (_, res) <- runSMTWith z3 $ query $ + -- verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) + -- putStrLn $ "successfully explored: " <> show (length res) <> " paths" + -- , testCase "factorize 973013" $ do Just factor <- solcRuntime "PrimalityCheck" [i| @@ -545,25 +587,46 @@ main = defaultMain $ testGroup "hevm" set EVM.storage (Symbolic store))) verify vm Nothing Nothing (Just checkAssertions) putStrLn $ "found counterexample:" - - , - testCase "dynamic bytes" $ do + -- , + -- testCase "dynamic bytes (calldataload)" $ do + -- Just c <- solcRuntime "C" + -- [i| + -- contract C + -- { + -- function f() public pure { + -- uint y; + -- uint z; + -- assembly { + -- y := calldataload(12) + -- z := calldataload(31) + -- } + -- assert(y == z); + -- } + -- } + -- |] + -- -- should find a counterexample + -- Right cex <- runSMTWith z3 $ do + -- query $ checkAssert c Nothing [] + -- putStrLn $ "found counterexample" + + + -- , + testCase "dynamic bytes (abi decoding)" $ do Just c <- solcRuntime "C" [i| contract C { function f(bytes memory b1, bytes memory b2) public pure { b1 = b2; - assert(b1[1] == b2[1]); - } + assert(b1[1] == b2[1]); + } } |] -- should find a counterexample Left (_, res) <- runSMTWith z3{verbose=True} $ do - setTimeOut 5000 +-- setTimeOut 20000 query $ checkAssert c Nothing [] putStrLn $ "successfully explored: " <> show (length res) <> " paths" - ] , testGroup "Equivalence checking" [ From 1149e7ece85e89e646dda0e869f83cf360e5a3bf Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Mon, 7 Sep 2020 17:34:43 +0200 Subject: [PATCH 22/36] update sbv --- haskell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haskell.nix b/haskell.nix index 44c2ebb0f..58b707f5a 100644 --- a/haskell.nix +++ b/haskell.nix @@ -15,7 +15,7 @@ in self-hs: super-hs: sbv_prepatch = pkgs.haskell.lib.dontCheck (self-hs.callCabal2nix "sbv" (builtins.fetchGit { url = "https://github.com/LeventErkok/sbv/"; - rev = "91637c043d206530bc64d7eac88d2f80e8db0b85"; + rev = "fe5f5aff026307a1582cc7eafbbabd26796ef434"; }) {inherit (pkgs) z3;}); in { From b4178a073aba2c947d47838546fd0a492eb7c1f2 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Mon, 7 Sep 2020 19:02:27 +0200 Subject: [PATCH 23/36] run only z3 tests for now --- nix/hevm-tests/default.nix | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/nix/hevm-tests/default.nix b/nix/hevm-tests/default.nix index e18ff5b33..0187eb29d 100644 --- a/nix/hevm-tests/default.nix +++ b/nix/hevm-tests/default.nix @@ -11,9 +11,9 @@ let in { yulEquivalence-z3 = runWithSolver ./yul-equivalence.nix "z3"; - yulEquivalence-cvc4 = runWithSolver ./yul-equivalence.nix "cvc4"; + #yulEquivalence-cvc4 = runWithSolver ./yul-equivalence.nix "cvc4"; # z3 takes 3hrs to run these tests on a fast machine, and even then ~180 timeout - #smtChecker-z3 = runWithSolver ./smt-checker.nix "z3"; - smtChecker-cvc4 = runWithSolver ./smt-checker.nix "cvc4"; + smtChecker-z3 = runWithSolver ./smt-checker.nix "z3"; + #smtChecker-cvc4 = runWithSolver ./smt-checker.nix "cvc4"; } From 97ac68691be9d111d4410b905bf7b17577828582 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 8 Sep 2020 17:04:27 +0200 Subject: [PATCH 24/36] allow calldata to be either a buffer or pseudodynamic (old approach) --- src/hevm/src/EVM.hs | 40 ++++++++++++++---- src/hevm/src/EVM/Exec.hs | 4 +- src/hevm/src/EVM/SymExec.hs | 57 ++++++++++++++++--------- src/hevm/src/EVM/Symbolic.hs | 29 ++++++++++++- src/hevm/src/EVM/TTY.hs | 8 +++- src/hevm/src/EVM/UnitTest.hs | 4 +- src/hevm/src/EVM/VMTest.hs | 6 +-- src/hevm/test/test.hs | 80 ++++++++++++++++++------------------ 8 files changed, 150 insertions(+), 78 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 3f47c4078..e46861c98 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -16,6 +16,7 @@ module EVM where import Prelude hiding (log, Word, exponent) import Data.SBV hiding (Word, output, Unknown) +import Data.SBV.List (implode, subList) import Data.Proxy (Proxy(..)) import EVM.ABI import EVM.Types @@ -170,7 +171,7 @@ data Cache = Cache -- | A way to specify an initial VM state data VMOpts = VMOpts { vmoptContract :: Contract - , vmoptCalldata :: Buffer -- maximum size of uint32 as per eip 1985 + , vmoptCalldata :: Calldata , vmoptValue :: SymWord , vmoptAddress :: Addr , vmoptCaller :: SAddr @@ -225,7 +226,7 @@ data FrameState = FrameState , _stack :: [SymWord] , _memory :: Buffer , _memorySize :: SWord 32 - , _calldata :: Buffer + , _calldata :: Calldata , _callvalue :: SymWord , _caller :: SAddr , _gas :: Word @@ -312,6 +313,14 @@ data StorageModel instance ParseField StorageModel +-- | Calldata can either by a normal buffer, or a custom "pseudo dynamic" encoding. See EVM.Symbolic for details +data CalldataModel + = BufferCD + | BoundedCD + deriving (Read, Show) + +instance ParseField CalldataModel + -- | Various environmental data data Env = Env { _contracts :: Map Addr Contract @@ -342,7 +351,7 @@ blankState = FrameState , _stack = mempty , _memory = mempty , _memorySize = 0 - , _calldata = mempty + , _calldata = CalldataBuffer mempty , _callvalue = 0 , _caller = 0 , _gas = 0 @@ -501,8 +510,8 @@ exec1 = do -- call to precompile let ?op = 0x00 -- dummy value - copyBytesToMemory (the state calldata) (len $ the state calldata) 0 0 - executePrecompile self (the state gas) 0 (len $ the state calldata) 0 0 [] + copyCalldataToMemory (the state calldata) (cdlen $ the state calldata) 0 0 + executePrecompile self (the state gas) 0 (cdlen $ the state calldata) 0 0 [] vmx <- get case view (state.stack) vmx of (x:_) -> case maybeLitWord x of @@ -712,12 +721,14 @@ exec1 = do -- op: CALLDATALOAD 0x35 -> stackOp1 (const g_verylow) $ - flip readSWord (the state calldata) + case the state calldata of + CalldataBuffer bf -> flip readSWord bf + CalldataDynamic bf -> \(S _ i) -> readStaticWordWithBound (sFromIntegral i) bf -- op: CALLDATASIZE 0x36 -> limitStack 1 . burn g_base $ - next >> pushSym (len $ the state calldata) + next >> pushSym (cdlen $ the state calldata) -- op: CALLDATACOPY 0x37 -> @@ -727,7 +738,7 @@ exec1 = do accessUnboundedMemoryRange fees xTo xSize $ do next assign (state . stack) xs - copyBytesToMemory (the state calldata) xSize xFrom xTo + copyCalldataToMemory (the state calldata) xSize xFrom xTo _ -> underrun -- op: CODESIZE @@ -1909,7 +1920,7 @@ delegateCall this gasGiven xTo xContext xValue xInOffset xInSize xOutOffset xOut assign memory mempty assign memorySize 0 assign returndata mempty - assign calldata (readMemory xInOffset xInSize vm0) + assign calldata (CalldataBuffer $ readMemory xInOffset xInSize vm0) continue @@ -2195,6 +2206,17 @@ accessMemoryWord :: FeeSchedule Word -> SymWord -> EVM () -> EVM () accessMemoryWord fees x = accessMemoryRange fees x 32 +copyCalldataToMemory + :: Calldata -> SymWord -> SymWord -> SymWord -> EVM () +copyCalldataToMemory (CalldataBuffer bf) size xOffset yOffset = + copyBytesToMemory bf size xOffset yOffset +copyCalldataToMemory (CalldataDynamic (b, l)) size xOffset yOffset = + case (maybeLitWord size, maybeLitWord xOffset, maybeLitWord yOffset) of + (Just size', Just xOffset', Just yOffset') -> + copyBytesToMemory (StaticSymBuffer [ite (i .<= l) x 0 | (x, i) <- zip b [1..]]) size' xOffset' yOffset' + _ -> + copyBytesToMemory (DynamicSymBuffer (subList (implode b) 0 (sFromIntegral l))) size xOffset yOffset + copyBytesToMemory :: Buffer -> SymWord -> SymWord -> SymWord -> EVM () copyBytesToMemory bs size xOffset yOffset = diff --git a/src/hevm/src/EVM/Exec.hs b/src/hevm/src/EVM/Exec.hs index d960b87ea..0fede87b7 100644 --- a/src/hevm/src/EVM/Exec.hs +++ b/src/hevm/src/EVM/Exec.hs @@ -2,7 +2,7 @@ module EVM.Exec where import EVM import EVM.Concrete (createAddress) -import EVM.Symbolic (litAddr) +import EVM.Symbolic (litAddr, Calldata(..)) import EVM.Types import qualified EVM.FeeSchedule as FeeSchedule @@ -22,7 +22,7 @@ vmForEthrunCreation :: ByteString -> VM vmForEthrunCreation creationCode = (makeVm $ VMOpts { vmoptContract = initialContract (InitCode creationCode) - , vmoptCalldata = mempty + , vmoptCalldata = CalldataBuffer mempty , vmoptValue = 0 , vmoptAddress = createAddress ethrunAddress 1 , vmoptCaller = litAddr ethrunAddress diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index b67fad92d..cb400be78 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -16,7 +16,7 @@ import EVM.Stepper (Stepper) import qualified EVM.Stepper as Stepper import qualified Control.Monad.Operational as Operational import EVM.Types hiding (Word) -import EVM.Symbolic (SymWord(..), sw256) +import EVM.Symbolic (SymWord(..), sw256, Calldata(..)) import EVM.Concrete (createAddress, Word) import qualified EVM.FeeSchedule as FeeSchedule import Data.SBV.Trans.Control @@ -93,19 +93,28 @@ staticCalldata sig typesignature concreteArgs = sig' = litBytes $ selector sig -abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel -> Query VM -abstractVM typesignature concreteArgs x storagemodel = do +-- | Construct a VM out of a type signature, possibly with specialized concrete arguments +-- ,bytecode, storagemodel and calldata structure. +abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel -> CalldataModel -> Query VM +abstractVM typesignature concreteArgs x storagemodel calldatamodel = do (cd',pathCond) <- case typesignature of - Nothing -> do list <- freshVar_ - return (DynamicSymBuffer list, - -- due to some current z3 shenanegans (possibly related to: https://github.com/Z3Prover/z3/issues/4635) - -- we assume the list length to be shorter than max_length both as a bitvector and as an integer. - -- The latter implies the former as long as max_length fits in a bitvector, but assuming it explitly - -- improves z3 (4.8.8) performance. - SList.length list .< 1000 .&& - sw256 (sFromIntegral (SList.length list)) .< sw256 1000) + Nothing -> case calldatamodel of + BufferCD -> do + list <- freshVar_ + return (CalldataBuffer (DynamicSymBuffer list), + -- due to some current z3 shenanegans (possibly related to: https://github.com/Z3Prover/z3/issues/4635) + -- we assume the list length to be shorter than max_length both as a bitvector and as an integer. + -- The latter implies the former as long as max_length fits in a bitvector, but assuming it explitly + -- improves z3 (4.8.8) performance. + SList.length list .< 1000 .&& + sw256 (sFromIntegral (SList.length list)) .< sw256 1000) + + BoundedCD -> do + cd <- sbytes256 + len <- freshVar_ + return (CalldataDynamic (cd, len), len .<= 256) Just (name, typs) -> do symbytes <- staticCalldata name typs concreteArgs - return (StaticSymBuffer symbytes, sTrue) + return (CalldataBuffer (StaticSymBuffer symbytes), sTrue) symstore <- case storagemodel of SymbolicS -> Symbolic <$> freshArray_ Nothing @@ -116,7 +125,7 @@ abstractVM typesignature concreteArgs x storagemodel = do return $ loadSymVM (RuntimeCode x) symstore storagemodel c value' cd' & over pathConditions (<> [pathCond]) -loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> Buffer -> VM +loadSymVM :: ContractCode -> Storage -> StorageModel -> SAddr -> SymWord -> Calldata -> VM loadSymVM x initStore model addr callvalue' calldata' = (makeVm $ VMOpts { vmoptContract = contractWithStore x initStore @@ -212,17 +221,21 @@ maxIterationsReached vm (Just maxIter) = type Precondition = VM -> SBool type Postcondition = (VM, VM) -> SBool +checkAssertBuffer :: ByteString -> Query (Either (VM, [VM]) VM) +checkAssertBuffer c = verifyContract c Nothing [] SymbolicS BufferCD (const sTrue) (Just checkAssertions) + + checkAssert :: ByteString -> Maybe (Text, [AbiType]) -> [String] -> Query (Either (VM, [VM]) VM) -checkAssert c signature' concreteArgs = verifyContract c signature' concreteArgs SymbolicS (const sTrue) (Just checkAssertions) +checkAssert c signature' concreteArgs = verifyContract c signature' concreteArgs SymbolicS BoundedCD (const sTrue) (Just checkAssertions) checkAssertions :: Postcondition checkAssertions (_, out) = case view result out of Just (EVM.VMFailure (EVM.UnrecognizedOpcode 254)) -> sFalse _ -> sTrue -verifyContract :: ByteString -> Maybe (Text, [AbiType]) -> [String] -> StorageModel -> Precondition -> Maybe Postcondition -> Query (Either (VM, [VM]) VM) -verifyContract theCode signature' concreteArgs storagemodel pre maybepost = do - preStateRaw <- abstractVM signature' concreteArgs theCode storagemodel +verifyContract :: ByteString -> Maybe (Text, [AbiType]) -> [String] -> StorageModel -> CalldataModel -> Precondition -> Maybe Postcondition -> Query (Either (VM, [VM]) VM) +verifyContract theCode signature' concreteArgs storagemodel calldatamodel pre maybepost = do + preStateRaw <- abstractVM signature' concreteArgs theCode storagemodel calldatamodel -- add the pre condition to the pathconditions to ensure that we are only exploring valid paths let preState = over pathConditions ((++) [pre preStateRaw]) preStateRaw verify preState Nothing Nothing maybepost @@ -264,7 +277,7 @@ verify preState maxIter rpcinfo maybepost = do -- | Compares two contract runtimes for trace equivalence by running two VMs and comparing the end states. equivalenceCheck :: ByteString -> ByteString -> Maybe Integer -> Maybe (Text, [AbiType]) -> Query (Either ([VM], [VM]) VM) equivalenceCheck bytecodeA bytecodeB maxiter signature' = do - preStateA <- abstractVM signature' [] bytecodeA SymbolicS + preStateA <- abstractVM signature' [] bytecodeA SymbolicS BoundedCD let preself = preStateA ^. state . contract precaller = preStateA ^. state . caller @@ -327,8 +340,12 @@ showCounterexample vm maybesig = do SAddr caller' = view (EVM.state . EVM.caller) vm -- cdlen' <- num <$> getValue cdlen calldatainput <- case calldata' of - StaticSymBuffer cd -> mapM (getValue.fromSized) cd >>= return . pack - ConcreteBuffer cd -> return $ cd + CalldataDynamic (cd, cdlen) -> do + cdlen' <- num <$> getValue cdlen + mapM (getValue.fromSized) (take cdlen' cd) >>= return . pack + CalldataBuffer (StaticSymBuffer cd) -> mapM (getValue.fromSized) cd >>= return . pack + CalldataBuffer (ConcreteBuffer cd) -> return $ cd + CalldataBuffer (DynamicSymBuffer cd) -> (fmap fromSized) <$> getValue cd >>= return . pack callvalue' <- num <$> getValue cvalue caller'' <- num <$> getValue caller' io $ do diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index fb465e6b0..1c06189b3 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -210,7 +210,6 @@ readByteOrZero'' i bs = (bs .!! (sFromIntegral i)) (literal 0) - -- Generates a ridiculously large set of constraints (roughly 25k) when -- the index is symbolic, but it still seems (kind of) manageable -- for the solvers. @@ -284,12 +283,26 @@ altReadSWord (S _ i) x = read32At :: SInteger -> SList (WordN 8) -> SymWord read32At i x = sw256 $ fromBytes $ [x .!! literal i | i <- [0..31]] +-- | Although calldata can be modeled perfectly well directly as a Buffer, +-- we allow for it to take on a special form; the pair ([SWord 8], SWord 32) +-- where the second argument is understood as the length of the list. +-- This allows us to 'fake' dynamically sized calldata arrays in a way +-- that has proven more efficient than `SList`. +data Calldata + = CalldataBuffer Buffer + | CalldataDynamic ([SWord 8], SWord 32) + deriving Show + -- a whole foldable instance seems overkill, but length is always good to have! len :: Buffer -> SymWord --SWord 32 len (DynamicSymBuffer a) = sw256 $ sFromIntegral $ SL.length a len (StaticSymBuffer bs) = litWord . num $ length bs len (ConcreteBuffer bs) = litWord . num $ BS.length bs +cdlen :: Calldata -> SymWord +cdlen (CalldataBuffer bf) = len bf +cdlen (CalldataDynamic (_, a)) = sw256 $ sFromIntegral a + grab :: Int -> Buffer -> Buffer grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs @@ -378,6 +391,20 @@ readSWord i bf = case (maybeLitWord i, bf) of (Just i', ConcreteBuffer x) -> num $ Concrete.readMemoryWord i' x _ -> readSWord'' i (dynamize bf) + +select' :: (Ord b, Num b, SymVal b, Mergeable a) => [a] -> a -> SBV b -> a +select' xs err ind = walk xs ind err + where walk [] _ acc = acc + walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) + +-- Generates a ridiculously large set of constraints (roughly 25k) when +-- the index is symbolic, but it still seems (kind of) manageable +-- for the solvers. +readStaticWordWithBound :: SWord 32 -> ([SWord 8], SWord 32) -> SymWord +readStaticWordWithBound ind (xs, bound) = + let boundedList = [ite (i .<= bound) x 0 | (x, i) <- zip xs [1..]] + in sw256 . fromBytes $ [select' boundedList 0 (ind + j) | j <- [0..31]] + -- | Custom instances for SymWord, many of which have direct -- analogues for concrete words defined in Concrete.hs diff --git a/src/hevm/src/EVM/TTY.hs b/src/hevm/src/EVM/TTY.hs index 0fbf76aa9..015851b9b 100644 --- a/src/hevm/src/EVM/TTY.hs +++ b/src/hevm/src/EVM/TTY.hs @@ -12,7 +12,7 @@ import Brick.Widgets.List import EVM import EVM.ABI (abiTypeSolidity, decodeAbiValue, AbiType(..), emptyAbi) -import EVM.Symbolic (SymWord(..)) +import EVM.Symbolic (SymWord(..), Calldata(..)) import EVM.SymExec (maxIterationsReached) import EVM.Dapp (DappInfo, dappInfo) import EVM.Dapp (dappUnitTests, unitTestMethods, dappSolcByName, dappSolcByHash, dappSources) @@ -868,12 +868,16 @@ prettyIfConcrete (StaticSymBuffer x) = show x prettyIfConcrete (DynamicSymBuffer x) = show x prettyIfConcrete (ConcreteBuffer x) = prettyHex 40 x +prettyIfConcreteCd :: Calldata -> String +prettyIfConcreteCd (CalldataBuffer bf) = prettyIfConcrete bf +prettyIfConcreteCd (CalldataDynamic (x, l)) = show x + drawTracePane :: UiVmState -> UiWidget drawTracePane s = case view uiShowMemory s of True -> hBorderWithLabel (txt "Calldata") - <=> str (prettyIfConcrete $ view (uiVm . state . calldata) s) + <=> str (prettyIfConcreteCd $ view (uiVm . state . calldata) s) <=> hBorderWithLabel (txt "Returndata") <=> str (prettyIfConcrete (view (uiVm . state . returndata) s)) <=> hBorderWithLabel (txt "Output") diff --git a/src/hevm/src/EVM/UnitTest.hs b/src/hevm/src/EVM/UnitTest.hs index 6f9a7d015..0a02bf3e6 100644 --- a/src/hevm/src/EVM/UnitTest.hs +++ b/src/hevm/src/EVM/UnitTest.hs @@ -553,7 +553,7 @@ setupCall TestVMParams{..} sig args = do use (env . contracts) >>= assign (tx . txReversion) assign (tx . isCreate) False loadContract testAddress - assign (state . calldata) (ConcreteBuffer $ abiMethod sig args) + assign (state . calldata) (CalldataBuffer (ConcreteBuffer $ abiMethod sig args)) assign (state . caller) (litAddr testCaller) assign (state . gas) (w256 testGasCall) @@ -563,7 +563,7 @@ initialUnitTestVm (UnitTestOptions {..}) theContract = TestVMParams {..} = testParams vm = makeVm $ VMOpts { vmoptContract = initialContract (InitCode (view creationCode theContract)) - , vmoptCalldata = mempty + , vmoptCalldata = CalldataBuffer mempty , vmoptValue = 0 , vmoptAddress = testAddress , vmoptCaller = litAddr testCaller diff --git a/src/hevm/src/EVM/VMTest.hs b/src/hevm/src/EVM/VMTest.hs index b31d4a10d..6212e93ae 100644 --- a/src/hevm/src/EVM/VMTest.hs +++ b/src/hevm/src/EVM/VMTest.hs @@ -255,7 +255,7 @@ parseVmOpts v = (JSON.Object env, JSON.Object exec) -> EVM.VMOpts <$> (dataField exec "code" >>= pure . EVM.initialContract . EVM.RuntimeCode) - <*> (dataField exec "data" >>= pure . ConcreteBuffer) + <*> (dataField exec "data" >>= pure . CalldataBuffer . ConcreteBuffer) <*> (w256lit <$> wordField exec "value") <*> addrField exec "address" <*> (litAddr <$> addrField exec "caller") @@ -376,7 +376,7 @@ fromCreateBlockchainCase block tx preState postState = in Right $ Case (EVM.VMOpts { vmoptContract = EVM.initialContract (EVM.InitCode (txData tx)) - , vmoptCalldata = mempty + , vmoptCalldata = CalldataBuffer mempty , vmoptValue = w256lit $ txValue tx , vmoptAddress = createdAddr , vmoptCaller = (litAddr origin) @@ -415,7 +415,7 @@ fromNormalBlockchainCase block tx preState postState = (_, _, Just origin, Just checkState) -> Right $ Case (EVM.VMOpts { vmoptContract = EVM.initialContract theCode - , vmoptCalldata = ConcreteBuffer $ txData tx + , vmoptCalldata = CalldataBuffer $ ConcreteBuffer $ txData tx , vmoptValue = litWord (EVM.w256 $ txValue tx) , vmoptAddress = toAddr , vmoptCaller = (litAddr origin) diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index 81f2ed005..c22174945 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -273,33 +273,35 @@ main = defaultMain $ testGroup "hevm" in case view result poststate of Just (VMSuccess (StaticSymBuffer out)) -> (fromBytes out) .== x + y _ -> sFalse - Left (_, res) <- runSMT $ query $ verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre post + Left (_, res) <- runSMT $ query $ verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS BoundedCD pre post putStrLn $ "successfully explored: " <> show (length res) <> " paths" , - -- testCase "x == y => x + y == 2 * y" $ do - -- Just safeAdd <- solcRuntime "SafeAdd" - -- [i| - -- contract SafeAdd { - -- function add(uint x, uint y) public pure returns (uint z) { - -- require((z = x + y) >= x); - -- } - -- } - -- |] - -- let pre preVM = let [x, y] = getStaticAbiArgs preVM - -- in (x .<= x + y) - -- .&& (x .== y) - -- .&& view (state . callvalue) preVM .== 0 - -- post (prestate, poststate) = - -- let [_, y] = getStaticAbiArgs prestate - -- in case view result poststate of - -- Just (VMSuccess (StaticSymBuffer out)) -> fromBytes out .== 2 * y - -- _ -> sFalse - -- Left (_, res) <- runSMTWith z3 $ query $ - -- verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) - -- putStrLn $ "successfully explored: " <> show (length res) <> " paths" - -- , + testCase "x == y => x + y == 2 * y" $ do + Just safeAdd <- solcRuntime "SafeAdd" + [i| + contract SafeAdd { + function add(uint x, uint y) public pure returns (uint z) { + require((z = x + y) >= x); + } + } + |] + let pre preVM = let [x, y] = getStaticAbiArgs preVM + in (x .<= x + y) + .&& (x .== y) + .&& view (state . callvalue) preVM .== 0 + post (prestate, poststate) = + let [_, y] = getStaticAbiArgs prestate + in case view result poststate of + Just (VMSuccess (StaticSymBuffer out)) -> fromBytes out .== 2 * y + _ -> sFalse + Left (_, res) <- runSMTWith z3 $ query $ + verifyContract safeAdd (Just ("add(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS BoundedCD pre (Just post) + putStrLn $ "successfully explored: " <> show (length res) <> " paths" + + , + testCase "factorize 973013" $ do Just factor <- solcRuntime "PrimalityCheck" [i| @@ -312,8 +314,8 @@ main = defaultMain $ testGroup "hevm" |] bs <- runSMTWith cvc4 $ query $ do Right vm <- checkAssert factor (Just ("factor(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] - case view (state . calldata . _1) vm of - StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + case view (state . calldata) vm of + CalldataBuffer (StaticSymBuffer bs) -> BS.pack <$> mapM (getValue.fromSized) bs _ -> error "unexpected" let [AbiUInt 256 x, AbiUInt 256 y] = decodeAbiValues [AbiUIntType 256, AbiUIntType 256] bs @@ -344,7 +346,7 @@ main = defaultMain $ testGroup "hevm" in case view result poststate of Just (VMSuccess _) -> prex + 2 * y .== postx _ -> sFalse - Left (_, res) <- runSMT $ query $ verifyContract c (Just ("f(uint256)", [AbiUIntType 256])) [] SymbolicS pre post + Left (_, res) <- runSMT $ query $ verifyContract c (Just ("f(uint256)", [AbiUIntType 256])) [] SymbolicS BoundedCD pre post putStrLn $ "successfully explored: " <> show (length res) <> " paths" , -- Inspired by these `msg.sender == to` token bugs @@ -376,9 +378,9 @@ main = defaultMain $ testGroup "hevm" Just (VMSuccess _) -> prex + prey .== postx + (posty :: SWord 256) _ -> sFalse bs <- runSMT $ query $ do - Right vm <- verifyContract c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS pre (Just post) - case view (state . calldata . _1) vm of - StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + Right vm <- verifyContract c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] SymbolicS BoundedCD pre (Just post) + case view (state . calldata) vm of + CalldataBuffer (StaticSymBuffer bs) -> BS.pack <$> mapM (getValue.fromSized) bs _ -> error "unexpected" let [AbiUInt 256 x, AbiUInt 256 y] = decodeAbiValues [AbiUIntType 256, AbiUIntType 256] bs @@ -449,8 +451,8 @@ main = defaultMain $ testGroup "hevm" |] bs <- runSMT $ query $ do Right vm <- checkAssert c (Just ("deposit(uint8)", [AbiUIntType 8])) [] - case view (state . calldata . _1) vm of - StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + case view (state . calldata) vm of + CalldataBuffer (StaticSymBuffer bs) -> BS.pack <$> mapM (getValue.fromSized) bs _ -> error "unexpected" let [deposit] = decodeAbiValues [AbiUIntType 8] bs @@ -507,8 +509,8 @@ main = defaultMain $ testGroup "hevm" |] bs <- runSMTWith z3 $ query $ do Right vm <- checkAssert c (Just ("f(uint256,uint256,uint256,uint256)", replicate 4 (AbiUIntType 256))) [] - case view (state . calldata . _1) vm of - StaticSymBuffer bs -> BS.pack <$> mapM (getValue.fromSized) bs + case view (state . calldata) vm of + CalldataBuffer (StaticSymBuffer bs) -> BS.pack <$> mapM (getValue.fromSized) bs _ -> error "unexpected" let [AbiUInt 256 x, @@ -578,7 +580,7 @@ main = defaultMain $ testGroup "hevm" Just c <- solcRuntime "C" code Just a <- solcRuntime "A" code Right cex <- runSMT $ query $ do - vm0 <- abstractVM (Just ("call_A()", [])) [] c SymbolicS + vm0 <- abstractVM (Just ("call_A()", [])) [] c SymbolicS BoundedCD store <- freshArray (show aAddr) Nothing let vm = vm0 & set (state . callvalue) 0 @@ -625,7 +627,7 @@ main = defaultMain $ testGroup "hevm" -- should find a counterexample Left (_, res) <- runSMTWith z3{verbose=True} $ do -- setTimeOut 20000 - query $ checkAssert c Nothing [] + query $ checkAssertBuffer c putStrLn $ "successfully explored: " <> show (length res) <> " paths" ] , testGroup "Equivalence checking" @@ -642,7 +644,7 @@ main = defaultMain $ testGroup "hevm" -- } } let aPrgm = hex "602060006000376000805160008114601d5760018114602457fe6029565b8191506029565b600191505b50600160015250" bPrgm = hex "6020600060003760005160008114601c5760028114602057fe6021565b6021565b5b506001600152" - runSMTWith z3 $ query $ do + runSMTWith cvc4 $ query $ do Right counterexample <- equivalenceCheck aPrgm bPrgm Nothing Nothing return () @@ -656,7 +658,7 @@ runSimpleVM :: ByteString -> ByteString -> Maybe ByteString runSimpleVM x ins = case loadVM x of Nothing -> Nothing Just vm -> - case runState (assign (state.calldata) (ConcreteBuffer ins) >> exec) vm of + case runState (assign (state.calldata) (CalldataBuffer $ ConcreteBuffer ins) >> exec) vm of (VMSuccess (ConcreteBuffer bs), _) -> Just bs _ -> Nothing @@ -722,8 +724,8 @@ runStatements stmts args t = do getStaticAbiArgs :: VM -> [SWord 256] getStaticAbiArgs vm = - let SymbolicBuffer bs = ditch 4 $ view (state . calldata . _1) vm - in fmap (\i -> fromBytes $ take 32 (drop (i*32) bs)) [0..((length bs) `div` 32 - 1)] + let CalldataBuffer (StaticSymBuffer bs) = view (state . calldata) vm + in fmap (\i -> fromBytes $ take 32 (drop (i*32) (drop 4 bs))) [0..((length (drop 4 bs)) `div` 32 - 1)] -- includes shaving off 4 byte function sig decodeAbiValues :: [AbiType] -> ByteString -> [AbiValue] From 0884f9ccc33344aa8d8931ea28095daf48452995 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 9 Sep 2020 22:19:36 +0200 Subject: [PATCH 25/36] put dynamic buffer test in dapp-test instead of hevm --- src/dapp-tests/bytes.sol | 7 ++++ src/dapp-tests/integration/tests.sh | 4 ++ src/dapp-tests/shell.nix | 2 +- src/hevm/hevm-cli/hevm-cli.hs | 59 ++++++++++++++++++----------- src/hevm/src/EVM.hs | 4 +- src/hevm/src/EVM/Fetch.hs | 2 +- src/hevm/src/EVM/SymExec.hs | 6 +-- src/hevm/src/EVM/Symbolic.hs | 9 +++-- src/hevm/test/test.hs | 50 ++++++++---------------- 9 files changed, 76 insertions(+), 67 deletions(-) create mode 100644 src/dapp-tests/bytes.sol diff --git a/src/dapp-tests/bytes.sol b/src/dapp-tests/bytes.sol new file mode 100644 index 000000000..dbec0336c --- /dev/null +++ b/src/dapp-tests/bytes.sol @@ -0,0 +1,7 @@ +contract Bytes +{ + function f(bytes memory b1, bytes memory b2) public pure { + b1 = b2; + assert(b1[1] == b2[1]); + } +} diff --git a/src/dapp-tests/integration/tests.sh b/src/dapp-tests/integration/tests.sh index 5296a50fa..05a82427a 100755 --- a/src/dapp-tests/integration/tests.sh +++ b/src/dapp-tests/integration/tests.sh @@ -66,6 +66,10 @@ test_hevm_symbolic() { solc --bin-runtime -o . --overwrite AB.sol hevm equivalence --code-a $( "Block state is be fetched from" -- symbolic execution opts - , jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" - , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" - , storageModel :: w ::: Maybe StorageModel "Select storage model: ConcreteS, SymbolicS (default) or InitialS" - , sig :: w ::: Maybe Text "Signature of types to decode / encode" - , arg :: w ::: [String] "Values to encode" - , debug :: w ::: Bool "Run interactively" - , getModels :: w ::: Bool "Print example testcase for each execution path" - , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 20000)" - , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" - , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" - , smtoutput :: w ::: Bool "Print verbose smt output" + , jsonFile :: w ::: Maybe String "Filename or path to dapp build output (default: out/*.solc.json)" + , dappRoot :: w ::: Maybe String "Path to dapp project root directory (default: . )" + , storageModel :: w ::: Maybe StorageModel "Select storage model: ConcreteS, SymbolicS (default) or InitialS" + , calldataModel :: w ::: Maybe CalldataModel "Select calldata model: BoundedCD (default), or DynamicCD" + , sig :: w ::: Maybe Text "Signature of types to decode / encode" + , arg :: w ::: [String] "Values to encode" + , debug :: w ::: Bool "Run interactively" + , getModels :: w ::: Bool "Print example testcase for each execution path" + , smttimeout :: w ::: Maybe Integer "Timeout given to SMT solver in milliseconds (default: 20000)" + , maxIterations :: w ::: Maybe Integer "Number of times we may revisit a particular branching point" + , solver :: w ::: Maybe Text "Used SMT solver: z3 (default) or cvc4" + , smtoutput :: w ::: Bool "Print verbose smt output" } | Equivalence -- prove equivalence between two programs { codeA :: w ::: ByteString "Bytecode of the first program" @@ -681,7 +683,7 @@ vmFromCommand cmd = do value' = word value 0 caller' = addr caller 0 origin' = addr origin 0 - calldata' = ConcreteBuffer $ bytes calldata "" + calldata' = CalldataBuffer $ ConcreteBuffer $ bytes calldata "" codeType = if create cmd then EVM.InitCode else EVM.RuntimeCode address' = if create cmd then createAddress origin' (word nonce 0) @@ -716,18 +718,29 @@ symvmFromCommand :: Command Options.Unwrapped -> Query EVM.VM symvmFromCommand cmd = do caller' <- maybe (SAddr <$> freshVar_) (return . litAddr) (caller cmd) callvalue' <- maybe (sw256 <$> freshVar_) (return . w256lit) (value cmd) - calldata' <- case (calldata cmd, sig cmd) of - -- static calldata (up to 256 bytes) - (Nothing, Nothing) -> do - StaticSymBuffer <$> sbytes256 + (calldata', preCond) <- case (calldata cmd, sig cmd, calldataModel cmd) of + -- dynamic calldata via smt lists + (Nothing, Nothing, Just DynamicCD) -> do + cd <- freshVar_ + return (CalldataBuffer (DynamicSymBuffer cd), + SList.length cd .< 1000 .&& + sw256 (sFromIntegral (SList.length cd)) .< sw256 1000) + + -- dynamic calldata via (bounded) haskell list + (Nothing, Nothing, _) -> do + cd <- sbytes256 + len <- freshVar_ + return (CalldataDynamic (cd, len), len .<= 256) + -- fully concrete calldata - (Just c, Nothing) -> - return $ ConcreteBuffer $ decipher c + (Just c, Nothing, _) -> + return (CalldataBuffer (ConcreteBuffer $ decipher c), sTrue) -- calldata according to given abi with possible specializations from the `arg` list - (Nothing, Just sig') -> do + (Nothing, Just sig', _) -> do method' <- io $ functionAbi sig' let typs = snd <$> view methodInputs method' - StaticSymBuffer <$> staticCalldata (view methodSignature method') typs (arg cmd) + cd <- staticCalldata (view methodSignature method') typs (arg cmd) + return (CalldataBuffer (StaticSymBuffer cd), sTrue) _ -> error "incompatible options: calldata and abi" @@ -773,7 +786,7 @@ symvmFromCommand cmd = do (_, _, Nothing) -> error $ "must provide at least (rpc + address) or code" - return vm + return $ vm & over EVM.pathConditions (<> [preCond]) where decipher = hexByteString "bytes" . strip0x diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index e46861c98..d89416b52 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -315,7 +315,7 @@ instance ParseField StorageModel -- | Calldata can either by a normal buffer, or a custom "pseudo dynamic" encoding. See EVM.Symbolic for details data CalldataModel - = BufferCD + = DynamicCD | BoundedCD deriving (Read, Show) @@ -2213,7 +2213,7 @@ copyCalldataToMemory (CalldataBuffer bf) size xOffset yOffset = copyCalldataToMemory (CalldataDynamic (b, l)) size xOffset yOffset = case (maybeLitWord size, maybeLitWord xOffset, maybeLitWord yOffset) of (Just size', Just xOffset', Just yOffset') -> - copyBytesToMemory (StaticSymBuffer [ite (i .<= l) x 0 | (x, i) <- zip b [1..]]) size' xOffset' yOffset' + copyBytesToMemory (StaticSymBuffer [ite (i .<= l) x 0 | (x, i) <- zip b [1..]]) (litWord size') (litWord xOffset') (litWord yOffset') _ -> copyBytesToMemory (DynamicSymBuffer (subList (implode b) 0 (sFromIntegral l))) size xOffset yOffset diff --git a/src/hevm/src/EVM/Fetch.hs b/src/hevm/src/EVM/Fetch.hs index c59912ac1..4050a3d14 100644 --- a/src/hevm/src/EVM/Fetch.hs +++ b/src/hevm/src/EVM/Fetch.hs @@ -187,7 +187,7 @@ checksat b = do push 1 b <- getInfo Name m <- case b of -- some custom strategies for z3 which have proven to be quite useful (can still be tweaked) - Resp_Name "Z3" -> checkSatUsing "(check-sat-using (then (using-params simplify :cache-all true) smt))" + Resp_Name "Z3" -> checkSatUsing "(check-sat-using (then (using-params simplify :push_ite_bv true :ite_extra_rules true) smt))" _ -> checkSat pop 1 return m diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index cb400be78..0c6f488e2 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -99,7 +99,7 @@ abstractVM :: Maybe (Text, [AbiType]) -> [String] -> ByteString -> StorageModel abstractVM typesignature concreteArgs x storagemodel calldatamodel = do (cd',pathCond) <- case typesignature of Nothing -> case calldatamodel of - BufferCD -> do + DynamicCD -> do list <- freshVar_ return (CalldataBuffer (DynamicSymBuffer list), -- due to some current z3 shenanegans (possibly related to: https://github.com/Z3Prover/z3/issues/4635) @@ -221,8 +221,8 @@ maxIterationsReached vm (Just maxIter) = type Precondition = VM -> SBool type Postcondition = (VM, VM) -> SBool -checkAssertBuffer :: ByteString -> Query (Either (VM, [VM]) VM) -checkAssertBuffer c = verifyContract c Nothing [] SymbolicS BufferCD (const sTrue) (Just checkAssertions) +checkAssertDynamic :: ByteString -> Query (Either (VM, [VM]) VM) +checkAssertDynamic c = verifyContract c Nothing [] SymbolicS DynamicCD (const sTrue) (Just checkAssertions) checkAssert :: ByteString -> Maybe (Text, [AbiType]) -> [String] -> Query (Either (VM, [VM]) VM) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 1c06189b3..0a7046c3d 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -62,7 +62,10 @@ forceLitBytes = BS.pack . fmap (fromSized . fromJust . unliteral) forceBuffer :: Buffer -> ByteString forceBuffer (ConcreteBuffer b) = b -forceBuffer (SymbolicBuffer b) = forceLitBytes b +forceBuffer (StaticSymBuffer b) = forceLitBytes b +forceBuffer (DynamicSymBuffer b) = case unliteral b of + Just b' -> BS.pack $ fmap fromSized b' + Nothing -> error "unexpected symbolic argument" -- | Arithmetic operations on SymWord @@ -331,13 +334,13 @@ readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (literal $ num i) bs --- pad up to 10000 bytes in the dynamic case +-- pad up to 1000 bytes in the dynamic case sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer sliceWithZero (S _ o) (S _ s) bf = case (unliteral o, unliteral s, bf) of (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) (Just o', Just s', m) -> truncpad' (num s') (ditch (num o') m) - _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 10000 0)) (sFromIntegral o) (sFromIntegral s) + _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 1000 0)) (sFromIntegral o) (sFromIntegral s) writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer writeMemory bs1 n src dst bs0 = diff --git a/src/hevm/test/test.hs b/src/hevm/test/test.hs index c22174945..7dda52a8c 100644 --- a/src/hevm/test/test.hs +++ b/src/hevm/test/test.hs @@ -558,9 +558,9 @@ main = defaultMain $ testGroup "hevm" Right counterexample <- runSMTWith cvc4 $ query $ checkAssert c (Just ("f(uint256,uint256)", [AbiUIntType 256, AbiUIntType 256])) [] putStrLn $ "found counterexample:" + , - , - testCase "multiple contracts" $ do + testCase "multiple contracts" $ do let code = [i| contract C { @@ -589,46 +589,28 @@ main = defaultMain $ testGroup "hevm" set EVM.storage (Symbolic store))) verify vm Nothing Nothing (Just checkAssertions) putStrLn $ "found counterexample:" - -- , - -- testCase "dynamic bytes (calldataload)" $ do - -- Just c <- solcRuntime "C" - -- [i| - -- contract C - -- { - -- function f() public pure { - -- uint y; - -- uint z; - -- assembly { - -- y := calldataload(12) - -- z := calldataload(31) - -- } - -- assert(y == z); - -- } - -- } - -- |] - -- -- should find a counterexample - -- Right cex <- runSMTWith z3 $ do - -- query $ checkAssert c Nothing [] - -- putStrLn $ "found counterexample" - - - -- , - testCase "dynamic bytes (abi decoding)" $ do + , + testCase "dynamic bytes (calldataload)" $ do Just c <- solcRuntime "C" [i| contract C { - function f(bytes memory b1, bytes memory b2) public pure { - b1 = b2; - assert(b1[1] == b2[1]); + function f() public pure { + uint y; + uint z; + assembly { + y := calldataload(12) + z := calldataload(31) } + assert(y == z); + } } |] -- should find a counterexample - Left (_, res) <- runSMTWith z3{verbose=True} $ do --- setTimeOut 20000 - query $ checkAssertBuffer c - putStrLn $ "successfully explored: " <> show (length res) <> " paths" + Right cex <- runSMTWith z3 $ do + query $ checkAssert c Nothing [] + putStrLn $ "found counterexample" + ] , testGroup "Equivalence checking" [ From f59a912d996325feb6b84cbbc11c1d864874098b Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Mon, 14 Sep 2020 15:19:56 +0200 Subject: [PATCH 26/36] fix rebase fuckups --- src/hevm/src/EVM/Symbolic.hs | 39 ++++++++++-------------------------- src/hevm/src/EVM/Types.hs | 2 ++ 2 files changed, 13 insertions(+), 28 deletions(-) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 0a7046c3d..d0d6b56aa 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -101,9 +101,9 @@ sgt (S _ x) (S _ y) = shiftRight' :: SymWord -> SymWord -> SymWord shiftRight' (S _ a') b@(S _ b') = case (num <$> unliteral a', b) of - (Just n, (S (FromBytes (SymbolicBuffer a)) _)) | n `mod` 8 == 0 && n <= 256 -> + (Just n, (S (FromBytes (StaticSymBuffer a)) _)) | n `mod` 8 == 0 && n <= 256 -> let bs = replicate (n `div` 8) 0 <> (take ((256 - n) `div` 8) a) - in S (FromBytes (SymbolicBuffer bs)) (fromBytes bs) + in S (FromBytes (StaticSymBuffer bs)) (fromBytes bs) _ -> sw256 $ sShiftRight b' a' -- | Operations over static symbolic memory (list of symbolic bytes) @@ -154,7 +154,8 @@ truncpad' n m = case m of Nothing -> StaticSymBuffer $ takeStatic n (xs .++ literal (replicate n 0)) swordAt :: Int -> [SWord 8] -> SymWord -swordAt i bs = sw256 . fromBytes $ truncpad 32 $ drop i bs +swordAt i bs = let b = truncpad 32 $ drop i bs + in S (FromBytes (StaticSymBuffer b)) (fromBytes b) swordAt' :: SymWord -> SList (WordN 8) -> SymWord swordAt' i@(S _ i') bs = @@ -213,29 +214,6 @@ readByteOrZero'' i bs = (bs .!! (sFromIntegral i)) (literal 0) --- Generates a ridiculously large set of constraints (roughly 25k) when --- the index is symbolic, but it still seems (kind of) manageable --- for the solvers. -readSWordWithBound :: SWord 32 -> Buffer -> SWord 32 -> SymWord -readSWordWithBound ind (SymbolicBuffer xs) bound = case (num <$> fromSized <$> unliteral ind, num <$> fromSized <$> unliteral bound) of - (Just i, Just b) -> - let bs = truncpad 32 $ drop i (take b xs) - in S (FromBytes (SymbolicBuffer bs)) (fromBytes bs) - _ -> - let boundedList = [ite (i .<= bound) x 0 | (x, i) <- zip xs [1..]] - in sw256 . fromBytes $ [select' boundedList 0 (ind + j) | j <- [0..31]] - -readSWordWithBound ind (ConcreteBuffer xs) bound = - case fromSized <$> unliteral ind of - Nothing -> readSWordWithBound ind (SymbolicBuffer (litBytes xs)) bound - Just x' -> - -- INVARIANT: bound should always be length xs for concrete bytes - -- so we should be able to safely ignore it here - litWord $ Concrete.readMemoryWord (num x') xs - -readMemoryWord' :: Word -> [SWord 8] -> SymWord -readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) - -- pad up to 1000 bytes sslice :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) sslice (S _ o) (S _ l) bs = case (unliteral $ SL.length bs, unliteral (o + l)) of @@ -405,8 +383,13 @@ select' xs err ind = walk xs ind err -- for the solvers. readStaticWordWithBound :: SWord 32 -> ([SWord 8], SWord 32) -> SymWord readStaticWordWithBound ind (xs, bound) = - let boundedList = [ite (i .<= bound) x 0 | (x, i) <- zip xs [1..]] - in sw256 . fromBytes $ [select' boundedList 0 (ind + j) | j <- [0..31]] + case (num <$> fromSized <$> unliteral ind, num <$> fromSized <$> unliteral bound) of + (Just i, Just b) -> + let bs = truncpad 32 $ drop i (take b xs) + in S (FromBytes (StaticSymBuffer bs)) (fromBytes bs) + _ -> + let boundedList = [ite (i .<= bound) x 0 | (x, i) <- zip xs [1..]] + in sw256 $ fromBytes [select' boundedList 0 (ind + j) | j <- [0..31]] -- | Custom instances for SymWord, many of which have direct -- analogues for concrete words defined in Concrete.hs diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index d2c7a97eb..421e219fb 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -14,6 +14,8 @@ import Data.Aeson (FromJSONKey (..), FromJSONKeyFunction (..)) #endif import Data.SBV +import Data.SBV.List ((.++)) +import qualified Data.SBV.List as SL import Data.Kind import Data.Monoid ((<>)) import Data.Bifunctor (first) From 90fb4f76436fddd4a8c3f1340c7f09584a015ba3 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Mon, 14 Sep 2020 15:54:52 +0200 Subject: [PATCH 27/36] don't change which tests are run --- nix/hevm-tests/default.nix | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/nix/hevm-tests/default.nix b/nix/hevm-tests/default.nix index 0187eb29d..e18ff5b33 100644 --- a/nix/hevm-tests/default.nix +++ b/nix/hevm-tests/default.nix @@ -11,9 +11,9 @@ let in { yulEquivalence-z3 = runWithSolver ./yul-equivalence.nix "z3"; - #yulEquivalence-cvc4 = runWithSolver ./yul-equivalence.nix "cvc4"; + yulEquivalence-cvc4 = runWithSolver ./yul-equivalence.nix "cvc4"; # z3 takes 3hrs to run these tests on a fast machine, and even then ~180 timeout - smtChecker-z3 = runWithSolver ./smt-checker.nix "z3"; - #smtChecker-cvc4 = runWithSolver ./smt-checker.nix "cvc4"; + #smtChecker-z3 = runWithSolver ./smt-checker.nix "z3"; + smtChecker-cvc4 = runWithSolver ./smt-checker.nix "cvc4"; } From 35e8d51632a8c2b23cbed2d3810332be99d48c2d Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 15 Sep 2020 11:39:57 +0200 Subject: [PATCH 28/36] fix concrete RETURNDATA --- src/hevm/src/EVM.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index d89416b52..e084d275c 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -813,10 +813,16 @@ exec1 = do accessUnboundedMemoryRange fees xTo xSize $ do next assign (state . stack) xs - -- TODO: consult smt about possible failure here - -- if len (the state returndata) < num xFrom + num xSize - -- then vmError InvalidMemoryAccess - copyBytesToMemory (the state returndata) xSize xFrom xTo + case unliteral $ len (the state returndata) .< xFrom + xSize of + Nothing -> + --TODO: consult smt about possible failure here + copyBytesToMemory (the state returndata) xSize xFrom xTo + + Just res -> + if res + then vmError InvalidMemoryAccess + else copyBytesToMemory (the state returndata) xSize xFrom xTo + _ -> underrun -- op: EXTCODEHASH From c1247710ef583953d6c7c58eb9b64dd20b0ef8f9 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 15 Sep 2020 14:11:12 +0200 Subject: [PATCH 29/36] simplify refunds --- src/hevm/src/EVM.hs | 34 +++++++++++++++++----------------- src/hevm/src/EVM/TTY.hs | 2 ++ 2 files changed, 19 insertions(+), 17 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index e084d275c..e7e329e57 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -250,7 +250,7 @@ data TxState = TxState data SubState = SubState { _selfdestructs :: [Addr] , _touchedAccounts :: [Addr] - , _refunds :: [(Addr, Word)] -- TODO: make symbolic as well + , _refunds :: Word -- TODO: make symbolic as well -- in principle we should include logs here, but do not for now } @@ -406,7 +406,7 @@ makeVm o = VM , _origin = vmoptOrigin o , _toAddr = vmoptAddress o , _value = vmoptValue o - , _substate = SubState mempty mempty mempty + , _substate = SubState mempty mempty 0 , _isCreate = vmoptCreate o , _txReversion = Map.fromList [(vmoptAddress o, vmoptContract o)] @@ -953,14 +953,17 @@ exec1 = do (ite (current .== original) (litWord g_sreset) (litWord g_sload))) - anticost = ite (current .== new) 0 - (ite (current .== original) - (ite (original ./= 0 .&& new .== 0) (litWord r_sclear) 0) - (ite (original ./= 0) - (ite (new .== 0) (litWord r_sclear) 0) - (ite (original .== 0) - (litWord (g_sset - g_sload)) - (litWord (g_sreset - g_sload))))) + anticost = ite (current .== new) + 0 + (ite (current .== original) + (ite (original ./= 0 .&& new .== 0) (litWord r_sclear) 0) + ((ite (original ./= 0) + (ite (new .== 0) (litWord r_sclear) 0) + 0) + + + (ite (original .== 0) + (litWord (g_sset - g_sload)) + (litWord (g_sreset - g_sload))))) unrefund = ite (current ./= new .&& current ./= original .&& @@ -1627,7 +1630,7 @@ finalize = do let burnRemainingGas = use (state . gas) >>= flip burn noop revertContracts = use (tx . txReversion) >>= assign (env . contracts) - revertSubstate = assign (tx . substate) (SubState mempty mempty mempty) + revertSubstate = assign (tx . substate) (SubState mempty mempty 0) use result >>= \case Nothing -> @@ -1650,7 +1653,7 @@ finalize = do -- compute and pay the refund to the caller and the -- corresponding payment to the miner txOrigin <- use (tx . origin) - sumRefunds <- (sum . (snd <$>)) <$> (use (tx . substate . refunds)) + sumRefunds <- use (tx . substate . refunds) miner <- use (block . coinbase) blockReward <- r_block <$> (use (block . schedule)) gasPrice <- use (tx . gasprice) @@ -1791,7 +1794,7 @@ refundSym n = case maybeLitWord n of refund :: Word -> EVM () refund n = do self <- use (state . contract) - pushTo (tx . substate . refunds) (self, n) + tx . substate . refunds += n unRefundSym :: SymWord -> EVM () unRefundSym n = case maybeLitWord n of @@ -1800,10 +1803,7 @@ unRefundSym n = case maybeLitWord n of unRefund :: Word -> EVM () unRefund n = do - self <- use (state . contract) - refs <- use (tx . substate . refunds) - assign (tx . substate . refunds) - (filter (\(a,b) -> not (a == self && b == n)) refs) + tx . substate . refunds -= n touchAccount :: Addr -> EVM() touchAccount = pushTo ((tx . substate) . touchedAccounts) diff --git a/src/hevm/src/EVM/TTY.hs b/src/hevm/src/EVM/TTY.hs index 015851b9b..926f58436 100644 --- a/src/hevm/src/EVM/TTY.hs +++ b/src/hevm/src/EVM/TTY.hs @@ -884,6 +884,8 @@ drawTracePane s = <=> str (maybe "" show (view (uiVm . result) s)) <=> hBorderWithLabel (txt "Cache") <=> str (show (view (uiVm . cache . path) s)) + <=> hBorderWithLabel (txt "refund") + <=> str (show (view (uiVm . tx . substate . refunds) s)) <=> hBorderWithLabel (txt "Memory") <=> viewport TracePane Vertical (str (prettyIfConcrete (view (uiVm . state . memory) s))) From b41dd3eb82c2b037460ee383d7c526135e4059a5 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 15 Sep 2020 15:15:13 +0200 Subject: [PATCH 30/36] fix SSTORE accounting --- src/hevm/src/EVM.hs | 42 ++++++++++++++++++------------------------ 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index e7e329e57..2d7a53793 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -947,30 +947,24 @@ exec1 = do then finishFrame (FrameErrored (OutOfGas availableGas g_callstipend)) else do let original = fromMaybe 0 (readStorage (view origStorage this) x) - - cost = ite (current .== new) (litWord g_sload) - (ite (current .== original .&& original .== 0) (litWord g_sset) - (ite (current .== original) (litWord g_sreset) - (litWord g_sload))) - - anticost = ite (current .== new) - 0 - (ite (current .== original) - (ite (original ./= 0 .&& new .== 0) (litWord r_sclear) 0) - ((ite (original ./= 0) - (ite (new .== 0) (litWord r_sclear) 0) - 0) - + - (ite (original .== 0) - (litWord (g_sset - g_sload)) - (litWord (g_sreset - g_sload))))) - - unrefund = ite (current ./= new .&& - current ./= original .&& - original ./= 0 .&& - new ./= 0) - (litWord r_sclear) - 0 + pairPlus :: (SymWord, SymWord) -> (SymWord, SymWord) -> (SymWord, SymWord) + pairPlus (a,b) (c,d) = (a + c, b + d) + (cost, (anticost, unrefund)) = + ite (current .== new) (litWord g_sload, (0, 0)) + (ite (original .== current) + (ite (original .== 0) (litWord g_sset, (0, 0)) + (ite (new .== 0) (litWord g_sreset, (litWord r_sclear, 0)) + (litWord g_sreset, (0, 0)))) + -- cost always g_sload in this clause + (litWord g_sload, pairPlus + (ite (original ./= 0) + (pairPlus (ite (current .== 0) (0, litWord r_sclear) (0,0)) + (ite (new .== 0) (litWord r_sclear, 0) (0,0))) + (0,0)) + (ite (original .== new) + (ite (original .== 0) (litWord (g_sset - g_sload), 0) + (litWord (g_sreset - g_sload), 0)) + (0,0)))) burnSym cost $ do next From 174f487201c6b359d75dfc9100a0371500606f17 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 15 Sep 2020 18:00:19 +0200 Subject: [PATCH 31/36] fix memory access accounting in concrete case --- src/hevm/src/EVM.hs | 31 +++++++++++++------------------ 1 file changed, 13 insertions(+), 18 deletions(-) diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 2d7a53793..99e22b03b 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -2171,20 +2171,15 @@ accessUnboundedMemoryRange -> SymWord -> EVM () -> EVM () -accessUnboundedMemoryRange fees f l continue = do - m0 <- use (state . memorySize) - case (maybeLitWord f, maybeLitWord l, unliteral m0) of - (Just f', Just l', Just (num -> m0')) -> do - let m1 = 32 * ceilDiv (max m0' (f' + l')) 32 - burn (memoryCost fees m1 - memoryCost fees m0') $ do - assign (state . memorySize) (num m1) - continue - _ -> do - -- let m1 = 32 * ceilDiv (max m0 (num f + num l)) 32 - -- todo: consult smt here - -- assign (state . memorySize) (num m1) - continue - +accessUnboundedMemoryRange fees f l continue = + if maybe False ((==) 0) (maybeLitWord l) then continue + -- TODO: check for l .== 0 in the symbolic case as well + else do + m0 <- sw256 <$> sFromIntegral <$> use (state . memorySize) + let m1@(S _ m1') = 32 * ceilSDiv (smax m0 (f + l)) 32 + burnSym (memoryCost fees m1 - memoryCost fees m0) $ do + assign (state . memorySize) (sFromIntegral m1') + continue accessMemoryRange :: FeeSchedule Word @@ -2611,12 +2606,12 @@ costOfPrecompile (FeeSchedule {..}) precompileAddr input = _ -> error ("unimplemented precompiled contract " ++ show precompileAddr) -- Gas cost of memory expansion -memoryCost :: FeeSchedule Word -> Word -> Word +memoryCost :: FeeSchedule Word -> SymWord -> SymWord memoryCost FeeSchedule{..} byteCount = let - wordCount = ceilDiv byteCount 32 - linearCost = g_memory * wordCount - quadraticCost = div (wordCount * wordCount) 512 + wordCount = ceilSDiv byteCount 32 + linearCost = litWord g_memory * wordCount + quadraticCost = (wordCount * wordCount) `sDiv` 512 in linearCost + quadraticCost From 248e23262cbf7dc8592b203b2fcf1b8c405f0bbb Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 15 Sep 2020 19:13:57 +0200 Subject: [PATCH 32/36] fix calldataload --- src/hevm/hevm-cli/hevm-cli.hs | 2 +- src/hevm/src/EVM.hs | 14 +++++++------- src/hevm/src/EVM/SymExec.hs | 4 ++-- src/hevm/src/EVM/Symbolic.hs | 32 +++++++++++++++++--------------- 4 files changed, 27 insertions(+), 25 deletions(-) diff --git a/src/hevm/hevm-cli/hevm-cli.hs b/src/hevm/hevm-cli/hevm-cli.hs index ca58e6b7e..3639fe6e5 100644 --- a/src/hevm/hevm-cli/hevm-cli.hs +++ b/src/hevm/hevm-cli/hevm-cli.hs @@ -729,7 +729,7 @@ symvmFromCommand cmd = do -- dynamic calldata via (bounded) haskell list (Nothing, Nothing, _) -> do cd <- sbytes256 - len <- freshVar_ + len <- sw256 <$> freshVar_ return (CalldataDynamic (cd, len), len .<= 256) -- fully concrete calldata diff --git a/src/hevm/src/EVM.hs b/src/hevm/src/EVM.hs index 99e22b03b..a0f591169 100644 --- a/src/hevm/src/EVM.hs +++ b/src/hevm/src/EVM.hs @@ -225,7 +225,7 @@ data FrameState = FrameState , _pc :: Int , _stack :: [SymWord] , _memory :: Buffer - , _memorySize :: SWord 32 + , _memorySize :: SymWord , _calldata :: Calldata , _callvalue :: SymWord , _caller :: SAddr @@ -723,7 +723,7 @@ exec1 = do 0x35 -> stackOp1 (const g_verylow) $ case the state calldata of CalldataBuffer bf -> flip readSWord bf - CalldataDynamic bf -> \(S _ i) -> readStaticWordWithBound (sFromIntegral i) bf + CalldataDynamic bf -> flip readStaticWordWithBound bf -- op: CALLDATASIZE 0x36 -> @@ -1007,7 +1007,7 @@ exec1 = do -- op: MSIZE 0x59 -> limitStack 1 . burn g_base $ - next >> pushSym (sw256 $ sFromIntegral $ the state memorySize) + next >> pushSym (the state memorySize) -- op: GAS 0x5a -> @@ -2175,10 +2175,10 @@ accessUnboundedMemoryRange fees f l continue = if maybe False ((==) 0) (maybeLitWord l) then continue -- TODO: check for l .== 0 in the symbolic case as well else do - m0 <- sw256 <$> sFromIntegral <$> use (state . memorySize) - let m1@(S _ m1') = 32 * ceilSDiv (smax m0 (f + l)) 32 + m0 <- use (state . memorySize) + let m1 = 32 * ceilSDiv (smax m0 (f + l)) 32 burnSym (memoryCost fees m1 - memoryCost fees m0) $ do - assign (state . memorySize) (sFromIntegral m1') + assign (state . memorySize) m1 continue accessMemoryRange @@ -2205,7 +2205,7 @@ copyCalldataToMemory :: Calldata -> SymWord -> SymWord -> SymWord -> EVM () copyCalldataToMemory (CalldataBuffer bf) size xOffset yOffset = copyBytesToMemory bf size xOffset yOffset -copyCalldataToMemory (CalldataDynamic (b, l)) size xOffset yOffset = +copyCalldataToMemory (CalldataDynamic (b, (S _ l))) size xOffset yOffset = case (maybeLitWord size, maybeLitWord xOffset, maybeLitWord yOffset) of (Just size', Just xOffset', Just yOffset') -> copyBytesToMemory (StaticSymBuffer [ite (i .<= l) x 0 | (x, i) <- zip b [1..]]) (litWord size') (litWord xOffset') (litWord yOffset') diff --git a/src/hevm/src/EVM/SymExec.hs b/src/hevm/src/EVM/SymExec.hs index 0c6f488e2..8c13bf8f7 100644 --- a/src/hevm/src/EVM/SymExec.hs +++ b/src/hevm/src/EVM/SymExec.hs @@ -111,7 +111,7 @@ abstractVM typesignature concreteArgs x storagemodel calldatamodel = do BoundedCD -> do cd <- sbytes256 - len <- freshVar_ + len <- sw256 <$> freshVar_ return (CalldataDynamic (cd, len), len .<= 256) Just (name, typs) -> do symbytes <- staticCalldata name typs concreteArgs return (CalldataBuffer (StaticSymBuffer symbytes), sTrue) @@ -340,7 +340,7 @@ showCounterexample vm maybesig = do SAddr caller' = view (EVM.state . EVM.caller) vm -- cdlen' <- num <$> getValue cdlen calldatainput <- case calldata' of - CalldataDynamic (cd, cdlen) -> do + CalldataDynamic (cd, (S _ cdlen)) -> do cdlen' <- num <$> getValue cdlen mapM (getValue.fromSized) (take cdlen' cd) >>= return . pack CalldataBuffer (StaticSymBuffer cd) -> mapM (getValue.fromSized) cd >>= return . pack diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index d0d6b56aa..8c7c77aeb 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -187,8 +187,8 @@ writeMemory' bs1 (C _ n) (C _ src) (C _ dst) bs0 = readMemoryWord' :: Word -> [SWord 8] -> SymWord readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) -readMemoryWord32' :: Word -> [SWord 8] -> SWord 32 -readMemoryWord32' (C _ i) m = fromBytes $ truncpad 4 (drop (num i) m) +readMemoryWord32' :: Word -> [SWord 8] -> SymWord +readMemoryWord32' (C _ i) m = sw256 $ fromBytes $ truncpad 4 (drop (num i) m) setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] setMemoryWord' (C _ i) (S _ x) = @@ -208,8 +208,8 @@ readSWord' (C _ i) x = else swordAt (num i) x -- | Operations over dynamic symbolic memory (smt list of bytes) -readByteOrZero'' :: SWord 32 -> SList (WordN 8) -> SWord 8 -readByteOrZero'' i bs = +readByteOrZero'' :: SymWord -> SList (WordN 8) -> SWord 8 +readByteOrZero'' (S _ i) bs = ite (sFromIntegral (SL.length bs) .> i + 1) (bs .!! (sFromIntegral i)) (literal 0) @@ -265,24 +265,24 @@ read32At :: SInteger -> SList (WordN 8) -> SymWord read32At i x = sw256 $ fromBytes $ [x .!! literal i | i <- [0..31]] -- | Although calldata can be modeled perfectly well directly as a Buffer, --- we allow for it to take on a special form; the pair ([SWord 8], SWord 32) +-- we allow for it to take on a special form; the pair ([SWord 8], SymWord) -- where the second argument is understood as the length of the list. -- This allows us to 'fake' dynamically sized calldata arrays in a way -- that has proven more efficient than `SList`. data Calldata = CalldataBuffer Buffer - | CalldataDynamic ([SWord 8], SWord 32) + | CalldataDynamic ([SWord 8], SymWord) deriving Show -- a whole foldable instance seems overkill, but length is always good to have! -len :: Buffer -> SymWord --SWord 32 +len :: Buffer -> SymWord len (DynamicSymBuffer a) = sw256 $ sFromIntegral $ SL.length a len (StaticSymBuffer bs) = litWord . num $ length bs len (ConcreteBuffer bs) = litWord . num $ BS.length bs cdlen :: Calldata -> SymWord cdlen (CalldataBuffer bf) = len bf -cdlen (CalldataDynamic (_, a)) = sw256 $ sFromIntegral a +cdlen (CalldataDynamic (_, a)) = a grab :: Int -> Buffer -> Buffer grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs @@ -310,7 +310,7 @@ grabS n bs = case unliteral n of readByteOrZero :: Int -> Buffer -> SWord 8 readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs -readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (literal $ num i) bs +readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (litWord $ num i) bs -- pad up to 1000 bytes in the dynamic case sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer @@ -343,11 +343,13 @@ readMemoryWord i bf = case (maybeLitWord i, bf) of readMemoryWord32 :: SymWord -> Buffer -> SWord 32 readMemoryWord32 i m = case (maybeLitWord i, m) of - (Just i', StaticSymBuffer m') -> readMemoryWord32' i' m' + (Just i', StaticSymBuffer m') -> let S _ s = readMemoryWord32' i' m' + in sFromIntegral s (Just i', ConcreteBuffer m') -> num $ Concrete.readMemoryWord32 i' m' (_, DynamicSymBuffer m') -> case truncpad' 4 $ dropS i m' of ConcreteBuffer s -> literal $ num $ Concrete.readMemoryWord32 0 s - StaticSymBuffer s -> readMemoryWord32' 0 s + StaticSymBuffer s -> let S _ s' = readMemoryWord32' 0 s + in sFromIntegral s' DynamicSymBuffer s -> fromBytes [s .!! literal k | k <- [0..3]] @@ -369,7 +371,7 @@ setMemoryByte i x m = case (maybeLitWord i, m) of readSWord :: SymWord -> Buffer -> SymWord readSWord i bf = case (maybeLitWord i, bf) of (Just i', StaticSymBuffer x) -> readSWord' i' x - (Just i', ConcreteBuffer x) -> num $ Concrete.readMemoryWord i' x + (Just i', ConcreteBuffer x) -> litWord $ Concrete.readBlobWord i' x _ -> readSWord'' i (dynamize bf) @@ -381,9 +383,9 @@ select' xs err ind = walk xs ind err -- Generates a ridiculously large set of constraints (roughly 25k) when -- the index is symbolic, but it still seems (kind of) manageable -- for the solvers. -readStaticWordWithBound :: SWord 32 -> ([SWord 8], SWord 32) -> SymWord -readStaticWordWithBound ind (xs, bound) = - case (num <$> fromSized <$> unliteral ind, num <$> fromSized <$> unliteral bound) of +readStaticWordWithBound :: SymWord -> ([SWord 8], SymWord) -> SymWord +readStaticWordWithBound (S _ ind) (xs, S _ bound) = + case (num <$> unliteral ind, num <$> unliteral bound) of (Just i, Just b) -> let bs = truncpad 32 $ drop i (take b xs) in S (FromBytes (StaticSymBuffer bs)) (fromBytes bs) From 5472d0ba627d7582fa37e51c42b88fdd9f2648a7 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 16 Sep 2020 16:32:26 +0200 Subject: [PATCH 33/36] turn on z3 dynamic tests --- nix/hevm-tests/default.nix | 2 +- nix/hevm-tests/smt-checker.nix | 103 +++++++++++++++++++++++++-------- 2 files changed, 80 insertions(+), 25 deletions(-) diff --git a/nix/hevm-tests/default.nix b/nix/hevm-tests/default.nix index e18ff5b33..bb3283b55 100644 --- a/nix/hevm-tests/default.nix +++ b/nix/hevm-tests/default.nix @@ -14,6 +14,6 @@ in yulEquivalence-cvc4 = runWithSolver ./yul-equivalence.nix "cvc4"; # z3 takes 3hrs to run these tests on a fast machine, and even then ~180 timeout - #smtChecker-z3 = runWithSolver ./smt-checker.nix "z3"; + smtChecker-z3 = runWithSolver ./smt-checker.nix "z3"; smtChecker-cvc4 = runWithSolver ./smt-checker.nix "cvc4"; } diff --git a/nix/hevm-tests/smt-checker.nix b/nix/hevm-tests/smt-checker.nix index 56edc20d6..67146d262 100644 --- a/nix/hevm-tests/smt-checker.nix +++ b/nix/hevm-tests/smt-checker.nix @@ -47,6 +47,35 @@ let "types/array_dynamic_3_fail.sol" ]; + z3Timeout = [ + "operators/compound_assignment_division_1.sol" + "operators/compound_assignment_division_2.sol" + "operators/delete_array_index_2d.sol" + ]; + + dynamic = [ + # OpCalldatacopy + "loops/for_loop_array_assignment_memory_memory.sol" + "loops/for_loop_array_assignment_memory_storage.sol" + "loops/while_loop_array_assignment_memory_memory.sol" + "loops/while_loop_array_assignment_memory_storage.sol" + "types/address_call.sol" + "types/address_delegatecall.sol" + "types/address_staticcall.sol" + "types/array_aliasing_storage_2.sol" + "types/array_aliasing_storage_3.sol" + "types/array_aliasing_storage_5.sol" + "types/array_branch_1d.sol" + "types/array_branches_1d.sol" + "types/array_dynamic_parameter_1.sol" + "types/array_dynamic_parameter_1_fail.sol" + "types/bytes_1.sol" + "types/bytes_2.sol" + "types/bytes_2_fail.sol" + "types/mapping_unsupported_key_type_1.sol" + "types/function_type_array_as_reference_type.sol" + ]; + ignored = [ # --- constructor arguments --- @@ -115,26 +144,26 @@ let # OpJump "complex/slither/external_function.sol" - # OpCalldatacopy - "loops/for_loop_array_assignment_memory_memory.sol" - "loops/for_loop_array_assignment_memory_storage.sol" - "loops/while_loop_array_assignment_memory_memory.sol" - "loops/while_loop_array_assignment_memory_storage.sol" - "types/address_call.sol" - "types/address_delegatecall.sol" - "types/address_staticcall.sol" - "types/array_aliasing_storage_2.sol" - "types/array_aliasing_storage_3.sol" - "types/array_aliasing_storage_5.sol" - "types/array_branch_1d.sol" - "types/array_branches_1d.sol" - "types/array_dynamic_parameter_1.sol" - "types/array_dynamic_parameter_1_fail.sol" - "types/bytes_1.sol" - "types/bytes_2.sol" - "types/bytes_2_fail.sol" - "types/mapping_unsupported_key_type_1.sol" - "types/function_type_array_as_reference_type.sol" + # # OpCalldatacopy + # "loops/for_loop_array_assignment_memory_memory.sol" + # "loops/for_loop_array_assignment_memory_storage.sol" + # "loops/while_loop_array_assignment_memory_memory.sol" + # "loops/while_loop_array_assignment_memory_storage.sol" + # "types/address_call.sol" + # "types/address_delegatecall.sol" + # "types/address_staticcall.sol" + # "types/array_aliasing_storage_2.sol" + # "types/array_aliasing_storage_3.sol" + # "types/array_aliasing_storage_5.sol" + # "types/array_branch_1d.sol" + # "types/array_branches_1d.sol" + # "types/array_dynamic_parameter_1.sol" + # "types/array_dynamic_parameter_1_fail.sol" + # "types/bytes_1.sol" + # "types/bytes_2.sol" + # "types/bytes_2_fail.sol" + # "types/mapping_unsupported_key_type_1.sol" + # "types/function_type_array_as_reference_type.sol" # OpBlockhash "special/blockhash.sol" @@ -223,8 +252,8 @@ let # symbolic` on all contracts within. # $1 == input file # $2 == hevm smt backend + # $3 == dynamic? checkWithHevm = pkgs.writeShellScript "checkWithHevm" '' - # write json file to store for later debugging testName=$(${testName} $1) json=$out/jsonFiles/$testName.json @@ -236,7 +265,7 @@ let explore() { set -x - hevm_output=$(${timeout} 90s ${hevm} symbolic --code "$1" --solver "$2" --json-file "$3" $4 2>&1) + hevm_output=$(${timeout} 90s ${hevm} symbolic --code "$1" --solver "$2" --json-file "$3" $4 $5 2>&1) status=$? set +x @@ -273,10 +302,15 @@ let iterations="--max-iterations 3" fi + dynamic="" + if ! [[ -z "$3" ]]; then + dynamic="--calldata-model DynamicCD" + fi + ${echo} ${echo} exploring runtime bytecode: bin_runtime=$(${jq} -r --arg c $contract -c '.contracts[$c]."bin-runtime"' $json) - explore "$bin_runtime" "$2" "$json" "$iterations" + explore "$bin_runtime" "$2" "$json" "$iterations" "$dynamic" done exit 0 @@ -305,6 +339,27 @@ let exit 0 fi + z3Timeouts=(${toString z3Timeout}) + if [[ " ''${z3Timeouts[@]} " =~ " ''${testName} " ]] && [[ $2 = "z3" ]]; then + ${echo} "skipping test:" ${testName} + ${echo} "${strings.ignore}" + exit 0 + fi + + dynamicFlag="" + dynamicTests=(${toString dynamic}) + if [[ " ''${dynamicTests[@]} " =~ " ''${testName} " ]]; then + # echo $2 + if [[ $2 = "z3" ]]; then + dynamicFlag=1 + else + ${echo} "skipping test:" ${testName} + ${echo} "${strings.ignore}" + + exit 0 + fi + fi + ${grep} -q 'Error trying to invoke SMT solver.' $1 if [ $? == 0 ]; then ${echo} ${strings.smtCheckerFailed} && exit; fi ${grep} -q 'Assertion checker does not yet implement' $1 @@ -312,7 +367,7 @@ let ${grep} -q 'Assertion checker does not yet support' $1 if [ $? == 0 ]; then ${echo} ${strings.smtCheckerFailed} && exit; fi - hevm_output=$(${checkWithHevm} $1 $2 2>&1) + hevm_output=$(${checkWithHevm} $1 $2 "$dynamicFlag" 2>&1) echo "$hevm_output" ${grep} -q '${strings.timeout}' <<< "$hevm_output" From 39f4524d8c97f491f1b82344123fef0ddb8d91e8 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Wed, 14 Oct 2020 12:14:53 +0200 Subject: [PATCH 34/36] sketch of a new structure --- src/hevm/src/EVM/Types.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index 421e219fb..7e984f084 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -94,17 +94,22 @@ litBytes bs = fmap (toSized . literal) (BS.unpack bs) -- | A buffer is a list of bytes, and is used to model EVM memory or calldata. -- During concrete execution, this is simply `ByteString`. --- In symbolic settings, the structure of a buffer is sometimes known statically, --- in which case simply use a list of symbolic bytes. --- When we are dealing with dynamically determined calldata or memory (such as if --- we are interpreting a function which a `memory bytes` argument), --- we use smt lists. Note that smt lists are not yet supported by cvc4! data Buffer = ConcreteBuffer ByteString - | StaticSymBuffer [SWord 8] - | DynamicSymBuffer (SList (WordN 8)) + | SymbolicBuffer SliceSet deriving (Show) +type BoundedArray = (SArray (WordN 256) Word8, SWord 256) + +data SliceSet + = Ground DynBuffer + | Insert SymWord Slice SliceSet + +type Slice = SymWord SymWord SliceSet + +readBoundedArray :: SWord 256 -> BoundedArray -> Word8 +readBoundedArray i (a,len) = ite (i .> len) 0 (readArray i a) + dynamize :: Buffer -> SList (WordN 8) dynamize (ConcreteBuffer a) = SL.implode $ litBytes a dynamize (StaticSymBuffer a) = SL.implode a From 6a88b66d17e6d99177cba742e2a2f4e2c55268c6 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 27 Oct 2020 14:10:59 +0100 Subject: [PATCH 35/36] sketches of spain --- src/hevm/src/EVM/Symbolic.hs | 22 +------ src/hevm/src/EVM/Types.hs | 109 +++++++++++++++++++++++------------ src/hevm/src/EVM/UnitTest.hs | 30 +++++----- 3 files changed, 87 insertions(+), 74 deletions(-) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 8c7c77aeb..04c78b550 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -17,10 +17,6 @@ import Data.SBV hiding (runSMT, newArray_, addAxiom, Word) import qualified Data.SBV.List as SL import Data.SBV.List ((.++), (.!!)) --- | Symbolic words of 256 bits, possibly annotated with additional --- "insightful" information -data SymWord = S Whiff (SWord 256) - -- | Convenience functions transporting between the concrete and symbolic realm sw256 :: SWord 256 -> SymWord sw256 = S Dull @@ -38,9 +34,6 @@ w256lit = S Dull . literal . toSizzle litAddr :: Addr -> SAddr litAddr = SAddr . literal . toSizzle -maybeLitWord :: SymWord -> Maybe Word -maybeLitWord (S whiff a) = fmap (C whiff . fromSizzle) (unliteral a) - maybeLitAddr :: SAddr -> Maybe Addr maybeLitAddr (SAddr a) = fmap fromSizzle (unliteral a) @@ -395,23 +388,12 @@ readStaticWordWithBound (S _ ind) (xs, S _ bound) = -- | Custom instances for SymWord, many of which have direct -- analogues for concrete words defined in Concrete.hs - -instance Show SymWord where - show s@(S Dull _) = case maybeLitWord s of - Nothing -> "" - Just w -> show w - show (S (Var var) x) = var ++ ": " ++ show x - show (S (InfixBinOp symbol x y) z) = show x ++ symbol ++ show y ++ ": " ++ show z - show (S (BinOp symbol x y) z) = symbol ++ show x ++ show y ++ ": " ++ show z - show (S (UnOp symbol x) z) = symbol ++ show x ++ ": " ++ show z - show (S whiff x) = show whiff ++ ": " ++ show x - instance EqSymbolic SymWord where (.==) (S _ x) (S _ y) = x .== y instance Num SymWord where - (S _ x) + (S _ y) = sw256 (x + y) - (S _ x) * (S _ y) = sw256 (x * y) + (S _ x) + (S _ y) = sw256 (x + y `mod` 2 ^ 256) + (S _ x) * (S _ y) = sw256 (x * y `mod ` 2 ^256) abs (S _ x) = sw256 (abs x) signum (S _ x) = sw256 (signum x) fromInteger x = sw256 (fromInteger x) diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index 7e984f084..ff4068f9b 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -7,13 +7,14 @@ module EVM.Types where +import Prelude hiding (Word) import Data.Aeson (FromJSON (..), (.:)) #if MIN_VERSION_aeson(1, 0, 0) import Data.Aeson (FromJSONKey (..), FromJSONKeyFunction (..)) #endif -import Data.SBV +import Data.SBV hiding (Word) import Data.SBV.List ((.++)) import qualified Data.SBV.List as SL import Data.Kind @@ -96,46 +97,80 @@ litBytes bs = fmap (toSized . literal) (BS.unpack bs) -- During concrete execution, this is simply `ByteString`. data Buffer = ConcreteBuffer ByteString - | SymbolicBuffer SliceSet + | Slice SymWord SymWord Buffer + | SymbolicBuffer BoundedArray + | Insert SymWord Buffer Buffer deriving (Show) type BoundedArray = (SArray (WordN 256) Word8, SWord 256) -data SliceSet - = Ground DynBuffer - | Insert SymWord Slice SliceSet - -type Slice = SymWord SymWord SliceSet - -readBoundedArray :: SWord 256 -> BoundedArray -> Word8 -readBoundedArray i (a,len) = ite (i .> len) 0 (readArray i a) - -dynamize :: Buffer -> SList (WordN 8) -dynamize (ConcreteBuffer a) = SL.implode $ litBytes a -dynamize (StaticSymBuffer a) = SL.implode a -dynamize (DynamicSymBuffer a) = a - -instance EqSymbolic Buffer where - ConcreteBuffer a .== ConcreteBuffer b = literal (a == b) - ConcreteBuffer a .== StaticSymBuffer b = litBytes a .== b - StaticSymBuffer a .== ConcreteBuffer b = a .== litBytes b - StaticSymBuffer a .== StaticSymBuffer b = a .== b - a .== b = dynamize a .== dynamize b - - -instance Semigroup Buffer where - ConcreteBuffer a <> ConcreteBuffer b = ConcreteBuffer (a <> b) - ConcreteBuffer a <> StaticSymBuffer b = StaticSymBuffer (litBytes a <> b) - c@(ConcreteBuffer a) <> DynamicSymBuffer b = DynamicSymBuffer (dynamize c .++ b) - - StaticSymBuffer a <> ConcreteBuffer b = StaticSymBuffer (a <> litBytes b) - StaticSymBuffer a <> StaticSymBuffer b = StaticSymBuffer (a <> b) - c@(StaticSymBuffer a) <> DynamicSymBuffer b = DynamicSymBuffer (dynamize c .++ b) - - a <> b = DynamicSymBuffer (dynamize a .++ dynamize b) - -instance Monoid Buffer where - mempty = ConcreteBuffer mempty +readBoundedArray :: SWord 256 -> BoundedArray -> SWord8 +readBoundedArray i (a,len) = ite (i .> len) 0 (readArray a i) + +-- | Symbolic words of 256 bits, possibly annotated with additional +-- "insightful" information +data SymWord = S Whiff (SWord 256) + +data Word = C Whiff W256 --maybe to remove completely in the future + +-- | This type can give insight into the provenance of a term +data Whiff = Dull + | FromKeccak ByteString + | Var String + | FromBytes Buffer + | InfixBinOp String Whiff Whiff + | BinOp String Whiff Whiff + | UnOp String Whiff + deriving Show + +maybeLitWord :: SymWord -> Maybe Word +maybeLitWord (S whiff a) = fmap (C whiff . fromSizzle) (unliteral a) + +instance Show SymWord where + show s@(S Dull _) = case maybeLitWord s of + Nothing -> "" + Just w -> show w + show (S (Var var) x) = var ++ ": " ++ show x + show (S (InfixBinOp symbol x y) z) = show x ++ symbol ++ show y ++ ": " ++ show z + show (S (BinOp symbol x y) z) = symbol ++ show x ++ show y ++ ": " ++ show z + show (S (UnOp symbol x) z) = symbol ++ show x ++ ": " ++ show z + show (S whiff x) = show whiff ++ ": " ++ show x + +instance Show Word where + show (C Dull x) = show x + show (C (Var var) x) = var ++ ": " ++ show x + show (C (InfixBinOp symbol x y) z) = show x ++ symbol ++ show y ++ ": " ++ show z + show (C (BinOp symbol x y) z) = symbol ++ show x ++ show y ++ ": " ++ show z + show (C (UnOp symbol x) z) = symbol ++ show x ++ ": " ++ show z + show (C whiff x) = show whiff ++ ": " ++ show x + + +-- dynamize :: Buffer -> SList (WordN 8) +-- dynamize (ConcreteBuffer a) = SL.implode $ litBytes a +-- dynamize (StaticSymBuffer a) = SL.implode a +-- dynamize (DynamicSymBuffer a) = a + +-- instance EqSymbolic Buffer where +-- ConcreteBuffer a .== ConcreteBuffer b = literal (a == b) +-- ConcreteBuffer a .== StaticSymBuffer b = litBytes a .== b +-- StaticSymBuffer a .== ConcreteBuffer b = a .== litBytes b +-- StaticSymBuffer a .== StaticSymBuffer b = a .== b +-- a .== b = dynamize a .== dynamize b + + +-- instance Semigroup Buffer where +-- ConcreteBuffer a <> ConcreteBuffer b = ConcreteBuffer (a <> b) +-- ConcreteBuffer a <> StaticSymBuffer b = StaticSymBuffer (litBytes a <> b) +-- c@(ConcreteBuffer a) <> DynamicSymBuffer b = DynamicSymBuffer (dynamize c .++ b) + +-- StaticSymBuffer a <> ConcreteBuffer b = StaticSymBuffer (a <> litBytes b) +-- StaticSymBuffer a <> StaticSymBuffer b = StaticSymBuffer (a <> b) +-- c@(StaticSymBuffer a) <> DynamicSymBuffer b = DynamicSymBuffer (dynamize c .++ b) + +-- a <> b = DynamicSymBuffer (dynamize a .++ dynamize b) + +-- instance Monoid Buffer where +-- mempty = ConcreteBuffer mempty newtype Addr = Addr { addressWord160 :: Word160 } diff --git a/src/hevm/src/EVM/UnitTest.hs b/src/hevm/src/EVM/UnitTest.hs index 0a02bf3e6..9f85a34dc 100644 --- a/src/hevm/src/EVM/UnitTest.hs +++ b/src/hevm/src/EVM/UnitTest.hs @@ -106,36 +106,32 @@ type ABIMethod = Text -- | Assuming a constructor is loaded, this stepper will run the constructor -- to create the test contract, give it an initial balance, and run `setUp()'. -initializeUnitTest :: UnitTestOptions -> Stepper () +initializeUnitTest :: UnitTestOptions -> EVM () initializeUnitTest UnitTestOptions { .. } = do let addr = testAddress testParams - Stepper.evm $ do - -- Maybe modify the initial VM, e.g. to load library code - modify vmModifier - -- Make a trace entry for running the constructor - pushTrace (EntryTrace "constructor") + -- Maybe modify the initial VM, e.g. to load library code + modify vmModifier + -- Make a trace entry for running the constructor + pushTrace (EntryTrace "constructor") -- Constructor is loaded; run until it returns code - void Stepper.execFully + exec -- Give a balance to the test target - Stepper.evm $ do - env . contracts . ix addr . balance += w256 (testBalanceCreate testParams) - - -- Initialize the test contract - setupCall testParams "setUp()" emptyAbi - popTrace - pushTrace (EntryTrace "initialize test") + env . contracts . ix addr . balance += w256 (testBalanceCreate testParams) + -- Initialize the test contract + setupCall testParams "setUp()" emptyAbi + popTrace + pushTrace (EntryTrace "initialize test") -- Let `setUp()' run to completion - res <- Stepper.execFully - Stepper.evm $ case res of + res <- exec + case res of Left e -> pushTrace (ErrorTrace e) _ -> popTrace - -- | Assuming a test contract is loaded and initialized, this stepper -- will run the specified test method and return whether it succeeded. runUnitTest :: UnitTestOptions -> ABIMethod -> AbiValue -> Stepper Bool From 42c48a6d9e35cff8f912209b46ad863870b25f01 Mon Sep 17 00:00:00 2001 From: Martin Lundfall Date: Tue, 12 Jan 2021 13:48:11 +0100 Subject: [PATCH 36/36] wip --- src/hevm/src/EVM/Concrete.hs | 81 +---- src/hevm/src/EVM/Symbolic.hs | 573 +++++++++++++++++------------------ src/hevm/src/EVM/Types.hs | 62 +++- 3 files changed, 347 insertions(+), 369 deletions(-) diff --git a/src/hevm/src/EVM/Concrete.hs b/src/hevm/src/EVM/Concrete.hs index 653e5593d..b07c9d69a 100644 --- a/src/hevm/src/EVM/Concrete.hs +++ b/src/hevm/src/EVM/Concrete.hs @@ -7,7 +7,7 @@ import Prelude hiding (Word) import EVM.Keccak (keccak) import EVM.RLP -import EVM.Types (Addr, W256 (..), num, word, padRight, word160Bytes, word256Bytes, Buffer) +import EVM.Types import Control.Lens ((^?), ix) import Data.Bits (Bits (..), FiniteBits (..), shiftL, shiftR) @@ -36,21 +36,6 @@ byteStringSliceWithDefaultZeroes offset size bs = let bs' = BS.take size (BS.drop offset bs) in bs' <> BS.replicate (size - BS.length bs') 0 --- | This type can give insight into the provenance of a term -data Whiff = Dull - | FromKeccak ByteString - | Var String - | FromBytes Buffer - | InfixBinOp String Whiff Whiff - | BinOp String Whiff Whiff - | UnOp String Whiff - deriving Show - -w256 :: W256 -> Word -w256 = C Dull - -data Word = C Whiff W256 --maybe to remove completely in the future - wordValue :: Word -> W256 wordValue (C _ x) = x @@ -112,70 +97,6 @@ blobSize x = w256 (num (BS.length x)) keccakBlob :: ByteString -> Word keccakBlob x = C (FromKeccak x) (keccak x) -instance Show Word where - show (C Dull x) = show x - show (C (Var var) x) = var ++ ": " ++ show x - show (C (InfixBinOp symbol x y) z) = show x ++ symbol ++ show y ++ ": " ++ show z - show (C (BinOp symbol x y) z) = symbol ++ show x ++ show y ++ ": " ++ show z - show (C (UnOp symbol x) z) = symbol ++ show x ++ ": " ++ show z - show (C whiff x) = show whiff ++ ": " ++ show x - -instance Read Word where - readsPrec n s = - case readsPrec n s of - [(x, r)] -> [(C Dull x, r)] - _ -> [] - -instance Bits Word where - (C _ x) .&. (C _ y) = w256 (x .&. y) - (C _ x) .|. (C _ y) = w256 (x .|. y) - (C _ x) `xor` (C _ y) = w256 (x `xor` y) - complement (C _ x) = w256 (complement x) - shift (C _ x) i = w256 (shift x i) - rotate (C _ x) i = w256 (rotate x i) - bitSize (C _ x) = bitSize x - bitSizeMaybe (C _ x) = bitSizeMaybe x - isSigned (C _ x) = isSigned x - testBit (C _ x) = testBit x - bit i = w256 (bit i) - popCount (C _ x) = popCount x - -instance FiniteBits Word where - finiteBitSize (C _ x) = finiteBitSize x - countLeadingZeros (C _ x) = countLeadingZeros x - countTrailingZeros (C _ x) = countTrailingZeros x - -instance Bounded Word where - minBound = w256 minBound - maxBound = w256 maxBound - -instance Eq Word where - (C _ x) == (C _ y) = x == y - -instance Enum Word where - toEnum i = w256 (toEnum i) - fromEnum (C _ x) = fromEnum x - -instance Integral Word where - quotRem (C _ x) (C _ y) = - let (a, b) = quotRem x y - in (w256 a, w256 b) - toInteger (C _ x) = toInteger x - -instance Num Word where - (C _ x) + (C _ y) = w256 (x + y) - (C _ x) * (C _ y) = w256 (x * y) - abs (C _ x) = w256 (abs x) - signum (C _ x) = w256 (signum x) - fromInteger x = w256 (fromInteger x) - negate (C _ x) = w256 (negate x) - -instance Real Word where - toRational (C _ x) = toRational x - -instance Ord Word where - compare (C _ x) (C _ y) = compare x y - -- Copied from the standard library just to get specialization. -- We also use bit operations instead of modulo and multiply. -- (This operation was significantly slow.) diff --git a/src/hevm/src/EVM/Symbolic.hs b/src/hevm/src/EVM/Symbolic.hs index 04c78b550..cc5ea67a1 100644 --- a/src/hevm/src/EVM/Symbolic.hs +++ b/src/hevm/src/EVM/Symbolic.hs @@ -11,7 +11,6 @@ import Data.ByteString (ByteString) import Control.Lens hiding (op, (:<), (|>), (.>)) import Data.Maybe (fromMaybe, fromJust) import EVM.Types -import EVM.Concrete (Word (..), Whiff(..)) import qualified EVM.Concrete as Concrete import Data.SBV hiding (runSMT, newArray_, addAxiom, Word) import qualified Data.SBV.List as SL @@ -56,9 +55,7 @@ forceLitBytes = BS.pack . fmap (fromSized . fromJust . unliteral) forceBuffer :: Buffer -> ByteString forceBuffer (ConcreteBuffer b) = b forceBuffer (StaticSymBuffer b) = forceLitBytes b -forceBuffer (DynamicSymBuffer b) = case unliteral b of - Just b' -> BS.pack $ fmap fromSized b' - Nothing -> error "unexpected symbolic argument" +forceBuffer _ = error "unexpected symbolic argument" -- | Arithmetic operations on SymWord @@ -99,292 +96,292 @@ shiftRight' (S _ a') b@(S _ b') = case (num <$> unliteral a', b) of in S (FromBytes (StaticSymBuffer bs)) (fromBytes bs) _ -> sw256 $ sShiftRight b' a' --- | Operations over static symbolic memory (list of symbolic bytes) -truncpad :: Int -> [SWord 8] -> [SWord 8] -truncpad n xs = if m > n then take n xs - else mappend xs (replicate (n - m) 0) - where m = length xs - --- | Is the list concretely known empty? -isConcretelyEmpty :: SymVal a => SList a -> Bool -isConcretelyEmpty sl | Just l <- unliteral sl = null l - | True = False - --- WARNING: only works when (n <= list length) -takeStatic :: (SymVal a) => Int -> SList a -> [SBV a] -takeStatic 0 ls = [] -takeStatic n ls = - let (x, xs) = SL.uncons ls - in x:(takeStatic (n - 1) xs) - --- tries to create a static list whenever possible -dropS :: SymWord -> SList (WordN 8) -> Buffer -dropS n ls = - if isConcretelyEmpty ls - then mempty - else case (maybeLitWord n, unliteral $ SL.length ls) of - (Just n', Just l) -> - if n' == 0 - then StaticSymBuffer $ takeStatic (num $ max n' (num l)) ls - else let (_, xs) = SL.uncons ls - in dropS (litWord $ n' - 1) xs - _ -> DynamicSymBuffer $ SL.drop (bv2int n) ls - --- special case of sliceWithZero when size is known -truncpad' :: Int -> Buffer -> Buffer -truncpad' n m = case m of - ConcreteBuffer xs -> ConcreteBuffer $ Concrete.byteStringSliceWithDefaultZeroes 0 n xs - StaticSymBuffer xs -> StaticSymBuffer $ truncpad n xs - DynamicSymBuffer xs -> - case unliteral $ SL.length xs of - - Just (num -> l) -> StaticSymBuffer $ - - if n <= l - then takeStatic n xs - else takeStatic n (xs .++ literal (replicate (n - l) 0)) - - Nothing -> StaticSymBuffer $ takeStatic n (xs .++ literal (replicate n 0)) - -swordAt :: Int -> [SWord 8] -> SymWord -swordAt i bs = let b = truncpad 32 $ drop i bs - in S (FromBytes (StaticSymBuffer b)) (fromBytes b) - -swordAt' :: SymWord -> SList (WordN 8) -> SymWord -swordAt' i@(S _ i') bs = - ite (sFromIntegral (SL.length bs) .<= i') - (sw256 0) - (case truncpad' 32 $ dropS i bs of - ConcreteBuffer s -> litWord $ Concrete.w256 $ Concrete.wordAt 0 s - StaticSymBuffer s -> sw256 $ fromBytes s - DynamicSymBuffer s -> sw256 $ fromBytes [s .!! literal i | i <- [0..31]]) - -readByteOrZero' :: Int -> [SWord 8] -> SWord 8 -readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) - -sliceWithZero' :: Int -> Int -> [SWord 8] -> [SWord 8] -sliceWithZero' o s m = truncpad s $ drop o m - -writeMemory' :: [SWord 8] -> Word -> Word -> Word -> [SWord 8] -> [SWord 8] -writeMemory' bs1 (C _ n) (C _ src) (C _ dst) bs0 = - let - (a, b) = splitAt (num dst) bs0 - a' = replicate (num dst - length a) 0 - c = if src > num (length bs1) - then replicate (num n) 0 - else sliceWithZero' (num src) (num n) bs1 - b' = drop (num n) b - in - a <> a' <> c <> b' - -readMemoryWord' :: Word -> [SWord 8] -> SymWord -readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) - -readMemoryWord32' :: Word -> [SWord 8] -> SymWord -readMemoryWord32' (C _ i) m = sw256 $ fromBytes $ truncpad 4 (drop (num i) m) - -setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] -setMemoryWord' (C _ i) (S _ x) = - writeMemory' (toBytes x) 32 0 (num i) - -setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] -setMemoryByte' (C _ i) x = - writeMemory' [x] 1 0 (num i) - -setMemoryByte'' :: SymWord -> SWord 8 -> Buffer -> Buffer -setMemoryByte'' i x = dynWriteMemory (StaticSymBuffer [x]) 1 0 i - -readSWord' :: Word -> [SWord 8] -> SymWord -readSWord' (C _ i) x = - if i > num (length x) - then sw256 $ 0 - else swordAt (num i) x - --- | Operations over dynamic symbolic memory (smt list of bytes) -readByteOrZero'' :: SymWord -> SList (WordN 8) -> SWord 8 -readByteOrZero'' (S _ i) bs = - ite (sFromIntegral (SL.length bs) .> i + 1) - (bs .!! (sFromIntegral i)) - (literal 0) - --- pad up to 1000 bytes -sslice :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) -sslice (S _ o) (S _ l) bs = case (unliteral $ SL.length bs, unliteral (o + l)) of - (Just le, Just (num -> max)) -> - SL.subList (if le < max then bs .++ literal (replicate (num (max - le)) 0) else bs) o' l' - _ -> SL.subList (bs .++ literal (replicate 10000 0)) o' l' - where o' = sFromIntegral o - l' = sFromIntegral l - -sdynWriteMemory :: SList (WordN 8) -> SymWord -> SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) -sdynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = - let - a = sslice 0 dst bs0 - b = sslice src n bs1 - c = SL.drop (sFromIntegral $ dst' + n') bs0 - - in - a .++ b .++ c - -dynWriteMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer -dynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = - let - a = sliceWithZero 0 dst bs0 - b = sliceWithZero src n bs1 - c = ditchS (sFromIntegral $ dst' + n') bs0 - - in - a <> b <> c - -setMemoryWord'' :: SymWord -> SymWord -> Buffer -> Buffer -setMemoryWord'' i (S _ x) = - dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 i - -readSWord'' :: SymWord -> SList (WordN 8) -> SymWord -readSWord'' i x = case (maybeLitWord i, unliteral (SL.length x)) of - (Just i', Just l) -> - if num l <= i' - then 0 - else read32At (literal $ num $ Concrete.wordValue i') (x .++ literal (replicate (num $ l + 32 - num i') 0)) - _ -> altReadSWord i x - -altReadSWord :: SymWord -> SList (WordN 8) -> SymWord -altReadSWord (S _ i) x = - ite (i .< sFromIntegral (SL.length x)) - (read32At (sFromIntegral i) (x .++ literal (replicate 32 0))) - (sw256 0) - -read32At :: SInteger -> SList (WordN 8) -> SymWord -read32At i x = sw256 $ fromBytes $ [x .!! literal i | i <- [0..31]] - --- | Although calldata can be modeled perfectly well directly as a Buffer, --- we allow for it to take on a special form; the pair ([SWord 8], SymWord) --- where the second argument is understood as the length of the list. --- This allows us to 'fake' dynamically sized calldata arrays in a way --- that has proven more efficient than `SList`. -data Calldata - = CalldataBuffer Buffer - | CalldataDynamic ([SWord 8], SymWord) - deriving Show - --- a whole foldable instance seems overkill, but length is always good to have! -len :: Buffer -> SymWord -len (DynamicSymBuffer a) = sw256 $ sFromIntegral $ SL.length a -len (StaticSymBuffer bs) = litWord . num $ length bs -len (ConcreteBuffer bs) = litWord . num $ BS.length bs - -cdlen :: Calldata -> SymWord -cdlen (CalldataBuffer bf) = len bf -cdlen (CalldataDynamic (_, a)) = a - -grab :: Int -> Buffer -> Buffer -grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs -grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs -grab n (DynamicSymBuffer bs) = - case unliteral $ SL.length bs of - Nothing -> DynamicSymBuffer $ SL.take (literal $ num n) bs - Just l' -> StaticSymBuffer $ takeStatic (num $ max n (num l')) bs - -ditch :: Int -> Buffer -> Buffer -ditch n (StaticSymBuffer bs) = StaticSymBuffer $ drop n bs -ditch n (ConcreteBuffer bs) = ConcreteBuffer $ BS.drop n bs -ditch n (DynamicSymBuffer bs) = dropS (litWord $ num n) bs - -ditchS :: SInteger -> Buffer -> Buffer -ditchS n bs = case unliteral n of - Nothing -> dropS (sw256 $ sFromIntegral n) (dynamize bs) - Just n' -> ditch (num n') bs - -grabS :: SInteger -> Buffer -> Buffer -grabS n bs = case unliteral n of - Nothing -> DynamicSymBuffer $ SL.take n (dynamize bs) - Just n' -> grab (num n') bs - -readByteOrZero :: Int -> Buffer -> SWord 8 -readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs -readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs -readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (litWord $ num i) bs - --- pad up to 1000 bytes in the dynamic case -sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer -sliceWithZero (S _ o) (S _ s) bf = case (unliteral o, unliteral s, bf) of - (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) - (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) - (Just o', Just s', m) -> truncpad' (num s') (ditch (num o') m) - _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 1000 0)) (sFromIntegral o) (sFromIntegral s) - -writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer -writeMemory bs1 n src dst bs0 = - case (maybeLitWord n, maybeLitWord src, maybeLitWord dst, bs0, bs1) of - (Just n', Just src', Just dst', ConcreteBuffer bs0', ConcreteBuffer bs1') -> - ConcreteBuffer $ Concrete.writeMemory bs1' n' src' dst' bs0' - (Just n', Just src', Just dst', StaticSymBuffer bs0', ConcreteBuffer bs1') -> - StaticSymBuffer $ writeMemory' (litBytes bs1') n' src' dst' bs0' - (Just n', Just src', Just dst', ConcreteBuffer bs0', StaticSymBuffer bs1') -> - StaticSymBuffer $ writeMemory' bs1' n' src' dst' (litBytes bs0') - (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> - StaticSymBuffer $ writeMemory' bs1' n' src' dst' bs0' --- TODO: figure whether dynWriteMemory or sdynWriteMemory is better - _ -> dynWriteMemory bs1 n src dst bs0 --- _ -> DynamicSymBuffer $ sdynWriteMemory (dynamize bs1) n src dst (dynamize bs0) - -readMemoryWord :: SymWord -> Buffer -> SymWord -readMemoryWord i bf = case (maybeLitWord i, bf) of - (Just i', StaticSymBuffer m) -> readMemoryWord' i' m - (Just i', ConcreteBuffer m) -> litWord $ Concrete.readMemoryWord i' m - _ -> swordAt' i (dynamize bf) - -readMemoryWord32 :: SymWord -> Buffer -> SWord 32 -readMemoryWord32 i m = case (maybeLitWord i, m) of - (Just i', StaticSymBuffer m') -> let S _ s = readMemoryWord32' i' m' - in sFromIntegral s - (Just i', ConcreteBuffer m') -> num $ Concrete.readMemoryWord32 i' m' - (_, DynamicSymBuffer m') -> case truncpad' 4 $ dropS i m' of - ConcreteBuffer s -> literal $ num $ Concrete.readMemoryWord32 0 s - StaticSymBuffer s -> let S _ s' = readMemoryWord32' 0 s - in sFromIntegral s' - DynamicSymBuffer s -> fromBytes [s .!! literal k | k <- [0..3]] +-- -- | Operations over static symbolic memory (list of symbolic bytes) +-- truncpad :: Int -> [SWord 8] -> [SWord 8] +-- truncpad n xs = if m > n then take n xs +-- else mappend xs (replicate (n - m) 0) +-- where m = length xs + +-- -- | Is the list concretely known empty? +-- isConcretelyEmpty :: SymVal a => SList a -> Bool +-- isConcretelyEmpty sl | Just l <- unliteral sl = null l +-- | True = False + +-- -- WARNING: only works when (n <= list length) +-- takeStatic :: (SymVal a) => Int -> SList a -> [SBV a] +-- takeStatic 0 ls = [] +-- takeStatic n ls = +-- let (x, xs) = SL.uncons ls +-- in x:(takeStatic (n - 1) xs) + +-- -- tries to create a static list whenever possible +-- dropS :: SymWord -> SList (WordN 8) -> Buffer +-- dropS n ls = +-- if isConcretelyEmpty ls +-- then mempty +-- else case (maybeLitWord n, unliteral $ SL.length ls) of +-- (Just n', Just l) -> +-- if n' == 0 +-- then StaticSymBuffer $ takeStatic (num $ max n' (num l)) ls +-- else let (_, xs) = SL.uncons ls +-- in dropS (litWord $ n' - 1) xs +-- _ -> DynamicSymBuffer $ SL.drop (bv2int n) ls + +-- -- special case of sliceWithZero when size is known +-- truncpad' :: Int -> Buffer -> Buffer +-- truncpad' n m = case m of +-- ConcreteBuffer xs -> ConcreteBuffer $ Concrete.byteStringSliceWithDefaultZeroes 0 n xs +-- StaticSymBuffer xs -> StaticSymBuffer $ truncpad n xs +-- DynamicSymBuffer xs -> +-- case unliteral $ SL.length xs of + +-- Just (num -> l) -> StaticSymBuffer $ + +-- if n <= l +-- then takeStatic n xs +-- else takeStatic n (xs .++ literal (replicate (n - l) 0)) + +-- Nothing -> StaticSymBuffer $ takeStatic n (xs .++ literal (replicate n 0)) + +-- swordAt :: Int -> [SWord 8] -> SymWord +-- swordAt i bs = let b = truncpad 32 $ drop i bs +-- in S (FromBytes (StaticSymBuffer b)) (fromBytes b) + +-- swordAt' :: SymWord -> SList (WordN 8) -> SymWord +-- swordAt' i@(S _ i') bs = +-- ite (sFromIntegral (SL.length bs) .<= i') +-- (sw256 0) +-- (case truncpad' 32 $ dropS i bs of +-- ConcreteBuffer s -> litWord $ Concrete.w256 $ Concrete.wordAt 0 s +-- StaticSymBuffer s -> sw256 $ fromBytes s +-- DynamicSymBuffer s -> sw256 $ fromBytes [s .!! literal i | i <- [0..31]]) + +-- readByteOrZero' :: Int -> [SWord 8] -> SWord 8 +-- readByteOrZero' i bs = fromMaybe 0 (bs ^? ix i) + +-- sliceWithZero' :: Int -> Int -> [SWord 8] -> [SWord 8] +-- sliceWithZero' o s m = truncpad s $ drop o m + +-- writeMemory' :: [SWord 8] -> Word -> Word -> Word -> [SWord 8] -> [SWord 8] +-- writeMemory' bs1 (C _ n) (C _ src) (C _ dst) bs0 = +-- let +-- (a, b) = splitAt (num dst) bs0 +-- a' = replicate (num dst - length a) 0 +-- c = if src > num (length bs1) +-- then replicate (num n) 0 +-- else sliceWithZero' (num src) (num n) bs1 +-- b' = drop (num n) b +-- in +-- a <> a' <> c <> b' + +-- readMemoryWord' :: Word -> [SWord 8] -> SymWord +-- readMemoryWord' (C _ i) m = sw256 $ fromBytes $ truncpad 32 (drop (num i) m) + +-- readMemoryWord32' :: Word -> [SWord 8] -> SymWord +-- readMemoryWord32' (C _ i) m = sw256 $ fromBytes $ truncpad 4 (drop (num i) m) + +-- setMemoryWord' :: Word -> SymWord -> [SWord 8] -> [SWord 8] +-- setMemoryWord' (C _ i) (S _ x) = +-- writeMemory' (toBytes x) 32 0 (num i) + +-- setMemoryByte' :: Word -> SWord 8 -> [SWord 8] -> [SWord 8] +-- setMemoryByte' (C _ i) x = +-- writeMemory' [x] 1 0 (num i) + +-- setMemoryByte'' :: SymWord -> SWord 8 -> Buffer -> Buffer +-- setMemoryByte'' i x = dynWriteMemory (StaticSymBuffer [x]) 1 0 i + +-- readSWord' :: Word -> [SWord 8] -> SymWord +-- readSWord' (C _ i) x = +-- if i > num (length x) +-- then sw256 $ 0 +-- else swordAt (num i) x + +-- -- | Operations over dynamic symbolic memory (smt list of bytes) +-- readByteOrZero'' :: SymWord -> SList (WordN 8) -> SWord 8 +-- readByteOrZero'' (S _ i) bs = +-- ite (sFromIntegral (SL.length bs) .> i + 1) +-- (bs .!! (sFromIntegral i)) +-- (literal 0) + +-- -- pad up to 1000 bytes +-- sslice :: SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) +-- sslice (S _ o) (S _ l) bs = case (unliteral $ SL.length bs, unliteral (o + l)) of +-- (Just le, Just (num -> max)) -> +-- SL.subList (if le < max then bs .++ literal (replicate (num (max - le)) 0) else bs) o' l' +-- _ -> SL.subList (bs .++ literal (replicate 10000 0)) o' l' +-- where o' = sFromIntegral o +-- l' = sFromIntegral l + +-- sdynWriteMemory :: SList (WordN 8) -> SymWord -> SymWord -> SymWord -> SList (WordN 8) -> SList (WordN 8) +-- sdynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = +-- let +-- a = sslice 0 dst bs0 +-- b = sslice src n bs1 +-- c = SL.drop (sFromIntegral $ dst' + n') bs0 + +-- in +-- a .++ b .++ c + +-- dynWriteMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer +-- dynWriteMemory bs1 n@(S _ n') src@(S _ src') dst@(S _ dst') bs0 = +-- let +-- a = sliceWithZero 0 dst bs0 +-- b = sliceWithZero src n bs1 +-- c = ditchS (sFromIntegral $ dst' + n') bs0 + +-- in +-- a <> b <> c + +-- setMemoryWord'' :: SymWord -> SymWord -> Buffer -> Buffer +-- setMemoryWord'' i (S _ x) = +-- dynWriteMemory (StaticSymBuffer $ toBytes x) 32 0 i + +-- readSWord'' :: SymWord -> SList (WordN 8) -> SymWord +-- readSWord'' i x = case (maybeLitWord i, unliteral (SL.length x)) of +-- (Just i', Just l) -> +-- if num l <= i' +-- then 0 +-- else read32At (literal $ num $ Concrete.wordValue i') (x .++ literal (replicate (num $ l + 32 - num i') 0)) +-- _ -> altReadSWord i x + +-- altReadSWord :: SymWord -> SList (WordN 8) -> SymWord +-- altReadSWord (S _ i) x = +-- ite (i .< sFromIntegral (SL.length x)) +-- (read32At (sFromIntegral i) (x .++ literal (replicate 32 0))) +-- (sw256 0) + +-- read32At :: SInteger -> SList (WordN 8) -> SymWord +-- read32At i x = sw256 $ fromBytes $ [x .!! literal i | i <- [0..31]] + +-- -- | Although calldata can be modeled perfectly well directly as a Buffer, +-- -- we allow for it to take on a special form; the pair ([SWord 8], SymWord) +-- -- where the second argument is understood as the length of the list. +-- -- This allows us to 'fake' dynamically sized calldata arrays in a way +-- -- that has proven more efficient than `SList`. +-- data Calldata +-- = CalldataBuffer Buffer +-- | CalldataDynamic ([SWord 8], SymWord) +-- deriving Show + +-- -- a whole foldable instance seems overkill, but length is always good to have! +-- len :: Buffer -> SymWord +-- len (DynamicSymBuffer a) = sw256 $ sFromIntegral $ SL.length a +-- len (StaticSymBuffer bs) = litWord . num $ length bs +-- len (ConcreteBuffer bs) = litWord . num $ BS.length bs + +-- cdlen :: Calldata -> SymWord +-- cdlen (CalldataBuffer bf) = len bf +-- cdlen (CalldataDynamic (_, a)) = a + +-- grab :: Int -> Buffer -> Buffer +-- grab n (StaticSymBuffer bs) = StaticSymBuffer $ take n bs +-- grab n (ConcreteBuffer bs) = ConcreteBuffer $ BS.take n bs +-- grab n (DynamicSymBuffer bs) = +-- case unliteral $ SL.length bs of +-- Nothing -> DynamicSymBuffer $ SL.take (literal $ num n) bs +-- Just l' -> StaticSymBuffer $ takeStatic (num $ max n (num l')) bs + +-- ditch :: Int -> Buffer -> Buffer +-- ditch n (StaticSymBuffer bs) = StaticSymBuffer $ drop n bs +-- ditch n (ConcreteBuffer bs) = ConcreteBuffer $ BS.drop n bs +-- ditch n (DynamicSymBuffer bs) = dropS (litWord $ num n) bs + +-- ditchS :: SInteger -> Buffer -> Buffer +-- ditchS n bs = case unliteral n of +-- Nothing -> dropS (sw256 $ sFromIntegral n) (dynamize bs) +-- Just n' -> ditch (num n') bs + +-- grabS :: SInteger -> Buffer -> Buffer +-- grabS n bs = case unliteral n of +-- Nothing -> DynamicSymBuffer $ SL.take n (dynamize bs) +-- Just n' -> grab (num n') bs + +-- readByteOrZero :: Int -> Buffer -> SWord 8 +-- readByteOrZero i (StaticSymBuffer bs) = readByteOrZero' i bs +-- readByteOrZero i (ConcreteBuffer bs) = num $ Concrete.readByteOrZero i bs +-- readByteOrZero i (DynamicSymBuffer bs) = readByteOrZero'' (litWord $ num i) bs + +-- -- pad up to 1000 bytes in the dynamic case +-- sliceWithZero :: SymWord -> SymWord -> Buffer -> Buffer +-- sliceWithZero (S _ o) (S _ s) bf = case (unliteral o, unliteral s, bf) of +-- (Just o', Just s', StaticSymBuffer m) -> StaticSymBuffer (sliceWithZero' (num o') (num s') m) +-- (Just o', Just s', ConcreteBuffer m) -> ConcreteBuffer (Concrete.byteStringSliceWithDefaultZeroes (num o') (num s') m) +-- (Just o', Just s', m) -> truncpad' (num s') (ditch (num o') m) +-- _ -> DynamicSymBuffer $ SL.subList (dynamize bf .++ literal (replicate 1000 0)) (sFromIntegral o) (sFromIntegral s) + +-- writeMemory :: Buffer -> SymWord -> SymWord -> SymWord -> Buffer -> Buffer +-- writeMemory bs1 n src dst bs0 = +-- case (maybeLitWord n, maybeLitWord src, maybeLitWord dst, bs0, bs1) of +-- (Just n', Just src', Just dst', ConcreteBuffer bs0', ConcreteBuffer bs1') -> +-- ConcreteBuffer $ Concrete.writeMemory bs1' n' src' dst' bs0' +-- (Just n', Just src', Just dst', StaticSymBuffer bs0', ConcreteBuffer bs1') -> +-- StaticSymBuffer $ writeMemory' (litBytes bs1') n' src' dst' bs0' +-- (Just n', Just src', Just dst', ConcreteBuffer bs0', StaticSymBuffer bs1') -> +-- StaticSymBuffer $ writeMemory' bs1' n' src' dst' (litBytes bs0') +-- (Just n', Just src', Just dst', StaticSymBuffer bs0', StaticSymBuffer bs1') -> +-- StaticSymBuffer $ writeMemory' bs1' n' src' dst' bs0' +-- -- TODO: figure whether dynWriteMemory or sdynWriteMemory is better +-- _ -> dynWriteMemory bs1 n src dst bs0 +-- -- _ -> DynamicSymBuffer $ sdynWriteMemory (dynamize bs1) n src dst (dynamize bs0) + +-- readMemoryWord :: SymWord -> Buffer -> SymWord +-- readMemoryWord i bf = case (maybeLitWord i, bf) of +-- (Just i', StaticSymBuffer m) -> readMemoryWord' i' m +-- (Just i', ConcreteBuffer m) -> litWord $ Concrete.readMemoryWord i' m +-- _ -> swordAt' i (dynamize bf) + +-- readMemoryWord32 :: SymWord -> Buffer -> SWord 32 +-- readMemoryWord32 i m = case (maybeLitWord i, m) of +-- (Just i', StaticSymBuffer m') -> let S _ s = readMemoryWord32' i' m' +-- in sFromIntegral s +-- (Just i', ConcreteBuffer m') -> num $ Concrete.readMemoryWord32 i' m' +-- (_, DynamicSymBuffer m') -> case truncpad' 4 $ dropS i m' of +-- ConcreteBuffer s -> literal $ num $ Concrete.readMemoryWord32 0 s +-- StaticSymBuffer s -> let S _ s' = readMemoryWord32' 0 s +-- in sFromIntegral s' +-- DynamicSymBuffer s -> fromBytes [s .!! literal k | k <- [0..3]] -setMemoryWord :: SymWord -> SymWord -> Buffer -> Buffer -setMemoryWord i x bf = case (maybeLitWord i, maybeLitWord x, bf) of - (Just i', Just x', ConcreteBuffer z) -> ConcreteBuffer $ Concrete.setMemoryWord i' x' z - (Just i', _ , ConcreteBuffer z) -> StaticSymBuffer $ setMemoryWord' i' x (litBytes z) - (Just i', _ , StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' i' x z - _ -> setMemoryWord'' i x bf - -setMemoryByte :: SymWord -> SWord 8 -> Buffer -> Buffer -setMemoryByte i x m = case (maybeLitWord i, m) of - (Just i', StaticSymBuffer m) -> StaticSymBuffer $ setMemoryByte' i' x m - (Just i', ConcreteBuffer m) -> case fromSized <$> unliteral x of - Nothing -> StaticSymBuffer $ setMemoryByte' i' x (litBytes m) - Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i' x' m - _ -> setMemoryByte'' i x m - -readSWord :: SymWord -> Buffer -> SymWord -readSWord i bf = case (maybeLitWord i, bf) of - (Just i', StaticSymBuffer x) -> readSWord' i' x - (Just i', ConcreteBuffer x) -> litWord $ Concrete.readBlobWord i' x - _ -> readSWord'' i (dynamize bf) - - -select' :: (Ord b, Num b, SymVal b, Mergeable a) => [a] -> a -> SBV b -> a -select' xs err ind = walk xs ind err - where walk [] _ acc = acc - walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) - --- Generates a ridiculously large set of constraints (roughly 25k) when --- the index is symbolic, but it still seems (kind of) manageable --- for the solvers. -readStaticWordWithBound :: SymWord -> ([SWord 8], SymWord) -> SymWord -readStaticWordWithBound (S _ ind) (xs, S _ bound) = - case (num <$> unliteral ind, num <$> unliteral bound) of - (Just i, Just b) -> - let bs = truncpad 32 $ drop i (take b xs) - in S (FromBytes (StaticSymBuffer bs)) (fromBytes bs) - _ -> - let boundedList = [ite (i .<= bound) x 0 | (x, i) <- zip xs [1..]] - in sw256 $ fromBytes [select' boundedList 0 (ind + j) | j <- [0..31]] +-- setMemoryWord :: SymWord -> SymWord -> Buffer -> Buffer +-- setMemoryWord i x bf = case (maybeLitWord i, maybeLitWord x, bf) of +-- (Just i', Just x', ConcreteBuffer z) -> ConcreteBuffer $ Concrete.setMemoryWord i' x' z +-- (Just i', _ , ConcreteBuffer z) -> StaticSymBuffer $ setMemoryWord' i' x (litBytes z) +-- (Just i', _ , StaticSymBuffer z) -> StaticSymBuffer $ setMemoryWord' i' x z +-- _ -> setMemoryWord'' i x bf + +-- setMemoryByte :: SymWord -> SWord 8 -> Buffer -> Buffer +-- setMemoryByte i x m = case (maybeLitWord i, m) of +-- (Just i', StaticSymBuffer m) -> StaticSymBuffer $ setMemoryByte' i' x m +-- (Just i', ConcreteBuffer m) -> case fromSized <$> unliteral x of +-- Nothing -> StaticSymBuffer $ setMemoryByte' i' x (litBytes m) +-- Just x' -> ConcreteBuffer $ Concrete.setMemoryByte i' x' m +-- _ -> setMemoryByte'' i x m + +-- readSWord :: SymWord -> Buffer -> SymWord +-- readSWord i bf = case (maybeLitWord i, bf) of +-- (Just i', StaticSymBuffer x) -> readSWord' i' x +-- (Just i', ConcreteBuffer x) -> litWord $ Concrete.readBlobWord i' x +-- _ -> readSWord'' i (dynamize bf) + + +-- select' :: (Ord b, Num b, SymVal b, Mergeable a) => [a] -> a -> SBV b -> a +-- select' xs err ind = walk xs ind err +-- where walk [] _ acc = acc +-- walk (e:es) i acc = walk es (i-1) (ite (i .== 0) e acc) + +-- -- Generates a ridiculously large set of constraints (roughly 25k) when +-- -- the index is symbolic, but it still seems (kind of) manageable +-- -- for the solvers. +-- readStaticWordWithBound :: SymWord -> ([SWord 8], SymWord) -> SymWord +-- readStaticWordWithBound (S _ ind) (xs, S _ bound) = +-- case (num <$> unliteral ind, num <$> unliteral bound) of +-- (Just i, Just b) -> +-- let bs = truncpad 32 $ drop i (take b xs) +-- in S (FromBytes (StaticSymBuffer bs)) (fromBytes bs) +-- _ -> +-- let boundedList = [ite (i .<= bound) x 0 | (x, i) <- zip xs [1..]] +-- in sw256 $ fromBytes [select' boundedList 0 (ind + j) | j <- [0..31]] -- | Custom instances for SymWord, many of which have direct -- analogues for concrete words defined in Concrete.hs diff --git a/src/hevm/src/EVM/Types.hs b/src/hevm/src/EVM/Types.hs index ff4068f9b..a392bbc87 100644 --- a/src/hevm/src/EVM/Types.hs +++ b/src/hevm/src/EVM/Types.hs @@ -96,7 +96,8 @@ litBytes bs = fmap (toSized . literal) (BS.unpack bs) -- | A buffer is a list of bytes, and is used to model EVM memory or calldata. -- During concrete execution, this is simply `ByteString`. data Buffer - = ConcreteBuffer ByteString + = ConcreteBuffer ByteString + | StaticSymBuffer [SWord 8] | Slice SymWord SymWord Buffer | SymbolicBuffer BoundedArray | Insert SymWord Buffer Buffer @@ -123,6 +124,9 @@ data Whiff = Dull | UnOp String Whiff deriving Show +w256 :: W256 -> Word +w256 = C Dull + maybeLitWord :: SymWord -> Maybe Word maybeLitWord (S whiff a) = fmap (C whiff . fromSizzle) (unliteral a) @@ -144,6 +148,62 @@ instance Show Word where show (C (UnOp symbol x) z) = symbol ++ show x ++ ": " ++ show z show (C whiff x) = show whiff ++ ": " ++ show x +instance Read Word where + readsPrec n s = + case readsPrec n s of + [(x, r)] -> [(C Dull x, r)] + _ -> [] + +instance Bits Word where + (C _ x) .&. (C _ y) = w256 (x .&. y) + (C _ x) .|. (C _ y) = w256 (x .|. y) + (C _ x) `xor` (C _ y) = w256 (x `xor` y) + complement (C _ x) = w256 (complement x) + shift (C _ x) i = w256 (shift x i) + rotate (C _ x) i = w256 (rotate x i) + bitSize (C _ x) = bitSize x + bitSizeMaybe (C _ x) = bitSizeMaybe x + isSigned (C _ x) = isSigned x + testBit (C _ x) = testBit x + bit i = w256 (bit i) + popCount (C _ x) = popCount x + +instance FiniteBits Word where + finiteBitSize (C _ x) = finiteBitSize x + countLeadingZeros (C _ x) = countLeadingZeros x + countTrailingZeros (C _ x) = countTrailingZeros x + +instance Bounded Word where + minBound = w256 minBound + maxBound = w256 maxBound + +instance Eq Word where + (C _ x) == (C _ y) = x == y + +instance Enum Word where + toEnum i = w256 (toEnum i) + fromEnum (C _ x) = fromEnum x + +instance Integral Word where + quotRem (C _ x) (C _ y) = + let (a, b) = quotRem x y + in (w256 a, w256 b) + toInteger (C _ x) = toInteger x + +instance Num Word where + (C _ x) + (C _ y) = w256 (x + y) + (C _ x) * (C _ y) = w256 (x * y) + abs (C _ x) = w256 (abs x) + signum (C _ x) = w256 (signum x) + fromInteger x = w256 (fromInteger x) + negate (C _ x) = w256 (negate x) + +instance Real Word where + toRational (C _ x) = toRational x + +instance Ord Word where + compare (C _ x) (C _ y) = compare x y + -- dynamize :: Buffer -> SList (WordN 8) -- dynamize (ConcreteBuffer a) = SL.implode $ litBytes a