Skip to content

Commit fad3a08

Browse files
hyperthunkhyperthunk
committed
Merge branch 'mx' into development
2 parents f91d8c4 + 905b487 commit fad3a08

File tree

21 files changed

+1581
-672
lines changed

21 files changed

+1581
-672
lines changed

‎.gitignore

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,4 +11,5 @@ dist/
1111
*.ps
1212
*.swp
1313
cabal-dev
14+
cabal-dev*
1415
.DS_Store

‎distributed-process.cabal

Lines changed: 48 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ Library
6464
Control.Distributed.Process.Closure,
6565
Control.Distributed.Process.Debug,
6666
Control.Distributed.Process.Internal.Types,
67+
Control.Distributed.Process.Management,
6768
Control.Distributed.Process.Node,
6869
Control.Distributed.Process.Serializable,
6970
Control.Distributed.Process.UnsafePrimitives
@@ -77,10 +78,14 @@ Library
7778
Control.Distributed.Process.Internal.StrictMVar,
7879
Control.Distributed.Process.Internal.WeakTQueue,
7980
Control.Distributed.Process.Internal.StrictContainerAccessors,
80-
Control.Distributed.Process.Internal.Trace.Types,
81-
Control.Distributed.Process.Internal.Trace.Primitives,
82-
Control.Distributed.Process.Internal.Trace.Tracer,
83-
Control.Distributed.Process.Internal.Trace.Remote
81+
Control.Distributed.Process.Management.Agent,
82+
Control.Distributed.Process.Management.Bus,
83+
Control.Distributed.Process.Management.Table,
84+
Control.Distributed.Process.Management.Types,
85+
Control.Distributed.Process.Management.Trace.Primitives,
86+
Control.Distributed.Process.Management.Trace.Remote,
87+
Control.Distributed.Process.Management.Trace.Types,
88+
Control.Distributed.Process.Management.Trace.Tracer
8489
Extensions: RankNTypes,
8590
ScopedTypeVariables,
8691
FlexibleInstances,
@@ -163,6 +168,37 @@ Test-Suite TestStats
163168
ghc-options: -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
164169
HS-Source-Dirs: tests
165170

171+
172+
Test-Suite TestMx
173+
Type: exitcode-stdio-1.0
174+
Main-Is: TestMx.hs
175+
Build-Depends: base >= 4.4 && < 5,
176+
random >= 1.0 && < 1.1,
177+
ansi-terminal >= 0.5 && < 0.6,
178+
containers >= 0.4 && < 0.6,
179+
stm >= 2.4 && < 2.5,
180+
distributed-process,
181+
network-transport >= 0.3 && < 0.4,
182+
network-transport-tcp >= 0.3 && < 0.4,
183+
binary >= 0.5 && < 0.7,
184+
network >= 2.3 && < 2.5,
185+
HUnit >= 1.2 && < 1.3,
186+
test-framework >= 0.6 && < 0.9,
187+
test-framework-hunit >= 0.2.0 && < 0.4,
188+
unix >= 2.5.0.0
189+
Extensions: RankNTypes,
190+
ScopedTypeVariables,
191+
FlexibleInstances,
192+
UndecidableInstances,
193+
ExistentialQuantification,
194+
GADTs,
195+
GeneralizedNewtypeDeriving,
196+
DeriveDataTypeable,
197+
CPP,
198+
BangPatterns
199+
ghc-options: -Wall -debug -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
200+
HS-Source-Dirs: tests
201+
166202
Test-Suite TestTracing
167203
Type: exitcode-stdio-1.0
168204
Main-Is: TestTracing.hs
@@ -180,14 +216,19 @@ Test-Suite TestTracing
180216
test-framework >= 0.6 && < 0.9,
181217
test-framework-hunit >= 0.2.0 && < 0.4,
182218
unix >= 2.5.0.0
183-
Extensions: CPP,
219+
Extensions: RankNTypes,
184220
ScopedTypeVariables,
221+
FlexibleInstances,
222+
UndecidableInstances,
223+
ExistentialQuantification,
224+
GADTs,
225+
GeneralizedNewtypeDeriving,
185226
DeriveDataTypeable,
186-
GeneralizedNewtypeDeriving
227+
CPP,
228+
BangPatterns
187229
ghc-options: -Wall -debug -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
188230
HS-Source-Dirs: tests
189231

190-
191232
Executable distributed-process-throughput
192233
if flag(benchmarks)
193234
Build-Depends: base >= 4.4 && < 5,

