diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,11 @@ +Version 4.3.4 +----- + +* Yet more safe the resource preemption. + +* Introducing exception SimulationRetry, which is needed for parallel distributed simulation. + Version 4.3.3 ----- diff --git a/Simulation/Aivika/Event.hs b/Simulation/Aivika/Event.hs --- a/Simulation/Aivika/Event.hs +++ b/Simulation/Aivika/Event.hs @@ -46,6 +46,8 @@ memoEventInTime, -- * Disposable DisposableEvent(..), + -- * Retrying Computation + retryEvent, -- * Debugging traceEvent) where diff --git a/Simulation/Aivika/Internal/Cont.hs b/Simulation/Aivika/Internal/Cont.hs --- a/Simulation/Aivika/Internal/Cont.hs +++ b/Simulation/Aivika/Internal/Cont.hs @@ -790,7 +790,15 @@ if not f then invokeEvent p $ enqueueEvent (pointTime p) $ - resumeCont c a + Event $ \p -> + do f <- invokeEvent p $ + contPreemptionBegun $ + contId $ contAux c + if not f + then invokeEvent p $ + resumeCont c a + else invokeEvent p $ + sleepCont c a else invokeEvent p $ sleepCont c a diff --git a/Simulation/Aivika/Internal/Event.hs b/Simulation/Aivika/Internal/Event.hs --- a/Simulation/Aivika/Internal/Event.hs +++ b/Simulation/Aivika/Internal/Event.hs @@ -52,6 +52,8 @@ memoEventInTime, -- * Disposable DisposableEvent(..), + -- * Retrying Computation + retryEvent, -- * Debugging traceEvent) where @@ -409,6 +411,11 @@ mempty = DisposableEvent $ return () mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y + +-- | Retry the current computation as possible, using the specified argument +-- as a 'SimulationRetry' exception message in case of failure. +retryEvent :: String -> Event a +retryEvent message = throwEvent $ SimulationRetry message -- | Show the debug message with the current simulation time. traceEvent :: String -> Event a -> Event a diff --git a/Simulation/Aivika/Internal/Process.hs b/Simulation/Aivika/Internal/Process.hs --- a/Simulation/Aivika/Internal/Process.hs +++ b/Simulation/Aivika/Internal/Process.hs @@ -88,6 +88,8 @@ memoProcess, -- * Never Ending Process neverProcess, + -- * Retrying Computation + retryProcess, -- * Debugging traceProcess) where @@ -716,6 +718,11 @@ let signal = processCancelling pid in handleSignal_ signal $ \_ -> resumeCont c $ error "It must never be computed: neverProcess" + +-- | Retry the current computation as possible, using the specified argument +-- as a 'SimulationRetry' exception message in case of failure. +retryProcess :: String -> Process a +retryProcess = liftEvent . retryEvent -- | Show the debug message with the current simulation time. traceProcess :: String -> Process a -> Process a diff --git a/Simulation/Aivika/Internal/Simulation.hs b/Simulation/Aivika/Internal/Simulation.hs --- a/Simulation/Aivika/Internal/Simulation.hs +++ b/Simulation/Aivika/Internal/Simulation.hs @@ -32,7 +32,8 @@ memoSimulation, -- * Exceptions SimulationException(..), - SimulationAbort(..)) where + SimulationAbort(..), + SimulationRetry(..)) where import Control.Exception import Control.Monad @@ -197,11 +198,22 @@ instance Exception SimulationException -- | An exception that signals of aborting the simulation. -data SimulationAbort = SimulationAbort +data SimulationAbort = SimulationAbort String -- ^ The exception to abort the simulation. deriving (Show, Typeable) +-- | An exception that signals that the current computation should be retried +-- as possible, which feature may be supported by the simulation engine or not. +data SimulationRetry = SimulationRetry String + -- ^ The exception to retry the computation. + deriving (Show, Typeable) + instance Exception SimulationAbort where + + toException = toException . SimulationException + fromException x = do { SimulationException a <- fromException x; cast a } + +instance Exception SimulationRetry where toException = toException . SimulationException fromException x = do { SimulationException a <- fromException x; cast a } diff --git a/Simulation/Aivika/Process.hs b/Simulation/Aivika/Process.hs --- a/Simulation/Aivika/Process.hs +++ b/Simulation/Aivika/Process.hs @@ -83,6 +83,8 @@ memoProcess, -- * Never Ending Process neverProcess, + -- * Retrying Computation + retryProcess, -- * Debugging traceProcess) where diff --git a/Simulation/Aivika/Resource.hs b/Simulation/Aivika/Resource.hs --- a/Simulation/Aivika/Resource.hs +++ b/Simulation/Aivika/Resource.hs @@ -214,12 +214,14 @@ do let r = pointRun p t = pointTime p when (count < 0) $ - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be negative: " ++ "newResourceWithMaxCount." case maxCount of Just maxCount | count > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: newResourceWithMaxCount." _ -> @@ -424,7 +426,8 @@ let a' = a + 1 case resourceMaxCount r of Just maxCount | a' > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: releaseResource'." _ -> @@ -509,7 +512,7 @@ -- ^ the increment for the resource count -> Event () incResourceCount r n - | n < 0 = error "The increment cannot be negative: incResourceCount" + | n < 0 = throwEvent $ SimulationRetry "The increment cannot be negative: incResourceCount" | n == 0 = return () | otherwise = do releaseResource' r @@ -524,7 +527,7 @@ -- ^ the decrement for the resource count -> Process () decResourceCount r n - | n < 0 = error "The decrement cannot be negative: decResourceCount" + | n < 0 = throwProcess $ SimulationRetry "The decrement cannot be negative: decResourceCount" | n == 0 = return () | otherwise = do decResourceCount' r diff --git a/Simulation/Aivika/Resource/Base.hs b/Simulation/Aivika/Resource/Base.hs --- a/Simulation/Aivika/Resource/Base.hs +++ b/Simulation/Aivika/Resource/Base.hs @@ -167,7 +167,8 @@ newResource s count = Simulation $ \r -> do when (count < 0) $ - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be negative: " ++ "newResource." countRef <- newIORef count @@ -190,12 +191,14 @@ newResourceWithMaxCount s count maxCount = Simulation $ \r -> do when (count < 0) $ - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be negative: " ++ "newResourceWithMaxCount." case maxCount of Just maxCount | count > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: newResourceWithMaxCount." _ -> @@ -287,7 +290,8 @@ let a' = a + 1 case resourceMaxCount r of Just maxCount | a' > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: releaseResourceWithinEvent." _ -> @@ -358,7 +362,7 @@ -- ^ the increment for the resource count -> Event () incResourceCount r n - | n < 0 = error "The increment cannot be negative: incResourceCount" + | n < 0 = throwEvent $ SimulationRetry "The increment cannot be negative: incResourceCount" | n == 0 = return () | otherwise = do releaseResourceWithinEvent r @@ -373,7 +377,7 @@ -- ^ the decrement for the resource count -> Process () decResourceCount r n - | n < 0 = error "The decrement cannot be negative: decResourceCount" + | n < 0 = throwProcess $ SimulationRetry "The decrement cannot be negative: decResourceCount" | n == 0 = return () | otherwise = do requestResource r diff --git a/Simulation/Aivika/Resource/Preemption.hs b/Simulation/Aivika/Resource/Preemption.hs --- a/Simulation/Aivika/Resource/Preemption.hs +++ b/Simulation/Aivika/Resource/Preemption.hs @@ -129,12 +129,14 @@ do let r = pointRun p t = pointTime p when (count < 0) $ - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be negative: " ++ "newResourceWithMaxCount." case maxCount of Just maxCount | count > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: newResourceWithMaxCount." _ -> @@ -314,7 +316,8 @@ then do invokeEvent p $ updateResourceUtilisationCount r (-1) invokeEvent p $ releaseResource' r invokeEvent p $ resumeCont c () - else error $ + else throwIO $ + SimulationRetry "The resource was not acquired by this process: releaseResource" -- | Release the resource increasing its count and resuming one of the @@ -328,7 +331,8 @@ let a' = a + 1 case resourceMaxCount r of Just maxCount | a' > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: releaseResource'." _ -> @@ -385,7 +389,8 @@ do let t = pointTime p a <- readIORef (resourceCountRef r) when (a == 0) $ - error $ + throwIO $ + SimulationRetry "The resource exceeded and its count is zero: decResourceCount'" f <- PQ.queueNull (resourceActingQueue r) unless f $ @@ -408,7 +413,7 @@ -- ^ the increment for the resource count -> Event () incResourceCount r n - | n < 0 = error "The increment cannot be negative: incResourceCount" + | n < 0 = throwEvent $ SimulationRetry "The increment cannot be negative: incResourceCount" | n == 0 = return () | otherwise = do releaseResource' r @@ -422,7 +427,7 @@ -- ^ the decrement for the resource count -> Event () decResourceCount r n - | n < 0 = error "The decrement cannot be negative: decResourceCount" + | n < 0 = throwEvent $ SimulationRetry "The decrement cannot be negative: decResourceCount" | n == 0 = return () | otherwise = do decResourceCount' r diff --git a/Simulation/Aivika/Resource/Preemption/Base.hs b/Simulation/Aivika/Resource/Preemption/Base.hs --- a/Simulation/Aivika/Resource/Preemption/Base.hs +++ b/Simulation/Aivika/Resource/Preemption/Base.hs @@ -88,7 +88,8 @@ newResource count = Simulation $ \r -> do when (count < 0) $ - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be negative: " ++ "newResource." countRef <- newIORef count @@ -109,12 +110,14 @@ newResourceWithMaxCount count maxCount = Simulation $ \r -> do when (count < 0) $ - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be negative: " ++ "newResourceWithMaxCount." case maxCount of Just maxCount | count > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: newResourceWithMaxCount." _ -> @@ -191,7 +194,8 @@ if f then do invokeEvent p $ releaseResource' r invokeEvent p $ resumeCont c () - else error $ + else throwIO $ + SimulationRetry "The resource was not acquired by this process: releaseResource" -- | Release the resource increasing its count and resuming one of the @@ -205,7 +209,8 @@ let a' = a + 1 case resourceMaxCount r of Just maxCount | a' > maxCount -> - error $ + throwIO $ + SimulationRetry $ "The resource count cannot be greater than " ++ "its maximum value: releaseResource'." _ -> @@ -256,7 +261,8 @@ Event $ \p -> do a <- readIORef (resourceCountRef r) when (a == 0) $ - error $ + throwIO $ + SimulationRetry "The resource exceeded and its count is zero: decResourceCount'" f <- PQ.queueNull (resourceActingQueue r) unless f $ @@ -278,7 +284,7 @@ -- ^ the increment for the resource count -> Event () incResourceCount r n - | n < 0 = error "The increment cannot be negative: incResourceCount" + | n < 0 = throwEvent $ SimulationRetry "The increment cannot be negative: incResourceCount" | n == 0 = return () | otherwise = do releaseResource' r @@ -292,7 +298,7 @@ -- ^ the decrement for the resource count -> Event () decResourceCount r n - | n < 0 = error "The decrement cannot be negative: decResourceCount" + | n < 0 = throwEvent $ SimulationRetry "The decrement cannot be negative: decResourceCount" | n == 0 = return () | otherwise = do decResourceCount' r diff --git a/Simulation/Aivika/Simulation.hs b/Simulation/Aivika/Simulation.hs --- a/Simulation/Aivika/Simulation.hs +++ b/Simulation/Aivika/Simulation.hs @@ -25,6 +25,7 @@ memoSimulation, -- * Exceptions SimulationException(..), - SimulationAbort(..)) where + SimulationAbort(..), + SimulationRetry(..)) where import Simulation.Aivika.Internal.Simulation diff --git a/aivika.cabal b/aivika.cabal --- a/aivika.cabal +++ b/aivika.cabal @@ -1,5 +1,5 @@ name: aivika -version: 4.3.3 +version: 4.3.4 synopsis: A multi-paradigm simulation library description: Aivika is a multi-paradigm simulation library with a strong emphasis @@ -91,7 +91,7 @@ category: Simulation license: BSD3 license-file: LICENSE -copyright: (c) 2009-2015. David Sorokin +copyright: (c) 2009-2016. David Sorokin author: David Sorokin maintainer: David Sorokin homepage: http://www.aivikasoft.com/en/products/aivika.html