source: project/release/5/mailbox/trunk/mailbox.scm @ 39700

Last change on this file since 39700 was 39700, checked in by Kon Lovett, 8 weeks ago

new test runner, remove "primitives", stop variant `check-' proc gen, fix record printers

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