‎src/Control/Distributed/Process/Debug.hs

Lines changed: 40 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -17,16 +17,14 @@
1717
--
1818
-- [Enabling Tracing]
1919
--
20-
-- Tracing is disabled by default, because it carries a relatively small, but
21-
-- tangible cost. To enable tracing, the environment variable
22-
-- @DISTRIBUTED_PROCESS_TRACE_ENABLED@ must be set to some value (actual content
23-
-- is ignored). When the environment variable /is/ set, the system will
24-
-- generate /trace events/ in various circumstances - see 'TraceEvent' for a
25-
-- list of all the published events. A user can additionally publish custom
26-
-- trace events in the form of 'TraceEvLog' log messages or pass custom
27-
-- (i.e., completely user defined) event data using the 'traceMessage' function.
28-
-- If the environment variable is not set, no trace events will ever be
29-
-- published.
20+
-- Throughout the lifecycle of a local node, the distributed-process runtime
21+
-- generates /trace events/, describing internal runtime activities such as
22+
-- the spawning and death of processes, message sending, delivery and so on.
23+
-- See the 'MxEvent' type's documentation for a list of all the published
24+
-- event types, which correspond directly to the types of 'Management' event.
25+
-- Users can additionally publish custom trace events in the form of
26+
-- 'MxLog' log messages or pass custom (i.e., completely user defined)
27+
-- event data using the 'traceMessage' function.
3028
--
3129
-- All published traces are forwarded to a /tracer process/, which can be
3230
-- specified (and changed) at runtime using 'traceEnable'. Some pre-defined
@@ -37,38 +35,37 @@
3735
--
3836
-- [Working with multiple tracer processes]
3937
--
40-
-- The system tracing facility only ever writes to a single tracer process. This
38+
-- The tracing facility only ever writes to a single tracer process. This
4139
-- invariant insulates the tracer controller and ensures a fast path for
4240
-- handling all trace events. /This/ module provides facilities for layering
4341
-- trace handlers using Cloud Haskell's built-in delegation primitives.
4442
--
4543
-- The 'startTracer' function wraps the registered @tracer@ process with the
46-
-- supplied handler and also forwarding trace events to the original tracer.
44+
-- supplied handler and also forwards trace events to the original tracer.
4745
-- The corresponding 'stopTracer' function terminates tracer processes in
48-
-- reverse of the order in which they were started, and re-establishes the
46+
-- reverse of the order in which they were started, and re-registers the
4947
-- previous tracer process.
5048
--
5149
-- [Built in tracers]
5250
--
5351
-- The built in tracers provide a simple /logging/ facility that writes trace
5452
-- events out to either a log file, @stderr@ or the GHC eventlog. These tracers
5553
-- can be configured using environment variables, or specified manually using
56-
-- the 'traceEnable' function. The base tracer process cannot be
54+
-- the 'traceEnable' function.
5755
--
5856
-- When a new local node is started, the contents of several environment
59-
-- variables are checked to determine how the default tracer process
60-
-- will handle trace events. If none of these variables is set, then the
61-
-- trace events will be effectively ignored, although they will still be
62-
-- generated and passed through the system. Only one configuration will be
63-
-- chosen - the first that contains a (valid) value. These environment
64-
-- variables, in the order they're checked, are:
57+
-- variables are checked to determine which default tracer process is selected.
58+
-- If none of these variables is set, a no-op tracer process is installed,
59+
-- which effectively ignores all trace messages. Note that in this case,
60+
-- trace events are still generated and passed through the system.
61+
-- Only one default tracer will be chosen - the first that contains a (valid)
62+
-- value. These environment variables, in the order they're examined, are:
6563
--
6664
-- 1. @DISTRIBUTED_PROCESS_TRACE_FILE@
6765
-- This is checked for a valid file path. If it exists and the file can be
6866
-- opened for writing, all trace output will be directed thence. If the supplied
69-
-- path is invalid, or the file is unavailable for writing - e.g., because
70-
-- another node has already started tracing to it - then this tracer will be
71-
-- disabled.
67+
-- path is invalid, or the file is unavailable for writing, this tracer will not
68+
-- be selected.
7269
--
7370
-- 2. @DISTRIBUTED_PROCESS_TRACE_CONSOLE@
7471
-- This is checked for /any/ non-empty value. If set, then all trace output will
@@ -81,8 +78,10 @@
8178
-- Users of the /simplelocalnet/ Cloud Haskell backend should also note that
8279
-- because the trace file option only supports trace output from a single node
8380
-- (so as to avoid interleaving), a file trace configured for the master node
84-
-- will prevent slaves from tracing to the file and will need to fall back to
85-
-- the console or eventlog tracers instead.
81+
-- will prevent slaves from tracing to the file. They will need to fall back to
82+
-- the console or eventlog tracers instead, which can be accomplished by setting
83+
-- one of these environment variables /as well/, since the latter will only be
84+
-- selected on slaves (when the file tracer selection fails).
8685
--
8786
-- Support for writing to the eventlog requires specific intervention to work,
8887
-- without which, written traces are silently dropped/ignored and no output will
@@ -93,11 +92,9 @@
9392
module Control.Distributed.Process.Debug
9493
( -- * Exported Data Types
9594
TraceArg(..)
96-
, TraceEvent(..)
9795
, TraceFlags(..)
9896
, TraceSubject(..)
9997
-- * Configuring Tracing
100-
, isTracingEnabled
10198
, enableTrace
10299
, enableTraceAsync
103100
, disableTrace
@@ -147,35 +144,36 @@ import Control.Distributed.Process.Internal.Types
147144
, LocalProcess(..)
148145
, ProcessMonitorNotification(..)
149146
)
150-
import Control.Distributed.Process.Internal.Trace.Types
147+
import Control.Distributed.Process.Management.Types
148+
( MxEvent(..)
149+
)
150+
import Control.Distributed.Process.Management.Trace.Types
151151
( TraceArg(..)
152-
, TraceEvent(..)
153152
, TraceFlags(..)
154153
, TraceSubject(..)
155154
, defaultTraceFlags
156155
)
157-
import Control.Distributed.Process.Internal.Trace.Tracer
156+
import Control.Distributed.Process.Management.Trace.Tracer
158157
( systemLoggerTracer
159158
, logfileTracer
160159
, eventLogTracer
161160
)
162-
import Control.Distributed.Process.Internal.Trace.Primitives
161+
import Control.Distributed.Process.Management.Trace.Primitives
163162
( withRegisteredTracer
164163
, enableTrace
165164
, enableTraceAsync
166165
, disableTrace
167166
, setTraceFlags
168167
, setTraceFlagsAsync
169168
, getTraceFlags
170-
, isTracingEnabled
171169
, traceOn
172170
, traceOff
173171
, traceOnly
174172
, traceLog
175173
, traceLogFmt
176174
, traceMessage
177175
)
178-
import qualified Control.Distributed.Process.Internal.Trace.Remote as Remote
176+
import qualified Control.Distributed.Process.Management.Trace.Remote as Remote
179177
import Control.Distributed.Process.Node
180178

