simulation: Use Double for DiffTime (#116)

simulation/src/ChanMux.hs

@@ -148,7 +148,7 @@ demuxer bearer queues =
 
 newConnectionBundleTCP ::
   forall bundle m.
-  (MuxBundle bundle, MonadTime m, MonadMonotonicTime m, MonadDelay m, MonadAsync m, MessageSize (MuxMsg bundle), MonadMVar m, MonadFork m) =>
+  (MuxBundle bundle, MonadTime m, MonadMonotonicTimeNSec m, MonadDelay m, MonadAsync m, MessageSize (MuxMsg bundle), MonadMVar m, MonadFork m) =>
   Tracer m (LabelTcpDir (TcpEvent (MuxMsg bundle))) ->
   TcpConnProps ->
   m (bundle (Chan m), bundle (Chan m))

simulation/src/ChanTCP.hs

@@ -61,7 +61,7 @@ instance (MessageSize a, MessageSize b) => MessageSize (a, b) where
 -- symmetric and without jitter.
 newConnectionTCP ::
   forall m a.
-  (MonadTime m, MonadMonotonicTime m, MonadDelay m, MonadAsync m, MessageSize a) =>
+  (MonadTime m, MonadMonotonicTimeNSec m, MonadDelay m, MonadAsync m, MessageSize a) =>
   Tracer m (LabelTcpDir (TcpEvent a)) ->
   TcpConnProps ->
   m (Chan m a, Chan m a)
@@ -107,7 +107,7 @@ writeSendBuf :: MonadSTM m => SendBuf m a -> a -> m ()
 writeSendBuf sendbuf msg = atomically (putTMVar sendbuf msg)
 
 readRecvBuf ::
-  (MonadSTM m, MonadMonotonicTime m, MonadDelay m) =>
+  (MonadSTM m, MonadMonotonicTimeNSec m, MonadDelay m) =>
   RecvBuf m a ->
   m a
 readRecvBuf recvbuf = do
@@ -121,11 +121,11 @@ readRecvBuf recvbuf = do
 
   now <- getMonotonicTime
   let delay = arrivaltime `diffTime` now
-  when (delay > 0) (threadDelaySI delay)
+  when (delay > 0) (threadDelay delay)
   return msg
 
 mkChan ::
-  (MonadSTM m, MonadMonotonicTime m, MonadDelay m) =>
+  (MonadSTM m, MonadMonotonicTimeNSec m, MonadDelay m) =>
   SendBuf m a ->
   RecvBuf m a ->
   Chan m a
@@ -136,7 +136,7 @@ mkChan sendbuf recvbuf =
     }
 
 transport ::
-  (MonadSTM m, MonadMonotonicTime m, MonadDelay m, MessageSize a) =>
+  (MonadSTM m, MonadMonotonicTimeNSec m, MonadDelay m, MessageSize a) =>
   Tracer m (TcpEvent a) ->
   TcpConnProps ->
   SendBuf m a ->
@@ -177,7 +177,7 @@ transport tracer tcpprops sendbuf recvbuf = do
     -- schedule the arrival, and wait until it has finished sending
     atomically $ modifyTVar' recvbuf (PQ.insert msgRecvTrailingEdge msg)
     traceWith tracer (TcpSendMsg msg forecast tcpforecasts)
