From ec98bad3088376abac9008b9c856bc82fb834f17 Mon Sep 17 00:00:00 2001 From: Stevan Andjelkovic Date: Tue, 11 May 2021 12:25:37 +0200 Subject: [PATCH] feat(runtime): add basic support for state --- .../src/StuntDouble/Actor.hs | 12 ++++++++-- .../src/StuntDouble/EventLoop.hs | 14 +++++++---- .../src/StuntDouble/EventLoop/State.hs | 4 ++++ .../test/StuntDouble/EventLoopTest.hs | 24 ++++++++++++++++++- 4 files changed, 47 insertions(+), 7 deletions(-) diff --git a/src/runtime-prototype/src/StuntDouble/Actor.hs b/src/runtime-prototype/src/StuntDouble/Actor.hs index 7ebc9996..5facdae7 100644 --- a/src/runtime-prototype/src/StuntDouble/Actor.hs +++ b/src/runtime-prototype/src/StuntDouble/Actor.hs @@ -54,7 +54,15 @@ remoteCall rr m = Free (RemoteCall rr m return) asyncIO :: IO IOResult -> Free ActorF (Async IOResult) asyncIO m = Free (AsyncIO m return) +get :: Free ActorF State +get = Free (Get return) + +put :: State -> Free ActorF () +put state' = Free (Put state' return) -- XXX: -newtype State = State Int - deriving Num +newtype State = State { getState :: Int } + deriving (Show, Num) + +initState :: State +initState = State 0 diff --git a/src/runtime-prototype/src/StuntDouble/EventLoop.hs b/src/runtime-prototype/src/StuntDouble/EventLoop.hs index 9d1b68ac..0b63d9eb 100644 --- a/src/runtime-prototype/src/StuntDouble/EventLoop.hs +++ b/src/runtime-prototype/src/StuntDouble/EventLoop.hs @@ -52,6 +52,7 @@ initLoopState name transport elog = <*> newTVarIO [] <*> newTBQueueIO 128 <*> newTVarIO Map.empty + <*> newTVarIO Map.empty <*> newTVarIO [] <*> newTVarIO Map.empty <*> pure transport @@ -93,6 +94,7 @@ handleCommand (Spawn actor respVar) ls = atomically $ do actors <- readTVar (loopStateActors ls) let lref = LocalRef (Map.size actors) writeTVar (loopStateActors ls) (Map.insert lref actor actors) + modifyTVar' (loopStateActorState ls) (Map.insert lref initState) putTMVar respVar lref handleCommand Quit ls = do pids <- atomically (readTVar (loopStatePids ls)) @@ -176,7 +178,7 @@ runActor ls self = iterM go return go :: ActorF (IO a) -> IO a go (Call lref msg k) = do Just actor <- lookupActor lref (loopStateActors ls) - Now reply <- runActor ls self (actor msg) + Now reply <- runActor ls (localToRemoteRef (loopStateName ls) lref) (actor msg) emit ls (LogInvoke self lref msg reply) k reply go (RemoteCall rref msg k) = do @@ -205,10 +207,14 @@ runActor ls self = iterM go return -- event loop is running on. atomically (modifyTVar' (loopStateIOAsyncs ls) (a :)) k a - go (Get k) = do - undefined + go (Get k) = do + states <- readTVarIO (loopStateActorState ls) + let state = states Map.! remoteToLocalRef self + k state go (Put state' k) = do - undefined + atomically (modifyTVar' (loopStateActorState ls) + (Map.insert (remoteToLocalRef self) state')) + k () quit :: EventLoopRef -> IO () quit r = atomically $ diff --git a/src/runtime-prototype/src/StuntDouble/EventLoop/State.hs b/src/runtime-prototype/src/StuntDouble/EventLoop/State.hs index 0f5ef920..c1feeeb3 100644 --- a/src/runtime-prototype/src/StuntDouble/EventLoop/State.hs +++ b/src/runtime-prototype/src/StuntDouble/EventLoop/State.hs @@ -19,6 +19,7 @@ data LoopState = LoopState -- event loop itself. , loopStateQueue :: TBQueue Event , loopStateActors :: TVar (Map LocalRef (Message -> Actor)) -- XXX: Only changed by main loop, so no need for STM? + , loopStateActorState :: TVar (Map LocalRef State) , loopStateIOAsyncs :: TVar [Async IOResult] , loopStateIOContinuations :: TVar (Map (Async IOResult) (RemoteRef, CorrelationId, IOResult -> Actor)) @@ -79,6 +80,9 @@ dumpState ls = do putStrLn "=== LOOPSTATE DUMP ===" putStr "loopStateName = " putStrLn (getEventLoopName (loopStateName ls)) + putStr "loopStateActorState = " + states <- readTVarIO (loopStateActorState ls) + print states corrId <- readTVarIO (loopStateNextCorrelationId ls) putStr "loopStateNextCorrelationId = " print corrId diff --git a/src/runtime-prototype/test/StuntDouble/EventLoopTest.hs b/src/runtime-prototype/test/StuntDouble/EventLoopTest.hs index 635794c9..1c918a24 100644 --- a/src/runtime-prototype/test/StuntDouble/EventLoopTest.hs +++ b/src/runtime-prototype/test/StuntDouble/EventLoopTest.hs @@ -5,7 +5,7 @@ module StuntDouble.EventLoopTest where import Control.Exception import Control.Concurrent import Control.Concurrent.Async -import Test.HUnit +import Test.HUnit hiding (State) import StuntDouble @@ -112,3 +112,25 @@ unit_asyncIO = do reply @?= Message "Got: result") (\(e :: SomeException) -> dump el >> eventLog el >>= mapM_ print >> print e) -} + +statefulActor :: Message -> Actor +statefulActor (Message intStr) = do + s <- get + let int :: Int + int = read intStr + s' :: State + s' = State int + s + put s' + return (Now (Message (show (getState s')))) + +unit_state :: Assertion +unit_state = do + elog <- emptyEventLog + let ev = eventLoopA "state" + el <- makeEventLoop "/tmp" ev elog + lref <- spawn el statefulActor + reply <- invoke el lref (Message "1") + reply @?= Message "1" + reply2 <- invoke el lref (Message "2") + reply2 @?= Message "3" + quit el