module Simulation.Aivika.Resource.Preemption.Base
(
Resource,
newResource,
newResourceWithMaxCount,
resourceMaxCount,
resourceCount,
requestResourceWithPriority,
releaseResource,
usingResourceWithPriority,
incResourceCount,
decResourceCount,
alterResourceCount) where
import Data.IORef
import Data.Maybe
import Control.Monad
import Control.Monad.Trans
import Control.Exception
import Simulation.Aivika.Internal.Specs
import Simulation.Aivika.Internal.Simulation
import Simulation.Aivika.Internal.Event
import Simulation.Aivika.Internal.Cont
import Simulation.Aivika.Internal.Process
import Simulation.Aivika.QueueStrategy
import qualified Simulation.Aivika.PriorityQueue as PQ
data Resource =
Resource { Resource -> Maybe Int
resourceMaxCount :: Maybe Int,
Resource -> IORef Int
resourceCountRef :: IORef Int,
Resource -> PriorityQueue ResourceActingItem
resourceActingQueue :: PQ.PriorityQueue ResourceActingItem,
Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue :: PQ.PriorityQueue ResourceAwaitingItem }
data ResourceActingItem =
ResourceActingItem { ResourceActingItem -> Double
actingItemPriority :: Double,
ResourceActingItem -> ProcessId
actingItemId :: ProcessId }
type ResourceAwaitingItem = Either ResourceRequestingItem ResourcePreemptedItem
data ResourceRequestingItem =
ResourceRequestingItem { ResourceRequestingItem -> Double
requestingItemPriority :: Double,
ResourceRequestingItem -> ProcessId
requestingItemId :: ProcessId,
ResourceRequestingItem -> FrozenCont ()
requestingItemCont :: FrozenCont () }
data ResourcePreemptedItem =
ResourcePreemptedItem { ResourcePreemptedItem -> Double
preemptedItemPriority :: Double,
ResourcePreemptedItem -> ProcessId
preemptedItemId :: ProcessId }
instance Eq Resource where
Resource
x == :: Resource -> Resource -> Bool
== Resource
y = Resource -> IORef Int
resourceCountRef Resource
x forall a. Eq a => a -> a -> Bool
== Resource -> IORef Int
resourceCountRef Resource
y
instance Eq ResourceActingItem where
ResourceActingItem
x == :: ResourceActingItem -> ResourceActingItem -> Bool
== ResourceActingItem
y = ResourceActingItem -> ProcessId
actingItemId ResourceActingItem
x forall a. Eq a => a -> a -> Bool
== ResourceActingItem -> ProcessId
actingItemId ResourceActingItem
y
newResource :: Int
-> Simulation Resource
newResource :: Int -> Simulation Resource
newResource Int
count =
forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
r ->
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
String -> SimulationRetry
SimulationRetry forall a b. (a -> b) -> a -> b
$
String
"The resource count cannot be negative: " forall a. [a] -> [a] -> [a]
++
String
"newResource."
IORef Int
countRef <- forall a. a -> IO (IORef a)
newIORef Int
count
PriorityQueue ResourceActingItem
actingQueue <- forall a. IO (PriorityQueue a)
PQ.newQueue
PriorityQueue ResourceAwaitingItem
waitQueue <- forall a. IO (PriorityQueue a)
PQ.newQueue
forall (m :: * -> *) a. Monad m => a -> m a
return Resource { resourceMaxCount :: Maybe Int
resourceMaxCount = forall a. a -> Maybe a
Just Int
count,
resourceCountRef :: IORef Int
resourceCountRef = IORef Int
countRef,
resourceActingQueue :: PriorityQueue ResourceActingItem
resourceActingQueue = PriorityQueue ResourceActingItem
actingQueue,
resourceWaitQueue :: PriorityQueue ResourceAwaitingItem
resourceWaitQueue = PriorityQueue ResourceAwaitingItem
waitQueue }
newResourceWithMaxCount :: Int
-> Maybe Int
-> Simulation Resource
newResourceWithMaxCount :: Int -> Maybe Int -> Simulation Resource
newResourceWithMaxCount Int
count Maybe Int
maxCount =
forall a. (Run -> IO a) -> Simulation a
Simulation forall a b. (a -> b) -> a -> b
$ \Run
r ->
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count forall a. Ord a => a -> a -> Bool
< Int
0) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
String -> SimulationRetry
SimulationRetry forall a b. (a -> b) -> a -> b
$
String
"The resource count cannot be negative: " forall a. [a] -> [a] -> [a]
++
String
"newResourceWithMaxCount."
case Maybe Int
maxCount of
Just Int
maxCount | Int
count forall a. Ord a => a -> a -> Bool
> Int
maxCount ->
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
String -> SimulationRetry
SimulationRetry forall a b. (a -> b) -> a -> b
$
String
"The resource count cannot be greater than " forall a. [a] -> [a] -> [a]
++
String
"its maximum value: newResourceWithMaxCount."
Maybe Int
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
IORef Int
countRef <- forall a. a -> IO (IORef a)
newIORef Int
count
PriorityQueue ResourceActingItem
actingQueue <- forall a. IO (PriorityQueue a)
PQ.newQueue
PriorityQueue ResourceAwaitingItem
waitQueue <- forall a. IO (PriorityQueue a)
PQ.newQueue
forall (m :: * -> *) a. Monad m => a -> m a
return Resource { resourceMaxCount :: Maybe Int
resourceMaxCount = Maybe Int
maxCount,
resourceCountRef :: IORef Int
resourceCountRef = IORef Int
countRef,
resourceActingQueue :: PriorityQueue ResourceActingItem
resourceActingQueue = PriorityQueue ResourceActingItem
actingQueue,
resourceWaitQueue :: PriorityQueue ResourceAwaitingItem
resourceWaitQueue = PriorityQueue ResourceAwaitingItem
waitQueue }
resourceCount :: Resource -> Event Int
resourceCount :: Resource -> Event Int
resourceCount Resource
r =
forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p -> forall a. IORef a -> IO a
readIORef (Resource -> IORef Int
resourceCountRef Resource
r)
requestResourceWithPriority :: Resource
-> Double
-> Process ()
requestResourceWithPriority :: Resource -> Double -> Process ()
requestResourceWithPriority Resource
r Double
priority =
forall a. (ProcessId -> Cont a) -> Process a
Process forall a b. (a -> b) -> a -> b
$ \ProcessId
pid ->
forall a. (ContParams a -> Event ()) -> Cont a
Cont forall a b. (a -> b) -> a -> b
$ \ContParams ()
c ->
forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
do Int
a <- forall a. IORef a -> IO a
readIORef (Resource -> IORef Int
resourceCountRef Resource
r)
if Int
a forall a. Eq a => a -> a -> Bool
== Int
0
then do Bool
f <- forall a. PriorityQueue a -> IO Bool
PQ.queueNull (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r)
if Bool
f
then do FrozenCont ()
c <- forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$
forall a. ContParams a -> a -> Event () -> Event (FrozenCont a)
freezeContReentering ContParams ()
c () forall a b. (a -> b) -> a -> b
$
forall a. ContParams a -> Cont a -> Event ()
invokeCont ContParams ()
c forall a b. (a -> b) -> a -> b
$
forall a. ProcessId -> Process a -> Cont a
invokeProcess ProcessId
pid forall a b. (a -> b) -> a -> b
$
Resource -> Double -> Process ()
requestResourceWithPriority Resource
r Double
priority
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue Resource
r) Double
priority (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> FrozenCont () -> ResourceRequestingItem
ResourceRequestingItem Double
priority ProcessId
pid FrozenCont ()
c)
else do (Double
p0', ResourceActingItem
item0) <- forall a. PriorityQueue a -> IO (Double, a)
PQ.queueFront (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r)
let p0 :: Double
p0 = - Double
p0'
pid0 :: ProcessId
pid0 = ResourceActingItem -> ProcessId
actingItemId ResourceActingItem
item0
if Double
priority forall a. Ord a => a -> a -> Bool
< Double
p0
then do forall a. PriorityQueue a -> IO ()
PQ.dequeue (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r)
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r) (- Double
priority) forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> ResourceActingItem
ResourceActingItem Double
priority ProcessId
pid
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue Resource
r) Double
p0 (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> ResourcePreemptedItem
ResourcePreemptedItem Double
p0 ProcessId
pid0)
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ ProcessId -> Event ()
processPreemptionBegin ProcessId
pid0
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ forall a. ContParams a -> a -> Event ()
resumeCont ContParams ()
c ()
else do FrozenCont ()
c <- forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$
forall a. ContParams a -> a -> Event () -> Event (FrozenCont a)
freezeContReentering ContParams ()
c () forall a b. (a -> b) -> a -> b
$
forall a. ContParams a -> Cont a -> Event ()
invokeCont ContParams ()
c forall a b. (a -> b) -> a -> b
$
forall a. ProcessId -> Process a -> Cont a
invokeProcess ProcessId
pid forall a b. (a -> b) -> a -> b
$
Resource -> Double -> Process ()
requestResourceWithPriority Resource
r Double
priority
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue Resource
r) Double
priority (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> FrozenCont () -> ResourceRequestingItem
ResourceRequestingItem Double
priority ProcessId
pid FrozenCont ()
c)
else do let a' :: Int
a' = Int
a forall a. Num a => a -> a -> a
- Int
1
Int
a' seq :: forall a b. a -> b -> b
`seq` forall a. IORef a -> a -> IO ()
writeIORef (Resource -> IORef Int
resourceCountRef Resource
r) Int
a'
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r) (- Double
priority) forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> ResourceActingItem
ResourceActingItem Double
priority ProcessId
pid
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ forall a. ContParams a -> a -> Event ()
resumeCont ContParams ()
c ()
releaseResource :: Resource
-> Process ()
releaseResource :: Resource -> Process ()
releaseResource Resource
r =
forall a. (ProcessId -> Cont a) -> Process a
Process forall a b. (a -> b) -> a -> b
$ \ProcessId
pid ->
forall a. (ContParams a -> Event ()) -> Cont a
Cont forall a b. (a -> b) -> a -> b
$ \ContParams ()
c ->
forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
do Bool
f <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall a. PriorityQueue a -> (a -> Bool) -> IO (Maybe a)
PQ.queueDeleteBy (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r) (\ResourceActingItem
item -> ResourceActingItem -> ProcessId
actingItemId ResourceActingItem
item forall a. Eq a => a -> a -> Bool
== ProcessId
pid)
if Bool
f
then do forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ Resource -> Event ()
releaseResource' Resource
r
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ forall a. ContParams a -> a -> Event ()
resumeCont ContParams ()
c ()
else forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
String -> SimulationRetry
SimulationRetry
String
"The resource was not acquired by this process: releaseResource"
releaseResource' :: Resource
-> Event ()
releaseResource' :: Resource -> Event ()
releaseResource' Resource
r =
forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
do Int
a <- forall a. IORef a -> IO a
readIORef (Resource -> IORef Int
resourceCountRef Resource
r)
let a' :: Int
a' = Int
a forall a. Num a => a -> a -> a
+ Int
1
case Resource -> Maybe Int
resourceMaxCount Resource
r of
Just Int
maxCount | Int
a' forall a. Ord a => a -> a -> Bool
> Int
maxCount ->
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
String -> SimulationRetry
SimulationRetry forall a b. (a -> b) -> a -> b
$
String
"The resource count cannot be greater than " forall a. [a] -> [a] -> [a]
++
String
"its maximum value: releaseResource'."
Maybe Int
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Bool
f <- forall a. PriorityQueue a -> IO Bool
PQ.queueNull (Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue Resource
r)
if Bool
f
then Int
a' seq :: forall a b. a -> b -> b
`seq` forall a. IORef a -> a -> IO ()
writeIORef (Resource -> IORef Int
resourceCountRef Resource
r) Int
a'
else do (Double
priority', ResourceAwaitingItem
item) <- forall a. PriorityQueue a -> IO (Double, a)
PQ.queueFront (Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue Resource
r)
forall a. PriorityQueue a -> IO ()
PQ.dequeue (Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue Resource
r)
case ResourceAwaitingItem
item of
Left (ResourceRequestingItem Double
priority ProcessId
pid FrozenCont ()
c) ->
do Maybe (ContParams ())
c <- forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ forall a. FrozenCont a -> Event (Maybe (ContParams a))
unfreezeCont FrozenCont ()
c
case Maybe (ContParams ())
c of
Maybe (ContParams ())
Nothing ->
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ Resource -> Event ()
releaseResource' Resource
r
Just ContParams ()
c ->
do forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r) (- Double
priority) forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> ResourceActingItem
ResourceActingItem Double
priority ProcessId
pid
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ Double -> Event () -> Event ()
enqueueEvent (Point -> Double
pointTime Point
p) forall a b. (a -> b) -> a -> b
$ forall a. ContParams a -> a -> Event ()
reenterCont ContParams ()
c ()
Right (ResourcePreemptedItem Double
priority ProcessId
pid) ->
do Bool
f <- forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ ProcessId -> Event Bool
processCancelled ProcessId
pid
case Bool
f of
Bool
True ->
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ Resource -> Event ()
releaseResource' Resource
r
Bool
False ->
do forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r) (- Double
priority) forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> ResourceActingItem
ResourceActingItem Double
priority ProcessId
pid
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ ProcessId -> Event ()
processPreemptionEnd ProcessId
pid
usingResourceWithPriority :: Resource
-> Double
-> Process a
-> Process a
usingResourceWithPriority :: forall a. Resource -> Double -> Process a -> Process a
usingResourceWithPriority Resource
r Double
priority Process a
m =
do Resource -> Double -> Process ()
requestResourceWithPriority Resource
r Double
priority
forall a b. Process a -> Process b -> Process a
finallyProcess Process a
m forall a b. (a -> b) -> a -> b
$ Resource -> Process ()
releaseResource Resource
r
decResourceCount' :: Resource -> Event ()
decResourceCount' :: Resource -> Event ()
decResourceCount' Resource
r =
forall a. (Point -> IO a) -> Event a
Event forall a b. (a -> b) -> a -> b
$ \Point
p ->
do Int
a <- forall a. IORef a -> IO a
readIORef (Resource -> IORef Int
resourceCountRef Resource
r)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
a forall a. Eq a => a -> a -> Bool
== Int
0) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$
String -> SimulationRetry
SimulationRetry
String
"The resource exceeded and its count is zero: decResourceCount'"
Bool
f <- forall a. PriorityQueue a -> IO Bool
PQ.queueNull (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
f forall a b. (a -> b) -> a -> b
$
do (Double
p0', ResourceActingItem
item0) <- forall a. PriorityQueue a -> IO (Double, a)
PQ.queueFront (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r)
let p0 :: Double
p0 = - Double
p0'
pid0 :: ProcessId
pid0 = ResourceActingItem -> ProcessId
actingItemId ResourceActingItem
item0
forall a. PriorityQueue a -> IO ()
PQ.dequeue (Resource -> PriorityQueue ResourceActingItem
resourceActingQueue Resource
r)
forall a. PriorityQueue a -> Double -> a -> IO ()
PQ.enqueue (Resource -> PriorityQueue ResourceAwaitingItem
resourceWaitQueue Resource
r) Double
p0 (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Double -> ProcessId -> ResourcePreemptedItem
ResourcePreemptedItem Double
p0 ProcessId
pid0)
forall a. Point -> Event a -> IO a
invokeEvent Point
p forall a b. (a -> b) -> a -> b
$ ProcessId -> Event ()
processPreemptionBegin ProcessId
pid0
let a' :: Int
a' = Int
a forall a. Num a => a -> a -> a
- Int
1
Int
a' seq :: forall a b. a -> b -> b
`seq` forall a. IORef a -> a -> IO ()
writeIORef (Resource -> IORef Int
resourceCountRef Resource
r) Int
a'
incResourceCount :: Resource
-> Int
-> Event ()
incResourceCount :: Resource -> Int -> Event ()
incResourceCount Resource
r Int
n
| Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = forall e a. Exception e => e -> Event a
throwEvent forall a b. (a -> b) -> a -> b
$ String -> SimulationRetry
SimulationRetry String
"The increment cannot be negative: incResourceCount"
| Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise =
do Resource -> Event ()
releaseResource' Resource
r
Resource -> Int -> Event ()
incResourceCount Resource
r (Int
n forall a. Num a => a -> a -> a
- Int
1)
decResourceCount :: Resource
-> Int
-> Event ()
decResourceCount :: Resource -> Int -> Event ()
decResourceCount Resource
r Int
n
| Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = forall e a. Exception e => e -> Event a
throwEvent forall a b. (a -> b) -> a -> b
$ String -> SimulationRetry
SimulationRetry String
"The decrement cannot be negative: decResourceCount"
| Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise =
do Resource -> Event ()
decResourceCount' Resource
r
Resource -> Int -> Event ()
decResourceCount Resource
r (Int
n forall a. Num a => a -> a -> a
- Int
1)
alterResourceCount :: Resource
-> Int
-> Event ()
alterResourceCount :: Resource -> Int -> Event ()
alterResourceCount Resource
r Int
n
| Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = Resource -> Int -> Event ()
decResourceCount Resource
r (- Int
n)
| Int
n forall a. Ord a => a -> a -> Bool
> Int
0 = Resource -> Int -> Event ()
incResourceCount Resource
r Int
n
| Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()