-    threadDelaySI (msgSendTrailingEdge `diffTime` now')
+    threadDelay (msgSendTrailingEdge `diffTime` now')
     -- We keep the sendbuf full until the message has finished sending
     -- so that there's less buffering, and better simulates the TCP buffer
     -- rather than an extra app-level buffer.

simulation/src/ExamplesLayout.hs

@@ -5,6 +5,7 @@ module ExamplesLayout where
 import qualified Graphics.Rendering.Cairo as Cairo
 import Numeric (showFFloat)
 
+import TimeCompat (secondsToDiffTime)
 import Viz
 
 ------------------------------------------------------------------------------
@@ -80,7 +81,7 @@ example5 =
 
 example6 :: Visualization
 example6 =
-  slowmoVisualization 0.1 $
+  slowmoVisualization (secondsToDiffTime 0.1) $
     Viz nullVizModel $
       LayoutAbove
         [ layoutLabelTime

simulation/src/ExamplesRelayP2P.hs

@@ -11,13 +11,14 @@ import SimRelayP2P
 import SimTCPLinks (kilobytes, mkTcpConnProps)
 import SimTypes
 import System.Random (mkStdGen, uniform)
+import TimeCompat (secondsToDiffTime)
 import Viz
 import VizSimRelay (relaySimVizModel)
 import VizSimRelayP2P
 
 example1 :: Visualization
 example1 =
-  slowmoVisualization 0.1 $
+  slowmoVisualization (secondsToDiffTime 0.1) $
     Viz model $
       LayoutAbove
         [ layoutLabelTime
@@ -34,8 +35,8 @@ example1 =
                         Layout $
                           chartDiffusionImperfection
                             p2pTopography
-                            0.1
-                            (96 / 1000)
+                            (secondsToDiffTime 0.1)
+                            (secondsToDiffTime $ 96 / 1000)
                             config
                     ]
                 , LayoutAbove
@@ -57,7 +58,7 @@ example1 =
         (\latency -> mkTcpConnProps latency (kilobytes 1000))
         ( \rng ->
             RelayNodeConfig
-              { blockProcessingDelay = const 0.1 -- 100ms
+              { blockProcessingDelay = const (secondsToDiffTime 0.1) -- 100ms
               , blockGeneration =
                   PoissonGenerationPattern
                     (kilobytes 96)
@@ -87,7 +88,7 @@ example1 =
 
 example2 :: Visualization
 example2 =
-  slowmoVisualization 0.2 $
+  slowmoVisualization (secondsToDiffTime 0.2) $
     Viz (pairVizModel model1 model2) $
       LayoutAbove
         [ layoutLabel 18 "Flat vs cylindrical world topology"
@@ -149,7 +150,7 @@ example2 =
         (\latency -> mkTcpConnProps latency (kilobytes 1000))
         ( \rng ->
             RelayNodeConfig
-              { blockProcessingDelay = const 0.1 -- 100ms
+              { blockProcessingDelay = const (secondsToDiffTime 0.1) -- 100ms
               , blockGeneration =
                   PoissonGenerationPattern
                     (kilobytes 96)

simulation/src/LeiosProtocol/Short/Node.hs

@@ -297,7 +297,7 @@ newLeiosNodeState cfg = do
 
 leiosNode ::
   forall m.
-  (MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m, MonadMonotonicTime m) =>
+  (MonadMVar m, MonadFork m, MonadAsync m, MonadSTM m, MonadTime m, MonadDelay m, MonadMonotonicTimeNSec m) =>
   Tracer m LeiosNodeEvent ->
   LeiosNodeConfig ->
   [Leios (Chan m)] ->
@@ -395,7 +395,7 @@ leiosNode tracer cfg followers peers = do
       ]
 
 processCPUTasks ::
-  (MonadSTM m, MonadDelay m, MonadMonotonicTime m) =>
+  (MonadSTM m, MonadDelay m, MonadMonotonicTimeNSec m) =>
   NumCores ->
   Tracer m CPUTask ->
   TaskMultiQueue LeiosNodeTask m ->
@@ -463,7 +463,7 @@ dispatchValidation tracer cfg leiosState req =
     atomically $ do
       completion [eb]
       ibs <- RB.keySet <$> readTVar leiosState.relayIBState.relayBufferVar
-      let ibsNeeded = Map.fromList $ [(eb.id, Set.fromList eb.inputBlocks Set.\\ ibs)]
+      let ibsNeeded = Map.fromList [(eb.id, Set.fromList eb.inputBlocks Set.\\ ibs)]
       modifyTVar' leiosState.ibsNeededForEBVar (`Map.union` ibsNeeded)
     traceEnterState [eb] EventEB
   valVote v completion = (ValVote,) . (CPUTask $ cfg.leios.delays.voteMsgValidation v,) $ do

simulation/src/LeiosProtocol/Short/Sim.hs

@@ -128,7 +128,7 @@ traceRelayLink1 tcpprops =
           <$> leiosNode (nodeTracer nodeA) (leiosNodeConfig nodeA) [pA] [cA]
           <*> leiosNode (nodeTracer nodeB) (leiosNodeConfig nodeB) [pB] [cB]
       mapM_ forkIO threads
-      forever $ threadDelaySI 1000
+      forever $ threadDelay 1000
  where
   (nodeA, nodeB) = (NodeId 0, NodeId 1)
 

simulation/src/LeiosProtocol/Short/SimP2P.hs

@@ -89,7 +89,7 @@ traceLeiosP2P
                 (Map.keys p2pNodes)
                 (unfoldr (Just . split) rng0)
           ]
-        forever $ threadDelaySI 1000
+        forever $ threadDelay 1000
    where
     tracer :: Tracer (IOSim s) LeiosEvent
     tracer = simTracer

simulation/src/LeiosProtocol/SimTestRelay.hs

@@ -139,7 +139,7 @@ relayNode
           RelayConsumerConfig
             { relay = relayConfig
             , -- sequential validation of headers
-              validateHeaders = map (const 0.1) >>> sum >>> \d -> when (d >= 0) $ threadDelaySI d
+              validateHeaders = map (const 0.1) >>> sum >>> \d -> when (d >= 0) $ threadDelay d
             , headerId = testHeaderId
             , prioritize = sortOn (Down . testHeaderExpiry) . Map.elems
             , submitPolicy = SubmitAll
@@ -174,7 +174,7 @@ relayNode
        where
         -- TODO: make different generators produce different non-overlapping ids
         go !blkid = do
-          threadDelaySI gendelay
+          threadDelay gendelay
           now <- getCurrentTime
           let blk =
                 TestBlock
@@ -192,7 +192,7 @@ relayNode
         go !rng = do
           let (u, rng') = uniformR (0, 1) rng
               gendelay = realToFrac ((-log u) * lambda :: Double) :: DiffTime
-          threadDelaySI gendelay
+          threadDelay gendelay
           now <- getCurrentTime
           let (blkidn, rng'') = uniform rng'
               blkid = TestBlockId blkidn
@@ -239,7 +239,7 @@ relayNode
     processing submitq =
       forever $ do
         (blks, completion) <- atomically $ readTQueue submitq
-        threadDelaySI (sum $ map blockProcessingDelay blks)
+        threadDelay (sum $ map blockProcessingDelay blks)
         _ <- atomically $ completion blks -- "relayNode: completions should not block"
         forM_ blks $ \blk -> traceWith tracer (RelayNodeEventEnterBuffer blk)
 

simulation/src/LeiosProtocol/TaskMultiQueue.hs

@@ -1,10 +1,7 @@
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections #-}
 
 module LeiosProtocol.TaskMultiQueue where
@@ -29,7 +26,7 @@ newTaskMultiQueue :: (MonadSTM m, IsLabel l) => Natural -> STM m (TaskMultiQueue
 newTaskMultiQueue = newTaskMultiQueue' (minBound, maxBound)
 
 writeTMQueue :: (MonadSTM m, IsLabel l) => TaskMultiQueue l m -> l -> (CPUTask, m ()) -> STM m ()
-writeTMQueue (TaskMultiQueue mq) lbl task = writeTBQueue (mq ! lbl) task
+writeTMQueue (TaskMultiQueue mq) lbl = writeTBQueue (mq ! lbl)
 
 readTMQueue :: forall m l. (MonadSTM m, IsLabel l) => TaskMultiQueue l m -> l -> STM m (CPUTask, m ())
 readTMQueue (TaskMultiQueue mq) lbl = readTBQueue (mq ! lbl)
@@ -39,13 +36,13 @@ flushTMQueue (TaskMultiQueue mq) = forM (assocs mq) (\(l, q) -> (l,) <$> flushTB
 
 runInfParallelBlocking ::
   forall m l.
-  (MonadSTM m, MonadDelay m, IsLabel l, MonadMonotonicTime m) =>
+  (MonadSTM m, MonadDelay m, IsLabel l, MonadMonotonicTimeNSec m) =>
   Tracer m CPUTask ->
   TaskMultiQueue l m ->
   m ()
 runInfParallelBlocking tracer mq = do
   xs <- atomically $ do
-    xs <- concat . map snd <$> flushTMQueue mq
+    xs <- concatMap snd <$> flushTMQueue mq
     when (null xs) retry
     return xs
   mapM_ (traceWith tracer . fst) xs

simulation/src/ModelTCP.hs

@@ -24,7 +24,6 @@ import Data.List.NonEmpty (NonEmpty ((:|)))
 import qualified Data.List.NonEmpty as NE
 import Data.PQueue.Prio.Min (MinPQueue)
 import qualified Data.PQueue.Prio.Min as PQ
-import Data.Ratio ((%))
 import Data.Semigroup (Semigroup (sconcat))
 import TimeCompat
 
@@ -306,10 +305,7 @@ forecastTcpMsgSend
 
     serialisationTime :: Bytes -> DiffTime
     serialisationTime msg =
-      fromRational
-        ( toInteger (fromBytes msg)
-            % toInteger (fromBytes tcpBandwidth)
-        )
+      secondsToDiffTime (fromIntegral (fromBytes msg) / fromIntegral (fromBytes tcpBandwidth))
 
 -- | To make the result easier to interpret, merge together any fragments
 -- that are in fact contiguous.

simulation/src/P2P.hs

@@ -222,7 +222,7 @@ p2pGraphIdealDiffusionTimesFromNode
   (P2PIdealDiffusionTimes g latencies)
   (NodeId nid) =
     sort
-      [ realToFrac (latencies ! (nid, nid'))
+      [ secondsToDiffTime (latencies ! (nid, nid'))
       | nid' <- range (bounds g)
       ]
 
@@ -257,7 +257,7 @@ p2pGraphIdealDiffusionTimes
                   communicationDelay
                     (NodeId a)
                     (NodeId b)
-                    (realToFrac linkLatency)
+                    (secondsToDiffTime linkLatency)
              in realToFrac msgLatency
         )
         (realToFrac . processingDelay . NodeId)

simulation/src/PraosProtocol/BlockFetch.hs

@@ -600,7 +600,7 @@ setupValidatorThreads tracer cfg st n = do
   (waitingVar, processWaitingThread) <- setupProcessWaitingThread (contramap PraosNodeEventCPU tracer) (Just 1) st.blocksVar
   let doTask (delay, m) = do
         traceWith tracer . PraosNodeEventCPU . CPUTask $ delay
-        threadDelaySI delay
+        threadDelay delay
         m
 
   -- if we have the previous block, we process the task sequentially to provide back pressure on the queue.
@@ -647,7 +647,7 @@ processWaiting tracer npar blocksVar waitingVar = go
   parallelDelay xs = do
     let !d = maximum $ map fst xs
     forM_ xs $ traceWith tracer . CPUTask . fst
-    threadDelaySI d
+    threadDelay d
     mapM_ snd xs
   go = forever $ join $ atomically $ do
     waiting <- readTVar waitingVar

simulation/src/PraosProtocol/ChainSync.hs

@@ -1,12 +1,10 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}

simulation/src/PraosProtocol/PraosNode.hs

@@ -143,7 +143,7 @@ setupPraosThreads tracer cfg st0 followers peers = do
   let valHeader h = do
         let !delay = cfg.headerValidationDelay h
         traceWith tracer (PraosNodeEventCPU (CPUTask delay))
-        threadDelaySI delay
+        threadDelay delay
   (map Concurrently ts ++) <$> setupPraosThreads' tracer cfg valHeader f st0 followers peers
 
 setupPraosThreads' ::

simulation/src/PraosProtocol/SimChainSync.hs

@@ -88,7 +88,7 @@ traceRelayLink1 tcpprops =
       return ()
  where
   consumerNode cfg chan = do
-    let valHeader = threadDelaySI . cfg.headerValidationDelay
+    let valHeader = threadDelay . cfg.headerValidationDelay
     st <- ChainConsumerState <$> newTVarIO Chain.Genesis <*> pure valHeader
     let nullTracer = Tracer $ const $ return ()
     runChainConsumer nullTracer cfg chan st

simulation/src/PraosProtocol/SimPraosP2P.hs

@@ -86,7 +86,7 @@ tracePraosP2P
                 (Map.keys p2pNodes)
                 (unfoldr (Just . split) rng0)
           ]
-        forever $ threadDelaySI 1000
+        forever $ threadDelay 1000
    where
     tracer :: Tracer (IOSim s) PraosEvent
     tracer = simTracer

simulation/src/RelayProtocol.hs

@@ -26,6 +26,8 @@ module RelayProtocol (
   relayClient,
 ) where
 
+import Chan (Chan (readChan, writeChan))
+import ChanTCP (MessageSize (..))
 import Control.Exception (assert)
 import Control.Monad (when)
 import Data.FingerTree (FingerTree)
@@ -41,9 +43,6 @@ import Data.Word (Word64)
 import STMCompat
 import TimeCompat
 
-import Chan (Chan (readChan, writeChan))
-import ChanTCP (MessageSize (..))
-
 -- | The block relay buffer is a queue of blocks. The buffer is used to
 -- communicate currently active valid blocks.
 --

simulation/src/SimRelay.hs

@@ -137,7 +137,7 @@ relayNode
         -- TODO: make different generators produce different non-overlapping ids
 
         go !blkid = do
-          threadDelaySI gendelay
+          threadDelay gendelay
           now <- getCurrentTime
           let blk =
                 TestBlock
@@ -156,7 +156,7 @@ relayNode
         go !rng = do
           let (u, rng') = uniformR (0, 1) rng
               gendelay = realToFrac ((-log u) * lambda :: Double) :: DiffTime
-          threadDelaySI gendelay
+          threadDelay gendelay
           now <- getCurrentTime
           let (blkidn, rng'') = uniform rng'
               blkid = TestBlockId blkidn
@@ -204,7 +204,7 @@ relayNode
     processing submitq =
       forever $ do
         (blk, completion) <- atomically $ readTQueue submitq
-        threadDelaySI (blockProcessingDelay blk)
+        threadDelay (blockProcessingDelay blk)
         _ <- atomically completion -- "relayNode: completions should not block"
         traceWith tracer (RelayNodeEventEnterBuffer blk)
 

simulation/src/SimRelayP2P.hs

@@ -53,7 +53,7 @@ traceRelayP2P
               (inChan, outChan) <-
                 newConnectionTCP
                   (linkTracer na nb)
-                  (tcpprops (realToFrac latency))
+                  (tcpprops (secondsToDiffTime latency))
               return ((na, nb), (inChan, outChan))
             | ((na, nb), latency) <- Map.toList p2pLinks
             ]