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

Last change on this file since 34362 was 34362, checked in by Kon Lovett, 3 years ago

rel 2.2.2

File size: 18.1 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
310        ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
311          ;Timed-out, so no message
312          ;Remove from wait queue
313          (%mailbox-waiters-delete! mb ($current-thread))
314          ;Indicate no available message
315          (timeout-exit!) )
316        (else
317          ;Unblocked early
318          UNBLOCKED-TAG ) )
319      #; ;NOT YET
320      (if (eq? ($current-thread) ##sys#primordial-thread)
321        (begin
322          (warning "mailbox attempt to sleep primordial-thread" mb)
323          (timeout-exit!) )
324        (cond
325          ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
326            ;Timed-out, so no message
327            ;Remove from wait queue
328            (%mailbox-waiters-delete! mb ($current-thread))
329            ;Indicate no available message
330            (timeout-exit!) )
331          (else
332            ;Unblocked early
333            UNBLOCKED-TAG ) ) ) )
334    ;No timeout so suspend until something delivered
335    (else
336      (thread-suspend! ($current-thread))
337      ;We're resumed
338      UNBLOCKED-TAG ) ) )
339
340;; Wait current thread on the mailbox unless a message available
341
342;Note that the arguments, except the ?expr0 ..., must be base values.
343(define-syntax on-mailbox-available
344  (syntax-rules ()
345    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
346      (let waiting ()
347        (cond
348          ((%mailbox-queue-empty? ?mb)
349            (let ((res (wait-mailbox-thread! ?loc ?mb ?timout ?timout-value)))
350              ;When a thread ready then check mailbox again, could be empty.
351              (if ($eq? UNBLOCKED-TAG res)
352                (waiting)
353                ;else some sort of problem
354                res ) ) )
355          (else
356            ?expr0 ... ) ) ) ) ) )
357
358#; ;XXX
359(define (wait-mailbox-if-empty! loc mb timout timout-value)
360  (on-mailbox-available loc mb timout timout-value
361    MESSAGE-WAITING-TAG ) )
362
363;;; Mailbox
364
365;; Mailbox Exceptions
366
367(define mailbox-timeout-condition? (make-condition-predicate exn mailbox timeout))
368
369;DEPRECATE
370(define mailbox-timeout-exception? mailbox-timeout-condition?)
371
372;; Mailbox Constructor
373
374(define (make-mailbox #!optional (nm (gensym 'mailbox)))
375  (%make-mailbox nm) )
376
377(define (mailbox? obj)
378  (%mailbox? obj) )
379
380;; Mailbox Properties
381
382(define (mailbox-name mb)
383  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
384
385(define (mailbox-empty? mb)
386  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
387
388(define (mailbox-count mb)
389  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
390
391(define (mailbox-waiting? mb)
392  (not
393    ($null?
394      (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
395
396(define (mailbox-waiters mb)
397  ($list-copy
398    (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
399
400;; Mailbox Operations
401
402(define (mailbox-send! mb x)
403  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
404  (ready-mailbox-thread! mb) )
405
406(define (mailbox-wait! mb #!optional timout)
407  (when timout (%check-timeout 'mailbox-wait! timout))
408  (on-mailbox-available 'mailbox-wait!
409    (%check-mailbox 'mailbox-wait! mb)
410    timout NO-TOVAL-TAG
411    (void) ) )
412
413(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
414  (when timout (%check-timeout 'mailbox-receive! timout))
415  (on-mailbox-available 'mailbox-receive!
416    (%check-mailbox 'mailbox-receive! mb)
417    timout timout-value
418    (%mailbox-queue-remove! mb) ) )
419
420(define (mailbox-push-back! mb x)
421  (%mailbox-queue-push-back!
422    (%check-mailbox 'mailbox-send! mb) x)
423  (ready-mailbox-thread! mb) )
424
425(define (mailbox-push-back-list! mb ls)
426  (%mailbox-queue-push-back-list!
427    (%check-mailbox 'mailbox-send! mb)
428    (%check-list ls 'mailbox-send!))
429  (ready-mailbox-thread! mb) )
430
431;;; Mailbox Cursor
432
433;; Mailbox Cursor Constructor
434
435(define (make-mailbox-cursor mb)
436  (%make-mailbox-cursor
437    (%check-mailbox 'make-mailbox-cursor mb)) )
438
439;; Mailbox Cursor Properties
440
441(define (mailbox-cursor? obj)
442  (%mailbox-cursor? obj) )
443
444(define (mailbox-cursor-mailbox mbc)
445  (%mailbox-cursor-mailbox
446    (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
447
448(define (mailbox-cursor-rewound? mbc)
449  (not
450    (%mailbox-cursor-winding?
451      (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
452
453(define (mailbox-cursor-unwound? mbc)
454  ($null?
455    (%mailbox-cursor-next-pair
456      (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
457
458;; Mailbox Cursor Operations
459
460(define (mailbox-cursor-rewind mbc)
461  (%mailbox-cursor-rewind!
462    (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
463
464#; ;XXX
465(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
466  (%check-mailbox-cursor 'mailbox-cursor-next mbc)
467  (when timout (%check-timeout 'mailbox-cursor-next timout))
468  ;Waiting mailbox peek.
469  (let ((mb (%mailbox-cursor-mailbox mbc)))
470    (receive (mailbox-waiter cursor-pair-getter)
471               (if (%mailbox-cursor-winding? mbc)
472                 ;then unconditionally wait until something added
473                 (values wait-mailbox-thread!
474                         (lambda () (%mailbox-queue-last-pair mb)))
475                 ;else grab the start of a, probably, non-empty queue
476                 (values wait-mailbox-if-empty!
477                         (lambda () (%mailbox-queue-first-pair mb))))
478      (let scanning ()
479        (let ((next-pair (%mailbox-cursor-next-pair mbc)))
480          ;Anything next?
481          (if (not (%null? next-pair))
482            ;then peek into the queue for the next item
483            (let ((item (%car next-pair)))
484              (%mailbox-cursor-prev-pair-set! mbc next-pair)
485              (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
486              item )
487            ;else wait for something in the mailbox
488            (let ((res (mailbox-waiter 'mailbox-cursor-next mb timout timout-value)))
489              (cond
490                ;continue scanning?
491                ((or ($eq? MESSAGE-WAITING-TAG res)
492                     ($eq? UNBLOCKED-TAG res))
493                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
494                  (scanning) )
495                ;otherwise timed-out
496                (else
497                  res ) ) ) ) ) ) ) ) )
498
499(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
500  (when timout (%check-timeout 'mailbox-cursor-next timout))
501  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
502    ;Seed rewound cursor
503    (unless (%mailbox-cursor-winding? mbc)
504      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
505    ;Pull next item from queue at cursor
506    (let scanning ()
507      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
508        ;Anything next?
509        (if (not ($null? curr-pair))
510          ;then peek into the queue for the next item
511          (let ((item ($car curr-pair)))
512            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
513            (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
514            item )
515          ;else wait for something in the mailbox
516          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
517            (cond
518              ;continue scanning?
519              (($eq? UNBLOCKED-TAG res)
520                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
521                (scanning) )
522              ;some problem (timeout maybe)
523              (else
524                res ) ) ) ) ) ) ) )
525
526(define (mailbox-cursor-extract-and-rewind! mbc)
527  (%mailbox-cursor-extract!
528    (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
529  (%mailbox-cursor-rewind! mbc) )
530
531;;; Read/Print Syntax
532
533(define-record-printer (mailbox mb out)
534  (with-output-to-port out
535    (lambda ()
536      (display "#<mailbox")
537      (display #\space) (display (%mailbox-name mb))
538      (display " queued = ") (display (%mailbox-queue-count mb))
539      (display " waiters = ") (display (%mailbox-waiters-count mb))
540      (display ">") ) ) )
541
542(define-record-printer (mailbox-cursor mbc out)
543  (with-output-to-port out
544    (lambda ()
545      (display "#<mailbox-cursor")
546      (display " mailbox = ") (display (%mailbox-name (%mailbox-cursor-mailbox mbc)))
547      (display " status = ") (display (if (%mailbox-cursor-winding? mbc) "winding" "rewound"))
548      (display ">") ) ) )
549
550) ;module mailbox
Note: See TracBrowser for help on using the repository browser.