source: project/release/5/mailbox/tags/3.0.1/mailbox.scm @ 36201

Last change on this file since 36201 was 36201, checked in by Kon Lovett, 14 months ago

C5 so explicit time-number (fix+float only), rel 3.0.1

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