module Simulation.Aivika.Trans.Internal.Cont
(ContParams,
ContCancellation(..),
Cont(..),
ContId,
ContEvent(..),
FrozenCont,
newContId,
contSignal,
contCancellationInitiated,
contCancellationInitiate,
contCancellationInitiating,
contCancellationActivated,
contCancellationBind,
contCancellationConnect,
contPreemptionBegun,
contPreemptionBegin,
contPreemptionBeginning,
contPreemptionEnd,
contPreemptionEnding,
invokeCont,
runCont,
rerunCont,
spawnCont,
contParallel,
contParallel_,
catchCont,
finallyCont,
throwCont,
resumeCont,
resumeECont,
reenterCont,
freezeCont,
freezeContReentering,
unfreezeCont,
substituteCont,
contCanceled,
contAwait,
traceCont) where
import Data.Array
import Data.Monoid
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Applicative
import Debug.Trace (trace)
import Simulation.Aivika.Trans.Ref.Base
import Simulation.Aivika.Trans.Exception
import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Dynamics
import Simulation.Aivika.Trans.Internal.Event
import Simulation.Aivika.Trans.Signal
data ContCancellation = CancelTogether
| CancelChildAfterParent
| CancelParentAfterChild
| CancelInIsolation
data ContId m =
ContId { contCancellationInitiatedRef :: Ref m Bool,
contCancellationActivatedRef :: Ref m Bool,
contPreemptionCountRef :: Ref m Int,
contSignalSource :: SignalSource m ContEvent
}
instance MonadDES m => Eq (ContId m) where
x == y = contCancellationInitiatedRef x == contCancellationInitiatedRef y
data ContEvent = ContCancellationInitiating
| ContPreemptionBeginning
| ContPreemptionEnding
deriving (Eq, Ord, Show)
newContId :: MonadDES m => Simulation m (ContId m)
newContId =
Simulation $ \r ->
do r1 <- invokeSimulation r $ newRef False
r2 <- invokeSimulation r $ newRef False
r3 <- invokeSimulation r $ newRef 0
s <- invokeSimulation r newSignalSource
return ContId { contCancellationInitiatedRef = r1,
contCancellationActivatedRef = r2,
contPreemptionCountRef = r3,
contSignalSource = s
}
contSignal :: ContId m -> Signal m ContEvent
contSignal = publishSignal . contSignalSource
contCancellationInitiating :: MonadDES m => ContId m -> Signal m ()
contCancellationInitiating =
filterSignal_ (ContCancellationInitiating ==) . contSignal
contCancellationInitiated :: MonadDES m => ContId m -> Event m Bool
contCancellationInitiated =
readRef . contCancellationInitiatedRef
contCancellationActivated :: MonadDES m => ContId m -> Event m Bool
contCancellationActivated =
readRef . contCancellationActivatedRef
contCancellationDeactivate :: MonadDES m => ContId m -> Event m ()
contCancellationDeactivate x =
writeRef (contCancellationActivatedRef x) False
contCancellationBind :: MonadDES m => ContId m -> [ContId m] -> Event m (DisposableEvent m)
contCancellationBind x ys =
Event $ \p ->
do hs1 <- forM ys $ \y ->
invokeEvent p $
handleSignal (contCancellationInitiating x) $ \_ ->
contCancellationInitiate y
hs2 <- forM ys $ \y ->
invokeEvent p $
handleSignal (contCancellationInitiating y) $ \_ ->
contCancellationInitiate x
return $ mconcat hs1 <> mconcat hs2
contCancellationConnect :: MonadDES m
=> ContId m
-> ContCancellation
-> ContId m
-> Event m (DisposableEvent m)
contCancellationConnect parent cancellation child =
Event $ \p ->
do let m1 =
handleSignal (contCancellationInitiating parent) $ \_ ->
contCancellationInitiate child
m2 =
handleSignal (contCancellationInitiating child) $ \_ ->
contCancellationInitiate parent
h1 <-
case cancellation of
CancelTogether -> invokeEvent p m1
CancelChildAfterParent -> invokeEvent p m1
CancelParentAfterChild -> return mempty
CancelInIsolation -> return mempty
h2 <-
case cancellation of
CancelTogether -> invokeEvent p m2
CancelChildAfterParent -> return mempty
CancelParentAfterChild -> invokeEvent p m2
CancelInIsolation -> return mempty
return $ h1 <> h2
contCancellationInitiate :: MonadDES m => ContId m -> Event m ()
contCancellationInitiate x =
Event $ \p ->
do f <- invokeEvent p $ readRef (contCancellationInitiatedRef x)
unless f $
do invokeEvent p $ writeRef (contCancellationInitiatedRef x) True
invokeEvent p $ writeRef (contCancellationActivatedRef x) True
invokeEvent p $ triggerSignal (contSignalSource x) ContCancellationInitiating
contPreemptionBegin :: MonadDES m => ContId m -> Event m ()
contPreemptionBegin x =
Event $ \p ->
do f <- invokeEvent p $ readRef (contCancellationInitiatedRef x)
unless f $
do n <- invokeEvent p $ readRef (contPreemptionCountRef x)
let n' = n + 1
n' `seq` invokeEvent p $ writeRef (contPreemptionCountRef x) n'
when (n == 0) $
invokeEvent p $
triggerSignal (contSignalSource x) ContPreemptionBeginning
contPreemptionEnd :: MonadDES m => ContId m -> Event m ()
contPreemptionEnd x =
Event $ \p ->
do f <- invokeEvent p $ readRef (contCancellationInitiatedRef x)
unless f $
do n <- invokeEvent p $ readRef (contPreemptionCountRef x)
let n' = n 1
n' `seq` invokeEvent p $ writeRef (contPreemptionCountRef x) n'
when (n' == 0) $
invokeEvent p $
triggerSignal (contSignalSource x) ContPreemptionEnding
contPreemptionBeginning :: MonadDES m => ContId m -> Signal m ()
contPreemptionBeginning =
filterSignal_ (ContPreemptionBeginning ==) . contSignal
contPreemptionEnding :: MonadDES m => ContId m -> Signal m ()
contPreemptionEnding =
filterSignal_ (ContPreemptionEnding ==) . contSignal
contPreemptionBegun :: MonadDES m => ContId m -> Event m Bool
contPreemptionBegun x =
Event $ \p ->
do n <- invokeEvent p $ readRef (contPreemptionCountRef x)
return (n > 0)
newtype Cont m a = Cont (ContParams m a -> Event m ())
data ContParams m a =
ContParams { contCont :: a -> Event m (),
contAux :: ContParamsAux m }
data ContParamsAux m =
ContParamsAux { contECont :: SomeException -> Event m (),
contCCont :: () -> Event m (),
contId :: ContId m,
contCancelFlag :: Event m Bool,
contCatchFlag :: Bool }
instance MonadDES m => Monad (Cont m) where
return a =
Cont $ \c ->
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else invokeEvent p $ contCont c a
(Cont m) >>= k =
Cont $ \c ->
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else invokeEvent p $ m $
let cont a = invokeCont c (k a)
in c { contCont = cont }
instance MonadDES m => MonadCompTrans Cont m where
liftComp m =
Cont $ \c ->
Event $ \p ->
if contCatchFlag . contAux $ c
then liftWithCatching m p c
else liftWithoutCatching m p c
instance MonadDES m => ParameterLift Cont m where
liftParameter (Parameter m) =
Cont $ \c ->
Event $ \p ->
if contCatchFlag . contAux $ c
then liftWithCatching (m $ pointRun p) p c
else liftWithoutCatching (m $ pointRun p) p c
instance MonadDES m => SimulationLift Cont m where
liftSimulation (Simulation m) =
Cont $ \c ->
Event $ \p ->
if contCatchFlag . contAux $ c
then liftWithCatching (m $ pointRun p) p c
else liftWithoutCatching (m $ pointRun p) p c
instance MonadDES m => DynamicsLift Cont m where
liftDynamics (Dynamics m) =
Cont $ \c ->
Event $ \p ->
if contCatchFlag . contAux $ c
then liftWithCatching (m p) p c
else liftWithoutCatching (m p) p c
instance MonadDES m => EventLift Cont m where
liftEvent (Event m) =
Cont $ \c ->
Event $ \p ->
if contCatchFlag . contAux $ c
then liftWithCatching (m p) p c
else liftWithoutCatching (m p) p c
instance (MonadDES m, MonadIO m) => MonadIO (Cont m) where
liftIO m =
Cont $ \c ->
Event $ \p ->
if contCatchFlag . contAux $ c
then liftWithCatching (liftIO m) p c
else liftWithoutCatching (liftIO m) p c
instance MonadDES m => Functor (Cont m) where
fmap = liftM
instance MonadDES m => Applicative (Cont m) where
pure = return
(<*>) = ap
invokeCont :: ContParams m a -> Cont m a -> Event m ()
invokeCont p (Cont m) = m p
cancelCont :: MonadDES m => ContParams m a -> Event m ()
cancelCont c =
Event $ \p ->
do invokeEvent p $ contCancellationDeactivate (contId $ contAux c)
invokeEvent p $ (contCCont $ contAux c) ()
callCont :: MonadDES m => (a -> Cont m b) -> a -> ContParams m b -> Event m ()
callCont k a c =
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else invokeEvent p $ invokeCont c (k a)
catchCont :: (MonadDES m, Exception e) => Cont m a -> (e -> Cont m a) -> Cont m a
catchCont (Cont m) h =
Cont $ \c0 ->
Event $ \p ->
do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } }
z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else invokeEvent p $ m $
let econt e0 =
case fromException e0 of
Just e -> callCont h e c
Nothing -> (contECont . contAux $ c) e0
in c { contAux = (contAux c) { contECont = econt } }
finallyCont :: MonadDES m => Cont m a -> Cont m b -> Cont m a
finallyCont (Cont m) (Cont m') =
Cont $ \c0 ->
Event $ \p ->
do let c = c0 { contAux = (contAux c0) { contCatchFlag = True } }
z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else invokeEvent p $ m $
let cont a =
Event $ \p ->
invokeEvent p $ m' $
let cont b = contCont c a
in c { contCont = cont }
econt e =
Event $ \p ->
invokeEvent p $ m' $
let cont b = (contECont . contAux $ c) e
in c { contCont = cont }
ccont () =
Event $ \p ->
invokeEvent p $ m' $
let cont b = (contCCont . contAux $ c) ()
econt e = (contCCont . contAux $ c) ()
in c { contCont = cont,
contAux = (contAux c) { contECont = econt } }
in c { contCont = cont,
contAux = (contAux c) { contECont = econt,
contCCont = ccont } }
throwCont :: (MonadDES m, Exception e) => e -> Cont m a
throwCont = liftEvent . throwEvent
runCont :: MonadDES m
=> Cont m a
-> (a -> Event m ())
-> (SomeException -> Event m ())
-> (() -> Event m ())
-> ContId m
-> Bool
-> Event m ()
runCont (Cont m) cont econt ccont cid catchFlag =
m ContParams { contCont = cont,
contAux =
ContParamsAux { contECont = econt,
contCCont = ccont,
contId = cid,
contCancelFlag = contCancellationActivated cid,
contCatchFlag = catchFlag } }
liftWithoutCatching :: MonadDES m => m a -> Point m -> ContParams m a -> m ()
liftWithoutCatching m p c =
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else do a <- m
invokeEvent p $ contCont c a
liftWithCatching :: MonadDES m => m a -> Point m -> ContParams m a -> m ()
liftWithCatching m p c =
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else do let r = pointRun p
aref <- invokeSimulation r $ newRef undefined
eref <- invokeSimulation r $ newRef Nothing
catchComp
(m >>= invokeEvent p . writeRef aref)
(invokeEvent p . writeRef eref . Just)
e <- invokeEvent p $ readRef eref
case e of
Nothing ->
do a <- invokeEvent p $ readRef aref
invokeEvent p $ contCont c a
Just e ->
invokeEvent p $ (contECont . contAux) c e
resumeCont :: MonadDES m => ContParams m a -> a -> Event m ()
resumeCont c a =
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else invokeEvent p $ contCont c a
resumeECont :: MonadDES m => ContParams m a -> SomeException -> Event m ()
resumeECont c e =
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else invokeEvent p $ (contECont $ contAux c) e
contCanceled :: ContParams m a -> Event m Bool
contCanceled c = contCancelFlag $ contAux c
contParallel :: MonadDES m
=> [(Cont m a, ContId m)]
-> Cont m [a]
contParallel xs =
Cont $ \c ->
Event $ \p ->
do let n = length xs
r = pointRun p
worker =
do results <- forM [1..n] $ \i -> invokeSimulation r $ newRef undefined
counter <- invokeSimulation r $ newRef 0
catchRef <- invokeSimulation r $ newRef Nothing
hs <- invokeEvent p $
contCancellationBind (contId $ contAux c) $
map snd xs
let propagate =
Event $ \p ->
do n' <- invokeEvent p $ readRef counter
when (n' == n) $
do invokeEvent p $ disposeEvent hs
f1 <- invokeEvent p $ contCanceled c
f2 <- invokeEvent p $ readRef catchRef
case (f1, f2) of
(False, Nothing) ->
do rs <- forM results $ invokeEvent p . readRef
invokeEvent p $ resumeCont c rs
(False, Just e) ->
invokeEvent p $ resumeECont c e
(True, _) ->
invokeEvent p $ cancelCont c
cont result a =
Event $ \p ->
do invokeEvent p $ modifyRef counter (+ 1)
invokeEvent p $ writeRef result a
invokeEvent p propagate
econt e =
Event $ \p ->
do invokeEvent p $ modifyRef counter (+ 1)
r <- invokeEvent p $ readRef catchRef
case r of
Nothing -> invokeEvent p $ writeRef catchRef $ Just e
Just e' -> return ()
invokeEvent p propagate
ccont e =
Event $ \p ->
do invokeEvent p $ modifyRef counter (+ 1)
invokeEvent p propagate
forM_ (zip results xs) $ \(result, (x, cid)) ->
invokeEvent p $
runCont x (cont result) econt ccont cid (contCatchFlag $ contAux c)
z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else if n == 0
then invokeEvent p $ contCont c []
else worker
contParallel_ :: MonadDES m
=> [(Cont m a, ContId m)]
-> Cont m ()
contParallel_ xs =
Cont $ \c ->
Event $ \p ->
do let n = length xs
r = pointRun p
worker =
do counter <- invokeSimulation r $ newRef 0
catchRef <- invokeSimulation r $ newRef Nothing
hs <- invokeEvent p $
contCancellationBind (contId $ contAux c) $
map snd xs
let propagate =
Event $ \p ->
do n' <- invokeEvent p $ readRef counter
when (n' == n) $
do invokeEvent p $ disposeEvent hs
f1 <- invokeEvent p $ contCanceled c
f2 <- invokeEvent p $ readRef catchRef
case (f1, f2) of
(False, Nothing) ->
invokeEvent p $ resumeCont c ()
(False, Just e) ->
invokeEvent p $ resumeECont c e
(True, _) ->
invokeEvent p $ cancelCont c
cont a =
Event $ \p ->
do invokeEvent p $ modifyRef counter (+ 1)
invokeEvent p propagate
econt e =
Event $ \p ->
do invokeEvent p $ modifyRef counter (+ 1)
r <- invokeEvent p $ readRef catchRef
case r of
Nothing -> invokeEvent p $ writeRef catchRef $ Just e
Just e' -> return ()
invokeEvent p propagate
ccont e =
Event $ \p ->
do invokeEvent p $ modifyRef counter (+ 1)
invokeEvent p propagate
forM_ (zip [0..n1] xs) $ \(i, (x, cid)) ->
invokeEvent p $
runCont x cont econt ccont cid (contCatchFlag $ contAux c)
z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else if n == 0
then invokeEvent p $ contCont c ()
else worker
rerunCont :: MonadDES m => Cont m a -> ContId m -> Cont m a
rerunCont x cid =
Cont $ \c ->
Event $ \p ->
do let worker =
do hs <- invokeEvent p $
contCancellationBind (contId $ contAux c) [cid]
let cont a =
Event $ \p ->
do invokeEvent p $ disposeEvent hs
invokeEvent p $ resumeCont c a
econt e =
Event $ \p ->
do invokeEvent p $ disposeEvent hs
invokeEvent p $ resumeECont c e
ccont e =
Event $ \p ->
do invokeEvent p $ disposeEvent hs
invokeEvent p $ cancelCont c
invokeEvent p $
runCont x cont econt ccont cid (contCatchFlag $ contAux c)
z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else worker
spawnCont :: MonadDES m => ContCancellation -> Cont m () -> ContId m -> Cont m ()
spawnCont cancellation x cid =
Cont $ \c ->
Event $ \p ->
do let worker =
do hs <- invokeEvent p $
contCancellationConnect
(contId $ contAux c) cancellation cid
let cont a =
Event $ \p ->
do invokeEvent p $ disposeEvent hs
econt e =
Event $ \p ->
do invokeEvent p $ disposeEvent hs
invokeEvent p $ throwEvent e
ccont e =
Event $ \p ->
do invokeEvent p $ disposeEvent hs
invokeEvent p $
enqueueEvent (pointTime p) $
runCont x cont econt ccont cid False
invokeEvent p $
resumeCont c ()
z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else worker
newtype FrozenCont m a =
FrozenCont { unfreezeCont :: Event m (Maybe (ContParams m a))
}
freezeCont :: MonadDES m => ContParams m a -> Event m (FrozenCont m a)
freezeCont c =
Event $ \p ->
do let r = pointRun p
rh <- invokeSimulation r $ newRef Nothing
rc <- invokeSimulation r $ newRef $ Just c
h <- invokeEvent p $
handleSignal (contCancellationInitiating $
contId $
contAux c) $ \e ->
Event $ \p ->
do h <- invokeEvent p $ readRef rh
case h of
Nothing ->
error "The handler was lost: freezeCont."
Just h ->
do invokeEvent p $ disposeEvent h
c <- invokeEvent p $ readRef rc
case c of
Nothing -> return ()
Just c ->
do invokeEvent p $ writeRef rc Nothing
invokeEvent p $
enqueueEvent (pointTime p) $
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
when z $ invokeEvent p $ cancelCont c
invokeEvent p $ writeRef rh (Just h)
return $
FrozenCont $
Event $ \p ->
do invokeEvent p $ disposeEvent h
c <- invokeEvent p $ readRef rc
invokeEvent p $ writeRef rc Nothing
return c
freezeContReentering :: MonadDES m => ContParams m a -> a -> Event m () -> Event m (FrozenCont m a)
freezeContReentering c a m =
Event $ \p ->
do let r = pointRun p
rh <- invokeSimulation r $ newRef Nothing
rc <- invokeSimulation r $ newRef $ Just c
h <- invokeEvent p $
handleSignal (contCancellationInitiating $
contId $ contAux c) $ \e ->
Event $ \p ->
do h <- invokeEvent p $ readRef rh
case h of
Nothing ->
error "The handler was lost: freezeContReentering."
Just h ->
do invokeEvent p $ disposeEvent h
c <- invokeEvent p $ readRef rc
case c of
Nothing -> return ()
Just c ->
do invokeEvent p $ writeRef rc Nothing
invokeEvent p $
enqueueEvent (pointTime p) $
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
when z $ invokeEvent p $ cancelCont c
invokeEvent p $ writeRef rh (Just h)
return $
FrozenCont $
Event $ \p ->
do invokeEvent p $ disposeEvent h
c <- invokeEvent p $ readRef rc
invokeEvent p $ writeRef rc Nothing
case c of
Nothing -> return Nothing
z @ (Just c) ->
do f <- invokeEvent p $
contPreemptionBegun $
contId $ contAux c
if not f
then return z
else do let c = c { contCont = \a -> m }
invokeEvent p $ sleepCont c a
return Nothing
reenterCont :: MonadDES m => ContParams m a -> a -> Event m ()
reenterCont c a =
Event $ \p ->
do f <- invokeEvent p $
contPreemptionBegun $
contId $ contAux c
if not f
then invokeEvent p $
enqueueEvent (pointTime p) $
resumeCont c a
else invokeEvent p $
sleepCont c a
sleepCont :: MonadDES m => ContParams m a -> a -> Event m ()
sleepCont c a =
Event $ \p ->
do let r = pointRun p
rh <- invokeSimulation r $ newRef Nothing
h <- invokeEvent p $
handleSignal (contSignal $
contId $ contAux c) $ \e ->
Event $ \p ->
do h <- invokeEvent p $ readRef rh
case h of
Nothing ->
error "The handler was lost: sleepCont."
Just h ->
do invokeEvent p $ disposeEvent h
case e of
ContCancellationInitiating ->
invokeEvent p $
enqueueEvent (pointTime p) $
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
when z $ invokeEvent p $ cancelCont c
ContPreemptionEnding ->
invokeEvent p $
enqueueEvent (pointTime p) $
reenterCont c a
ContPreemptionBeginning ->
error "The computation was already preempted: sleepCont."
invokeEvent p $ writeRef rh (Just h)
substituteCont :: MonadDES m => ContParams m a -> (a -> Event m ()) -> ContParams m a
substituteCont c m = c { contCont = m }
contAwait :: MonadDES m => Signal m a -> Cont m a
contAwait signal =
Cont $ \c ->
Event $ \p ->
do let r = pointRun p
c <- invokeEvent p $ freezeCont c
rh <- invokeSimulation r $ newRef Nothing
h <- invokeEvent p $
handleSignal signal $
\a -> Event $
\p -> do x <- invokeEvent p $ readRef rh
case x of
Nothing ->
error "The signal was lost: contAwait."
Just x ->
do invokeEvent p $ disposeEvent x
c <- invokeEvent p $ unfreezeCont c
case c of
Nothing -> return ()
Just c ->
invokeEvent p $ reenterCont c a
invokeEvent p $ writeRef rh $ Just h
traceCont :: MonadDES m => String -> Cont m a -> Cont m a
traceCont message (Cont m) =
Cont $ \c ->
Event $ \p ->
do z <- invokeEvent p $ contCanceled c
if z
then invokeEvent p $ cancelCont c
else trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $
invokeEvent p $ m c