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

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

Release.

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