diff --git a/lib/Echidna/ABI.hs b/lib/Echidna/ABI.hs index 7fecbc9bc..482fe9850 100644 --- a/lib/Echidna/ABI.hs +++ b/lib/Echidna/ABI.hs @@ -267,7 +267,9 @@ canShrinkAbiValue = \case _ -> True shrinkInt :: (Integral a, MonadRandom m) => a -> m a -shrinkInt x = fromIntegral <$> getRandomR (0, toInteger x) +shrinkInt x = fromIntegral <$> getRandomR range + where range | x >= 0 = (0, toInteger x) + | otherwise = (toInteger x, 0) -- | Given an 'AbiValue', generate a random \"smaller\" (simpler) value of the same 'AbiType'. shrinkAbiValue :: MonadRandom m => AbiValue -> m AbiValue diff --git a/lib/Echidna/Shrink.hs b/lib/Echidna/Shrink.hs index a9693b43f..af985d02e 100644 --- a/lib/Echidna/Shrink.hs +++ b/lib/Echidna/Shrink.hs @@ -1,8 +1,7 @@ module Echidna.Shrink (shrinkTest) where -import Control.Monad ((<=<)) import Control.Monad.Catch (MonadThrow) -import Control.Monad.Random.Strict (MonadRandom, getRandomR, uniform) +import Control.Monad.Random.Strict (MonadRandom, uniform, weighted) import Control.Monad.Reader.Class (MonadReader (ask), asks) import Control.Monad.State.Strict (MonadIO) import Control.Monad.ST (RealWorld) @@ -96,8 +95,8 @@ shrinkSeq -> [Tx] -> m (Maybe ([Tx], TestValue, VM Concrete RealWorld)) shrinkSeq vm f v txs = do - -- apply one of the two possible simplification strategies (shrunk or shorten) with equal probability - txs' <- uniform =<< sequence [shorten, shrunk] + -- apply the simplification strategy + txs' <- shrunk -- remove certain type of "no calls" let txs'' = removeUselessNoCalls txs' -- check if the sequence still triggers a failed transaction @@ -113,11 +112,25 @@ shrinkSeq vm f v txs = do check (x:xs') vm' = do (_, vm'') <- execTx vm' x check xs' vm'' - -- | Simplify a sequence of transactions reducing the complexity of its arguments (using shrinkTx) - -- and then reducing its sender (using shrinkSender) - shrunk = mapM (shrinkSender <=< shrinkTx) txs - -- | Simplifiy a sequence of transactions randomly dropping one transaction (with uniform selection) - shorten = (\i -> take i txs ++ drop (i + 1) txs) <$> getRandomR (0, length txs) + -- maybe shrink a NoCall (delay) with a simplified strategy + maybeShrink tx@Tx{call = NoCall} = do + tool <- weighted [ + (shrinkDelay, 6), -- 60% try to reduce or remove delay + (pure, 4) -- 40% do nothing + ] + tool tx + -- maybe shrink other types of transactions + maybeShrink tx = do + tool <- weighted [ + (shrinkSender, 10), -- 5% shrink sender + (shrinkTx, 70), -- 35% shrink args, value, gas price, delay or (rarely) remove + (pure . removeCallTx, 60), -- 30% remove + (pure, 60) -- 30% do nothing + ] + tool tx + -- | Simplify a sequence of transactions sometimes reducing the complexity + -- of its arguments (using shrinkTx) and the sender (using shrinkSender) + shrunk = mapM maybeShrink txs -- | Given a transaction, replace the sender of the transaction by another one -- which is simpler (e.g. it is closer to zero). Usually this means that diff --git a/lib/Echidna/Transaction.hs b/lib/Echidna/Transaction.hs index e850622f3..d19e4897f 100644 --- a/lib/Echidna/Transaction.hs +++ b/lib/Echidna/Transaction.hs @@ -120,6 +120,19 @@ canShrinkTx _ = True removeCallTx :: Tx -> Tx removeCallTx t = Tx NoCall t.src t.dst 0 0 0 t.delay +shrinkDelay :: MonadRandom m => Tx -> m Tx +shrinkDelay tx = do + let + (time, blocks) = tx.delay + lower 0 = pure 0 + lower x = getRandomR (0 :: Integer, fromIntegral x) + >>= (\r -> uniform [0, r]) . fromIntegral -- try 0 quicker + delay' <- join $ uniform [ (time,) <$> lower blocks + , (,blocks) <$> lower time + , (,) <$> lower time <*> lower blocks + ] + pure tx { delay = level delay' } + -- | Given a 'Transaction', generate a random \"smaller\" 'Transaction', preserving origin, -- destination, value, and call signature. shrinkTx :: MonadRandom m => Tx -> m Tx @@ -138,12 +151,7 @@ shrinkTx tx = pure tx { Echidna.Types.Tx.value = value' } , do gasprice' <- lower tx.gasprice pure tx { Echidna.Types.Tx.gasprice = gasprice' } - , do let (time, blocks) = tx.delay - delay' <- join $ uniform [ (time,) <$> lower blocks - , (,blocks) <$> lower time - , (,) <$> lower time <*> lower blocks - ] - pure tx { delay = level delay' } + , shrinkDelay tx ] in join $ usuallyRarely (join (uniform possibilities)) (pure $ removeCallTx tx) diff --git a/src/test/Common.hs b/src/test/Common.hs index 5aa5fe779..2092925be 100644 --- a/src/test/Common.hs +++ b/src/test/Common.hs @@ -67,7 +67,7 @@ overrideQuiet conf = overrideLimits :: EConfig -> EConfig overrideLimits conf = conf { campaignConf = conf.campaignConf { testLimit = 10000 - , shrinkLimit = 4000 }} + , shrinkLimit = 10000 }} type SolcVersion = Version type SolcVersionComp = Version -> Bool