module Control.Distributed.Process.Internal.Closure
(
initRemoteTable
, resolveClosure
) where
import qualified Data.Map as Map (empty)
import Data.Accessor ((^.))
import Data.ByteString.Lazy (ByteString)
import Data.Binary (decode)
import Data.Typeable (TypeRep)
import Control.Applicative ((<$>))
import Control.Distributed.Process.Internal.Types
( RemoteTable(RemoteTable)
, remoteTableLabel
, remoteTableDict
, StaticLabel(..)
, ProcessId
, Process
, Closure(Closure)
, Static(Static)
, RuntimeSerializableSupport(..)
)
import Control.Distributed.Process.Internal.Dynamic
( Dynamic(Dynamic)
, toDyn
, dynApp
, dynApply
, unsafeCoerce#
)
import Control.Distributed.Process.Internal.TypeRep ()
import qualified Control.Distributed.Process.Internal.Closure.BuiltIn as BuiltIn
(remoteTable)
initRemoteTable :: RemoteTable
initRemoteTable = BuiltIn.remoteTable (RemoteTable Map.empty Map.empty)
resolveClosure :: RemoteTable -> StaticLabel -> ByteString -> Maybe Dynamic
resolveClosure rtable ClosureSend env = do
rss <- rtable ^. remoteTableDict typ
rssSend rss `dynApply` toDyn pid
where
(typ, pid) = decode env :: (TypeRep, ProcessId)
resolveClosure rtable ClosureReturn env = do
rss <- rtable ^. remoteTableDict typ
rssReturn rss `dynApply` toDyn arg
where
(typ, arg) = decode env :: (TypeRep, ByteString)
resolveClosure rtable ClosureExpect env =
rssExpect <$> rtable ^. remoteTableDict typ
where
typ = decode env :: TypeRep
resolveClosure rtable ClosureApply env = do
f <- resolveClosure rtable labelf envf
x <- resolveClosure rtable labelx envx
f `dynApply` x
where
(labelf, envf, labelx, envx) = decode env
resolveClosure _rtable ClosureConst env =
return $ Dynamic (decode env) (unsafeCoerce# const)
resolveClosure _rtable ClosureUnit _env =
return $ toDyn ()
resolveClosure _rtable CpId env =
return $ Dynamic (decode env) (unsafeCoerce# cpId)
where
cpId :: forall a. a -> Process a
cpId = return
resolveClosure _rtable CpComp env =
return $ Dynamic (decode env) (unsafeCoerce# cpComp)
where
cpComp :: forall a b c. (a -> Process b) -> (b -> Process c) -> a -> Process c
cpComp p q a = p a >>= q
resolveClosure _rtable CpFirst env =
return $ Dynamic (decode env) (unsafeCoerce# cpFirst)
where
cpFirst :: forall a b c. (a -> Process b) -> (a, c) -> Process (b, c)
cpFirst p (a, c) = do b <- p a ; return (b, c)
resolveClosure _rtable CpSwap env =
return $ Dynamic (decode env) (unsafeCoerce# cpSwap)
where
cpSwap :: forall a b. (a, b) -> Process (b, a)
cpSwap (a, b) = return (b, a)
resolveClosure _rtable CpCopy env =
return $ Dynamic (decode env) (unsafeCoerce# cpCopy)
where
cpCopy :: forall a. a -> Process (a, a)
cpCopy a = return (a, a)
resolveClosure _rtable CpLeft env =
return $ Dynamic (decode env) (unsafeCoerce# cpLeft)
where
cpLeft :: forall a b c. (a -> Process b) -> Either a c -> Process (Either b c)
cpLeft p (Left a) = do b <- p a ; return (Left b)
cpLeft _ (Right c) = return (Right c)
resolveClosure _rtable CpMirror env =
return $ Dynamic (decode env) (unsafeCoerce# cpMirror)
where
cpMirror :: forall a b. Either a b -> Process (Either b a)
cpMirror (Left a) = return (Right a)
cpMirror (Right b) = return (Left b)
resolveClosure _rtable CpUntag env =
return $ Dynamic (decode env) (unsafeCoerce# cpUntag)
where
cpUntag :: forall a. Either a a -> Process a
cpUntag (Left a) = return a
cpUntag (Right a) = return a
resolveClosure rtable CpApply env =
return $ Dynamic typApply (unsafeCoerce# cpApply)
where
cpApply :: forall a b. (Closure (a -> Process b), a) -> Process b
cpApply (Closure (Static flabel) fenv, x) = do
let Just f = resolveClosure rtable flabel fenv
Dynamic typResult val = f `dynApp` Dynamic typA (unsafeCoerce# x)
if typResult == typProcB
then unsafeCoerce# val
else error $ "Type error in cpApply: "
++ "mismatch between " ++ show typResult
++ " and " ++ show typProcB
(typApply, typA, typProcB) = decode env
resolveClosure rtable (UserStatic label) env = do
val <- rtable ^. remoteTableLabel label
dynApply val (toDyn env)