module Control.Hasim.SimRun (
runSimulation
) where
import Control.Hasim.DES
import Control.Hasim.Process
import Control.Hasim.Simulation
import Control.Hasim.Types
import Control.Hasim.WatchMap
import Control.Monad.State
import Data.IORef
import Data.Maybe
type SimRunM a = StateT SimRunSt IO a
data SimRunSt = SimRunSt { des :: DES
, time :: Time
, watchmap :: WatchMap
, latestPid :: Id
}
runSimulation :: Simulation -> IO ()
runSimulation sim = initDES (unSim sim) >>= evalStateT run . initSimRunSt
initSimRunSt :: DES -> SimRunSt
initSimRunSt des' = SimRunSt { des = des'
, time = 0
, watchmap = emptyWM
, latestPid = 1
}
getDES :: SimRunM DES
getDES = des `liftM` get
putDES :: DES -> SimRunM ()
putDES newdes = get >>= \st -> put (st { des = newdes })
getWatchmap :: SimRunM WatchMap
getWatchmap = watchmap `liftM` get
putWatchmap :: WatchMap -> SimRunM ()
putWatchmap newwm = get >>= \st -> put (st { watchmap = newwm })
getTime :: SimRunM Time
getTime = time `liftM` get
putTime :: Time -> SimRunM ()
putTime newtime = get >>= \st -> put (st { time = newtime })
popEvent :: SimRunM Event
popEvent = do
curDES <- getDES
when (isEmpty curDES) (error "Control.Hasim.SimRun.popEvent : empty DES")
let (evt, des') = removeNext curDES
putDES des'
return $! evt
run :: SimRunM ()
run = do
curDES <- getDES
if isEmpty curDES
then return ()
else popEvent >>= runEvent >> run
warp :: Event -> SimRunM ()
warp evt = do
oldtime <- getTime
when (eTime evt < oldtime)
(error "Control.Hasim.SimRun.runEvent : invalid time warp")
putTime $ eTime evt
runEvent :: Event -> SimRunM ()
runEvent evt = do
warp evt
stepRunnable (eRunnable evt)
reschedule :: Time -> Runnable -> SimRunM ()
reschedule newtime newrun = do
curDES <- getDES
putDES (update newtime newrun curDES)
maybeReschedule :: Time -> Maybe Runnable -> SimRunM ()
maybeReschedule t = maybe
(return ())
(reschedule t)
rescheduleNow :: Runnable -> SimRunM ()
rescheduleNow newrun = do
t <- getTime
reschedule t newrun
maybeRescheduleNow :: Maybe Runnable -> SimRunM ()
maybeRescheduleNow = maybe (return ()) rescheduleNow
execPopAcceptor :: Proc pkt st -> SimRunM ()
execPopAcceptor proc = lift $ acceptor proc `modifyIORef` tail
getAcceptor :: Proc pkt st -> SimRunM (Acceptor pkt st, Maybe Runnable)
getAcceptor proc = do
accs <- lift $ readIORef (acceptor proc)
when (null accs)
(error $
"Control.Hasim.SimRun.getAcceptor : " ++
"sending to empty acceptor list"
)
return $! head accs
addWatch :: Proc a stA
-> Proc b stB
-> SimRunM ()
addWatch watcher watched = do
wm <- getWatchmap
let p1 = Process watcher
let p2 = Process watched
putWatchmap (register p1 p2 wm)
execSend :: Proc a stA
-> pkt
-> Proc pkt stB
-> Time
-> (Maybe (Bool -> Runnable))
-> SimRunM ()
execSend sender pkt recv maxtime cont = do
(targetAcceptor, finallyCont) <- getAcceptor recv
case targetAcceptor pkt of
Refuse -> do
let rhs = case cont of
Nothing -> Nothing
Just cont' -> Just (\() -> cont' False)
maybeReschedule maxtime $
Just (Run sender (Unwatch recv) rhs)
addWatch sender recv
lift (wakeup sender `writeIORef`
Just (Run sender (Send pkt recv maxtime) cont)
)
Interrupt f -> do
execUnwatch sender recv
maybeRescheduleNow (cont >>= return . ($True))
rescheduleNow $ (toRunnable recv f) `rcatMaybe` finallyCont
Parallel f -> do
execUnwatch sender recv
maybeRescheduleNow (cont >>= return . ($True))
lift $ currentState recv `modifyIORef` f
execUnwatch :: Proc a stA
-> Proc b stB
-> SimRunM ()
execUnwatch sender recv = do
wm <- getWatchmap
let p1 = Process sender
let p2 = Process recv
putWatchmap (unregister p1 p2 wm)
lift (wakeup sender `writeIORef` Nothing)
rcat :: Runnable -> Runnable -> Runnable
(Run proc prim (Just c)) `rcat` r = Run proc prim (Just $ \x -> c x `rcat` r)
(Run proc prim Nothing) `rcat` r = Run proc prim (Just $ const r)
rcatMaybe :: Runnable -> Maybe Runnable -> Runnable
rcatMaybe r = maybe r (rcat r)
execWithAcceptor :: Proc pkt st
-> Acceptor pkt st
-> Action pkt st ()
-> Maybe Runnable
-> SimRunM ()
execWithAcceptor proc acc try cont = do
lift $ acceptor proc `modifyIORef` ((acc, cont):)
rescheduleNow $ (toRunnable proc try) `rcatMaybe` cont
stepRunnable :: Runnable -> SimRunM ()
stepRunnable (Run proc prim rest) = do
case prim of
Ret x -> do
let next = rest >>= return . ($x)
maybeRescheduleNow next
Wait t -> do
let next = rest >>= return . ($())
curTime <- getTime
maybeReschedule (curTime + t) next
Send pkt recv timeout -> do
execSend proc pkt recv timeout rest
Unwatch rcv -> do
execUnwatch proc rcv
let next = rest >>= return . ($())
maybeRescheduleNow next
WithAcceptor acc c -> do
let next = rest >>= return . ($())
execWithAcceptor proc acc c next
PopAcceptor -> do
execPopAcceptor proc
let next = rest >>= return . ($())
maybeRescheduleNow next
PerformIO io -> do
r <- lift io
let next = rest >>= return . ($r)
maybeRescheduleNow next
ObserveTime -> do
t <- getTime
let next = rest >>= return . ($t)
maybeRescheduleNow next
GetState -> do
st <- lift $ readIORef (currentState proc)
let next = rest >>= return . ($st)
maybeRescheduleNow next
PutState st -> do
lift $ currentState proc `writeIORef` st
let next = rest >>= return . ($())
maybeRescheduleNow next
WaitForever -> do
return ()
when (wake (Atom prim)) $ do
wm <- getWatchmap
forM_ (watchers wm (Process proc)) (\(Process p') -> do
x <- lift (readIORef $ wakeup p')
maybeRescheduleNow x
)
wake :: Atom -> Bool
wake (Atom (Ret _)) = False
wake (Atom (Wait _)) = False
wake (Atom (Send _ _ _)) = False
wake (Atom (Unwatch _)) = False
wake (Atom (WithAcceptor _ _)) = True
wake (Atom (PopAcceptor)) = True
wake (Atom (ObserveTime)) = False
wake (Atom (PerformIO _)) = False
wake (Atom (GetState)) = False
wake (Atom (PutState _)) = False
wake (Atom (WaitForever)) = False