{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Simulation.Aivika.Trans.Resource -- Copyright : Copyright (c) 2009-2016, David Sorokin -- License : BSD3 -- Maintainer : David Sorokin -- Stability : experimental -- Tested with: GHC 7.10.1 -- -- This module defines the resource which can be acquired and -- then released by the discontinuous process 'Process'. -- The resource can be either limited by the upper bound -- (run-time check), or it can have no upper bound. The latter -- is useful for modeling the infinite queue, for example. -- module Simulation.Aivika.Trans.Resource (-- * Resource Types FCFSResource, LCFSResource, SIROResource, PriorityResource, Resource, -- * Creating Resource newFCFSResource, newFCFSResourceWithMaxCount, newLCFSResource, newLCFSResourceWithMaxCount, newSIROResource, newSIROResourceWithMaxCount, newPriorityResource, newPriorityResourceWithMaxCount, newResource, newResourceWithMaxCount, -- * Resource Properties resourceStrategy, resourceMaxCount, resourceCount, resourceCountStats, resourceUtilisationCount, resourceUtilisationCountStats, resourceQueueCount, resourceQueueCountStats, resourceTotalWaitTime, resourceWaitTime, -- * Requesting for and Releasing Resource requestResource, requestResourceWithPriority, tryRequestResourceWithinEvent, releaseResource, releaseResourceWithinEvent, usingResource, usingResourceWithPriority, -- * Altering Resource incResourceCount, decResourceCount, -- * Signals resourceCountChanged, resourceCountChanged_, resourceUtilisationCountChanged, resourceUtilisationCountChanged_, resourceQueueCountChanged, resourceQueueCountChanged_, resourceWaitTimeChanged, resourceWaitTimeChanged_, resourceChanged_) where import Data.Monoid import Control.Monad import Control.Monad.Trans import Control.Exception import Simulation.Aivika.Trans.Ref.Base import Simulation.Aivika.Trans.DES import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Simulation import Simulation.Aivika.Trans.Internal.Event import Simulation.Aivika.Trans.Internal.Cont import Simulation.Aivika.Trans.Internal.Process import Simulation.Aivika.Trans.QueueStrategy import Simulation.Aivika.Trans.Statistics import Simulation.Aivika.Trans.Signal -- | The ordinary FCFS (First Come - First Serviced) resource. type FCFSResource m = Resource m FCFS -- | The ordinary LCFS (Last Come - First Serviced) resource. type LCFSResource m = Resource m LCFS -- | The SIRO (Serviced in Random Order) resource. type SIROResource m = Resource m SIRO -- | The resource with static priorities. type PriorityResource m = Resource m StaticPriorities -- | Represents the resource with strategy @s@ applied for queuing the requests. data Resource m s = Resource { resourceStrategy :: s, -- ^ Return the strategy applied for queuing the requests. resourceMaxCount :: Maybe Int, -- ^ Return the maximum count of the resource, where 'Nothing' -- means that the resource has no upper bound. resourceCountRef :: Ref m Int, resourceCountStatsRef :: Ref m (TimingStats Int), resourceCountSource :: SignalSource m Int, resourceUtilisationCountRef :: Ref m Int, resourceUtilisationCountStatsRef :: Ref m (TimingStats Int), resourceUtilisationCountSource :: SignalSource m Int, resourceQueueCountRef :: Ref m Int, resourceQueueCountStatsRef :: Ref m (TimingStats Int), resourceQueueCountSource :: SignalSource m Int, resourceTotalWaitTimeRef :: Ref m Double, resourceWaitTimeRef :: Ref m (SamplingStats Double), resourceWaitTimeSource :: SignalSource m (), resourceWaitList :: StrategyQueue m s (ResourceItem m) } data ResourceItem m = ResourceItem { resourceItemTime :: Double, resourceItemCont :: FrozenCont m () } -- | Create a new FCFS resource with the specified initial count which value becomes -- the upper bound as well. newFCFSResource :: MonadDES m => Int -- ^ the initial count (and maximal count too) of the resource -> Event m (FCFSResource m) {-# INLINABLE newFCFSResource #-} newFCFSResource = newResource FCFS -- | Create a new FCFS resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound. newFCFSResourceWithMaxCount :: MonadDES m => Int -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite -> Event m (FCFSResource m) {-# INLINABLE newFCFSResourceWithMaxCount #-} newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS -- | Create a new LCFS resource with the specified initial count which value becomes -- the upper bound as well. newLCFSResource :: MonadDES m => Int -- ^ the initial count (and maximal count too) of the resource -> Event m (LCFSResource m) {-# INLINABLE newLCFSResource #-} newLCFSResource = newResource LCFS -- | Create a new LCFS resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound. newLCFSResourceWithMaxCount :: MonadDES m => Int -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite -> Event m (LCFSResource m) {-# INLINABLE newLCFSResourceWithMaxCount #-} newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS -- | Create a new SIRO resource with the specified initial count which value becomes -- the upper bound as well. newSIROResource :: (MonadDES m, QueueStrategy m SIRO) => Int -- ^ the initial count (and maximal count too) of the resource -> Event m (SIROResource m) {-# INLINABLE newSIROResource #-} newSIROResource = newResource SIRO -- | Create a new SIRO resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound. newSIROResourceWithMaxCount :: (MonadDES m, QueueStrategy m SIRO) => Int -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite -> Event m (SIROResource m) {-# INLINABLE newSIROResourceWithMaxCount #-} newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO -- | Create a new priority resource with the specified initial count which value becomes -- the upper bound as well. newPriorityResource :: (MonadDES m, QueueStrategy m StaticPriorities) => Int -- ^ the initial count (and maximal count too) of the resource -> Event m (PriorityResource m) {-# INLINABLE newPriorityResource #-} newPriorityResource = newResource StaticPriorities -- | Create a new priority resource with the specified initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound. newPriorityResourceWithMaxCount :: (MonadDES m, QueueStrategy m StaticPriorities) => Int -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite -> Event m (PriorityResource m) {-# INLINABLE newPriorityResourceWithMaxCount #-} newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities -- | Create a new resource with the specified queue strategy and initial count. -- The last value becomes the upper bound as well. newResource :: (MonadDES m, QueueStrategy m s) => s -- ^ the strategy for managing the queuing requests -> Int -- ^ the initial count (and maximal count too) of the resource -> Event m (Resource m s) {-# INLINABLE newResource #-} newResource s count = newResourceWithMaxCount s count (Just count) -- | Create a new resource with the specified queue strategy, initial and maximum counts, -- where 'Nothing' means that the resource has no upper bound. newResourceWithMaxCount :: (MonadDES m, QueueStrategy m s) => s -- ^ the strategy for managing the queuing requests -> Int -- ^ the initial count of the resource -> Maybe Int -- ^ the maximum count of the resource, which can be indefinite -> Event m (Resource m s) {-# INLINABLE newResourceWithMaxCount #-} newResourceWithMaxCount s count maxCount = Event $ \p -> do let r = pointRun p t = pointTime p when (count < 0) $ error $ "The resource count cannot be negative: " ++ "newResourceWithMaxCount." case maxCount of Just maxCount | count > maxCount -> error $ "The resource count cannot be greater than " ++ "its maximum value: newResourceWithMaxCount." _ -> return () countRef <- invokeSimulation r $ newRef count countStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t count countSource <- invokeSimulation r newSignalSource utilCountRef <- invokeSimulation r $ newRef 0 utilCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0 utilCountSource <- invokeSimulation r newSignalSource queueCountRef <- invokeSimulation r $ newRef 0 queueCountStatsRef <- invokeSimulation r $ newRef $ returnTimingStats t 0 queueCountSource <- invokeSimulation r newSignalSource totalWaitTimeRef <- invokeSimulation r $ newRef 0 waitTimeRef <- invokeSimulation r $ newRef emptySamplingStats waitTimeSource <- invokeSimulation r newSignalSource waitList <- invokeSimulation r $ newStrategyQueue s return Resource { resourceStrategy = s, resourceMaxCount = maxCount, resourceCountRef = countRef, resourceCountStatsRef = countStatsRef, resourceCountSource = countSource, resourceUtilisationCountRef = utilCountRef, resourceUtilisationCountStatsRef = utilCountStatsRef, resourceUtilisationCountSource = utilCountSource, resourceQueueCountRef = queueCountRef, resourceQueueCountStatsRef = queueCountStatsRef, resourceQueueCountSource = queueCountSource, resourceTotalWaitTimeRef = totalWaitTimeRef, resourceWaitTimeRef = waitTimeRef, resourceWaitTimeSource = waitTimeSource, resourceWaitList = waitList } -- | Return the current available count of the resource. resourceCount :: MonadDES m => Resource m s -> Event m Int {-# INLINABLE resourceCount #-} resourceCount r = Event $ \p -> invokeEvent p $ readRef (resourceCountRef r) -- | Return the statistics for the available count of the resource. resourceCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int) {-# INLINABLE resourceCountStats #-} resourceCountStats r = Event $ \p -> invokeEvent p $ readRef (resourceCountStatsRef r) -- | Signal triggered when the 'resourceCount' property changes. resourceCountChanged :: MonadDES m => Resource m s -> Signal m Int {-# INLINABLE resourceCountChanged #-} resourceCountChanged r = publishSignal $ resourceCountSource r -- | Signal triggered when the 'resourceCount' property changes. resourceCountChanged_ :: MonadDES m => Resource m s -> Signal m () {-# INLINABLE resourceCountChanged_ #-} resourceCountChanged_ r = mapSignal (const ()) $ resourceCountChanged r -- | Return the current utilisation count of the resource. resourceUtilisationCount :: MonadDES m => Resource m s -> Event m Int {-# INLINABLE resourceUtilisationCount #-} resourceUtilisationCount r = Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountRef r) -- | Return the statistics for the utilisation count of the resource. resourceUtilisationCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int) {-# INLINABLE resourceUtilisationCountStats #-} resourceUtilisationCountStats r = Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountStatsRef r) -- | Signal triggered when the 'resourceUtilisationCount' property changes. resourceUtilisationCountChanged :: MonadDES m => Resource m s -> Signal m Int {-# INLINABLE resourceUtilisationCountChanged #-} resourceUtilisationCountChanged r = publishSignal $ resourceUtilisationCountSource r -- | Signal triggered when the 'resourceUtilisationCount' property changes. resourceUtilisationCountChanged_ :: MonadDES m => Resource m s -> Signal m () {-# INLINABLE resourceUtilisationCountChanged_ #-} resourceUtilisationCountChanged_ r = mapSignal (const ()) $ resourceUtilisationCountChanged r -- | Return the current queue length of the resource. resourceQueueCount :: MonadDES m => Resource m s -> Event m Int {-# INLINABLE resourceQueueCount #-} resourceQueueCount r = Event $ \p -> invokeEvent p $ readRef (resourceQueueCountRef r) -- | Return the statistics for the queue length of the resource. resourceQueueCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int) {-# INLINABLE resourceQueueCountStats #-} resourceQueueCountStats r = Event $ \p -> invokeEvent p $ readRef (resourceQueueCountStatsRef r) -- | Signal triggered when the 'resourceQueueCount' property changes. resourceQueueCountChanged :: MonadDES m => Resource m s -> Signal m Int {-# INLINABLE resourceQueueCountChanged #-} resourceQueueCountChanged r = publishSignal $ resourceQueueCountSource r -- | Signal triggered when the 'resourceQueueCount' property changes. resourceQueueCountChanged_ :: MonadDES m => Resource m s -> Signal m () {-# INLINABLE resourceQueueCountChanged_ #-} resourceQueueCountChanged_ r = mapSignal (const ()) $ resourceQueueCountChanged r -- | Return the total wait time of the resource. resourceTotalWaitTime :: MonadDES m => Resource m s -> Event m Double {-# INLINABLE resourceTotalWaitTime #-} resourceTotalWaitTime r = Event $ \p -> invokeEvent p $ readRef (resourceTotalWaitTimeRef r) -- | Return the statistics for the wait time of the resource. resourceWaitTime :: MonadDES m => Resource m s -> Event m (SamplingStats Double) {-# INLINABLE resourceWaitTime #-} resourceWaitTime r = Event $ \p -> invokeEvent p $ readRef (resourceWaitTimeRef r) -- | Signal triggered when the 'resourceTotalWaitTime' and 'resourceWaitTime' properties change. resourceWaitTimeChanged :: MonadDES m => Resource m s -> Signal m (SamplingStats Double) {-# INLINABLE resourceWaitTimeChanged #-} resourceWaitTimeChanged r = mapSignalM (\() -> resourceWaitTime r) $ resourceWaitTimeChanged_ r -- | Signal triggered when the 'resourceTotalWaitTime' and 'resourceWaitTime' properties change. resourceWaitTimeChanged_ :: MonadDES m => Resource m s -> Signal m () {-# INLINABLE resourceWaitTimeChanged_ #-} resourceWaitTimeChanged_ r = publishSignal $ resourceWaitTimeSource r -- | Request for the resource decreasing its count in case of success, -- otherwise suspending the discontinuous process until some other -- process releases the resource. requestResource :: (MonadDES m, EnqueueStrategy m s) => Resource m s -- ^ the requested resource -> Process m () {-# INLINABLE requestResource #-} requestResource r = Process $ \pid -> Cont $ \c -> Event $ \p -> do a <- invokeEvent p $ readRef (resourceCountRef r) if a == 0 then do c <- invokeEvent p $ freezeContReentering c () $ invokeCont c $ invokeProcess pid $ requestResource r invokeEvent p $ strategyEnqueue (resourceWaitList r) $ ResourceItem (pointTime p) c invokeEvent p $ updateResourceQueueCount r 1 else do invokeEvent p $ updateResourceWaitTime r 0 invokeEvent p $ updateResourceCount r (-1) invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ resumeCont c () -- | Request with the priority for the resource decreasing its count -- in case of success, otherwise suspending the discontinuous process -- until some other process releases the resource. requestResourceWithPriority :: (MonadDES m, PriorityQueueStrategy m s p) => Resource m s -- ^ the requested resource -> p -- ^ the priority -> Process m () {-# INLINABLE requestResourceWithPriority #-} requestResourceWithPriority r priority = Process $ \pid -> Cont $ \c -> Event $ \p -> do a <- invokeEvent p $ readRef (resourceCountRef r) if a == 0 then do c <- invokeEvent p $ freezeContReentering c () $ invokeCont c $ invokeProcess pid $ requestResourceWithPriority r priority invokeEvent p $ strategyEnqueueWithPriority (resourceWaitList r) priority $ ResourceItem (pointTime p) c invokeEvent p $ updateResourceQueueCount r 1 else do invokeEvent p $ updateResourceWaitTime r 0 invokeEvent p $ updateResourceCount r (-1) invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ resumeCont c () -- | Release the resource increasing its count and resuming one of the -- previously suspended processes as possible. releaseResource :: (MonadDES m, DequeueStrategy m s) => Resource m s -- ^ the resource to release -> Process m () {-# INLINABLE releaseResource #-} releaseResource r = Process $ \_ -> Cont $ \c -> Event $ \p -> do invokeEvent p $ releaseResourceWithinEvent r invokeEvent p $ resumeCont c () -- | Release the resource increasing its count and resuming one of the -- previously suspended processes as possible. releaseResourceWithinEvent :: (MonadDES m, DequeueStrategy m s) => Resource m s -- ^ the resource to release -> Event m () {-# INLINABLE releaseResourceWithinEvent #-} releaseResourceWithinEvent r = Event $ \p -> do invokeEvent p $ updateResourceUtilisationCount r (-1) invokeEvent p $ releaseResource' r -- | Release the resource without affecting its utilisation. releaseResource' :: (MonadDES m, DequeueStrategy m s) => Resource m s -- ^ the resource to release -> Event m () {-# INLINABLE releaseResource' #-} releaseResource' r = Event $ \p -> do a <- invokeEvent p $ readRef (resourceCountRef r) let a' = a + 1 case resourceMaxCount r of Just maxCount | a' > maxCount -> error $ "The resource count cannot be greater than " ++ "its maximum value: releaseResource'." _ -> return () f <- invokeEvent p $ strategyQueueNull (resourceWaitList r) if f then invokeEvent p $ updateResourceCount r 1 else do x <- invokeEvent p $ strategyDequeue (resourceWaitList r) invokeEvent p $ updateResourceQueueCount r (-1) c <- invokeEvent p $ unfreezeCont (resourceItemCont x) case c of Nothing -> invokeEvent p $ releaseResource' r Just c -> do invokeEvent p $ updateResourceWaitTime r (pointTime p - resourceItemTime x) invokeEvent p $ updateResourceUtilisationCount r 1 invokeEvent p $ enqueueEvent (pointTime p) $ resumeCont c () -- | Try to request for the resource decreasing its count in case of success -- and returning 'True' in the 'Event' monad; otherwise, returning 'False'. tryRequestResourceWithinEvent :: MonadDES m => Resource m s -- ^ the resource which we try to request for -> Event m Bool {-# INLINABLE tryRequestResourceWithinEvent #-} tryRequestResourceWithinEvent r = Event $ \p -> do a <- invokeEvent p $ readRef (resourceCountRef r) if a == 0 then return False else do invokeEvent p $ updateResourceWaitTime r 0 invokeEvent p $ updateResourceCount r (-1) invokeEvent p $ updateResourceUtilisationCount r 1 return True -- | Acquire the resource, perform some action and safely release the resource -- in the end, even if the 'IOException' was raised within the action. usingResource :: (MonadDES m, EnqueueStrategy m s) => Resource m s -- ^ the resource we are going to request for and then release in the end -> Process m a -- ^ the action we are going to apply having the resource -> Process m a -- ^ the result of the action {-# INLINABLE usingResource #-} usingResource r m = do requestResource r finallyProcess m $ releaseResource r -- | Acquire the resource with the specified priority, perform some action and -- safely release the resource in the end, even if the 'IOException' was raised -- within the action. usingResourceWithPriority :: (MonadDES m, PriorityQueueStrategy m s p) => Resource m s -- ^ the resource we are going to request for and then -- release in the end -> p -- ^ the priority -> Process m a -- ^ the action we are going to apply having the resource -> Process m a -- ^ the result of the action {-# INLINABLE usingResourceWithPriority #-} usingResourceWithPriority r priority m = do requestResourceWithPriority r priority finallyProcess m $ releaseResource r -- | Decrease the count of available resource. decResourceCount' :: (MonadDES m, EnqueueStrategy m s) => Resource m s -- ^ the resource for which to decrease the count -> Process m () {-# INLINABLE decResourceCount' #-} decResourceCount' r = do liftEvent $ updateResourceUtilisationCount r (-1) requestResource r -- | Increase the count of available resource by the specified number, -- invoking the awaiting processes as needed. incResourceCount :: (MonadDES m, DequeueStrategy m s) => Resource m s -- ^ the resource -> Int -- ^ the increment for the resource count -> Event m () {-# INLINABLE incResourceCount #-} incResourceCount r n | n < 0 = error "The increment cannot be negative: incResourceCount" | n == 0 = return () | otherwise = do releaseResource' r incResourceCount r (n - 1) -- | Decrease the count of available resource by the specified number, -- waiting for the processes capturing the resource as needed. decResourceCount :: (MonadDES m, EnqueueStrategy m s) => Resource m s -- ^ the resource -> Int -- ^ the decrement for the resource count -> Process m () {-# INLINABLE decResourceCount #-} decResourceCount r n | n < 0 = error "The decrement cannot be negative: decResourceCount" | n == 0 = return () | otherwise = do decResourceCount' r decResourceCount r (n - 1) -- | Signal triggered when one of the resource counters changes. resourceChanged_ :: MonadDES m => Resource m s -> Signal m () {-# INLINABLE resourceChanged_ #-} resourceChanged_ r = resourceCountChanged_ r <> resourceUtilisationCountChanged_ r <> resourceQueueCountChanged_ r -- | Update the resource count and its statistics. updateResourceCount :: MonadDES m => Resource m s -> Int -> Event m () {-# INLINABLE updateResourceCount #-} updateResourceCount r delta = Event $ \p -> do a <- invokeEvent p $ readRef (resourceCountRef r) let a' = a + delta a' `seq` invokeEvent p $ writeRef (resourceCountRef r) a' invokeEvent p $ modifyRef (resourceCountStatsRef r) $ addTimingStats (pointTime p) a' invokeEvent p $ triggerSignal (resourceCountSource r) a' -- | Update the resource utilisation count and its statistics. updateResourceUtilisationCount :: MonadDES m => Resource m s -> Int -> Event m () {-# INLINABLE updateResourceUtilisationCount #-} updateResourceUtilisationCount r delta = Event $ \p -> do a <- invokeEvent p $ readRef (resourceUtilisationCountRef r) let a' = a + delta a' `seq` invokeEvent p $ writeRef (resourceUtilisationCountRef r) a' invokeEvent p $ modifyRef (resourceUtilisationCountStatsRef r) $ addTimingStats (pointTime p) a' invokeEvent p $ triggerSignal (resourceUtilisationCountSource r) a' -- | Update the resource queue length and its statistics. updateResourceQueueCount :: MonadDES m => Resource m s -> Int -> Event m () {-# INLINABLE updateResourceQueueCount #-} updateResourceQueueCount r delta = Event $ \p -> do a <- invokeEvent p $ readRef (resourceQueueCountRef r) let a' = a + delta a' `seq` invokeEvent p $ writeRef (resourceQueueCountRef r) a' invokeEvent p $ modifyRef (resourceQueueCountStatsRef r) $ addTimingStats (pointTime p) a' invokeEvent p $ triggerSignal (resourceQueueCountSource r) a' -- | Update the resource wait time and its statistics. updateResourceWaitTime :: MonadDES m => Resource m s -> Double -> Event m () {-# INLINABLE updateResourceWaitTime #-} updateResourceWaitTime r delta = Event $ \p -> do a <- invokeEvent p $ readRef (resourceTotalWaitTimeRef r) let a' = a + delta a' `seq` invokeEvent p $ writeRef (resourceTotalWaitTimeRef r) a' invokeEvent p $ modifyRef (resourceWaitTimeRef r) $ addSamplingStats delta invokeEvent p $ triggerSignal (resourceWaitTimeSource r) ()