CAD-2907 ouroboros-consensus-shelley: computation stub module

ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal

@@ -38,6 +38,7 @@ library
                        Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion
                        Ouroboros.Consensus.Shelley.Ledger.Query
                        Ouroboros.Consensus.Shelley.Ledger.PeerSelection
+                       Ouroboros.Consensus.Shelley.Ledger.Stub
                        Ouroboros.Consensus.Shelley.Ledger.TPraos
                        Ouroboros.Consensus.Shelley.Node
                        Ouroboros.Consensus.Shelley.Node.Serialisation

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -80,6 +80,7 @@ import qualified Shelley.Spec.Ledger.STS.Chain as SL (PredicateFailure)
 import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
 import           Ouroboros.Consensus.Shelley.Ledger.Block
 import           Ouroboros.Consensus.Shelley.Ledger.Config
+import           Ouroboros.Consensus.Shelley.Ledger.Stub
 import           Ouroboros.Consensus.Shelley.Ledger.TPraos ()
 import           Ouroboros.Consensus.Shelley.Protocol (MaxMajorProtVer (..),
                      Ticked (TickedPraosLedgerView))

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Stub.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Ouroboros.Consensus.Shelley.Ledger.Stub
+  ( stubComputation
+  , stubComputationArg
+  , calibrateStubComputationArgForTime
+  )
+where
+
+import Data.List
+import Data.Bits
+import Text.Printf
+
+import qualified Data.IORef       as IO
+import qualified System.IO.Unsafe as IO
+
+import Data.Int
+
+stubComputation :: Int -> Integer
+stubComputation = fibWli
+
+stubComputationArg :: Int
+stubComputationArg = IO.unsafePerformIO (IO.readIORef stubComputationArgIORef)
+
+calibrateStubComputationArgForTime :: Double -> Double -> IO ()
+calibrateStubComputationArgForTime dt precision = do
+  searchIntDoubleM
+    (measuringPureIO stubComputation)
+    stubComputationBase dt precision
+    >>= setStubComputationArg
+ where
+   stubComputationBase = 100
+
+-- An evolution of the original "Fastest Fib on the West", by William Lee Irwin III,
+-- (also known as Nadya Yvette Chambers):
+--   http://www.haskell.org/pipermail/haskell-cafe/2005-January/008839.html
+-- This was picked because the minimum integer step difference is small enough,
+-- to provide small errors relative to desired execution time.
+fibWli :: Int -> Integer
+fibWli n =
+  snd . foldl_ fib_ (1, 0) . dropWhile not $
+    [testBit n k | k <- let s = finiteBitSize n in [s-1,s-2..0]]
+ where
+   fib_ (f, g) p
+     | p         = (f*(f+2*g), ss)
+     | otherwise = (ss, g*(2*f-g))
+    where ss = f*f+g*g
+   foldl_ = foldl' -- '
+
+-- Given a monotonic, monadic 'f', an initial guess x, the desired y and precision,
+-- find x', such that f x' is within precision from y.
+searchIntDoubleM
+  :: forall m
+  .  (Monad m, m ~ IO)
+  => (Int -> m Double)
+  -> Int
+  -> Double
+  -> Double
+  -> m Int
+searchIntDoubleM f x0 yTarget precision =
+  f x0 >>= contain True Nothing x0 >>= uncurry shrink
+ where
+   -- Establish upper/lower boundaries.
+   contain :: Bool -> Maybe (Int, Double) -> Int -> Double -> m ((Int, Double), (Int, Double))
+   contain _ Nothing x' y' =
+     f x'' >>= contain growing (Just (x', y')) x''
+    where
+      (,) growing x'' =
+        if yTarget > y'
+        then (True,  x' * 2)
+        else (False, x' `div` 2)
+   contain growing (Just (x, y)) x' y' = do
+     printf "contain %s %d/%f -> %d/%f\n" (show growing) x y x' y'
+     if needMoreRange
+     then contain growing (Just (x', y')) x'' =<< f x''
+     else pure answer
+    where
+      (,,) needMoreRange x'' answer =
+        if growing
+        then (yTarget > y', x'     * 2, ((x, y), (x', y')))
+        else (yTarget < y', x' `div` 2, ((x, y), (x', y')))
+
+   -- Shrink boundaries up to precision.
+   shrink :: (Int, Double) -> (Int, Double) -> m Int
+   shrink l@(x1, y1) u@(x2, y2) = do
+     printf "shrink %d/%f .. %d/%f prec %f\n" x1 y1 x2 y2 (abs (y1 - y2))
+     if abs (y1 - y2) < precision || x2 - x1 == 1
+     then pure (if lowerBetter then x1 else x2)
+     else do
+       yMid <- f xMid
+       if yMid < yTarget
+         then shrink   (xMid, yMid) u
+         else shrink l (xMid, yMid)
+    where
+      lowerBetter = abs (yTarget - y1) < abs (yTarget - y2)
+      xMid = (x2 + x1) `div` 2
+{-# NOINLINE searchIntDoubleM #-}
+
+stubComputationArgIORef :: IO.IORef Int
+stubComputationArgIORef =
+  IO.unsafePerformIO (IO.newIORef 0)
+{-# NOINLINE _stubComputationArgIORef #-}
+
+setStubComputationArg :: Int -> IO ()
+setStubComputationArg = IO.writeIORef stubComputationArgIORef
+
+measuringPureIO :: NFData b => (a -> b) -> a -> IO Double
+measuringPureIO f x =
+  minimum <$> mapM doTimes (take 3 $ repeat 1)
+ where
+   doTimes times = do
+     start <- getCPUTime
+     dts <- nf' rnf f x times
+     end   <- getCPUTime
+     pure $ fromIntegral (end - start) / (10^13)
+{-# NOINLINE measuringPureIO #-}
+
+-- | Generate a function which applies an argument to a function a
+-- given number of times, reducing the result to normal form.
+-- NOTE: from criterion-measurement
+nf' :: (b -> ()) -> (a -> b) -> a -> (Int64 -> IO ())
+nf' reduce f x = go
+  where
+    go n | n <= 0    = return ()
+         | otherwise = let !y = f x
+                       in reduce y `seq` go (n-1)
+{-# NOINLINE nf' #-}