Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/lib/protocol/xio.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/lib/protocol/xio.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 9 - (view) (download)

1 : monnier 2 (* xio.sml
2 :     *
3 :     * COPYRIGHT (c) 1990,1991 by John H. Reppy. See COPYRIGHT file for details.
4 :     *
5 :     * This code implements the low-level I/O of the X-protocol.
6 :     *
7 :     * NOTE: the implementation of close doesn't really work, since the socket may
8 :     * end up being closed before the output buffer is actually flushed (race condition).
9 :     *)
10 :    
11 :     signature XIO =
12 :     sig
13 :    
14 :     exception LostReply
15 :     exception ErrorReply of XErrors.xerror
16 :    
17 :     type connection
18 :    
19 :     val openConn : ('a, Socket.active Socket.stream) Socket.sock -> connection
20 :     val closeConn : connection -> unit
21 :    
22 :     val sameConn : (connection * connection) -> bool
23 :    
24 :     val request : connection -> Word8Vector.vector -> unit
25 :     val requestAndChk : connection -> Word8Vector.vector -> unit CML.event
26 :     val requestReply : connection -> Word8Vector.vector
27 :     -> Word8Vector.vector CML.event
28 :     val requestMultiReply : connection
29 :     -> (Word8Vector.vector * (Word8Vector.vector -> int))
30 :     -> Word8Vector.vector CML.event
31 :     val requestWithExposures : connection
32 :     -> (Word8Vector.vector * (unit -> Geometry.rect list) SyncVar.ivar)
33 :     -> unit
34 :    
35 :     val flushOut : connection -> unit
36 :    
37 :     val waitForXEvent : connection -> XEventTypes.xevent CML.event
38 :    
39 :     val readXError : connection -> (word * Word8Vector.vector)
40 :    
41 :     end
42 :    
43 :     structure XIo : XIO =
44 :     struct
45 :    
46 :     exception LostReply
47 :     exception ErrorReply of XErrors.xerror
48 :    
49 :     structure W = Word
50 :     structure W8A = Word8Array
51 :     structure W8V = Word8Vector
52 :     structure SV = SyncVar
53 :    
54 :     val emptyV = W8V.fromList[]
55 :    
56 :     fun newBuf sz = Word8Array.array(sz, 0w0)
57 :     val bufSz = 2048
58 :    
59 :     (* time to wait before flushing a non-empty output buffer *)
60 : monnier 8 val flushTimeOut = CML.timeOutEvt(Time.fromMilliseconds 50)
61 : monnier 2
62 :     (* request messages sent to the sequencer by clients *)
63 :     datatype req_msg
64 :     = RequestFlush
65 :     | RequestQuit
66 :     | Request of W8V.vector
67 :     | RequestAndChk of (W8V.vector * reply CML.chan)
68 :     | RequestReply of (W8V.vector * reply CML.chan)
69 :     | RequestReplies of (W8V.vector * reply CML.chan * (W8V.vector -> int))
70 :     | RequestExposures of (W8V.vector * (unit -> Geometry.rect list) SV.ivar)
71 :    
72 :     (* replies from the sequencer to client requests *)
73 :     and reply
74 :     = ReplyLost (* The reply was lost somewhere in transit *)
75 :     | Reply of W8V.vector (* A normal reply *)
76 :     | ReplyError of W8V.vector (* The server returned an error message *)
77 :    
78 :     (* messages from the sequencer to the output buffer *)
79 :     datatype out_msg
80 :     = OutFlush
81 :     | OutQuit
82 :     | OutMsg of W8V.vector
83 :    
84 :     (* +DEBUG *)
85 :     fun strToHex s =
86 :     String.translate
87 :     (fn c => StringCvt.padLeft #"0" 2 (Int.fmt StringCvt.HEX (Char.ord c)) ^ ".")
88 :     s
89 :     fun outMsgToStr OutFlush = "OutFlush"
90 :     | outMsgToStr OutQuit = "OutQuit"
91 :     | outMsgToStr (OutMsg v) = concat[
92 :     "OutMsg \"",
93 :     strToHex(Byte.unpackStringVec(v, 0, SOME 4)),
94 :     "..\" (", Int.toString(W8V.length v), " bytes)"
95 :     ]
96 :     (* -DEBUG *)
97 :    
98 :     (** The input stream manager **
99 :     * This monitors the input stream from the X-server, and breaks it up into
100 :     * individual messages, which are sent on outCh to be unmarshalled and routed
101 :     * by the sequencer. Each message to the sequencer is a record consisting
102 :     * of the message code and the message data.
103 :     *)
104 :     fun inbuf (outCh, sock) () = let
105 :     val stdMsgSz = 32
106 :     (* read n bytes from the socket *)
107 :     fun readVec (n, hdr) = let
108 :     fun read (0, [v]) = v
109 :     | read (0, vl) = W8V.concat(List.rev vl)
110 :     | read (n, vl) = let
111 :     val v = Socket.recvVec(sock, n)
112 :     in
113 :     case (W8V.length v)
114 :     (**** NOTE: we need a more graceful way to signal that the socket has closed!! ***)
115 :     of 0 => raise Fail "Socket closed"
116 :     | len => read (n - len, v::vl)
117 :     (* end case *)
118 :     end
119 :     in
120 :     read (n, hdr)
121 :     end
122 :     fun getMsg () = let
123 :     val msg = readVec (stdMsgSz, [])
124 :     in
125 :     case W8V.sub(msg, 0)
126 :     of 0w1 => let (* reply *)
127 :     val extraLen = LargeWord.toIntX(Pack32Big.subVec(msg, 1))
128 :     in
129 :     if (extraLen > 0)
130 :     then {
131 :     code = 0w1,
132 :     msg = readVec (4 * extraLen, [msg])
133 :     }
134 :     else {code = 0w1, msg = msg}
135 :     end
136 :     | k => {code = k, msg = msg}
137 :     (* end case *)
138 :     end
139 :     (* +DEBUG *)
140 :     val getMsg = fn () => let
141 :     val (res as {code, msg}) = getMsg ()
142 :     in
143 :     XDebug.trace (XDebug.ioTM, fn () => [
144 :     "XIo.getMsg: buf = \"",
145 :     strToHex(Byte.unpackStringVec(msg, 0, SOME 8)),
146 :     "..\", code = ", Word8.toString code,
147 :     ", len = ", Int.toString(W8V.length msg), "\n"
148 :     ]);
149 :     res
150 :     end
151 :     (* -DEBUG *)
152 :     fun loop () = (
153 :     CML.send (outCh, getMsg());
154 :     loop ())
155 :     in
156 :     loop () handle _ => CML.exit()
157 :     end
158 :    
159 :    
160 :     (** The output stream manager. **)
161 :     fun outbuf (inCh, sock) () = let
162 :     fun quit () = (Socket.close sock; CML.exit())
163 :     fun flushBuf strs = SockUtil.sendVec(sock, W8V.concat(rev strs))
164 :     (* +DEBUG *)
165 :     val flushBuf = fn strs => (
166 :     XDebug.trace (XDebug.ioTM, fn () => [
167 :     "Flush: ", Int.toString (List.length strs), " msgs, ",
168 :     Int.toString(List.foldl (fn (s, n) => W8V.length s + n) 0 strs), " bytes\n"
169 :     ]);
170 :     flushBuf strs)
171 :     (* -DEBUG *)
172 :     fun insert (s, (strs, nb)) = let
173 :     val n = W8V.length s
174 :     in
175 :     if (n+nb > bufSz)
176 :     then (flushBuf strs; ([s], n))
177 :     else (s::strs, n+nb)
178 :     end
179 :     (*****
180 :     fun loop ([], _) = (case CML.recv inCh
181 :     of OutFlush => loop([], 0)
182 :     | (OutMsg s) => loop([s], W8V.length s)
183 :     | OutQuit => quit())
184 :     | loop (buf as (strs, _)) = CML.select [
185 :     CML.wrap(flushTimeOut, fn _ => (flushBuf strs; loop([], 0))),
186 :     CML.wrap(CML.recvEvt inCh,
187 :     fn OutFlush => (flushBuf strs; loop([], 0))
188 :     | (OutMsg s) => loop(insert(s, buf))
189 :     | OutQuit => (flushBuf strs; quit()))
190 :     ]
191 :     *****)
192 :     fun prMsg msg = (
193 :     XDebug.trace (XDebug.ioTM, fn () => ["outbuf.loop: ", outMsgToStr msg, "\n"]);
194 :     msg)
195 :     fun loop (buf, _) = (
196 :     XDebug.trace (XDebug.ioTM, fn () => [
197 :     "outbuf.loop: waiting ", Int.toString(List.length buf), "\n"]);
198 :     case buf
199 :     of [] => (case prMsg(CML.recv inCh)
200 :     of OutFlush => loop([], 0)
201 :     | (OutMsg s) => loop([s], W8V.length s)
202 :     | OutQuit => quit()
203 :     (* end case *))
204 :     | strs => CML.select [
205 :     CML.wrap(flushTimeOut, fn _ => (flushBuf strs; loop([], 0))),
206 :     CML.wrap(CML.wrap(CML.recvEvt inCh, prMsg),
207 :     fn OutFlush => (flushBuf strs; loop([], 0))
208 :     | (OutMsg s) => loop(insert(s, (buf, 0)))
209 :     | OutQuit => (flushBuf strs; quit()))
210 :     ]
211 :     (* end case *))
212 :     in
213 :     loop ([], 0)
214 :     end (* outbuf *)
215 :    
216 :    
217 :     (** The sequencer **
218 :     * The sequencer is responsible for matching replies with requests. All requests to
219 :     * the X-server go through the sequencer, as do all messages from the X-server.
220 :     * The sequencer communicates on five fixed channels:
221 :     * reqCh -- request messages from clients
222 :     * inCh -- reply, error and event messages from the server (via the input buffer)
223 :     * outCh -- requests messages to the output buffer
224 :     * xevtCh -- X-events to the X-event buffer
225 :     * errCh -- errors to the error handler
226 :     * In addition, the sequencer sends replies to clients on the reply channel that
227 :     * was bundled with the request.
228 :     *)
229 :     local
230 :     (* the kind of reply that is pending for an outstanding request in the
231 :     * outstanding request queue. We use words to represent the sequence
232 :     * numbers.
233 :     *)
234 :     datatype outstanding_reply
235 :     = ErrorChk of (W.word * reply CML.chan)
236 :     | OneReply of (W.word * reply CML.chan)
237 :     | MultiReply of (W.word * reply CML.chan * (W8V.vector -> int) * W8V.vector list)
238 :     | ExposureReply of (W.word * (unit -> Geometry.rect list) SV.ivar)
239 :    
240 :     (* +DEBUG *)
241 :     fun seqnToStr n = W.fmt StringCvt.DEC n
242 :     fun dumpPendingQ (seqn, ([], [])) = XDebug.errTrace (fn () => [
243 :     "PendingQ(", seqnToStr seqn, "): empty\n"
244 :     ])
245 :     | dumpPendingQ (seqn, (front, rear)) = let
246 :     fun item2s (ErrorChk(n, _)) = " ErrorChk #" ^ (seqnToStr n) ^ "\n"
247 :     | item2s (OneReply(n, _)) = " OneReply #" ^ (seqnToStr n) ^ "\n"
248 :     | item2s (MultiReply(n, _, _, _)) = " MultiReply #" ^ (seqnToStr n) ^ "\n"
249 :     | item2s (ExposureReply(n, _)) = " ExposureReply #" ^ (seqnToStr n) ^ "\n"
250 :     fun dump ([], l) = (rev l)
251 :     | dump (x::r, l) = dump(r, (item2s x) :: l)
252 :     in
253 :     XDebug.errTrace (fn () =>
254 :     "PendingQ(" :: (seqnToStr seqn) :: "):\n"
255 :     :: (dump(front @ (rev rear), []))
256 :     )
257 :     end
258 :     (* -DEBUG *)
259 :    
260 :     fun seqnOf (ErrorChk(seqn, _)) = seqn
261 :     | seqnOf (OneReply(seqn, _)) = seqn
262 :     | seqnOf (MultiReply(seqn, _, _, _)) = seqn
263 :     | seqnOf (ExposureReply(seqn, _)) = seqn
264 :    
265 :     fun sendReply arg = (CML.spawn(fn () => CML.send arg); ())
266 :    
267 :     fun sendReplies (ch, replies) = let
268 :     fun loop [] = () | loop (s::r) = (CML.send(ch, Reply s); loop r)
269 :     in
270 :     CML.spawn (fn () => loop(rev replies)); ()
271 :     end
272 :    
273 :     fun insert (x, (front, rear)) = (front, x::rear)
274 :    
275 :     (* Synchronize the queue of outstanding requests with the sequence number n.
276 :     * Return the pair (f, q), where q is the synchronized queue and f is true
277 :     * if the head of q has sequence number b.
278 :     *)
279 :     fun syncOutstandingQ (n, q) = let
280 :     fun discardReply (ErrorChk(_, ch)) = sendReply(ch, Reply emptyV)
281 :     | discardReply (OneReply(_, ch)) = sendReply(ch, ReplyLost)
282 :     | discardReply (MultiReply(_, ch, _, [])) = sendReply(ch, ReplyLost)
283 :     | discardReply (MultiReply(_, ch, _, replies)) = sendReplies(ch, replies)
284 :     | discardReply (ExposureReply(_, syncV)) =
285 :     SV.iPut (syncV, fn () => raise LostReply)
286 :     fun scan (q' as ([], [])) = (false, q')
287 :     | scan ([], rear) = scan (rev rear, [])
288 :     | scan (q' as ((rpend :: r), rear)) = let
289 :     val seqn = seqnOf rpend
290 :     in
291 :     if (seqn < n)
292 :     then (discardReply rpend; scan (r, rear))
293 :     else if (seqn > n)
294 :     then (false, q')
295 :     else (true, q')
296 :     end
297 :     in
298 :     scan q
299 :     end
300 :    
301 :     (* extract the outstanding request corresponding to the given reply message (with
302 :     * sequence number n). If all of the expected replies have been received,
303 :     * then send the extracted reply to the requesting client.
304 :     *)
305 :     fun extractReply (n, reply, q) = (
306 :     case (syncOutstandingQ(n, q))
307 :     of (true, (OneReply(_, ch)::r, rear)) => (
308 :     sendReply(ch, Reply reply); (r, rear))
309 :     | (true, (MultiReply(seqn, ch, remain, replies)::r, rear)) => (
310 :     if ((remain reply) = 0)
311 :     then (sendReplies(ch, reply::replies); (r, rear))
312 :     else (MultiReply(seqn, ch, remain, reply::replies)::r, rear))
313 :     | _ =>
314 :     (* DEBUG *) (dumpPendingQ(n, q);
315 :     MLXError.impossible "[XIo.extractReply: bogus pending reply queue]"
316 :     (* DEBUG *) )
317 :     (* end case *))
318 :    
319 :     (* extract the outstanding request corresponding to the given exposure message
320 :     * (with seqence number n).
321 :     *)
322 :     fun extractExpose (n, reply, q) = (
323 :     case (syncOutstandingQ(n, q))
324 :     of (true, (ExposureReply(_, syncV)::r, rear)) => (
325 :     SV.iPut (syncV, fn () => reply); (r, rear))
326 :     (* for now, just drop it. When the gc-server supports graphics-exposures, these
327 :     * shouldn't happen. *)
328 :     | _ => q
329 :     (* +DEBUG
330 :     (dumpPendingQ(n, q);
331 :     MLXError.impossible "[XIo.extractExpose: bogus pending reply queue]")
332 :     -DEBUG *)
333 :     (* end case *))
334 :    
335 :     (* extract the outstanding request corresponding to the given error message
336 :     * (with seqence number n).
337 :     *)
338 :     fun extractErr (n, err, q) = (
339 :     case (syncOutstandingQ(n, q))
340 :     of (true, (ErrorChk(_, ch)::r, rear)) => (
341 :     sendReply(ch, ReplyError err); (r, rear))
342 :     | (true, (OneReply(_, ch)::r, rear)) => (
343 :     sendReply(ch, ReplyError err); (r, rear))
344 :     | (true, (MultiReply(_, ch, _, _)::r, rear)) => (
345 :     sendReply(ch, ReplyError err); (r, rear))
346 :     | (true, (ExposureReply(_, syncV)::r, rear)) => (
347 :     SV.iPut (syncV, fn () => raise ErrorReply(XReply.decodeError err));
348 :     (r, rear))
349 :     | (false, q') => q'
350 :     | _ =>
351 :     (* DEBUG *) (dumpPendingQ(n, q);
352 :     MLXError.impossible "[XIo.extractErr: bogus pending reply queue]"
353 :     (* DEBUG *) )
354 :     (* end case *))
355 :    
356 :     fun syncWithXEvt (n, q) = (
357 :     case (syncOutstandingQ(n, q))
358 :     of (true, (ErrorChk(_, ch)::r, rear)) => (
359 :     sendReply(ch, Reply emptyV); (r, rear))
360 :     | (_, q) => q
361 :     (* end case *))
362 :     in
363 :     fun sequencer (reqCh, inCh, outCh, xevtCh, errCh) () = let
364 :     fun quit () = (CML.send(outCh, OutQuit); CML.exit())
365 :     val inEvt = CML.recvEvt inCh
366 : monnier 8 val reqEvt = CML.recvEvt reqCh
367 : monnier 2 fun doRequest (req, (lastIn, lastOut, pending)) = (
368 :     CML.send(outCh, OutMsg req);
369 :     (lastIn, lastOut+0w1, pending))
370 :     fun doRequestAndChk ((req, replyCh), (lastIn, lastOut, pending)) = let
371 :     val n = lastOut+0w1
372 :     in
373 :     CML.send(outCh, OutMsg req);
374 :     (lastIn, n, insert(ErrorChk(n, replyCh), pending))
375 :     end
376 :     fun doRequestReply ((req, replyCh), (lastIn, lastOut, pending)) = let
377 :     val n = lastOut+0w1
378 :     in
379 :     CML.send(outCh, OutMsg req);
380 :     (lastIn, n, insert(OneReply(n, replyCh), pending))
381 :     end
382 :     fun doRequestReplies ((req, replyCh, remain), (lastIn, lastOut, pending)) = let
383 :     val n = lastOut+0w1
384 :     in
385 :     CML.send(outCh, OutMsg req);
386 :     (lastIn, n, insert(MultiReply(n, replyCh, remain, []), pending))
387 :     end
388 :     fun doRequestExposures ((req, syncV), (lastIn, lastOut, pending)) = let
389 :     val n = lastOut+0w1
390 :     in
391 :     CML.send(outCh, OutMsg req);
392 :     (lastIn, n, insert(ExposureReply(n, syncV), pending))
393 :     end
394 :     (* gobble requests w/o blocking and then flush the buffer *)
395 :     fun gobbleAndFlush arg = let
396 :     fun loop arg = (case (CML.recvPoll reqCh)
397 :     of NONE => arg
398 :     | (SOME RequestFlush) => loop arg
399 :     | (SOME RequestQuit) => quit()
400 :     | (SOME(Request req)) => loop (doRequest(req, arg))
401 :     | (SOME(RequestAndChk req)) => loop (doRequestAndChk (req, arg))
402 :     | (SOME(RequestReply req)) => loop (doRequestReply (req, arg))
403 :     | (SOME(RequestReplies req)) =>
404 :     loop (doRequestReplies (req, arg))
405 :     | (SOME(RequestExposures req)) =>
406 :     loop (doRequestExposures (req, arg))
407 :     (* end case *))
408 :     val res = loop arg
409 :     in
410 :     CML.send(outCh, OutFlush);
411 :     res
412 :     end
413 :     (* the is the main sequencer loop; we keep track of the sequence number
414 :     * of the last message in, the sequence number of the last message out,
415 :     * and the queue of pending requests.
416 :     *)
417 :     fun loop (arg as (lastReqIn, lastReqOut, pending)) = let
418 :     (* handle a request from a client *)
419 :     fun reqWrap RequestFlush = gobbleAndFlush arg
420 :     | reqWrap RequestQuit = quit()
421 :     | reqWrap (Request req) = (
422 :     CML.send(outCh, OutMsg req);
423 :     (lastReqIn, lastReqOut+0w1, pending))
424 :     | reqWrap (RequestAndChk req) =
425 :     gobbleAndFlush (doRequestAndChk (req, arg))
426 :     | reqWrap (RequestReply req) =
427 :     gobbleAndFlush (doRequestReply (req, arg))
428 :     | reqWrap (RequestReplies req) =
429 :     gobbleAndFlush (doRequestReplies (req, arg))
430 :     | reqWrap (RequestExposures req) =
431 :     gobbleAndFlush (doRequestExposures (req, arg))
432 :     (* handle a server-message (from the input buffer) *)
433 :     fun inWrap {code : Word8.word, msg} = let
434 :     (** NOTE: this doesn't work if there are 2^17 outgoing messages between
435 :     ** replies/events. We need to track (lastReqOut - lastReqIn), and if it
436 :     ** gets bigger than some reasonable size, generate a synchronization
437 :     ** (i.e., GetInputFocus message).
438 :     **)
439 :     fun getSeqN () = let
440 :     val shortSeqN = W.fromLargeWord(Pack16Big.subVec(msg, 1))
441 :     val seqn' = W.orb(
442 :     W.andb(lastReqIn, W.notb 0wxffff),
443 :     shortSeqN)
444 :     in
445 :     if (seqn' < lastReqIn)
446 :     (* NOTE: we should check for (seqn' + 0x10000) > lastReqOut *)
447 :     then seqn' + 0wx10000
448 :     else seqn'
449 :     end
450 :     in
451 :     case code
452 :     of 0w0 => let (* error message *)
453 :     val seqn = getSeqN()
454 :     in
455 :     CML.send(errCh, (seqn, msg));
456 :     (seqn, lastReqOut, extractErr(seqn, msg, pending))
457 :     end
458 :     | 0w1 => let (* reply message *)
459 :     val seqn = getSeqN()
460 :     in
461 :     (seqn, lastReqOut, extractReply(seqn, msg, pending))
462 :     end
463 :     | 0w11 => ( (* KeymapNotify event *)
464 :     CML.send (xevtCh, (code, msg));
465 :     ( lastReqIn, lastReqOut,
466 :     syncWithXEvt(lastReqIn, pending)
467 :     ))
468 :     | 0w13 => let (* GraphicsExpose event *)
469 :     val seqn = getSeqN()
470 :     open XEventTypes
471 :     fun pack (rl, GraphicsExposeXEvt{rect, count=0, ...}) =
472 :     rect::rl
473 :     | pack (rl, GraphicsExposeXEvt{rect, ...}) = (
474 :     case (CML.recv inCh)
475 :     of {code = 0w13, msg=s} =>
476 :     pack (rect::rl,
477 :     XReply.decodeGraphicsExpose s)
478 :     | _ => (
479 :     MLXError.warning
480 :     "[XIo.sequencer: misleading GraphicsExpose count]";
481 :     rect::rl)
482 :     (* end case *))
483 : monnier 8 val rects = pack ([], XReply.decodeGraphicsExpose msg)
484 :     in
485 :     ( seqn,
486 :     lastReqOut,
487 :     extractExpose(seqn, rects, pending)
488 :     )
489 :     end
490 : monnier 2 | 0w14 => let (* NoExpose event *)
491 :     val seqn = getSeqN()
492 :     in
493 :     (seqn, lastReqOut, extractExpose(seqn, [], pending))
494 :     end
495 :     | _ => let (* other event messages *)
496 :     val seqn = getSeqN()
497 :     in
498 :     CML.send (xevtCh, (code, msg));
499 :     (seqn, lastReqOut, syncWithXEvt(seqn, pending))
500 :     end
501 :     (* end case *)
502 :     end
503 :     in
504 :     loop (
505 :     CML.select [
506 : monnier 8 CML.wrap (reqEvt, reqWrap),
507 : monnier 2 CML.wrap (inEvt, inWrap)
508 :     ])
509 :     end (* loop *)
510 :     in
511 :     loop (0w0, 0w0, ([], []))
512 :     end (* sequencer *)
513 :     end (* local *)
514 :    
515 :    
516 :     (** The X-event buffer **
517 :     *
518 :     * The X-event buffer decodes and buffers X-events. This thread also packs
519 :     * expose events. It communicates on two channels as follows:
520 :     * xevtMsgCh -- raw messages from the sequencer
521 :     * xevtCh -- decoded events to the window registry
522 :     *)
523 :     fun xeventBuffer (xevtMsgCh, xevtCh) = let
524 :     open XEventTypes
525 :     fun decode (k, s) = #2(XReply.decodeXEvent (k, s))
526 :     fun packExposeEvts (e as ExposeXEvt{window, ...}) = let
527 :     fun pack (rl, ExposeXEvt{rects, count=0, ...}) = rects@rl
528 :     | pack (rl, ExposeXEvt{rects, ...}) =
529 :     pack (rects@rl, decode(CML.recv xevtMsgCh))
530 :     | pack (rl, _) = (
531 :     MLXError.warning "[XIo.sequencer: misleading Expose count]";
532 :     rl)
533 :     in
534 :     ExposeXEvt{window = window, rects = pack([], e), count = 0}
535 :     end
536 :     fun doXEvent (msg, q) = (case (decode msg)
537 :     of (e as ExposeXEvt _) => (packExposeEvts e) :: q
538 :     | e => (e :: q))
539 :     val getXEvt = CML.recvEvt xevtMsgCh
540 :     fun routeP () = let
541 :     fun loop ([], []) = loop(doXEvent(CML.recv xevtMsgCh, []), [])
542 :     | loop ([], rear) = loop(rev rear, [])
543 :     | loop (front as (x::r), rear) =
544 :     loop (CML.select [
545 :     CML.wrap (getXEvt, fn msg => (front, doXEvent(msg, rear))),
546 :     CML.wrap (CML.sendEvt(xevtCh, x), fn () => (r, rear))
547 :     ])
548 :     in
549 :     loop ([], [])
550 :     end
551 :     in
552 :     routeP
553 :     end (* xeventBuffer *)
554 :    
555 :    
556 :     (** The connection **)
557 :    
558 :     datatype connection = CONN of {
559 :     conn_id : unit ref,
560 :     xevt_ch : XEventTypes.xevent CML.chan,
561 :     req_ch : req_msg CML.chan,
562 :     err_ch : (W.word * W8V.vector) CML.chan,
563 :     flush : unit -> unit,
564 :     close : unit -> unit
565 :     }
566 :    
567 :     (* Create the threads and internal channels to manage a connection to the
568 :     * X server. We assume that the connection request/reply has already been
569 :     * dealt with.
570 :     *)
571 :     fun openConn sock = let
572 :     val inStrm = CML.channel() and outStrm = CML.channel()
573 :     val xevtStrm = CML.channel() and xevtMsgStrm = CML.channel()
574 :     val reqStrm = CML.channel() and errStrm = CML.channel()
575 :     val exposeStrm = CML.channel()
576 :     fun flushFn () = CML.send (reqStrm, RequestFlush)
577 :     fun closeFn () = (
578 :     XDebug.trace (XDebug.ioTM, fn () => ["close connection\n"]);
579 :     flushFn(); CML.send(reqStrm, RequestQuit))
580 :     in
581 :     (******
582 :     CML.spawn (sequencer (reqStrm, inStrm, outStrm, xevtMsgStrm, errStrm));
583 :     CML.spawn (inbuf (inStrm, sock));
584 :     CML.spawn (outbuf (outStrm, sock));
585 :     CML.spawn (xeventBuffer (xevtMsgStrm, xevtStrm));
586 :     ******)
587 :     (* DEBUG *) XDebug.xspawn ("Sequencer", sequencer (
588 :     reqStrm, inStrm, outStrm, xevtMsgStrm, errStrm));
589 :     (* DEBUG *) XDebug.xspawn ("Inbuf", inbuf (inStrm, sock));
590 :     (* DEBUG *) XDebug.xspawn ("Outbuf", outbuf (outStrm, sock));
591 :     (* DEBUG *) XDebug.xspawn ("XEventBuffer", xeventBuffer (xevtMsgStrm, xevtStrm));
592 :     CONN{
593 :     conn_id = ref (),
594 :     xevt_ch = xevtStrm,
595 :     req_ch = reqStrm,
596 :     err_ch = errStrm,
597 :     flush = flushFn,
598 :     close = closeFn
599 :     }
600 :     end
601 :    
602 :     fun closeConn (CONN{close, ...}) = close()
603 :    
604 :     fun sameConn (CONN{conn_id=a, ...}, CONN{conn_id=b, ...}) = (a = b)
605 :    
606 :     fun request (CONN{req_ch, ...}) s = (CML.send(req_ch, Request s))
607 :    
608 :     fun replyWrapper ReplyLost = raise LostReply
609 :     | replyWrapper (ReplyError s) = raise ErrorReply(XReply.decodeError s)
610 :     | replyWrapper (Reply s) = s
611 :    
612 :     (** NOTE: these should be done using a guard event eventually *)
613 :     (* Generate a request to the server and check on its successful completion. *)
614 :     fun requestAndChk (CONN{req_ch, ...}) s = let
615 :     val replyCh1 = CML.channel() and replyCh2 = CML.channel()
616 :     in
617 :     CML.send (req_ch, RequestAndChk(s, replyCh1));
618 :     CML.send (req_ch, RequestReply(XRequest.requestGetInputFocus, replyCh2));
619 :     CML.wrap (CML.recvEvt replyCh1,
620 :     fn (ReplyError s) => raise ErrorReply(XReply.decodeError s)
621 :     | _ => ())
622 :     end
623 :    
624 :     fun requestReply (CONN{req_ch, ...}) s = let
625 :     val replyCh = CML.channel()
626 :     in
627 :     CML.send (req_ch, RequestReply(s, replyCh));
628 :     CML.wrap (CML.recvEvt replyCh, replyWrapper)
629 :     end
630 :    
631 :     fun requestMultiReply (CONN{req_ch, ...}) (s, remain) = let
632 :     val replyCh = CML.channel()
633 :     in
634 :     CML.send (req_ch, RequestReplies(s, replyCh, remain));
635 :     CML.wrap (CML.recvEvt replyCh, replyWrapper)
636 :     end
637 :    
638 :     fun requestWithExposures (CONN{req_ch, ...}) (s, syncV) = let
639 :     val replyCh = CML.channel()
640 :     in
641 :     CML.send (req_ch, RequestExposures(s, syncV))
642 :     end
643 :    
644 :     fun flushOut (CONN{flush, ...}) = flush()
645 :    
646 :     fun waitForXEvent (CONN{xevt_ch, ...}) = CML.recvEvt xevt_ch
647 :     fun readXError (CONN{err_ch, ...}) = CML.recv err_ch
648 :    
649 :     end (* XIo *)
650 :    

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0