5821a0b · distributed-process

git.iko.soy/distributed-process

Improve resolveClosure

We weren't passing the closure environment. That was fine when we didn't support 'bind', but not fine if we do: the type of the result of binding those closures depends on the types of those closures, and we need the closure environment to get at them.

commit5821a0bea789fbc16980850c75b415107f47c7d0 authorEdsko de Vries <edsko@edsko.net> dateTue 26 Jun 2012, 13:37 (14 years ago) parentaf39337

3 files changed+20−31

compare with master

unifiedsplit

distributed-process/src/Control/Distributed/Process.hs+5−7 distributed-process/src/Control/Distributed/Process/Internal/Types.hs+13−20 distributed-process/src/Control/Distributed/Process/Node.hs+2−4

distributed-process/src/Control/Distributed/Process.hs+5−7

@@ -61,7 +61,6 @@ module Control.Distributed.Process

6161 ) where

6262

6363import Prelude hiding (catch)

64−import Data.Maybe (fromJust)

6564import Data.Binary (decode, encode)

6665import Data.Typeable (Typeable, typeOf)

6766import Control.Monad.Reader (ask)

@@ -370,13 +369,12 @@ unmonitor = sendCtrlMsg Nothing . Unmonitor

370369unClosure :: forall a. Typeable a => Closure a -> Process a

371370unClosure (Closure (Static label) env) = do

372371 rtable <- remoteTable <$> lift getLocalNode

373− let dyn = fromJust (resolveClosure rtable label)

374− dec = fromDyn dyn (throw (typeError dyn))

375− return (dec env)

372+ let Just dyn = resolveClosure rtable label env

373+ return $ fromDyn dyn (throw (typeError dyn))

376374 where

377− typeError proc = userError $ "lookupStatic type error: "

378− ++ "cannot match " ++ show (dynTypeRep proc)

379− ++ "against " ++ show (typeOf (undefined :: a))

375+ typeError dyn = userError $ "lookupStatic type error: "

376+ ++ "cannot match " ++ show (dynTypeRep dyn)

377+ ++ " against " ++ show (typeOf (undefined :: a))

380378

381379--------------------------------------------------------------------------------

382380-- Auxiliary API --

distributed-process/src/Control/Distributed/Process/Internal/Types.hs+13−20

@@ -100,10 +100,10 @@ import Control.Distributed.Process.Internal.CQueue (CQueue)

100100import Control.Distributed.Process.Internal.Dynamic

101101 ( Dynamic

102102 , toDyn

103− , fromDynamic

104103 , dynTypeRep

105104 , dynApp

106105 , dynBind

106+ , dynApply

107107 )

108108

109109--------------------------------------------------------------------------------

@@ -251,26 +251,19 @@ registerLabel label dyn = remoteTableLabel label ^= Just dyn

251251registerSender :: TypeRep -> Dynamic -> RemoteTable -> RemoteTable

252252registerSender typ dyn = remoteTableSender typ ^= Just dyn

253253

254−resolveClosure :: RemoteTable -> String -> Maybe Dynamic

255−resolveClosure rtable "$call" = Just (toDyn aux)

254+resolveClosure :: RemoteTable -> String -> ByteString -> Maybe Dynamic

255+resolveClosure rtable "$call" env = do

256+ proc <- resolveClosure rtable label env'

257+ sender <- rtable ^. remoteTableSender (dynTypeRep proc)

258+ proc `bind` (sender `dynApp` toDyn pid)

256259 where

257− -- TODO: error handling

258− aux :: ByteString -> Process ()

259− aux env = do

260− let (label, env', pid) = decode env :: (String, ByteString, ProcessId)

261− Just proc = resolveClosure rtable label

262− proc' = dynApp proc (toDyn env')

263− Just enc = rtable ^. remoteTableSender (dynTypeRep proc')

264− enc' = dynApp enc (toDyn pid)

265− Just bound = dynBind tyConProcess bindProcess proc' enc'

266− Just proc'' = fromDynamic bound

267− proc''

268−resolveClosure rtable "$bind" = Just (toDyn aux)

269− where

270− -- TODO: error handling

271− aux :: ByteString -> Process ()

272− aux _ = liftIO $ putStrLn "bind not yet supported"

273−resolveClosure rtable label = rtable ^. remoteTableLabel label

260+ (label, env', pid) = decode env :: (String, ByteString, ProcessId)

261+ bind = dynBind tyConProcess bindProcess

262+resolveClosure rtable "$bind" env =

263+ return $ toDyn ((liftIO $ putStrLn "bind not yet supported") :: Process ())

264+resolveClosure rtable label env = do

265+ val <- rtable ^. remoteTableLabel label

266+ dynApply val (toDyn env)

274267

275268tyConProcess :: TyCon

276269tyConProcess = typeRepTyCon (typeOf (undefined :: Process ()))

distributed-process/src/Control/Distributed/Process/Node.hs+2−4

@@ -493,11 +493,9 @@ isLocal nid pid = processNodeId pid == localNodeId nid

493493unClosure :: Typeable a => Closure a -> NC (Maybe a)

494494unClosure (Closure (Static label) env) = do

495495 rtable <- remoteTable <$> lift getLocalNode

496− case resolveClosure rtable label of

496+ case resolveClosure rtable label env of

497497 Nothing -> return Nothing

498− Just dyn -> case fromDynamic dyn of

499− Nothing -> return Nothing

500− Just dec -> return (Just $ dec env)

498+ Just dyn -> return (fromDynamic dyn)

501499

502500--------------------------------------------------------------------------------

503501-- Messages to local processes --