source: project/release/4/mailbox/tags/2.0.0/mailbox.scm @ 13533

Last change on this file since 13533 was 13533, checked in by Kon Lovett, 12 years ago

Rmvd extra space in record print.

File size: 15.3 KB
Line 
1;;;; mailbox.scm
2;;;; Kon Lovett, Mar '09 (from Chicken 3 "mailbox" by Felix & Kon)
3
4;; Issues
5;;
6;; - All operations inlined & primitive due to high-performance nature of IPC.
7;;
8;; - Uses ##sys#current-thread & ##sys#thread-unblock!
9
10(declare
11  (usual-integrations)
12  (disable-interrupts)
13  (fixnum)
14  (inline)
15  (local)
16  (no-procedure-checks)
17  (no-bound-checks)
18  (bound-to-procedure
19    ##sys#check-structure
20    ##sys#check-list
21    ##sys#check-symbol
22    ##sys#signal-hook
23    ##sys#thread-unblock!)
24  (always-bound
25    ##sys#current-thread) )
26
27
28;;;
29
30(include "chicken-primitive-object-inlines")
31(include "chicken-thread-object-inlines")
32
33(require-library ports srfi-18)
34
35
36;;; Queue Support
37
38(define-inline (%make-queue)
39  (%make-structure 'queue '() '()))
40
41(define-inline (%queue? obj)
42  (%structure-instance? obj 'queue) )
43
44(define-inline (%queue-first-pair q)
45  (%structure-ref q 1) )
46
47(define-inline (%queue-first-pair-set! q v)
48  (%structure-set! q 1 v) )
49
50(define-inline (%queue-last-pair q)
51  (%structure-ref q 2) )
52
53(define-inline (%queue-last-pair-set! q v)
54  (%structure-set! q 2 v) )
55
56(define-inline (%queue-empty? q)
57  (%null? (%queue-first-pair q)) )
58
59(define-inline (%queue-count q)
60  (%length (%queue-first-pair q)) )
61
62;; Queue Operations
63
64(define-inline (%queue-last-pair-empty! q)
65  (%structure-set!/immediate q 2 '()) )
66
67(define-inline (%queue-add! q datum)
68  (let ([new-pair (%cons datum '())])
69    (if (%null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
70        (%set-cdr! (%queue-last-pair q) new-pair) )
71    (%queue-last-pair-set! q new-pair) ) )
72
73(define-inline (%queue-remove! q)
74  (let* ([first-pair (%queue-first-pair q)]
75         [next-pair (%cdr first-pair)])
76    (%queue-first-pair-set! q next-pair)
77    (when (%null? next-pair) (%queue-last-pair-empty! q) )
78    (%car first-pair) ) )
79
80(define-inline (%queue-push-back! q item)
81  (let ([newlist (%cons item (%queue-first-pair q))])
82    (%queue-first-pair-set! q newlist)
83    (when (%null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
84
85(define-inline (%queue-push-back-list! q itemlist)
86  (let ([newlist (%append! (%list-copy itemlist) (%queue-first-pair q))])
87    (%queue-first-pair-set! q newlist)
88    (if (%null? newlist) (%queue-last-pair-empty! q)
89        (%queue-last-pair-set! q (%last-pair newlist) ) ) ) )
90
91(define-inline (%queue-extract-pair! q targ-pair)
92  ; Scan queue list until we find the item to remove
93  (let scanning ([this-pair (%queue-first-pair q)] [prev-pair '()])
94    ; Found it?
95    (if (%eq? this-pair targ-pair)
96        ;then cut out the pair
97        (let ([next-pair (%cdr this-pair)])
98          ; At the head of the list, or in the body?
99          (if (%null? prev-pair) (%queue-first-pair-set! q next-pair)
100              (%set-cdr! prev-pair next-pair) )
101          ; When the cut pair is the last item update the last pair ref.
102          (when (%eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) )
103        ;else keep looking for the pair
104        (scanning (%cdr this-pair) this-pair) ) ) )
105
106
107;;; Mailbox Support
108
109(define-inline (%make-mailbox nm)
110  (%make-structure 'mailbox nm (%make-queue) '()) )
111
112(define-inline (%mailbox? obj)
113  (%structure-instance? obj 'mailbox) )
114
115(define-inline (%mailbox-name mb)
116  (%structure-ref mb 1) )
117
118;; Message queue
119
120(define-inline (%mailbox-queue mb)
121  (%structure-ref mb 2) )
122
123(define-inline (%mailbox-queue-empty? mb)
124  (%queue-empty? (%mailbox-queue mb)) )
125
126(define-inline (%mailbox-queue-count mb)
127  (%queue-count (%mailbox-queue mb)) )
128
129(define-inline (%mailbox-queue-add! mb x)
130  (%queue-add! (%mailbox-queue mb) x) )
131
132(define-inline (%mailbox-queue-remove! mb)
133  (%queue-remove! (%mailbox-queue mb)) )
134
135(define-inline (%mailbox-queue-push-back! mb x)
136  (%queue-push-back! (%mailbox-queue mb) x) )
137
138(define-inline (%mailbox-queue-push-back-list! mb ls)
139  (%queue-push-back-list! (%mailbox-queue mb) ls) )
140
141(define-inline (%mailbox-queue-first-pair mb)
142  (%queue-first-pair (%mailbox-queue mb)) )
143
144(define-inline (%mailbox-queue-last-pair mb)
145  (%queue-last-pair (%mailbox-queue mb)) )
146
147;; Waiting threads
148
149(define-inline (%mailbox-waiters mb)
150  (%structure-ref mb 3) )
151
152(define-inline (%mailbox-waiters-set! mb v)
153  (%structure-set! mb 3 v) )
154
155(define-inline (%mailbox-waiters-empty? mb)
156  (%null? (%mailbox-waiters mb)) )
157
158(define-inline (%mailbox-waiters-count mb)
159  (%length (%mailbox-waiters mb)) )
160
161(define-inline (%mailbox-waiters-add! mb th)
162  (%mailbox-waiters-set! mb (%append! (%mailbox-waiters mb) (%cons th '()))) )
163
164(define-inline (%mailbox-waiters-delete! mb th)
165  (%mailbox-waiters-set! mb (%delq! th (%mailbox-waiters mb))) )
166
167(define-inline (%mailbox-waiters-pop! mb)
168  (let ([ts (%mailbox-waiters mb)])
169    (%mailbox-waiters-set! mb (%cdr ts))
170    (%car ts) ) )
171
172
173;;; Mailbox Cursor Support
174
175(define-inline (%make-mailbox-cursor mb)
176  (%make-structure 'mailbox-cursor '() #f mb) )
177
178(define-inline (%mailbox-cursor? obj)
179  (%structure-instance? obj 'mailbox-cursor) )
180
181(define-inline (%mailbox-cursor-next-pair mbc)
182  (%structure-ref mbc 1) )
183
184(define-inline (%mailbox-cursor-next-pair-set! mbc v)
185  (%structure-set! mbc 1 v) )
186
187(define-inline (%mailbox-cursor-next-pair-empty! mbc)
188  (%structure-set!/immediate mbc 1 '()) )
189
190(define-inline (%mailbox-cursor-prev-pair mbc)
191  (%structure-ref mbc 2) )
192
193(define-inline (%mailbox-cursor-prev-pair-set! mbc v)
194  (%structure-set! mbc 2 v) )
195
196(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
197  (%structure-set!/immediate mbc 2 #f) )
198
199(define-inline (%mailbox-cursor-winding? mbc)
200  (and (%mailbox-cursor-prev-pair mbc)
201       #t) )
202
203(define-inline (%mailbox-cursor-mailbox mbc)
204  (%structure-ref mbc 3) )
205
206(define-inline (%mailbox-cursor-rewind mbc)
207  (%mailbox-cursor-next-pair-empty! mbc)
208  (%mailbox-cursor-prev-pair-clear! mbc) )
209
210(define-inline (%mailbox-cursor-extract! mbc)
211  ; Unless 'mailbox-cursor-next' has been called don't remove
212  (and-let* ([prev-pair (%mailbox-cursor-prev-pair mbc)])
213    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
214
215
216;;; Time Support
217
218(define-inline (%time? obj)
219  (%structure-instance? obj 'time) )
220
221(define-inline (%timeout? obj)
222  (or (%time? obj) (%number? obj)) )
223
224
225;;; Unique Object Support
226
227(define-inline (%make-unique-object #!optional ident)
228  (if ident (%make-vector 1 ident)
229      '#() ) )
230
231
232;;; Argument Checking
233
234(define-inline (%check-mailbox loc obj)
235  (##sys#check-structure obj 'mailbox loc) )
236
237(define-inline (%check-mailbox-cursor loc obj)
238  (##sys#check-structure obj 'mailbox-cursor loc) )
239
240(define-inline (%check-timeout loc obj)
241  (unless (%timeout? obj)
242    (##sys#signal-hook #:type-error loc "bad argument type - invalid timeout object" obj) ) )
243
244(define-inline (%check-symbol loc obj)
245  (##sys#check-symbol obj loc) )
246
247(define-inline (%check-list loc obj)
248  (##sys#check-list obj loc) )
249
250
251;;;
252
253(module mailbox (;export
254  ;
255  mailbox-timeout-exception?
256  ;
257  make-mailbox
258  mailbox?
259  mailbox-name
260  mailbox-empty?
261  mailbox-count
262  mailbox-waiting?
263  mailbox-waiters
264  mailbox-send!
265  mailbox-wait!
266  mailbox-receive!
267  mailbox-push-back!
268  mailbox-push-back-list!
269  ;
270  make-mailbox-cursor
271  mailbox-cursor?
272  mailbox-cursor-mailbox
273  mailbox-cursor-next
274  mailbox-cursor-rewind
275  mailbox-cursor-rewound?
276  mailbox-cursor-extract-and-rewind!)
277
278(import
279  scheme
280  (only chicken
281    optional                ;due to #!optional implementation
282    let-optionals           ;due to #!optional implementation
283    handle-exceptions       ;due to condition-case implementation
284    with-exception-handler  ;due to handle-exceptions implementation
285    and-let* let-values
286    unless when
287    make-composite-condition make-property-condition condition-predicate
288    condition-case
289    error signal
290    gensym
291    define-record-printer)
292  (only ports
293    with-output-to-port)
294  (only srfi-18
295    thread-signal! thread-resume! thread-sleep! thread-suspend!) )
296
297
298;;; Mailbox Exceptions
299
300(define (make-mailbox-timeout-condition loc to-tim to-def)
301  (make-composite-condition
302   (make-property-condition 'exn
303    'location loc
304    'message "mailbox wait timeout occured"
305    'arguments (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def)))
306   (make-property-condition 'mailbox)
307   (make-property-condition 'timeout)) )
308
309
310;;; Mailbox Threading
311
312(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
313
314(define (ready-mailbox! mb)
315  ; Ready oldest waiting thread
316  (unless (%mailbox-waiters-empty? mb)
317    (let ([thread (%mailbox-waiters-pop! mb)])
318      ; Ready the thread based on wait mode
319      (if (not (%thread-blocked? thread)) (thread-resume! thread)
320          ;else wake early if sleeping
321          (when (%thread-blocked-for-timeout? thread)
322            ; Ready the thread
323            (##sys#thread-unblock! thread)
324            ; Tell 'wait-mailbox!' we unblocked early
325            (thread-signal! thread UNBLOCKED-TAG) ) ) ) )
326  ; Side-effect only
327  (%undefined-value) )
328
329(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
330
331(define (wait-mailbox! loc mb to-tim to-def)
332  ; Push current thread on mailbox waiting queue
333  (%mailbox-waiters-add! mb (%current-thread))
334  ; Waiting action
335  (cond
336    [to-tim           ; Timeout wanted so sleep until something happens
337      (let ([early? #f])
338        ; Sleep current thread until desired seconds elapsed
339        (condition-case (thread-sleep! to-tim)
340          [exn ()
341            ; Unless unblocked "early" then a real exception so propagate
342            (if (%eq? UNBLOCKED-TAG exn) (set! early? #t)
343                (signal exn) ) ] )
344        ; Awake
345        (cond
346          [early?       ; Unblocked early so we have a message
347            MESSAGE-WAITING-TAG ]
348          [else         ; Timedout
349            ; Remove from wait queue
350            (%mailbox-waiters-delete! mb (%current-thread))
351            ; Signal timeout when no default
352            (when (%undefined-value? to-def)
353              (thread-signal! (%current-thread)
354                              (make-mailbox-timeout-condition loc to-tim to-def)) )
355            ; No message waiting
356            to-def ] ) ) ]
357      [else           ; Suspend until something delivered
358        (thread-suspend! (%current-thread))
359        MESSAGE-WAITING-TAG ] ) )
360
361(define (wait-mailbox-if-empty! loc mb to-tim to-def)
362  (if (%mailbox-queue-empty? mb)
363      (wait-mailbox! loc mb to-tim to-def)
364      MESSAGE-WAITING-TAG ) )
365
366
367;;; Mailbox
368
369;; Mailbox Exceptions
370
371(define mailbox-timeout-exception?
372  (let ([exf (condition-predicate 'exn)]
373        [mbf (condition-predicate 'mailbox)]
374        [tmf (condition-predicate 'timeout)])
375    (lambda (obj)
376      (and (exf obj) (mbf obj) (tmf obj)) ) ) )
377
378;; Mailbox Constructor
379
380(define (make-mailbox #!optional (nm (gensym 'mailbox)))
381  (%check-symbol 'make-mailbox nm)
382  (%make-mailbox nm) )
383
384(define (mailbox? obj)
385  (%mailbox? obj) )
386
387;; Mailbox Properties
388
389(define (mailbox-name mb)
390  (%check-mailbox 'mailbox-name mb)
391  (%mailbox-name mb) )
392
393(define (mailbox-empty? mb)
394  (%check-mailbox 'mailbox-empty? mb)
395  (%mailbox-queue-empty? mb) )
396
397(define (mailbox-count mb)
398  (%check-mailbox 'mailbox-count mb)
399  (%mailbox-queue-count mb) )
400
401(define (mailbox-waiting? mb)
402  (%check-mailbox 'mailbox-waiting? mb)
403  (not (%null? (%mailbox-waiters mb))) )
404
405(define (mailbox-waiters mb)
406  (%check-mailbox 'mailbox-waiters mb)
407  (%list-copy (%mailbox-waiters mb)) )
408
409;; Mailbox Operations
410
411(define (mailbox-send! mb x)
412  (%check-mailbox 'mailbox-send! mb)
413  (%mailbox-queue-add! mb x)
414  (ready-mailbox! mb) )
415
416(define (mailbox-wait! mb #!optional to-tim)
417  (%check-mailbox 'mailbox-wait! mb)
418  (when to-tim (%check-timeout 'mailbox-wait! to-tim))
419  (wait-mailbox-if-empty! 'mailbox-wait! mb to-tim (%undefined-value)) )
420
421(define (mailbox-receive! mb #!optional to-tim (to-def (%undefined-value)))
422  (%check-mailbox 'mailbox-receive! mb)
423  (when to-tim (%check-timeout 'mailbox-receive! to-tim))
424  (let ([res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)])
425    ; Return next item in mailbox, if any
426    (if (%eq? MESSAGE-WAITING-TAG res) (%mailbox-queue-remove! mb)
427        ;else return the timeout default
428        res ) ) )
429
430(define (mailbox-push-back! mb x)
431  (%check-mailbox 'mailbox-send! mb)
432  (%mailbox-queue-push-back! mb x)
433  (ready-mailbox! mb) )
434
435(define (mailbox-push-back-list! mb ls)
436  (%check-mailbox 'mailbox-send! mb)
437  (%check-list ls 'mailbox-send!)
438  (%mailbox-queue-push-back-list! mb ls)
439  (ready-mailbox! mb) )
440
441
442;;; Mailbox Cursor
443
444;; Mailbox Cursor Constructor
445
446(define (make-mailbox-cursor mb)
447  (%check-mailbox 'make-mailbox-cursor mb)
448  (%make-mailbox-cursor mb) )
449
450;; Mailbox Cursor Properties
451
452(define (mailbox-cursor? obj)
453  (%mailbox-cursor? obj) )
454
455(define (mailbox-cursor-mailbox mbc)
456  (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)
457  (%mailbox-cursor-mailbox mbc) )
458
459(define (mailbox-cursor-rewound? mbc)
460  (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc)
461  (not (%mailbox-cursor-winding? mbc)) )
462
463;; Mailbox Cursor Operations
464
465(define (mailbox-cursor-rewind mbc)
466  (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)
467  (%mailbox-cursor-rewind mbc) )
468
469(define (mailbox-cursor-next mbc #!optional to-tim (to-def (%undefined-value)))
470  (%check-mailbox-cursor 'mailbox-cursor-next mbc)
471  (when to-tim (%check-timeout 'mailbox-cursor-next to-tim))
472  ; Waiting mailbox peek.
473  (let ([mb (%mailbox-cursor-mailbox mbc)])
474    (let-values ([(mailbox-waiter cursor-pair-getter)
475                  (if (%mailbox-cursor-winding? mbc)
476                      ;then wait for something to be appended
477                      (values wait-mailbox!
478                              (lambda () (%mailbox-queue-last-pair mb)))
479                      ;else grab the start of a, probably, non-empty queue
480                      (values wait-mailbox-if-empty!
481                              (lambda () (%mailbox-queue-first-pair mb))) ) ] )
482      (let scanning ([next-pair (%mailbox-cursor-next-pair mbc)])
483        ; Anything next?
484        (if (not (%null? next-pair))
485            ;then peek into the queue for the next item
486            (let ([item (%car next-pair)])
487              (%mailbox-cursor-prev-pair-set! mbc next-pair)
488              (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
489              item )
490            ;else wait for something in the mailbox
491            (let ([res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)])
492              (cond
493                [(%eq? MESSAGE-WAITING-TAG res)  ; so continue scanning
494                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
495                  (scanning (%mailbox-cursor-next-pair mbc)) ]
496                [else                            ; otherwise timedout
497                  res ] ) ) ) ) ) ) )
498
499(define (mailbox-cursor-extract-and-rewind! mbc)
500  (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
501  (%mailbox-cursor-extract! mbc)
502  (%mailbox-cursor-rewind mbc) )
503
504;;; Read/Print Syntax
505
506(define-record-printer (mailbox mb out)
507  (with-output-to-port out
508    (lambda ()
509      (display "#<mailbox")
510      (display #\space) (display (%mailbox-name mb))
511      (display " queued = ") (display (%mailbox-queue-count mb))
512      (display " waiters = ") (display (%mailbox-waiters-count mb))
513      (display ">") ) ) )
514
515(define-record-printer (mailbox-cursor mbc out)
516  (with-output-to-port out
517    (lambda ()
518      (display "#<mailbox-cursor")
519      (display " mailbox = ") (display (%mailbox-name (%mailbox-cursor-mailbox mbc)))
520      (display " status = ") (display (if (%mailbox-cursor-winding? mbc) "winding" "rewound"))
521      (display ">") ) ) )
522
523) ;module mailbox
Note: See TracBrowser for help on using the repository browser.