diff --git a/simulation/src/ChanMux.hs b/simulation/src/ChanMux.hs index 7bd30d66..3754ed30 100644 --- a/simulation/src/ChanMux.hs +++ b/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)) diff --git a/simulation/src/ChanTCP.hs b/simulation/src/ChanTCP.hs index b842a4f9..94c6ad81 100644 --- a/simulation/src/ChanTCP.hs +++ b/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. diff --git a/simulation/src/ExamplesLayout.hs b/simulation/src/ExamplesLayout.hs index 7e66c716..4c61b878 100644 --- a/simulation/src/ExamplesLayout.hs +++ b/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 diff --git a/simulation/src/ExamplesRelayP2P.hs b/simulation/src/ExamplesRelayP2P.hs index 31b2faae..2231e00a 100644 --- a/simulation/src/ExamplesRelayP2P.hs +++ b/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) diff --git a/simulation/src/LeiosProtocol/Short/Node.hs b/simulation/src/LeiosProtocol/Short/Node.hs index 523d1dda..06fb0ec0 100644 --- a/simulation/src/LeiosProtocol/Short/Node.hs +++ b/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 diff --git a/simulation/src/LeiosProtocol/Short/Sim.hs b/simulation/src/LeiosProtocol/Short/Sim.hs index 9badbb40..1bf67137 100644 --- a/simulation/src/LeiosProtocol/Short/Sim.hs +++ b/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) diff --git a/simulation/src/LeiosProtocol/Short/SimP2P.hs b/simulation/src/LeiosProtocol/Short/SimP2P.hs index e1e73d09..8c78f77e 100644 --- a/simulation/src/LeiosProtocol/Short/SimP2P.hs +++ b/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 diff --git a/simulation/src/LeiosProtocol/SimTestRelay.hs b/simulation/src/LeiosProtocol/SimTestRelay.hs index 90406675..0dbd1177 100644 --- a/simulation/src/LeiosProtocol/SimTestRelay.hs +++ b/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) diff --git a/simulation/src/LeiosProtocol/TaskMultiQueue.hs b/simulation/src/LeiosProtocol/TaskMultiQueue.hs index 68a1f0ba..91bbb711 100644 --- a/simulation/src/LeiosProtocol/TaskMultiQueue.hs +++ b/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 diff --git a/simulation/src/ModelTCP.hs b/simulation/src/ModelTCP.hs index 9a6cd7a9..51d5c87b 100644 --- a/simulation/src/ModelTCP.hs +++ b/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. diff --git a/simulation/src/P2P.hs b/simulation/src/P2P.hs index 4a22c30d..6f2fcefb 100644 --- a/simulation/src/P2P.hs +++ b/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) diff --git a/simulation/src/PraosProtocol/BlockFetch.hs b/simulation/src/PraosProtocol/BlockFetch.hs index 577affee..6ee83857 100644 --- a/simulation/src/PraosProtocol/BlockFetch.hs +++ b/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 diff --git a/simulation/src/PraosProtocol/ChainSync.hs b/simulation/src/PraosProtocol/ChainSync.hs index fa1608e1..5ef637ec 100644 --- a/simulation/src/PraosProtocol/ChainSync.hs +++ b/simulation/src/PraosProtocol/ChainSync.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} @@ -6,7 +5,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} diff --git a/simulation/src/PraosProtocol/PraosNode.hs b/simulation/src/PraosProtocol/PraosNode.hs index 8e67b662..9630ca3c 100644 --- a/simulation/src/PraosProtocol/PraosNode.hs +++ b/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' :: diff --git a/simulation/src/PraosProtocol/SimChainSync.hs b/simulation/src/PraosProtocol/SimChainSync.hs index 15995809..3617e770 100644 --- a/simulation/src/PraosProtocol/SimChainSync.hs +++ b/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 diff --git a/simulation/src/PraosProtocol/SimPraosP2P.hs b/simulation/src/PraosProtocol/SimPraosP2P.hs index 2b8d776f..83bec4de 100644 --- a/simulation/src/PraosProtocol/SimPraosP2P.hs +++ b/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 diff --git a/simulation/src/RelayProtocol.hs b/simulation/src/RelayProtocol.hs index 456d18c4..7a6b6827 100644 --- a/simulation/src/RelayProtocol.hs +++ b/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. -- diff --git a/simulation/src/SimRelay.hs b/simulation/src/SimRelay.hs index f2e80479..d725a266 100644 --- a/simulation/src/SimRelay.hs +++ b/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) diff --git a/simulation/src/SimRelayP2P.hs b/simulation/src/SimRelayP2P.hs index 301bf875..274af518 100644 --- a/simulation/src/SimRelayP2P.hs +++ b/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 ] diff --git a/simulation/src/SimTCPLinks.hs b/simulation/src/SimTCPLinks.hs index 6619cbb8..0bdb94d9 100644 --- a/simulation/src/SimTCPLinks.hs +++ b/simulation/src/SimTCPLinks.hs @@ -13,7 +13,7 @@ import Control.Monad.Class.MonadAsync ( ) import Control.Monad.IOSim as IOSim ( IOSim, - SimEvent (SimEvent, seTime, seType), + SimEvent (seType), SimEventType (EventLog), SimTrace, runSimTrace, @@ -138,7 +138,7 @@ generatorNode tracer (UniformTrafficPattern nmsgs msgsz mdelay) chan = do [ do writeChan chan msg traceWith tracer (MsgDepart msg) - maybe (return ()) threadDelaySI mdelay + maybe (return ()) threadDelay mdelay | msg <- map (flip TestMessage msgsz) [0 .. nmsgs - 1] ] @@ -196,9 +196,9 @@ selectTimedEvents = bifoldr (\_ _ -> []) ( \b acc -> case b of - SimEvent{seTime, seType} - | Just b' <- selectDynamic seType -> - (seTime, b') : acc + se + | Just b' <- selectDynamic (seType se) -> + (seTimeCompat se, b') : acc _ -> acc ) [] diff --git a/simulation/src/TimeCompat.hs b/simulation/src/TimeCompat.hs index fad0612d..ee9549b7 100644 --- a/simulation/src/TimeCompat.hs +++ b/simulation/src/TimeCompat.hs @@ -1,49 +1,88 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + module TimeCompat ( DiffTime, MonadTime (getCurrentTime), - MonadDelay (threadDelay), - MonadMonotonicTime (getMonotonicTime), + MonadDelay, + MonadMonotonicTimeNSec, + getMonotonicTime, Time (Time), - UTCTime, - NominalDiffTime, diffTimeToSeconds, + secondsToDiffTime, addTime, - addUTCTime, diffTime, - diffUTCTime, - threadDelaySI, + threadDelay, threadDelayNDT, + UTCTime, + NominalDiffTime, + diffUTCTime, waitUntil, + addUTCTime, + seTimeCompat, ) where import Control.Monad (when) -import Control.Monad.Class.MonadTime.SI ( - DiffTime, - MonadMonotonicTime (getMonotonicTime), - MonadTime (getCurrentTime), - NominalDiffTime, - Time (..), - UTCTime, - addTime, - addUTCTime, - diffTime, - diffUTCTime, - ) -import Control.Monad.Class.MonadTimer (MonadDelay (threadDelay)) -import Data.Time.Clock (diffTimeToPicoseconds) +import Control.Monad.IOSim (SimEvent) +import qualified Control.Monad.IOSim as IOSim (SimEvent (seTime)) +import Data.Aeson.Types (FromJSON, ToJSON) +import Data.Coerce (coerce) +import Data.Word (Word64) +import "io-classes" Control.Monad.Class.MonadTime (MonadMonotonicTimeNSec, MonadTime (getCurrentTime), NominalDiffTime, UTCTime, addUTCTime, diffUTCTime) +import qualified "io-classes" Control.Monad.Class.MonadTime as MonadTime (MonadMonotonicTimeNSec (getMonotonicTimeNSec)) +import "io-classes" Control.Monad.Class.MonadTimer (MonadDelay) +import qualified "io-classes" Control.Monad.Class.MonadTimer as MonadTimer (MonadDelay (threadDelay)) +import qualified "si-timers" Control.Monad.Class.MonadTime.SI as SI (DiffTime, Time (Time)) + +seTimeCompat :: SimEvent -> Time +seTimeCompat = Time . realToFrac @SI.DiffTime @DiffTime . coerce @SI.Time @SI.DiffTime . IOSim.seTime + +newtype Nano = Nano Word64 + deriving stock (Show) + deriving newtype (Eq, Ord, Num, Real, Enum, Integral) + deriving newtype (ToJSON, FromJSON) + +newtype Seconds = Seconds Double + deriving stock (Show) + deriving newtype (Eq, Ord, Num, Real, Enum, Fractional, RealFrac) + deriving newtype (ToJSON, FromJSON) + +newtype DiffTime = DiffTime Seconds + deriving stock (Show) + deriving newtype (Eq, Ord, Num, Real, Enum, Fractional, RealFrac) + deriving newtype (ToJSON, FromJSON) + +newtype Time = Time DiffTime + deriving newtype (Show, Eq, Ord) + deriving newtype (ToJSON, FromJSON) diffTimeToSeconds :: DiffTime -> Double -diffTimeToSeconds = (* 1e-12) . fromIntegral . diffTimeToPicoseconds +diffTimeToSeconds = coerce + +secondsToDiffTime :: Double -> DiffTime +secondsToDiffTime = coerce -threadDelaySI :: MonadDelay m => DiffTime -> m () -threadDelaySI = threadDelay . round . (* 1e6) +addTime :: DiffTime -> Time -> Time +addTime dt (Time t) = Time (dt + t) + +diffTime :: Time -> Time -> DiffTime +diffTime (Time t1) (Time t2) = t1 - t2 + +threadDelay :: MonadDelay m => DiffTime -> m () +threadDelay = MonadTimer.threadDelay . round . (* 1e6) threadDelayNDT :: MonadDelay m => NominalDiffTime -> m () -threadDelayNDT = threadDelay . round . (* 1e6) +threadDelayNDT = MonadTimer.threadDelay . round . (* 1e6) + +getMonotonicTime :: MonadMonotonicTimeNSec m => m Time +getMonotonicTime = + Time . DiffTime . (* 1e-9) . fromIntegral . Nano <$> MonadTime.getMonotonicTimeNSec -waitUntil :: (MonadMonotonicTime m, MonadDelay m) => Time -> m () +waitUntil :: (MonadMonotonicTimeNSec m, MonadDelay m) => Time -> m () waitUntil endtime = do now <- getMonotonicTime let delay = endtime `diffTime` now - when (delay > 0) (threadDelaySI delay) + when (delay > 0) (threadDelay delay) diff --git a/simulation/src/Viz.hs b/simulation/src/Viz.hs index b39b48d6..45aac94a 100644 --- a/simulation/src/Viz.hs +++ b/simulation/src/Viz.hs @@ -98,7 +98,7 @@ stepModelWithTime VizModel{stepModel} fps (time, frameno, model) = | frameno' `mod` fps == 0 = Time (fromIntegral (frameno' `div` fps) :: DiffTime) | otherwise = - addTime (1 / fromIntegral fps :: DiffTime) time + addTime (secondsToDiffTime (1 / fromIntegral fps)) time !timestep = time' `diffTime` time @@ -710,7 +710,7 @@ layoutLabelTime = Cairo.moveTo 5 20 Cairo.setFontSize 20 Cairo.setSourceRGB 0 0 0 - Cairo.showText (printf "Time (sec): %.4fs" (diffTimeToSeconds t) :: String) + Cairo.showText (printf "Time (sec): %.2fs" (diffTimeToSeconds t) :: String) layoutLabel :: Int -> String -> Layout (VizRender model) layoutLabel size label = diff --git a/simulation/src/VizChart.hs b/simulation/src/VizChart.hs index 3bdef507..bcb64523 100644 --- a/simulation/src/VizChart.hs +++ b/simulation/src/VizChart.hs @@ -6,13 +6,13 @@ module VizChart where import Data.Functor (void) -import Data.List (minimumBy) -import Data.Ord (comparing) import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Chart.Backend.Cairo as Chart import qualified Graphics.Rendering.Chart.Easy as Chart import TimeCompat +import Data.Foldable (minimumBy) +import Data.Ord (comparing) import ModelTCP import Viz @@ -53,8 +53,8 @@ instance Chart.PlotValue DiffTime where (map show) 10 50 - toValue = realToFrac - fromValue = realToFrac + toValue = diffTimeToSeconds + fromValue = secondsToDiffTime autoScaledAxis :: RealFrac a => Chart.LinearAxisParams a -> Chart.AxisFn a autoScaledAxis lap ps = scaledAxis lap rs ps