{-# LANGUAGE FlexibleContexts #-}
module Simulation.Aivika.Trans.Resource
(
FCFSResource,
LCFSResource,
SIROResource,
PriorityResource,
Resource,
newFCFSResource,
newFCFSResourceWithMaxCount,
newLCFSResource,
newLCFSResourceWithMaxCount,
newSIROResource,
newSIROResourceWithMaxCount,
newPriorityResource,
newPriorityResourceWithMaxCount,
newResource,
newResourceWithMaxCount,
resourceStrategy,
resourceMaxCount,
resourceCount,
resourceCountStats,
resourceUtilisationCount,
resourceUtilisationCountStats,
resourceQueueCount,
resourceQueueCountStats,
resourceTotalWaitTime,
resourceWaitTime,
requestResource,
requestResourceWithPriority,
tryRequestResourceWithinEvent,
releaseResource,
releaseResourceWithinEvent,
usingResource,
usingResourceWithPriority,
incResourceCount,
decResourceCount,
resetResource,
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.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
type FCFSResource m = Resource m FCFS
type LCFSResource m = Resource m LCFS
type SIROResource m = Resource m SIRO
type PriorityResource m = Resource m StaticPriorities
data Resource m s =
Resource { resourceStrategy :: s,
resourceMaxCount :: Maybe Int,
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 () }
newFCFSResource :: MonadDES m
=> Int
-> Event m (FCFSResource m)
{-# INLINABLE newFCFSResource #-}
newFCFSResource = newResource FCFS
newFCFSResourceWithMaxCount :: MonadDES m
=> Int
-> Maybe Int
-> Event m (FCFSResource m)
{-# INLINABLE newFCFSResourceWithMaxCount #-}
newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS
newLCFSResource :: MonadDES m
=> Int
-> Event m (LCFSResource m)
{-# INLINABLE newLCFSResource #-}
newLCFSResource = newResource LCFS
newLCFSResourceWithMaxCount :: MonadDES m
=> Int
-> Maybe Int
-> Event m (LCFSResource m)
{-# INLINABLE newLCFSResourceWithMaxCount #-}
newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS
newSIROResource :: (MonadDES m, QueueStrategy m SIRO)
=> Int
-> Event m (SIROResource m)
{-# INLINABLE newSIROResource #-}
newSIROResource = newResource SIRO
newSIROResourceWithMaxCount :: (MonadDES m, QueueStrategy m SIRO)
=> Int
-> Maybe Int
-> Event m (SIROResource m)
{-# INLINABLE newSIROResourceWithMaxCount #-}
newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO
newPriorityResource :: (MonadDES m, QueueStrategy m StaticPriorities)
=> Int
-> Event m (PriorityResource m)
{-# INLINABLE newPriorityResource #-}
newPriorityResource = newResource StaticPriorities
newPriorityResourceWithMaxCount :: (MonadDES m, QueueStrategy m StaticPriorities)
=> Int
-> Maybe Int
-> Event m (PriorityResource m)
{-# INLINABLE newPriorityResourceWithMaxCount #-}
newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities
newResource :: (MonadDES m, QueueStrategy m s)
=> s
-> Int
-> Event m (Resource m s)
{-# INLINABLE newResource #-}
newResource s count =
newResourceWithMaxCount s count (Just count)
newResourceWithMaxCount :: (MonadDES m, QueueStrategy m s)
=> s
-> Int
-> Maybe Int
-> Event m (Resource m s)
{-# INLINABLE newResourceWithMaxCount #-}
newResourceWithMaxCount s count maxCount =
Event $ \p ->
do let r = pointRun p
t = pointTime p
when (count < 0) $
throwComp $
SimulationRetry $
"The resource count cannot be negative: " ++
"newResourceWithMaxCount."
case maxCount of
Just maxCount | count > maxCount ->
throwComp $
SimulationRetry $
"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 }
resourceCount :: MonadDES m => Resource m s -> Event m Int
{-# INLINABLE resourceCount #-}
resourceCount r =
Event $ \p -> invokeEvent p $ readRef (resourceCountRef r)
resourceCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int)
{-# INLINABLE resourceCountStats #-}
resourceCountStats r =
Event $ \p -> invokeEvent p $ readRef (resourceCountStatsRef r)
resourceCountChanged :: MonadDES m => Resource m s -> Signal m Int
{-# INLINABLE resourceCountChanged #-}
resourceCountChanged r =
publishSignal $ resourceCountSource r
resourceCountChanged_ :: MonadDES m => Resource m s -> Signal m ()
{-# INLINABLE resourceCountChanged_ #-}
resourceCountChanged_ r =
mapSignal (const ()) $ resourceCountChanged r
resourceUtilisationCount :: MonadDES m => Resource m s -> Event m Int
{-# INLINABLE resourceUtilisationCount #-}
resourceUtilisationCount r =
Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountRef r)
resourceUtilisationCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int)
{-# INLINABLE resourceUtilisationCountStats #-}
resourceUtilisationCountStats r =
Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountStatsRef r)
resourceUtilisationCountChanged :: MonadDES m => Resource m s -> Signal m Int
{-# INLINABLE resourceUtilisationCountChanged #-}
resourceUtilisationCountChanged r =
publishSignal $ resourceUtilisationCountSource r
resourceUtilisationCountChanged_ :: MonadDES m => Resource m s -> Signal m ()
{-# INLINABLE resourceUtilisationCountChanged_ #-}
resourceUtilisationCountChanged_ r =
mapSignal (const ()) $ resourceUtilisationCountChanged r
resourceQueueCount :: MonadDES m => Resource m s -> Event m Int
{-# INLINABLE resourceQueueCount #-}
resourceQueueCount r =
Event $ \p -> invokeEvent p $ readRef (resourceQueueCountRef r)
resourceQueueCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int)
{-# INLINABLE resourceQueueCountStats #-}
resourceQueueCountStats r =
Event $ \p -> invokeEvent p $ readRef (resourceQueueCountStatsRef r)
resourceQueueCountChanged :: MonadDES m => Resource m s -> Signal m Int
{-# INLINABLE resourceQueueCountChanged #-}
resourceQueueCountChanged r =
publishSignal $ resourceQueueCountSource r
resourceQueueCountChanged_ :: MonadDES m => Resource m s -> Signal m ()
{-# INLINABLE resourceQueueCountChanged_ #-}
resourceQueueCountChanged_ r =
mapSignal (const ()) $ resourceQueueCountChanged r
resourceTotalWaitTime :: MonadDES m => Resource m s -> Event m Double
{-# INLINABLE resourceTotalWaitTime #-}
resourceTotalWaitTime r =
Event $ \p -> invokeEvent p $ readRef (resourceTotalWaitTimeRef r)
resourceWaitTime :: MonadDES m => Resource m s -> Event m (SamplingStats Double)
{-# INLINABLE resourceWaitTime #-}
resourceWaitTime r =
Event $ \p -> invokeEvent p $ readRef (resourceWaitTimeRef r)
resourceWaitTimeChanged :: MonadDES m => Resource m s -> Signal m (SamplingStats Double)
{-# INLINABLE resourceWaitTimeChanged #-}
resourceWaitTimeChanged r =
mapSignalM (\() -> resourceWaitTime r) $ resourceWaitTimeChanged_ r
resourceWaitTimeChanged_ :: MonadDES m => Resource m s -> Signal m ()
{-# INLINABLE resourceWaitTimeChanged_ #-}
resourceWaitTimeChanged_ r =
publishSignal $ resourceWaitTimeSource r
requestResource :: (MonadDES m, EnqueueStrategy m s)
=> Resource m s
-> 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 ()
requestResourceWithPriority :: (MonadDES m, PriorityQueueStrategy m s p)
=> Resource m s
-> p
-> 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 ()
releaseResource :: (MonadDES m, DequeueStrategy m s)
=> Resource m s
-> Process m ()
{-# INLINABLE releaseResource #-}
releaseResource r =
Process $ \_ ->
Cont $ \c ->
Event $ \p ->
do invokeEvent p $ releaseResourceWithinEvent r
invokeEvent p $ resumeCont c ()
releaseResourceWithinEvent :: (MonadDES m, DequeueStrategy m s)
=> Resource m s
-> Event m ()
{-# INLINABLE releaseResourceWithinEvent #-}
releaseResourceWithinEvent r =
Event $ \p ->
do invokeEvent p $ updateResourceUtilisationCount r (-1)
invokeEvent p $ releaseResource' r
releaseResource' :: (MonadDES m, DequeueStrategy m s)
=> Resource m s
-> 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 ->
throwComp $
SimulationRetry $
"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 ()
tryRequestResourceWithinEvent :: MonadDES m
=> Resource m s
-> 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
usingResource :: (MonadDES m, EnqueueStrategy m s)
=> Resource m s
-> Process m a
-> Process m a
{-# INLINABLE usingResource #-}
usingResource r m =
do requestResource r
finallyProcess m $ releaseResource r
usingResourceWithPriority :: (MonadDES m, PriorityQueueStrategy m s p)
=> Resource m s
-> p
-> Process m a
-> Process m a
{-# INLINABLE usingResourceWithPriority #-}
usingResourceWithPriority r priority m =
do requestResourceWithPriority r priority
finallyProcess m $ releaseResource r
decResourceCount' :: (MonadDES m, EnqueueStrategy m s)
=> Resource m s
-> Process m ()
{-# INLINABLE decResourceCount' #-}
decResourceCount' r =
do liftEvent $
updateResourceUtilisationCount r (-1)
requestResource r
incResourceCount :: (MonadDES m, DequeueStrategy m s)
=> Resource m s
-> Int
-> Event m ()
{-# INLINABLE incResourceCount #-}
incResourceCount r n
| n < 0 = throwEvent $ SimulationRetry "The increment cannot be negative: incResourceCount"
| n == 0 = return ()
| otherwise =
do releaseResource' r
incResourceCount r (n - 1)
decResourceCount :: (MonadDES m, EnqueueStrategy m s)
=> Resource m s
-> Int
-> Process m ()
{-# INLINABLE decResourceCount #-}
decResourceCount r n
| n < 0 = throwProcess $ SimulationRetry "The decrement cannot be negative: decResourceCount"
| n == 0 = return ()
| otherwise =
do decResourceCount' r
decResourceCount r (n - 1)
resourceChanged_ :: MonadDES m => Resource m s -> Signal m ()
{-# INLINABLE resourceChanged_ #-}
resourceChanged_ r =
resourceCountChanged_ r <>
resourceUtilisationCountChanged_ r <>
resourceQueueCountChanged_ r
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'
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'
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'
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) ()
resetResource :: MonadDES m => Resource m s -> Event m ()
{-# INLINABLE resetResource #-}
resetResource r =
Event $ \p ->
do let t = pointTime p
count <- invokeEvent p $ readRef (resourceCountRef r)
invokeEvent p $ writeRef (resourceCountStatsRef r) $
returnTimingStats t count
utilCount <- invokeEvent p $ readRef (resourceUtilisationCountRef r)
invokeEvent p $ writeRef (resourceUtilisationCountStatsRef r) $
returnTimingStats t utilCount
queueCount <- invokeEvent p $ readRef (resourceQueueCountRef r)
invokeEvent p $ writeRef (resourceQueueCountStatsRef r) $
returnTimingStats t queueCount
invokeEvent p $ writeRef (resourceTotalWaitTimeRef r) 0
invokeEvent p $ writeRef (resourceWaitTimeRef r) emptySamplingStats
invokeEvent p $
triggerSignal (resourceWaitTimeSource r) ()