Changeset 39734 in project


Ignore:
Timestamp:
03/18/21 02:54:06 (3 months ago)
Author:
Kon Lovett
Message:

use unlimited queue for waiters, add read waiters

Location:
release/5/mailbox/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/5/mailbox/trunk/inline-queue.scm

    r39733 r39734  
    55;;
    66;; - Uses (chicken fixnum) & (only record-variants define-record-type-variant)
    7 
    8 (define-inline (fxneg? n) (fx< n 0))
    9 (define-inline (fxabs n) (if (fxneg? n) (fxneg n) n))
    107
    118;; Queue Unlimited
     
    3532(define-inline (%queue-unlimited-count-sub! q n)
    3633  (%queue-unlimited-count-set! q (fx- (%queue-unlimited-count q) n)) )
     34
     35(define-inline (%queue-unlimited-empty? q #!optional (n 0))
     36  (fx<= (fx- (%queue-unlimited-count q) n) 0) )
     37
     38(define-inline (%queue-unlimited-full? q #!optional (n 0))
     39  #f )
    3740
    3841(define-inline (%queue-unlimited-extract-pair! q targ-pair)
     
    134137    (%queue-unlimited-extract-pair! q prev-pair) ) )
    135138
     139(define-inline (%queue-unlimited-delete! q x)
     140  (let ((c (%make-queue-unlimited-cursor)))
     141    (%queue-unlimited-cursor-start! q c)
     142    (let loop ()
     143      (let ((y (%queue-unlimited-cursor-next! q c)))
     144        (cond
     145          ((eof-object? y)
     146            #f )
     147          ((eq? x y)
     148            (%queue-unlimited-cursor-extract! q c)
     149            #t )
     150          (else
     151            (loop) ) ) ) ) ) )
     152
     153(define-inline (%queue-unlimited->list q)
     154  (let ((c (%make-queue-unlimited-cursor)))
     155    (%queue-unlimited-cursor-start! q c)
     156    (let loop ((ls '()))
     157      (let ((y (%queue-unlimited-cursor-next! q c)))
     158        (cond
     159          ((eof-object? y)
     160            ls )
     161          (else
     162            (loop (cons y ls)) ) ) ) ) ) )
     163
    136164;; Queue Limited
    137165
     
    187215(define-inline (%queue-limited-count-set! q v)
    188216  (error '%queue-limited-count-set! "immutable" v) )
     217
     218(define-inline (%queue-limited-empty? q #!optional (n 0))
     219  (fx<= (fx- (%queue-limited-count q) n) 0) )
     220
     221(define-inline (%queue-limited-full? q #!optional (n 0))
     222  (fx>= (fx+ (%queue-limited-count q) n) (%queue-limited-limit q)) )
    189223
    190224(define-inline (%queue-limited-room q)
     
    290324  (error '%queue-unbuffered-count-set! "immutable" v) )
    291325
     326(define-inline (%queue-unbuffered-empty? q #!optional (n 0))
     327  (or (fx< 0 n)
     328      (not (%queue-unbuffered-maybe? q))) )
     329
     330(define-inline (%queue-unbuffered-full? q #!optional (n 0))
     331  (or (fx< 0 n)
     332      (%queue-unbuffered-maybe? q)) )
     333
    292334(define-inline (%queue-unbuffered-room q)
    293335  (if (%queue-unbuffered-maybe? q) 0 1) )
     
    393435
    394436(define-inline (%queue-empty? q #!optional (n 0))
    395   (fx<= (fx- (%queue-count q) n) 0) )
     437  (cond
     438    ((%queue-unlimited? q)  (%queue-unlimited-empty? q))
     439    ((%queue-limited? q)    (%queue-limited-empty? q))
     440    (else                   (%queue-unbuffered-empty? q)) ) )
    396441
    397442(define-inline (%queue-full? q #!optional (n 0))
    398   (fx>= (fx+ (%queue-count q) n) (%queue-limit q)) )
     443  (cond
     444    ((%queue-unlimited? q)  (%queue-unlimited-full? q))
     445    ((%queue-limited? q)    (%queue-limited-full? q))
     446    (else                   (%queue-unbuffered-full? q)) ) )
    399447
    400448(define (queue-empty-error loc q) (error loc "queue empty" q))
     
    525573    ((%queue-limited? q)    (%queue-limited-cursor-extract! q c))
    526574    (else                   (%queue-unbuffered-cursor-extract! q c)) ) )
     575
     576(define-inline (%queue-delete! q x)
     577  (cond
     578    ((%queue-unlimited? q)  (%queue-unlimited-delete! q x))
     579    (else
     580      (let ((c (%make-queue-cursor)))
     581        (%queue-cursor-start! q c)
     582        (let loop ()
     583          (let ((y (%queue-cursor-next! q c)))
     584            (cond
     585              ((eof-object? y)
     586                #f )
     587              ((eq? x y)
     588                (%queue-cursor-extract! q c)
     589                #t )
     590              (else
     591                (loop) ) ) ) ) ) ) ) )
     592
     593(define-inline (%queue->list q)
     594  (cond
     595    ((%queue-unlimited? q)  (%queue-unlimited->list q))
     596    (else
     597      (let ((c (%make-queue-cursor)))
     598        (%queue-cursor-start! q c)
     599        (let loop ((ls '()))
     600          (let ((y (%queue-cursor-next! q c)))
     601            (cond
     602              ((eof-object? y)
     603                (reverse! ls) )
     604              (else
     605                (loop (cons y ls)) ) ) ) ) ) ) ) )
  • release/5/mailbox/trunk/mailbox.scm

    r39724 r39734  
    4444  mailbox-name
    4545  mailbox-empty?
     46  mailbox-full?
    4647  mailbox-count
    4748  mailbox-limit
    4849  mailbox-waiting?
    49   mailbox-waiters
     50  mailbox-read-waiters
     51  mailbox-write-waiters
    5052  mailbox-send!
    5153  mailbox-wait!
     
    6163  mailbox-cursor-rewound?
    6264  mailbox-cursor-unwound?
    63   mailbox-cursor-extract-and-rewind!)
     65  mailbox-cursor-extract-and-rewind!
     66  ;deprecated
     67  mailbox-waiters)
    6468
    6569(import scheme
     
    7276  (only (chicken format) printf)
    7377  (only (chicken string) ->string)
    74   (only (srfi 1) append! delete! list-copy last-pair)
     78  (only (srfi 1) append! reverse! list-copy last-pair)
    7579  (only (srfi 18)
    7680    time? current-thread thread-signal! thread-sleep! thread-suspend! thread-resume!))
     
    96100(: mailbox-name                       (mailbox --> *))
    97101(: mailbox-empty?                     (mailbox -> boolean))
     102(: mailbox-full?                      (mailbox -> boolean))
    98103(: mailbox-count                      (mailbox -> fixnum))
    99 (: mailbox-limit                      (mailbox -> fixnum))
     104(: mailbox-limit                      (mailbox --> fixnum))
    100105(: mailbox-waiting?                   (mailbox -> boolean))
    101 (: mailbox-waiters                    (mailbox -> list))
     106(: mailbox-read-waiters               (mailbox -> list))
     107(: mailbox-write-waiters              (mailbox -> list))
     108(: mailbox-waiters                    (deprecated mailbox-write-waiters))
    102109
    103110(: mailbox-send!                      (mailbox * -> void))
     
    213220        (lambda (k) e0 e1 ...)))))
    214221
     222;;fx-utils
     223
     224(define-inline (fxneg? n) (fx< n 0))
     225(define-inline (fxabs n) (if (fxneg? n) (fxneg n) n))
     226
    215227;;(only type-errors define-error-type)
    216228
     
    264276(define mailbox 'mailbox)
    265277(define-record-type-variant mailbox (unsafe unchecked inline)
    266   (%raw-make-mailbox nm qu wt)
     278  (%raw-make-mailbox nm qu rd wt)
    267279  (%mailbox?)
    268280  (nm %mailbox-name)
    269281  (qu %mailbox-queue)
    270   (wt %mailbox-waiters %mailbox-waiters-set!) )
     282  (wt %mailbox-read-waiters)
     283  (wt %mailbox-write-waiters) )
    271284
    272285(define-inline (%make-mailbox loc nm lm)
    273286  (unless (%valid-queue-limit? lm)
    274287    (error loc "invalid limit" lm nm) )
    275   (%raw-make-mailbox nm (%make-empty-queue lm) '()) )
     288  (%raw-make-mailbox nm
     289    (%make-empty-queue lm)
     290    (%make-empty-queue-unlimited)
     291    (%make-empty-queue-unlimited)) )
    276292
    277293(define (error-mailbox loc obj #!optional argnam)
     
    285301  (%queue-empty? (%mailbox-queue mb)) )
    286302
     303(define-inline (%mailbox-queue-full? mb)
     304  (%queue-full? (%mailbox-queue mb)) )
     305
    287306(define-inline (%mailbox-queue-count mb)
    288307  (%queue-count (%mailbox-queue mb)) )
     
    305324;; Waiting threads
    306325
    307 (define-inline (%mailbox-waiters-empty? mb)
    308   (null? (%mailbox-waiters mb)) )
    309 
    310 (define-inline (%mailbox-waiters-count mb)
    311   (length (%mailbox-waiters mb)) )
    312 
    313 (define-inline (%mailbox-waiters-add! mb th)
    314   (%mailbox-waiters-set! mb (append! (%mailbox-waiters mb) (cons th '()))) )
    315 
    316 (define-inline (%mailbox-waiters-delete! mb th)
    317   (%mailbox-waiters-set! mb (delete! th (%mailbox-waiters mb))) )
    318 
    319 (define-inline (%mailbox-waiters-pop! mb)
    320   (let ((ts (%mailbox-waiters mb)))
    321     (%mailbox-waiters-set! mb (cdr ts))
    322     (car ts) ) )
     326;read
     327
     328(define-inline (%mailbox-read-waiters-empty? mb)
     329  (%queue-unlimited-empty? (%mailbox-read-waiters mb)) )
     330
     331(define-inline (%mailbox-read-waiters-full? mb)
     332  (%queue-unlimited-full? (%mailbox-read-waiters mb)) )
     333
     334(define-inline (%mailbox-read-waiters-count mb)
     335 (%queue-unlimited-count (%mailbox-read-waiters mb)) )
     336
     337(define-inline (%mailbox-read-waiters-add! mb th)
     338  (%queue-unlimited-add! (%mailbox-read-waiters mb) th) )
     339
     340(define-inline (%mailbox-read-waiters-delete! mb th)
     341  (%queue-unlimited-delete! (%mailbox-read-waiters mb) th) )
     342
     343(define-inline (%mailbox-read-waiters-pop! mb)
     344  (%queue-unlimited-remove! (%mailbox-read-waiters mb)) )
     345
     346(define (%mailbox-read-waiters->list mb)
     347  (%queue-unlimited->list (%mailbox-read-waiters mb)) )
     348
     349;write
     350
     351(define-inline (%mailbox-write-waiters-empty? mb)
     352  (%queue-unlimited-empty? (%mailbox-write-waiters mb)) )
     353
     354(define-inline (%mailbox-write-waiters-count mb)
     355 (%queue-unlimited-count (%mailbox-write-waiters mb)) )
     356
     357(define-inline (%mailbox-write-waiters-add! mb th)
     358  (%queue-unlimited-add! (%mailbox-write-waiters mb) th) )
     359
     360(define-inline (%mailbox-write-waiters-delete! mb th)
     361  (%queue-unlimited-delete! (%mailbox-write-waiters mb) th) )
     362
     363(define-inline (%mailbox-write-waiters-pop! mb)
     364  (%queue-unlimited-remove! (%mailbox-write-waiters mb)) )
     365
     366(define (%mailbox-write-waiters->list mb)
     367  (%queue-unlimited->list (%mailbox-write-waiters mb)) )
    323368
    324369;;; Mailbox Cursor Support
     
    335380  (%raw-make-mailbox-cursor mb (%make-queue-cursor (%mailbox-queue mb))) )
    336381
    337 (define (error-mailbox-cursor loc obj #!optional argnam)
    338   (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor argnam) obj) )
     382(define (error-mailbox-cursor loc obj #!optional nam)
     383  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor nam) obj))
    339384
    340385(define-inline-check-type mailbox-cursor)
    341386
     387(define-inline (%mailbox-cursor-queue mbc) (%mailbox-queue (%mailbox-cursor-mailbox mbc)))
     388
    342389(define-inline (%mailbox-cursor-winding? mbc)
    343   (%queue-cursor-winding?
    344     (%mailbox-queue (%mailbox-cursor-mailbox mbc))
    345     (%mailbox-cursor-state mbc)) )
     390  (%queue-cursor-winding? (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
    346391
    347392(define-inline (%mailbox-cursor-unwound? mbc)
    348   (%queue-cursor-unwound?
    349     (%mailbox-queue (%mailbox-cursor-mailbox mbc))
    350     (%mailbox-cursor-state mbc)) )
     393  (%queue-cursor-unwound? (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
    351394
    352395(define-inline (%mailbox-cursor-rewind! mbc)
    353   (%queue-cursor-rewind!
    354     (%mailbox-queue (%mailbox-cursor-mailbox mbc))
    355     (%mailbox-cursor-state mbc)) )
     396  (%queue-cursor-rewind! (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
    356397
    357398(define-inline (%mailbox-cursor-extract! mbc)
    358   (%queue-cursor-extract!
    359     (%mailbox-queue (%mailbox-cursor-mailbox mbc))
    360     (%mailbox-cursor-state mbc)) )
     399  (%queue-cursor-extract! (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
    361400
    362401;;;
     
    371410;;; Mailbox Exceptions
    372411
    373 (define-inline (optional-timeout-value x #!optional (def (void)))
     412(define-inline (%optional-timeout-value x #!optional (def (void)))
    374413  (if (eq? x NO-TOVAL-TAG) def x) )
    375414
    376415(define (make-mailbox-timeout-condition loc mb timout timout-value)
    377   (let ((tv (optional-timeout-value timout-value)))
     416  (let ((tv (%optional-timeout-value timout-value)))
    378417    (make-composite-condition
    379418      (make-property-condition 'exn
     
    386425;;; Mailbox Threading
    387426
    388 ;; Select next waiting thread for the mailbox
    389 
    390 (define-inline (%mailbox-waiters-pop!? mb)
    391   (and (not (%mailbox-waiters-empty? mb)) (%mailbox-waiters-pop! mb)) )
    392 
    393 (define (ready-mailbox-thread! mb)
    394   ;ready oldest waiting thread
    395   (and-let* ((th (%mailbox-waiters-pop!? mb)))
    396     ;ready the thread based on wait mode
    397     (if (not (%thread-blocked? th))
    398       ;then restart
    399       (thread-resume! th)
    400       ;else wake early if sleeping
    401       ;all others dropped on the floor
    402       (when (%thread-blocked-for-timeout? th)
    403         ;ready the thread
    404         (##sys#thread-unblock! th)
    405         ;tell 'wait-mailbox-thread!' we unblocked early
    406         (thread-signal! th UNBLOCKED-TAG) ) ) )
    407     (void) )
     427;; Activate thread (for some mailbox)
     428
     429(define (restart-thread! th)
     430  ;
     431  (if (not (%thread-blocked? th))
     432    ;then restart
     433    (thread-resume! th)
     434    ;else wake early if sleeping
     435    ;all others dropped on the floor
     436    (when (%thread-blocked-for-timeout? th)
     437      ;ready the thread
     438      (##sys#thread-unblock! th)
     439      ;tell 'wait-mailbox-thread!' we unblocked early
     440      (thread-signal! th UNBLOCKED-TAG) ) )
     441  ;ensure void return
     442  (void) )
    408443
    409444;; Sleep current thread until timeout, known condition,
    410445;; or some other condition
    411446
    412 (define (thread-sleep/maybe-unblock! tim unblocked-tag)
     447(define (thread-sleep/unblock! tim unblocked-tag)
    413448;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
    414449  ;sleep current thread for desired seconds, unless unblocked "early".
     
    421456          (signal exp) ) )
    422457      (lambda ()
    423         (thread-sleep! tim) #t) ) ) )
     458        (thread-sleep! tim)
     459        #t) ) ) )
     460
     461;; Select next waiting thread for the mailbox
     462
     463(define (ready-mailbox-writer! mb)
     464  ;ready oldest waiting thread
     465  (unless (%mailbox-read-waiters-empty? mb)
     466    (restart-thread! (%mailbox-read-waiters-pop! mb)))
     467  (void) )
     468
     469(define (ready-mailbox-reader! mb)
     470  ;ready oldest waiting thread
     471  (unless (%mailbox-write-waiters-empty? mb)
     472    (restart-thread! (%mailbox-write-waiters-pop! mb)))
     473  (void) )
    424474
    425475;; Wait current thread on the mailbox until timeout, available message
    426476;; or some other condition
    427477
    428 (define (wait-mailbox-thread! loc mb timout timout-value)
     478(define (wait-mailbox-thread! loc mb wq timout timout-value)
    429479  ;
    430480  ;no available message due to timeout
     
    439489  ;
    440490  ;push current thread on mailbox waiting queue
    441   (%mailbox-waiters-add! mb (current-thread))
     491  (%queue-unlimited-add! wq (current-thread))
    442492  ;waiting action
    443493  (cond
     
    448498          ;
    449499          (cond
    450             ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
     500            ((thread-sleep/unblock! timout UNBLOCKED-TAG)
    451501              ;timed-out, so no message
    452502              ;remove from wait queue
    453               (%mailbox-waiters-delete! mb (current-thread))
     503              (%queue-unlimited-delete! wq (current-thread))
    454504              ;indicate no available message
    455505              (timeout-exit!) )
     
    461511          (if (eq? (current-thread) ##sys#primordial-thread)
    462512            (begin
    463               (%mailbox-waiters-delete! mb (current-thread))
     513              (%queue-unlimited-delete! wq (current-thread))
    464514              (warning "mailbox attempt to sleep primordial-thread" mb)
    465515              (timeout-exit!) )
    466516            (cond
    467               ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
     517              ((thread-sleep/unblock! timout UNBLOCKED-TAG)
    468518                ;timed-out, so no message
    469519                ;remove from wait queue
    470                 (%mailbox-waiters-delete! mb (current-thread))
     520                (%queue-unlimited-delete! wq (current-thread))
    471521                ;indicate no available message
    472522                (timeout-exit!) )
     
    483533
    484534;Note that the arguments, except the ?expr0 ..., must be base values.
    485 (define-syntax on-mailbox-available
     535
     536(define-syntax wait-mailbox-read!
    486537  (syntax-rules ()
    487     ((on-mailbox-available ?loc ?mb ?timout ?timout-value ?expr0 ...)
     538    ((wait-mailbox-read! ?loc ?mb ?timout ?timout-value ?expr0 ?expr1 ...)
    488539      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
    489         (let waiting ()
    490           (cond
    491             ((%mailbox-queue-empty? _mb)
    492               (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
    493                 ;when a thread ready then check mailbox again, could be empty.
    494                 (if (eq? UNBLOCKED-TAG res)
    495                   (waiting)
    496                   ;else some sort of problem
    497                   res ) ) )
    498             (else
    499               ?expr0 ... ) ) ) ) ) ) )
     540        (let ((wq (%mailbox-read-waiters _mb)))
     541          (let waiting ()
     542            (cond
     543              ((%mailbox-queue-full? _mb)
     544                (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
     545                  ;when a thread ready then check mailbox again, could be empty.
     546                  (if (eq? UNBLOCKED-TAG res)
     547                    (waiting)
     548                    ;else some sort of problem
     549                    res ) ) )
     550              (else
     551                ?expr0 ?expr1 ... ) ) ) ) ) ) ) )
     552
     553(define-syntax wait-mailbox-write!
     554  (syntax-rules ()
     555    ((wait-mailbox-write! ?loc ?mb ?timout ?timout-value ?expr0 ?expr1 ...)
     556      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
     557        (let ((wq (%mailbox-write-waiters _mb)))
     558          (let waiting ()
     559            (cond
     560              ((%mailbox-queue-empty? _mb)
     561                (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
     562                  ;when a thread ready then check mailbox again, could be empty.
     563                  (if (eq? UNBLOCKED-TAG res)
     564                    (waiting)
     565                    ;else some sort of problem
     566                    res ) ) )
     567              (else
     568                ?expr0 ?expr1 ... ) ) ) ) ) ) ) )
    500569
    501570#; ;XXX
    502571(define (wait-mailbox-if-empty! loc mb timout timout-value)
    503   (on-mailbox-available loc mb timout timout-value
     572  (wait-mailbox-write! loc mb timout timout-value
    504573    MESSAGE-WAITING-TAG ) )
    505574
     
    539608  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
    540609
     610(define (mailbox-full? mb)
     611  (%mailbox-queue-full? (%check-mailbox 'mailbox-empty? mb)) )
     612
    541613(define (mailbox-count mb)
    542614  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
     
    546618
    547619(define (mailbox-waiting? mb)
    548   (not (null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
    549 
    550 (define (mailbox-waiters mb)
    551   (list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
     620  (not (%mailbox-write-waiters-empty? (%check-mailbox 'mailbox-waiting? mb))) )
     621
     622(define (mailbox-write-waiters mb)
     623  (%mailbox-write-waiters->list (%check-mailbox 'mailbox-write-waiters mb)) )
     624
     625(define (mailbox-read-waiters mb)
     626  (%mailbox-read-waiters->list (%check-mailbox 'mailbox-read-waiters mb)) )
     627
     628(define mailbox-waiters mailbox-write-waiters)
    552629
    553630;; Mailbox Operations
     
    555632(define (mailbox-send! mb x)
    556633  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
    557   (ready-mailbox-thread! mb) )
     634  (ready-mailbox-reader! mb) )
    558635
    559636(define (mailbox-wait! mb #!optional timout)
    560637  (when timout (%check-timeout 'mailbox-wait! timout))
    561   (on-mailbox-available 'mailbox-wait!
    562     (%check-mailbox 'mailbox-wait! mb)
    563     timout NO-TOVAL-TAG
     638  (wait-mailbox-write! 'mailbox-wait!
     639    ;wait until
     640    (%check-mailbox 'mailbox-wait! mb) timout NO-TOVAL-TAG
     641    ;then
    564642    (void) ) )
    565643
    566644(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
    567645  (when timout (%check-timeout 'mailbox-receive! timout))
    568   (on-mailbox-available 'mailbox-receive!
    569     (%check-mailbox 'mailbox-receive! mb)
    570     timout timout-value
     646  (wait-mailbox-write! 'mailbox-receive!
     647    ;wait until
     648    (%check-mailbox 'mailbox-receive! mb) timout timout-value
     649    ;then
    571650    (%mailbox-queue-remove! mb) ) )
    572651
    573652(define (mailbox-push-back! mb x)
    574653  (%mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
    575   (ready-mailbox-thread! mb) )
     654  (ready-mailbox-reader! mb) )
    576655
    577656(define (mailbox-push-back-list! mb ls)
     
    579658    (%check-mailbox 'mailbox-send! mb)
    580659    (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
    581   (ready-mailbox-thread! mb) )
     660  (ready-mailbox-reader! mb) )
    582661
    583662;; Read/Print Syntax
     
    586665  (with-output-to-port out
    587666    (lambda ()
    588       (printf "#<mailbox ~A queued: ~A waiters: ~A limit: ~A>"
     667      (printf "#<mailbox ~S limit: ~A queued: ~A waiters: ~A/~A>"
    589668        (%mailbox-name mb)
     669        (%mailbox-queue-limit mb)
    590670        (%mailbox-queue-count mb)
    591         (%mailbox-waiters-count mb)
    592         (%mailbox-queue-limit mb)) ) ) )
     671        (%mailbox-read-waiters-count mb)
     672        (%mailbox-write-waiters-count mb)) ) ) )
    593673
    594674;;; Mailbox Cursor
     
    624704  (let* (
    625705    (mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc)))
    626     (q (%mailbox-queue mb))
    627     (c (%mailbox-cursor-state mbc)) )
     706    (mq (%mailbox-queue mb))
     707    (mc (%mailbox-cursor-state mbc)) )
    628708    ;seed rewound cursor
    629     (unless (%queue-cursor-winding? q c)
    630       (%queue-cursor-start! q c) )
     709    (unless (%queue-cursor-winding? mq mc)
     710      (%queue-cursor-start! mq mc) )
    631711    ;pull next item from queue at cursor
    632712    (let scanning ()
    633       (let ((item (%queue-cursor-next! q c)))
     713      (let ((item (%queue-cursor-next! mq mc)))
    634714        ;anything next?
    635715        (if (not (eof-object? item))
     
    637717          item
    638718          ;else wait for something in the mailbox
    639           (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
     719          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb
     720                      (%mailbox-write-waiters mb) timout timout-value)))
    640721            (cond
    641722              ;continue scanning?
    642723              ((eq? UNBLOCKED-TAG res)
    643                 (%queue-cursor-continue! q c)
     724                (%queue-cursor-continue! mq mc)
    644725                (scanning) )
    645726              ;some problem (timeout maybe)
Note: See TracChangeset for help on using the changeset viewer.