181179
import Control.Exception (SomeException)
@@ -200,7 +198,7 @@ import Prelude hiding (catch)
200198
-- through all the layers in turn. Once the top layer is stopped, the user
201199
-- is responsible for re-registering the original (prior) tracer pid before
202200
-- terminating. See 'withTracer' for a mechanism that handles that.
203-
startTracer :: (TraceEvent -> Process ()) -> Process ProcessId
201+
startTracer :: (MxEvent -> Process ()) -> Process ProcessId
204202
startTracer handler = do
205203
withRegisteredTracer $ \pid -> do
206204
node <- processNode <$> ask
@@ -212,7 +210,7 @@ startTracer handler = do
212210
-- disable tracing thereafter, before giving the result (or exception
213211
-- in case of failure).
214212
withTracer :: forall a.
215-
(TraceEvent -> Process ())
213+
(MxEvent -> Process ())
216214
-> Process a
217215
-> Process (Either SomeException a)
218216
withTracer handler proc = do
@@ -227,7 +225,7 @@ withTracer handler proc = do
227225
Nothing -> return ()
228226
Just _ -> do
229227
ref <- monitor tracer
230-
send tracer TraceEvDisable
228+
send tracer MxTraceDisable
231229
receiveWait [
232230
matchIf (\(ProcessMonitorNotification ref' _ _) -> ref == ref')
233231
(\_ -> return ())
@@ -244,12 +242,12 @@ withFlags flags proc = do
244242
finally (setTraceFlags flags >> try proc)
245243
(setTraceFlags oldFlags)
246244

247-
traceProxy :: ProcessId -> (TraceEvent -> Process ()) -> Process ()
245+
traceProxy :: ProcessId -> (MxEvent -> Process ()) -> Process ()
248246
traceProxy pid act = do
249-
proxy pid $ \(ev :: TraceEvent) ->
247+
proxy pid $ \(ev :: MxEvent) ->
250248
case ev of
251-
(TraceEvTakeover _) -> return False
252-
TraceEvDisable -> die "disabled"
249+
(MxTraceTakeover _) -> return False
250+
MxTraceDisable -> die "disabled"
253251
_ -> act ev >> return True
254252

255253
-- | Stops a user supplied tracer started with 'startTracer'.
@@ -264,8 +262,7 @@ traceProxy pid act = do
264262
-- supplied tracers (i.e., processes started via 'startTracer') have exited,
265263
-- subsequent calls to this function will have no effect.
266264
--
267-
-- If tracing support is disabled for the node, this function will also
268-
-- have no effect. If the last tracer to have been registered was not started
265+
-- If the last tracer to have been registered was not started
269266
-- with 'startTracer' then the behaviour of this function is /undefined/.
270267
stopTracer :: Process ()
271268
stopTracer =
@@ -276,5 +273,5 @@ stopTracer =
276273
basePid <- whereis "tracer.initial"
277274
case basePid == (Just pid) of
278275
True -> return ()
279-
False -> send pid TraceEvDisable
276+
False -> send pid MxTraceDisable
280277

‎src/Control/Distributed/Process/Internal/CQueue.hs

Lines changed: 6 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ module Control.Distributed.Process.Internal.CQueue
66
, MatchOn(..)
77
, newCQueue
88
, enqueue
9+
, enqueueSTM
910
, dequeue
1011
, mkWeakCQueue
1112
) where
@@ -52,7 +53,11 @@ newCQueue = CQueue <$> newMVar Nil <*> atomically newTChan
5253
--
5354
-- Enqueue is strict.
5455
enqueue :: CQueue a -> a -> IO ()
55-
enqueue (CQueue _arrived incoming) !a = atomically $ writeTChan incoming a
56+
enqueue (CQueue _arrived incoming) !a = atomically $ writeTChan incoming a
57+
58+
-- | Variant of enqueue for use in the STM monad.
59+
enqueueSTM :: CQueue a -> a -> STM ()
60+
enqueueSTM (CQueue _arrived incoming) !a = writeTChan incoming a
5661

5762
data BlockSpec =
5863
NonBlocking

‎src/Control/Distributed/Process/Internal/Primitives.hs

Lines changed: 9 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -191,9 +191,11 @@ import Control.Distributed.Process.Internal.Messaging
191191
, disconnect
192192
, sendCtrlMsg
193193
)
194-
import Control.Distributed.Process.Internal.Trace.Types
194+
import Control.Distributed.Process.Management.Types
195+
( MxEvent(..)
196+
)
197+
import Control.Distributed.Process.Management.Trace.Types
195198
( traceEvent
196-
, TraceEvent(..)
197199
)
198200
import Control.Distributed.Process.Internal.WeakTQueue
199201
( newTQueueIO
@@ -226,8 +228,8 @@ send them msg = do
226228
msg
227229
-- We do not fire the trace event until after the sending is complete;
228230
-- In the remote case, 'sendMessage' can block in the networking stack.
229-
liftIO $ traceEvent (localTracer node)
230-
(TraceEvSent them us (createUnencodedMessage msg))
231+
liftIO $ traceEvent (localEventBus node)
232+
(MxSent them us (createUnencodedMessage msg))
231233

232234
-- | /Unsafe/ variant of 'send'. This function makes /no/ attempt to serialize
233235
-- and (in the case when the destination process resides on the same local
@@ -410,8 +412,8 @@ forward msg them = do
410412
(messageToPayload msg)
411413
-- We do not fire the trace event until after the sending is complete;
412414
-- In the remote case, 'sendMessage' can block in the networking stack.
413-
liftIO $ traceEvent (localTracer node)
414-
(TraceEvSent them us msg)
415+
liftIO $ traceEvent (localEventBus node)
416+
(MxSent them us msg)
415417

416418

417419
-- | Wrap a 'Serializable' value in a 'Message'. Note that 'Message's are
@@ -551,7 +553,7 @@ delegate pid p = do
551553
]
552554
delegate pid p
553555

554-
-- | A straight relay that simply forwards all messages to the supplied pid.
556+
-- | A straight relay that forwards all messages to the supplied pid.
555557
relay :: ProcessId -> Process ()
556558
relay !pid = receiveWait [ matchAny (\m -> forward m pid) ] >> relay pid
557559

0 commit comments

Comments
 (0)