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,
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)
newFCFSResource = newResource FCFS
newFCFSResourceWithMaxCount :: MonadDES m
=> Int
-> Maybe Int
-> Event m (FCFSResource m)
newFCFSResourceWithMaxCount = newResourceWithMaxCount FCFS
newLCFSResource :: MonadDES m
=> Int
-> Event m (LCFSResource m)
newLCFSResource = newResource LCFS
newLCFSResourceWithMaxCount :: MonadDES m
=> Int
-> Maybe Int
-> Event m (LCFSResource m)
newLCFSResourceWithMaxCount = newResourceWithMaxCount LCFS
newSIROResource :: (MonadDES m, QueueStrategy m SIRO)
=> Int
-> Event m (SIROResource m)
newSIROResource = newResource SIRO
newSIROResourceWithMaxCount :: (MonadDES m, QueueStrategy m SIRO)
=> Int
-> Maybe Int
-> Event m (SIROResource m)
newSIROResourceWithMaxCount = newResourceWithMaxCount SIRO
newPriorityResource :: (MonadDES m, QueueStrategy m StaticPriorities)
=> Int
-> Event m (PriorityResource m)
newPriorityResource = newResource StaticPriorities
newPriorityResourceWithMaxCount :: (MonadDES m, QueueStrategy m StaticPriorities)
=> Int
-> Maybe Int
-> Event m (PriorityResource m)
newPriorityResourceWithMaxCount = newResourceWithMaxCount StaticPriorities
newResource :: (MonadDES m, QueueStrategy m s)
=> s
-> Int
-> Event m (Resource m s)
newResource s count =
newResourceWithMaxCount s count (Just count)
newResourceWithMaxCount :: (MonadDES m, QueueStrategy m s)
=> s
-> Int
-> Maybe Int
-> Event m (Resource m s)
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
resourceCount r =
Event $ \p -> invokeEvent p $ readRef (resourceCountRef r)
resourceCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int)
resourceCountStats r =
Event $ \p -> invokeEvent p $ readRef (resourceCountStatsRef r)
resourceCountChanged :: MonadDES m => Resource m s -> Signal m Int
resourceCountChanged r =
publishSignal $ resourceCountSource r
resourceCountChanged_ :: MonadDES m => Resource m s -> Signal m ()
resourceCountChanged_ r =
mapSignal (const ()) $ resourceCountChanged r
resourceUtilisationCount :: MonadDES m => Resource m s -> Event m Int
resourceUtilisationCount r =
Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountRef r)
resourceUtilisationCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int)
resourceUtilisationCountStats r =
Event $ \p -> invokeEvent p $ readRef (resourceUtilisationCountStatsRef r)
resourceUtilisationCountChanged :: MonadDES m => Resource m s -> Signal m Int
resourceUtilisationCountChanged r =
publishSignal $ resourceUtilisationCountSource r
resourceUtilisationCountChanged_ :: MonadDES m => Resource m s -> Signal m ()
resourceUtilisationCountChanged_ r =
mapSignal (const ()) $ resourceUtilisationCountChanged r
resourceQueueCount :: MonadDES m => Resource m s -> Event m Int
resourceQueueCount r =
Event $ \p -> invokeEvent p $ readRef (resourceQueueCountRef r)
resourceQueueCountStats :: MonadDES m => Resource m s -> Event m (TimingStats Int)
resourceQueueCountStats r =
Event $ \p -> invokeEvent p $ readRef (resourceQueueCountStatsRef r)
resourceQueueCountChanged :: MonadDES m => Resource m s -> Signal m Int
resourceQueueCountChanged r =
publishSignal $ resourceQueueCountSource r
resourceQueueCountChanged_ :: MonadDES m => Resource m s -> Signal m ()
resourceQueueCountChanged_ r =
mapSignal (const ()) $ resourceQueueCountChanged r
resourceTotalWaitTime :: MonadDES m => Resource m s -> Event m Double
resourceTotalWaitTime r =
Event $ \p -> invokeEvent p $ readRef (resourceTotalWaitTimeRef r)
resourceWaitTime :: MonadDES m => Resource m s -> Event m (SamplingStats Double)
resourceWaitTime r =
Event $ \p -> invokeEvent p $ readRef (resourceWaitTimeRef r)
resourceWaitTimeChanged :: MonadDES m => Resource m s -> Signal m (SamplingStats Double)
resourceWaitTimeChanged r =
mapSignalM (\() -> resourceWaitTime r) $ resourceWaitTimeChanged_ r
resourceWaitTimeChanged_ :: MonadDES m => Resource m s -> Signal m ()
resourceWaitTimeChanged_ r =
publishSignal $ resourceWaitTimeSource r
requestResource :: (MonadDES m, EnqueueStrategy m s)
=> Resource m s
-> Process m ()
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 ()
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 ()
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 ()
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 ()
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
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
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
usingResourceWithPriority r priority m =
do requestResourceWithPriority r priority
finallyProcess m $ releaseResource r
decResourceCount' :: (MonadDES m, EnqueueStrategy m s)
=> Resource m s
-> Process m ()
decResourceCount' r =
do liftEvent $
updateResourceUtilisationCount r (1)
requestResource r
incResourceCount :: (MonadDES m, DequeueStrategy m s)
=> Resource m s
-> Int
-> Event m ()
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 ()
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 ()
resourceChanged_ r =
resourceCountChanged_ r <>
resourceUtilisationCountChanged_ r <>
resourceQueueCountChanged_ r
updateResourceCount :: MonadDES m => Resource m s -> Int -> Event m ()
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 ()
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 ()
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 ()
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) ()