@@ -1,9 +1,16 @@
11{-# LANGUAGE ExistentialQuantification #-}
22{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE RecordWildCards #-}
34
4−module Duct.Event
5+module Duct.Context
56 ( Context(..)
67 , initContext
8+ , saveContext
9+ , restoreContext
10+ , continueContext
11+ , Location(..)
12+ , getLocation
13+ , setLocation
714 , getData
815 , setData
916 , modifyData
@@ -11,33 +18,39 @@ module Duct.Event
1118 )
1219where
1320
21+import Control.Applicative (Alternative(..))
1422import Control.Concurrent (ThreadId)
1523import Control.Concurrent.STM (TChan)
16−import Control.Monad.State (MonadState, gets, modify)
24+import Control.Monad.State (MonadState, gets, modify, StateT, MonadPlus)
25+import qualified Control.Monad.Trans.State.Lazy as Lazy (get, gets, modify, put)
1726import Data.Dynamic (TypeRep, Typeable, typeOf)
1827import Data.IORef (IORef)
1928import qualified Data.Map as M
2029import Unsafe.Coerce (unsafeCoerce)
30+import GHC.Prim (Any)
2131
2232------------------------------------------------------------------------------
2333-- State of a continuation
2434------------------------------------------------------------------------------
2535
26−type SData = ()
27−
2836-- | Describes the context of a computation.
29−data Context = forall m a b. Context
30− { event :: Maybe SData -- untyped, XXX rename to mailbox - can we do
37+data Context = Context
38+ { event :: Maybe () -- untyped, XXX rename to mailbox - can we do
3139 -- away with this?
3240 -- ^ event data to use in a continuation in a new thread
3341
3442 -- the 'm' and 'f' in an 'm >>= f' operation of the monad
3543 -- In nested binds we store the current m only, but the whole stack of fs
36− , currentm :: m a
37− , fstack :: [a -> m b]
44+ , currentm :: Any -- untyped, the real type is: m a
45+ , fstack :: [Any] -- untyped, the real type is: [a -> m b]
3846 -- ^ List of continuations
3947
40− , mfData :: M.Map TypeRep SData
48+ -- log only when there is a restore or if we are teleporting
49+ -- We can use a HasLog constraint to statically enable/disable logging
50+ -- , journal :: Maybe Log
51+ , location :: Location
52+
53+ , mfData :: M.Map TypeRep Any -- untyped, type coerced
4154 -- ^ State data accessed with get or put operations
4255
4356 -- XXX All of the following can be removed
@@ -92,15 +105,68 @@ initContext
92105 -> IORef Int
93106 -> Context
94107initContext x childChan pending credit =
95− Context { event = mempty
96− , currentm = x
108+ Context { event = mempty
109+ , currentm = unsafeCoerce x
97110 , fstack = []
111+ , location = Local
98112 , mfData = mempty
99113 , parentChannel = Nothing
100114 , childChannel = childChan
101115 , pendingThreads = pending
102116 , threadCredit = credit }
103117
118+------------------------------------------------------------------------------
119+-- Where is the computation running?
120+------------------------------------------------------------------------------
121+
122+data Location = Local | ForkedThread | RemoteNode
123+ deriving (Typeable, Eq, Show)
124+
125+getLocation :: Monad m => StateT Context m Location
126+getLocation = Lazy.gets location
127+
128+setLocation :: Monad m => Location -> StateT Context m ()
129+setLocation loc = Lazy.modify $ \Context { .. } -> Context { location = loc, .. }
130+
131+------------------------------------------------------------------------------
132+-- Saving and restoring the context of a computation
133+------------------------------------------------------------------------------
134+
135+-- Save the 'm' and 'f', in case we migrate to a new thread before the current
136+-- bind operation completes, we run the operation manually in the new thread
137+-- using this context.
138+saveContext :: Monad m => f a -> (a -> f b) -> StateT Context m ()
139+saveContext m f =
140+ Lazy.modify $ \Context { fstack = fs, .. } ->
141+ Context { currentm = unsafeCoerce m
142+ , fstack = unsafeCoerce f : fs
143+ , .. }
144+
145+-- pop the top function from the continuation stack, create the next closure,
146+-- set it as the current closure and return it.
147+restoreContext :: (Alternative f, Monad m) => Maybe a -> StateT Context m (f b)
148+restoreContext x = do
149+ -- XXX fstack must be non-empty when this is called.
150+ ctx@Context { fstack = f:fs } <- Lazy.get
151+
152+ let mres = case x of
153+ Nothing -> empty
154+ Just y -> (unsafeCoerce f) y
155+
156+ Lazy.put ctx { currentm = unsafeCoerce mres, fstack = fs }
157+
158+ return mres
159+
160+continueContext :: MonadPlus m => Context -> m a
161+continueContext Context { currentm = m, fstack = fs } =
162+ unsafeCoerce m >>= runfStack (unsafeCoerce fs)
163+
164+ where
165+
166+ -- runfStack :: Monad m => [a -> AsyncT m a] -> a -> AsyncT m b
167+ runfStack [] _ = empty
168+ runfStack (f:ff) x = f x >>= runfStack ff
169+
104170------------------------------------------------------------------------------
105171-- * Extensible State: Session Data Management
106172------------------------------------------------------------------------------