source: project/release/4/mailbox/tags/2.2.2/mailbox.scm @ 34364

Last change on this file since 34364 was 34364, checked in by Kon Lovett, 2 years ago

we may need this - cond-ex is better

File size: 18.2 KB
Line 
1;;;; mailbox.scm
2;;;; Kon Lovett, Mar '09
3;;;; Kon Lovett, Aug '17
4;;;; From Chicken 3 "mailbox" by Felix & Kon
5
6;; Issues
7;;
8;; - When compile-time feature `unsafe-operations' inlined & primitive routines used.
9;;
10;; - Has explicit "unspecified" returns in some cases to avoid leaks of internal
11;; objects.
12;;
13;; - 'wait-mailbox' may not return should a timeout exception occur.
14;;
15;; - Uses ##sys#thread-unblock!
16;;
17;; - Has knowledge of Unit srfi-18 time object internals.
18;;
19;; - Uses the Chicken extensions 'thread-suspend' & 'thread-resume'.
20;;
21;; - The thread waiting on a mailbox cursor may miss items since only
22;; the end of the queue is available safely.
23;;
24;; - Probably should be rewritten to use a mutex & condition-variable rather than
25;; disabling interrupts and having own thread waiting queue.
26
27(module mailbox
28
29(;export
30  ;Mailbox Exception API
31  mailbox-timeout-condition? mailbox-timeout-exception?
32  ;Mailbox API
33  make-mailbox
34  mailbox?
35  mailbox-name
36  mailbox-empty?
37  mailbox-count
38  mailbox-waiting?
39  mailbox-waiters
40  mailbox-send!
41  mailbox-wait!
42  mailbox-receive!
43  mailbox-push-back!
44  mailbox-push-back-list!
45  ;Mailbox Cursor API
46  make-mailbox-cursor
47  mailbox-cursor?
48  mailbox-cursor-mailbox
49  mailbox-cursor-next
50  mailbox-cursor-rewind
51  mailbox-cursor-rewound?
52  mailbox-cursor-unwound?
53  mailbox-cursor-extract-and-rewind!)
54
55(import scheme)
56
57(import chicken)
58
59(import
60  (only ports with-output-to-port)
61  (only srfi-1 append! delete! list-copy last-pair)
62  (only srfi-18
63    current-thread
64    thread-signal! thread-sleep!
65    thread-suspend! thread-resume!
66    time?) )
67(require-library
68  ports
69  srfi-1 srfi-18)
70
71(import
72  (only type-errors define-error-type error-list)
73  (only condition-utils make-exn-condition+ make-condition-predicate)
74  record-variants )
75(require-library
76  type-errors condition-utils
77  record-variants)
78
79;yes, yes, not a module form
80(declare
81  (disable-interrupts) ;A MUST!
82  (always-bound ##sys#primordial-thread)
83  (bound-to-procedure
84    ##sys#signal-hook
85    ##sys#thread-unblock!) )
86
87;;; Primitives
88
89(include "chicken-primitive-object-inlines")
90(include "chicken-thread-object-inlines")
91(include "inline-type-checks")
92(include "inline-queue")
93
94(cond-expand
95  (unsafe-operations
96    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (%eq? ?arg0 ...))))
97    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (%null? ?arg0 ...))))
98    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (%list? ?arg0 ...))))
99    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (%length ?arg0 ...))))
100    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (%append! ?arg0 ...))))
101    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (%delq! ?arg0 ...))))
102    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (%cons ?arg0 ...))))
103    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (%car ?arg0 ...))))
104    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (%cdr ?arg0 ...))))
105    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (%set-car! ?arg0 ...))))
106    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (%set-cdr! ?arg0 ...))))
107    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (%list-copy ?arg0 ...))))
108    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (%last-pair ?arg0 ...))))
109    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (%current-thread ?arg0 ...))))
110    (define-syntax $thread-blocked? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked? ?arg0 ...))))
111    (define-syntax $thread-blocked-for-timeout? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked-for-timeout? ?arg0 ...)))) )
112  (else
113    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (eq? ?arg0 ...))))
114    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (null? ?arg0 ...))))
115    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (list? ?arg0 ...))))
116    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (length ?arg0 ...))))
117    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (append! ?arg0 ...))))
118    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (delete! ?arg0 ...))))
119    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (cons ?arg0 ...))))
120    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (car ?arg0 ...))))
121    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (cdr ?arg0 ...))))
122    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (set-car! ?arg0 ...))))
123    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (set-cdr! ?arg0 ...))))
124    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (list-copy ?arg0 ...))))
125    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (last-pair ?arg0 ...))))
126    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (current-thread ?arg0 ...))))
127    (define ($thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
128    (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11)))) ) )
129
130;;; Support
131
132(define-inline (->boolean obj)
133  (and obj #t) )
134
135;;; Mailbox Support
136
137;; Mailbox
138
139(define-record-type-variant mailbox (unsafe unchecked inline)
140  (%%make-mailbox nm qu wt)
141  %mailbox?
142  (nm %mailbox-name)
143  (qu %mailbox-queue)
144  (wt %mailbox-waiters %mailbox-waiters-set!) )
145
146(define-inline (%make-mailbox nm)
147  (%%make-mailbox nm (%make-queue) '()) )
148
149(define-error-type mailbox)
150(define-inline-check-type mailbox)
151
152;; Message queue
153
154(define-inline (%mailbox-queue-first-pair mb)
155        (%queue-first-pair (%mailbox-queue mb)) )
156
157(define-inline (%mailbox-queue-last-pair mb)
158        (%queue-last-pair (%mailbox-queue mb)) )
159
160(define-inline (%mailbox-queue-empty? mb)
161        (%queue-empty? (%mailbox-queue mb)) )
162
163(define-inline (%mailbox-queue-count mb)
164        (%queue-count (%mailbox-queue mb)) )
165
166(define-inline (%mailbox-queue-add! mb x)
167        (%queue-add! (%mailbox-queue mb) x) )
168
169(define-inline (%mailbox-queue-remove! mb)
170        (%queue-remove! (%mailbox-queue mb)) )
171
172(define-inline (%mailbox-queue-push-back! mb x)
173        (%queue-push-back! (%mailbox-queue mb) x) )
174
175(define-inline (%mailbox-queue-push-back-list! mb ls)
176        (%queue-push-back-list! (%mailbox-queue mb) ls) )
177
178;; Waiting threads
179
180(define-inline (%mailbox-waiters-empty? mb)
181  ($null? (%mailbox-waiters mb)) )
182
183(define-inline (%mailbox-waiters-count mb)
184  ($length (%mailbox-waiters mb)) )
185
186(define-inline (%mailbox-waiters-add! mb th)
187  (%mailbox-waiters-set! mb ($append! (%mailbox-waiters mb) ($cons th '()))) )
188
189(define-inline (%mailbox-waiters-delete! mb th)
190  (%mailbox-waiters-set! mb ($delq! th (%mailbox-waiters mb))) )
191
192(define-inline (%mailbox-waiters-pop! mb)
193  (let ((ts (%mailbox-waiters mb)))
194    (%mailbox-waiters-set! mb ($cdr ts))
195    ($car ts) ) )
196
197;;; Mailbox Cursor Support
198
199(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
200  (%%make-mailbox-cursor np pp mb)
201  %mailbox-cursor?
202  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
203  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
204  (mb %mailbox-cursor-mailbox) )
205
206(define-inline (%make-mailbox-cursor mb)
207  (%%make-mailbox-cursor '() #f mb) )
208
209(define-error-type mailbox-cursor)
210(define-inline-check-type mailbox-cursor)
211
212(define-inline (%mailbox-cursor-winding? mbc)
213  (->boolean (%mailbox-cursor-prev-pair mbc)) )
214
215(define-inline (%mailbox-cursor-next-pair-empty! mbc)
216  (%mailbox-cursor-next-pair-set! mbc '()) )
217
218(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
219  (%mailbox-cursor-prev-pair-set! mbc #f) )
220
221(define-inline (%mailbox-cursor-rewind! mbc)
222  (%mailbox-cursor-next-pair-empty! mbc)
223  (%mailbox-cursor-prev-pair-clear! mbc) )
224
225(define-inline (%mailbox-cursor-extract! mbc)
226  ;Unless 'mailbox-cursor-next' has been called don't remove
227  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
228    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
229
230;; Time Support
231
232(define-inline (%timeout? obj)
233  (or (number? obj) (time? obj)) )
234
235(define-error-type timeout)
236(define-inline-check-type timeout)
237
238;;;
239
240;Unique objects used as tags
241(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
242(define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
243(define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
244#; ;XXX
245(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
246
247;;; Mailbox Exceptions
248
249(define (make-mailbox-timeout-condition loc mb timout timout-value)
250  (let ((tv (if ($eq? timout-value NO-TOVAL-TAG) (void) timout-value)))
251    (make-exn-condition+
252      loc "mailbox wait timeout occurred" (list timout tv)
253      `(mailbox box ,mb)
254      `(timeout time ,timout value ,tv) ) ) )
255
256;;; Mailbox Threading
257
258;; Select next waiting thread for the mailbox
259
260(define (ready-mailbox-thread! mb)
261  ;Ready oldest waiting thread
262  (unless (%mailbox-waiters-empty? mb)
263    (let ((thread (%mailbox-waiters-pop! mb)))
264      ;Ready the thread based on wait mode
265      (if (not ($thread-blocked? thread))
266        (thread-resume! thread)
267        ;else wake early if sleeping
268        (when ($thread-blocked-for-timeout? thread)
269          ;Ready the thread
270          (##sys#thread-unblock! thread)
271          ;Tell 'wait-mailbox-thread!' we unblocked early
272          (thread-signal! thread UNBLOCKED-TAG) ) ) )
273    (void) ) )
274
275;; Sleep current thread until timeout, known condition,
276;; or some other condition
277
278(define (thread-sleep/maybe-unblock! tim unblocked-tag)
279  ;Sleep current thread for desired seconds, unless unblocked "early".
280  (call/cc
281    (lambda (return)
282      (with-exception-handler
283        (lambda (exp)
284          (if ($eq? unblocked-tag exp)
285            (return #f)
286            ;Propagate any "real" exception.
287            (signal exp) ) )
288        (lambda () (thread-sleep! tim) #t) ) ) ) )
289
290;; Wait current thread on the mailbox until timeout, available message
291;; or some other condition
292
293(define (wait-mailbox-thread! loc mb timout timout-value)
294  ;no available message due to timeout
295  (define (timeout-exit!)
296    (if (not ($eq? timout-value NO-TOVAL-TAG))
297      timout-value
298      (begin
299        (thread-signal!
300          ($current-thread)
301          (make-mailbox-timeout-condition loc mb timout timout-value))
302        SEQ-FAIL-TAG ) ) )
303  ;Push current thread on mailbox waiting queue
304  (%mailbox-waiters-add! mb ($current-thread))
305  ;Waiting action
306  (cond
307    ;Timeout wanted so sleep until something happens
308    (timout
309      (cond-expand
310        (sleep-primordial-thread
311          (cond
312            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
313              ;Timed-out, so no message
314              ;Remove from wait queue
315              (%mailbox-waiters-delete! mb ($current-thread))
316              ;Indicate no available message
317              (timeout-exit!) )
318            (else
319              ;Unblocked early
320              UNBLOCKED-TAG ) ) )
321        (else
322          (if (eq? ($current-thread) ##sys#primordial-thread)
323            (begin
324              (warning "mailbox attempt to sleep primordial-thread" mb)
325              (timeout-exit!) )
326            (cond
327              ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
328                ;Timed-out, so no message
329                ;Remove from wait queue
330                (%mailbox-waiters-delete! mb ($current-thread))
331                ;Indicate no available message
332                (timeout-exit!) )
333              (else
334                ;Unblocked early
335                UNBLOCKED-TAG ) ) ) ) ) )
336    ;No timeout so suspend until something delivered
337    (else
338      (thread-suspend! ($current-thread))
339      ;We're resumed
340      UNBLOCKED-TAG ) ) )
341
342;; Wait current thread on the mailbox unless a message available
343
344;Note that the arguments, except the ?expr0 ..., must be base values.
345(define-syntax on-mailbox-available
346  (syntax-rules ()
347    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
348      (let waiting ()
349        (cond
350          ((%mailbox-queue-empty? ?mb)
351            (let ((res (wait-mailbox-thread! ?loc ?mb ?timout ?timout-value)))
352              ;When a thread ready then check mailbox again, could be empty.
353              (if ($eq? UNBLOCKED-TAG res)
354                (waiting)
355                ;else some sort of problem
356                res ) ) )
357          (else
358            ?expr0 ... ) ) ) ) ) )
359
360#; ;XXX
361(define (wait-mailbox-if-empty! loc mb timout timout-value)
362  (on-mailbox-available loc mb timout timout-value
363    MESSAGE-WAITING-TAG ) )
364
365;;; Mailbox
366
367;; Mailbox Exceptions
368
369(define mailbox-timeout-condition? (make-condition-predicate exn mailbox timeout))
370
371;DEPRECATE
372(define mailbox-timeout-exception? mailbox-timeout-condition?)
373
374;; Mailbox Constructor
375
376(define (make-mailbox #!optional (nm (gensym 'mailbox)))
377  (%make-mailbox nm) )
378
379(define (mailbox? obj)
380  (%mailbox? obj) )
381
382;; Mailbox Properties
383
384(define (mailbox-name mb)
385  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
386
387(define (mailbox-empty? mb)
388  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
389
390(define (mailbox-count mb)
391  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
392
393(define (mailbox-waiting? mb)
394  (not
395    ($null?
396      (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
397
398(define (mailbox-waiters mb)
399  ($list-copy
400    (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
401
402;; Mailbox Operations
403
404(define (mailbox-send! mb x)
405  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
406  (ready-mailbox-thread! mb) )
407
408(define (mailbox-wait! mb #!optional timout)
409  (when timout (%check-timeout 'mailbox-wait! timout))
410  (on-mailbox-available 'mailbox-wait!
411    (%check-mailbox 'mailbox-wait! mb)
412    timout NO-TOVAL-TAG
413    (void) ) )
414
415(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
416  (when timout (%check-timeout 'mailbox-receive! timout))
417  (on-mailbox-available 'mailbox-receive!
418    (%check-mailbox 'mailbox-receive! mb)
419    timout timout-value
420    (%mailbox-queue-remove! mb) ) )
421
422(define (mailbox-push-back! mb x)
423  (%mailbox-queue-push-back!
424    (%check-mailbox 'mailbox-send! mb) x)
425  (ready-mailbox-thread! mb) )
426
427(define (mailbox-push-back-list! mb ls)
428  (%mailbox-queue-push-back-list!
429    (%check-mailbox 'mailbox-send! mb)
430    (%check-list ls 'mailbox-send!))
431  (ready-mailbox-thread! mb) )
432
433;;; Mailbox Cursor
434
435;; Mailbox Cursor Constructor
436
437(define (make-mailbox-cursor mb)
438  (%make-mailbox-cursor
439    (%check-mailbox 'make-mailbox-cursor mb)) )
440
441;; Mailbox Cursor Properties
442
443(define (mailbox-cursor? obj)
444  (%mailbox-cursor? obj) )
445
446(define (mailbox-cursor-mailbox mbc)
447  (%mailbox-cursor-mailbox
448    (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
449
450(define (mailbox-cursor-rewound? mbc)
451  (not
452    (%mailbox-cursor-winding?
453      (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
454
455(define (mailbox-cursor-unwound? mbc)
456  ($null?
457    (%mailbox-cursor-next-pair
458      (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
459
460;; Mailbox Cursor Operations
461
462(define (mailbox-cursor-rewind mbc)
463  (%mailbox-cursor-rewind!
464    (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
465
466#; ;XXX
467(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
468  (%check-mailbox-cursor 'mailbox-cursor-next mbc)
469  (when timout (%check-timeout 'mailbox-cursor-next timout))
470  ;Waiting mailbox peek.
471  (let ((mb (%mailbox-cursor-mailbox mbc)))
472    (receive (mailbox-waiter cursor-pair-getter)
473               (if (%mailbox-cursor-winding? mbc)
474                 ;then unconditionally wait until something added
475                 (values wait-mailbox-thread!
476                         (lambda () (%mailbox-queue-last-pair mb)))
477                 ;else grab the start of a, probably, non-empty queue
478                 (values wait-mailbox-if-empty!
479                         (lambda () (%mailbox-queue-first-pair mb))))
480      (let scanning ()
481        (let ((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 timout timout-value)))
491              (cond
492                ;continue scanning?
493                ((or ($eq? MESSAGE-WAITING-TAG res)
494                     ($eq? UNBLOCKED-TAG res))
495                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
496                  (scanning) )
497                ;otherwise timed-out
498                (else
499                  res ) ) ) ) ) ) ) ) )
500
501(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
502  (when timout (%check-timeout 'mailbox-cursor-next timout))
503  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
504    ;Seed rewound cursor
505    (unless (%mailbox-cursor-winding? mbc)
506      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
507    ;Pull next item from queue at cursor
508    (let scanning ()
509      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
510        ;Anything next?
511        (if (not ($null? curr-pair))
512          ;then peek into the queue for the next item
513          (let ((item ($car curr-pair)))
514            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
515            (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
516            item )
517          ;else wait for something in the mailbox
518          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
519            (cond
520              ;continue scanning?
521              (($eq? UNBLOCKED-TAG res)
522                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
523                (scanning) )
524              ;some problem (timeout maybe)
525              (else
526                res ) ) ) ) ) ) ) )
527
528(define (mailbox-cursor-extract-and-rewind! mbc)
529  (%mailbox-cursor-extract!
530    (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
531  (%mailbox-cursor-rewind! mbc) )
532
533;;; Read/Print Syntax
534
535(define-record-printer (mailbox mb out)
536  (with-output-to-port out
537    (lambda ()
538      (display "#<mailbox")
539      (display #\space) (display (%mailbox-name mb))
540      (display " queued = ") (display (%mailbox-queue-count mb))
541      (display " waiters = ") (display (%mailbox-waiters-count mb))
542      (display ">") ) ) )
543
544(define-record-printer (mailbox-cursor mbc out)
545  (with-output-to-port out
546    (lambda ()
547      (display "#<mailbox-cursor")
548      (display " mailbox = ") (display (%mailbox-name (%mailbox-cursor-mailbox mbc)))
549      (display " status = ") (display (if (%mailbox-cursor-winding? mbc) "winding" "rewound"))
550      (display ">") ) ) )
551
552) ;module mailbox
Note: See TracBrowser for help on using the repository browser.