@@ -1,8 +1,6 @@
11{-# LANGUAGE TemplateHaskell #-}
22import System.Environment (getArgs)
33import System.Random (randomIO)
4−import Data.Binary (encode)
5−import Data.ByteString.Lazy (ByteString)
64import Control.Monad (forM)
75import Control.Monad.IO.Class (liftIO)
86import Control.Distributed.Process
@@ -11,76 +9,48 @@ import Control.Distributed.Process
119 , SendPort
1210 , newChan
1311 , sendChan
14− , Closure
1512 , spawn
1613 , receiveChan
1714 , spawnLocal
1815 )
19−import Control.Distributed.Process.Closure
20− ( SerializableDict(SerializableDict)
21− , staticDecode
22− )
2316import Control.Distributed.Process.Backend.Azure
24−import Control.Distributed.Static
25− ( Static
26− , staticLabel
27− , closure
28− , RemoteTable
29− , registerStatic
30− , staticCompose
17+import Control.Distributed.Process.Closure
18+ ( remotable
19+ , remotableDecl
20+ , mkClosure
3121 )
32−import Data.Rank1Dynamic (toDynamic)
33−import Control.Distributed.Process.Closure (remotable, mkClosure)
34−import qualified Language.Haskell.TH as TH
3522
3623randomElement :: [a] -> IO a
3724randomElement xs = do
3825 ix <- randomIO
3926 return (xs !! (ix `mod` length xs))
4027
41−f :: [TH.Name] -> TH.Q [TH.Dec]
42−f = remotable
43−
44−remotableDec :: [TH.Dec] -> TH.Q [TH.Dec]
45−remotableDec = undefined
46−
47−remotableDec [ [d| f :: Int |] ]
48−
49−main :: IO ()
50−main = undefined
51−
52−--------------------------------------------------------------------------------
53−-- Auxiliary --
54−--------------------------------------------------------------------------------
55−
56−
57−
58−{-
59−
60−--------------------------------------------------------------------------------
61−-- Distributed Fibonacci --
62−--------------------------------------------------------------------------------
63−
64−dfib :: ([NodeId], Integer, SendPort Integer) -> Process ()
65−dfib (_, 0, reply) = sendChan reply 0
66−dfib (_, 1, reply) = sendChan reply 1
67−dfib (nids, n, reply) = do
68− nid1 <- liftIO $ randomElement nids
69− nid2 <- liftIO $ randomElement nids
70− (sport, rport) <- newChan
71− spawn nid1 $ dfibClosure nids (n - 2) sport
72− spawn nid2 $ dfibClosure nids (n - 1) sport
73− n1 <- receiveChan rport
74− n2 <- receiveChan rport
75− sendChan reply $ n1 + n2
28+remotableDecl [
29+ [d| dfib :: ([NodeId], SendPort Integer, Integer) -> Process () ;
30+ dfib (_, reply, 0) = sendChan reply 0
31+ dfib (_, reply, 1) = sendChan reply 1
32+ dfib (nids, reply, n) = do
33+ nid1 <- liftIO $ randomElement nids
34+ nid2 <- liftIO $ randomElement nids
35+ (sport, rport) <- newChan
36+ _ <- spawn nid1 $ $(mkClosure 'dfib) (nids, sport, n - 2)
37+ _ <- spawn nid2 $ $(mkClosure 'dfib) (nids, sport, n - 1)
38+ n1 <- receiveChan rport
39+ n2 <- receiveChan rport
40+ sendChan reply $ n1 + n2
41+ |]
42+ ]
7643
7744remoteFib :: ([NodeId], Integer) -> Backend -> Process ()
7845remoteFib (nids, n) _backend = do
7946 (sport, rport) <- newChan
80− spawnLocal $ dfib (nids, n, sport)
47+ _ <- spawnLocal $ dfib (nids, sport, n)
8148 fib_n <- receiveChan rport
49+ mapM_ terminateNode nids
8250 remoteSend fib_n
8351
52+remotable ['remoteFib]
53+
8454printResult :: LocalProcess ()
8555printResult = do
8656 result <- localExpect :: LocalProcess Integer
@@ -90,7 +60,7 @@ main :: IO ()
9060main = do
9161 args <- getArgs
9262 case args of
93− "onvm":args' -> onVmMain __remoteTable args'
63+ "onvm":args' -> onVmMain (__remoteTable . __remoteTableDecl) args'
9464 [sid, x509, pkey, user, cloudService, n] -> do
9565 params <- defaultAzureParameters sid x509 pkey
9666 let params' = params { azureSshUserName = user }
@@ -98,43 +68,7 @@ main = do
9868 vms <- findVMs backend
9969 nids <- forM vms $ \vm -> spawnNodeOnVM backend vm "8080"
10070 callOnVM backend (head vms) "8081" $
101− ProcessPair (remoteFibClosure nids (read n)) printResult
71+ ProcessPair ($(mkClosure 'remoteFib) (nids, read n :: Integer))
72+ printResult
10273 _ ->
10374 error "Invalid command line arguments"
104−
105−--------------------------------------------------------------------------------
106−-- Static plumping --
107−--------------------------------------------------------------------------------
108−
109−dfibStatic :: Static (([NodeId], Integer, SendPort Integer) -> Process ())
110−dfibStatic = staticLabel "dfib"
111−
112−dfibDict :: Static (SerializableDict ([NodeId], Integer, SendPort Integer))
113−dfibDict = staticLabel "dfibDict"
114−
115−dfibClosure :: [NodeId] -> Integer -> SendPort Integer -> Closure (Process ())
116−dfibClosure nids n reply = closure decoder (encode (nids, n, reply))
117− where
118− decoder :: Static (ByteString -> Process ())
119− decoder = dfibStatic `staticCompose` staticDecode dfibDict
120−
121−remoteFibStatic :: Static (([NodeId], Integer) -> Backend -> Process ())
122−remoteFibStatic = staticLabel "remoteFib"
123−
124−remoteFibDict :: Static (SerializableDict ([NodeId], Integer))
125−remoteFibDict = staticLabel "remoteFibDict"
126−
127−remoteFibClosure :: [NodeId] -> Integer -> RemoteProcess ()
128−remoteFibClosure nids n = closure decoder (encode (nids, n))
129− where
130− decoder :: Static (ByteString -> Backend -> Process ())
131− decoder = remoteFibStatic `staticCompose` staticDecode remoteFibDict
132−
133−__remoteTable :: RemoteTable -> RemoteTable
134−__remoteTable =
135− registerStatic "dfib" (toDynamic dfib)
136− . registerStatic "dfibDict" (toDynamic (SerializableDict :: SerializableDict ([NodeId], Integer, SendPort Integer)))
137− . registerStatic "remoteFib" (toDynamic remoteFib)
138− . registerStatic "remoteFibDict" (toDynamic (SerializableDict :: SerializableDict ([NodeId], Integer)))
139−
140−-}