Changeset 13529 in project


Ignore:
Timestamp:
03/06/09 06:55:33 (11 years ago)
Author:
Kon Lovett
Message:

Bug fix for specific msg waiting tag usage,

Location:
release/4/mailbox
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/mailbox/tags/2.0.0/mailbox.scm

    r13510 r13529  
    44;; Issues
    55;;
    6 ;; - Depends on "library.scm" declaring '(disable-interrupts)'.
     6;; - All operations inlined & primitive due to high-performance nature of IPC.
    77;;
    88;; - Uses ##sys#current-thread & ##sys#thread-unblock!
    9 ;;
    10 ;; - Note use of 'undefined-value' to signal an empty mailbox.
    119
    1210(declare
     
    5957  (%null? (%queue-first-pair q)) )
    6058
    61 (define-inline (%queue-size q)
     59(define-inline (%queue-count q)
    6260  (%length (%queue-first-pair q)) )
     61
     62;; Queue Operations
     63
     64(define-inline (%queue-add! q datum)
     65  (let ([new-pair (%cons datum '())])
     66    (if (%null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
     67        (%set-cdr! (%queue-last-pair q) new-pair) )
     68    (%queue-last-pair-set! q new-pair) ) )
     69
     70(define-inline (%queue-remove! q)
     71  (let* ([first-pair (%queue-first-pair q)]
     72         [next-pair (%cdr first-pair)])
     73    (%queue-first-pair-set! q next-pair)
     74    (when (%null? next-pair) (%queue-last-pair-empty! q) )
     75    (%car first-pair) ) )
     76
     77(define-inline (%queue-push-back! q item)
     78  (let ([newlist (%cons item (%queue-first-pair q))])
     79    (%queue-first-pair-set! q newlist)
     80    (when (%null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
     81
     82(define-inline (%queue-push-back-list! q itemlist)
     83  (let ([newlist (%append! (%list-copy itemlist) (%queue-first-pair q))])
     84    (%queue-first-pair-set! q newlist)
     85    (if (%null? newlist) (%queue-last-pair-empty! q)
     86        (%queue-last-pair-set! q (%last-pair newlist) ) ) ) )
     87
     88(define-inline (%queue-extract-pair! q targ-pair)
     89  ; Scan queue list until we find the item to remove
     90  (let scanning ([this-pair (%queue-first-pair q)] [prev-pair '()])
     91    ; Found it?
     92    (if (%eq? this-pair targ-pair)
     93        ;then cut out the pair
     94        (let ([next-pair (%cdr this-pair)])
     95          ; At the head of the list, or in the body?
     96          (if (%null? prev-pair) (%queue-first-pair-set! q next-pair)
     97              (%set-cdr! prev-pair next-pair) )
     98          ; When the cut pair is the last item update the last pair ref.
     99          (when (%eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) )
     100        ;else keep looking for the pair
     101        (scanning (%cdr this-pair) this-pair) ) ) )
    63102
    64103
     
    68107  (%make-structure 'mailbox nm (%make-queue) '()) )
    69108
     109(define-inline (%mailbox? obj)
     110  (%structure-instance? obj 'mailbox) )
     111
    70112(define-inline (%mailbox-name mb)
    71113  (%structure-ref mb 1) )
     
    80122
    81123(define-inline (%mailbox-queue-count mb)
    82   (%queue-size (%mailbox-queue mb)) )
     124  (%queue-count (%mailbox-queue mb)) )
    83125
    84126(define-inline (%mailbox-queue-add! mb x)
     
    131173  (%make-structure 'mailbox-cursor '() #f mb) )
    132174
     175(define-inline (%mailbox-cursor? obj)
     176  (%structure-instance? obj 'mailbox-cursor) )
     177
    133178(define-inline (%mailbox-cursor-next-pair mbc)
    134179  (%structure-ref mbc 1) )
     
    164209  (and-let* ([prev-pair (%mailbox-cursor-prev-pair mbc)])
    165210    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
     211
     212
     213;;; Time Support
     214
     215(define-inline (%time? obj)
     216  (%structure-instance? obj 'time) )
     217
     218(define-inline (%timeout? obj)
     219  (or (%time? obj) (%number? obj)) )
     220
     221
     222;;; Unique Object Support
     223
     224(define-inline (%make-unique-object #!optional ident)
     225  (if ident (%make-vector 1 ident)
     226      '#() ) )
     227
     228
     229;;; Argument Checking
     230
     231(define-inline (%check-mailbox loc obj)
     232  (##sys#check-structure obj 'mailbox loc) )
     233
     234(define-inline (%check-mailbox-cursor loc obj)
     235  (##sys#check-structure obj 'mailbox-cursor loc) )
     236
     237(define-inline (%check-timeout loc obj)
     238  (unless (%timeout? obj)
     239    (##sys#signal-hook #:type-error loc "bad argument type - invalid timeout object" obj) ) )
     240
     241(define-inline (%check-symbol loc obj)
     242  (##sys#check-symbol obj loc) )
     243
     244(define-inline (%check-list loc obj)
     245  (##sys#check-list obj loc) )
    166246
    167247
     
    213293
    214294
    215 ;;; Queue Operations
    216 
    217 (define (%queue-add! q datum)
    218   (let ([new-pair (%cons datum '())])
    219     (if (%null? (%queue-first-pair q))
    220         (%queue-first-pair-set! q new-pair)
    221         (%set-cdr! (%queue-last-pair q) new-pair) )
    222     (%queue-last-pair-set! q new-pair) ) )
    223 
    224 (define (%queue-remove! q)
    225   (let* ([first-pair (%queue-first-pair q)]
    226          [next-pair (%cdr first-pair)])
    227     (%queue-first-pair-set! q next-pair)
    228     (when (%null? next-pair) (%queue-last-pair-empty! q) )
    229     (%car first-pair) ) )
    230 
    231 (define (%queue-push-back! q item)
    232   (let ([newlist (%cons item (%queue-first-pair q))])
    233     (%queue-first-pair-set! q newlist)
    234     (when (%null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
    235 
    236 (define (%queue-push-back-list! q itemlist)
    237   (let ([newlist (%append! (%list-copy itemlist) (%queue-first-pair q))])
    238     (%queue-first-pair-set! q newlist)
    239     (if (%null? newlist)
    240         (%queue-last-pair-empty! q)
    241         (%queue-last-pair-set! q (%last-pair newlist) ) ) ) )
    242 
    243 (define (%queue-extract-pair! q targ-pair)
    244   ; Scan queue list until we find the item to remove
    245   (let scanning ([this-pair (%queue-first-pair q)] [prev-pair '()])
    246     ; Found it?
    247     (if (%eq? this-pair targ-pair)
    248         ; then cut out the pair
    249         (let ([next-pair (%cdr this-pair)])
    250           ; At the head of the list, or in the body?
    251           (if (%null? prev-pair)
    252               (%queue-first-pair-set! q next-pair)
    253               (%set-cdr! prev-pair next-pair) )
    254           ; When the cut pair is the last item update the last pair ref.
    255           (when (%eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) )
    256         ; else keep looking for the pair
    257         (scanning (%cdr this-pair) this-pair) ) ) )
    258 
    259 
    260 ;;; Argument checking
    261 
    262 (define (check-mailbox loc obj)
    263   (##sys#check-structure obj 'mailbox loc) )
    264 
    265 (define (check-mailbox-cursor loc obj)
    266   (##sys#check-structure obj 'mailbox-cursor loc) )
    267 
    268 (define (check-timeout loc obj)
    269   (unless (or (not obj)
    270               (%structure-instance? obj 'time)
    271               (%number? obj))
    272     (##sys#signal-hook #:type-error loc "bad argument type - invalid timeout" obj) ) )
    273 
    274 
    275295;;; Mailbox Exceptions
    276296
     
    279299   (make-property-condition 'exn
    280300    'location loc
    281     'message "mailbox timeout occured"
     301    'message "mailbox wait timeout occured"
    282302    'arguments (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def)))
    283303   (make-property-condition 'mailbox)
     
    287307;;; Mailbox Threading
    288308
    289 (define UNBLOCKED-TAG '#())
     309(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
    290310
    291311(define (ready-mailbox! mb)
     
    294314    (let ([thread (%mailbox-waiters-pop! mb)])
    295315      ; Ready the thread based on wait mode
    296       (if (%thread-blocked? thread)
    297           ; then wake early if sleeping
     316      (if (not (%thread-blocked? thread)) (thread-resume! thread)
     317          ;else wake early if sleeping
    298318          (when (%thread-blocked-for-timeout? thread)
     319            ; Ready the thread
    299320            (##sys#thread-unblock! thread)
    300             (thread-signal! thread UNBLOCKED-TAG) )
    301           ; else suspended
    302           (thread-resume! thread) ) ) )
    303   ; Ensure unspecified result
     321            ; Tell 'wait-mailbox!' we unblocked early
     322            (thread-signal! thread UNBLOCKED-TAG) ) ) ) )
     323  ; Side-effect only
    304324  (%undefined-value) )
     325
     326(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
    305327
    306328(define (wait-mailbox! loc mb to-tim to-def)
     
    314336        (condition-case (thread-sleep! to-tim)
    315337          [exn ()
    316             ; Unless unblocked "early" propagate exception
    317             (if (eq? UNBLOCKED-TAG exn)
    318                 (set! early? #t)
     338            ; Unless unblocked "early" then a real exception so propagate
     339            (if (%eq? UNBLOCKED-TAG exn) (set! early? #t)
    319340                (signal exn) ) ] )
    320341        ; Awake
    321342        (cond
    322           [early?       ; Do nothing when unblocked early
    323             ; Ensure unspecified result
    324             (%undefined-value) ]
    325           [else         ; Report timeout
     343          [early?       ; Unblocked early so we have a message
     344            MESSAGE-WAITING-TAG ]
     345          [else         ; Timedout
    326346            ; Remove from wait queue
    327347            (%mailbox-waiters-delete! mb (%current-thread))
    328             ; Timeout result
    329             (cond
    330               [(%undefined-value? to-def) ; Signal an timeout exception
    331                 (thread-signal!
    332                   (%current-thread)
    333                   (make-mailbox-timeout-condition loc to-tim to-def))
    334                 ; Ensure unspecified result
    335                 (%undefined-value) ]
    336               [else                 ; Default result provided
    337                 to-def ] ) ] ) ) ]
     348            ; Signal timeout when no default
     349            (when (%undefined-value? to-def)
     350              (thread-signal! (%current-thread)
     351                              (make-mailbox-timeout-condition loc to-tim to-def)) )
     352            ; No message waiting
     353            to-def ] ) ) ]
    338354      [else           ; Suspend until something delivered
    339355        (thread-suspend! (%current-thread))
    340         ; Ensure unspecified result
    341         (%undefined-value) ] ) )
     356        MESSAGE-WAITING-TAG ] ) )
    342357
    343358(define (wait-mailbox-if-empty! loc mb to-tim to-def)
    344   (when (%mailbox-queue-empty? mb)
    345     (wait-mailbox! loc mb to-tim to-def) ) )
     359  (if (%mailbox-queue-empty? mb)
     360      (wait-mailbox! loc mb to-tim to-def)
     361      MESSAGE-WAITING-TAG ) )
    346362
    347363
     
    360376
    361377(define (make-mailbox #!optional (nm (gensym 'mailbox)))
    362   (##sys#check-symbol nm 'make-mailbox)
     378  (%check-symbol 'make-mailbox nm)
    363379  (%make-mailbox nm) )
    364380
     381(define (mailbox? obj)
     382  (%mailbox? obj) )
     383
    365384;; Mailbox Properties
    366385
    367 (define (mailbox? x)
    368   (%structure-instance? x 'mailbox) )
    369 
    370386(define (mailbox-name mb)
    371   (check-mailbox 'mailbox-name mb)
     387  (%check-mailbox 'mailbox-name mb)
    372388  (%mailbox-name mb) )
    373389
    374390(define (mailbox-empty? mb)
    375   (check-mailbox 'mailbox-empty? mb)
     391  (%check-mailbox 'mailbox-empty? mb)
    376392  (%mailbox-queue-empty? mb) )
    377393
    378394(define (mailbox-count mb)
    379   (check-mailbox 'mailbox-count mb)
     395  (%check-mailbox 'mailbox-count mb)
    380396  (%mailbox-queue-count mb) )
    381397
    382398(define (mailbox-waiting? mb)
    383   (check-mailbox 'mailbox-waiting? mb)
     399  (%check-mailbox 'mailbox-waiting? mb)
    384400  (not (%null? (%mailbox-waiters mb))) )
    385401
    386402(define (mailbox-waiters mb)
    387   (check-mailbox 'mailbox-waiters mb)
     403  (%check-mailbox 'mailbox-waiters mb)
    388404  (%list-copy (%mailbox-waiters mb)) )
    389405
     
    391407
    392408(define (mailbox-send! mb x)
    393   (check-mailbox 'mailbox-send! mb)
     409  (%check-mailbox 'mailbox-send! mb)
    394410  (%mailbox-queue-add! mb x)
    395411  (ready-mailbox! mb) )
    396412
    397413(define (mailbox-wait! mb #!optional to-tim)
    398   (check-mailbox 'mailbox-wait! mb)
    399   (check-timeout 'mailbox-wait! to-tim)
     414  (%check-mailbox 'mailbox-wait! mb)
     415  (when to-tim (%check-timeout 'mailbox-wait! to-tim))
    400416  (wait-mailbox-if-empty! 'mailbox-wait! mb to-tim (%undefined-value)) )
    401417
    402418(define (mailbox-receive! mb #!optional to-tim (to-def (%undefined-value)))
    403   (check-mailbox 'mailbox-receive! mb)
    404   (check-timeout 'mailbox-receive! to-tim)
     419  (%check-mailbox 'mailbox-receive! mb)
     420  (when to-tim (%check-timeout 'mailbox-receive! to-tim))
    405421  (let ([res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)])
    406     (if (%undefined-value? res)
    407         (%mailbox-queue-remove! mb)
     422    ; Return next item in mailbox, if any
     423    (if (%eq? MESSAGE-WAITING-TAG res) (%mailbox-queue-remove! mb)
     424        ;else return the timeout default
    408425        res ) ) )
    409426
    410427(define (mailbox-push-back! mb x)
    411   (check-mailbox 'mailbox-send! mb)
     428  (%check-mailbox 'mailbox-send! mb)
    412429  (%mailbox-queue-push-back! mb x)
    413430  (ready-mailbox! mb) )
    414431
    415432(define (mailbox-push-back-list! mb ls)
    416   (check-mailbox 'mailbox-send! mb)
    417   (##sys#check-list ls 'mailbox-send!)
     433  (%check-mailbox 'mailbox-send! mb)
     434  (%check-list ls 'mailbox-send!)
    418435  (%mailbox-queue-push-back-list! mb ls)
    419436  (ready-mailbox! mb) )
     
    425442
    426443(define (make-mailbox-cursor mb)
    427   (check-mailbox 'make-mailbox-cursor mb)
     444  (%check-mailbox 'make-mailbox-cursor mb)
    428445  (%make-mailbox-cursor mb) )
    429446
    430447;; Mailbox Cursor Properties
    431448
    432 (define (mailbox-cursor? x)
    433   (%structure-instance? x 'mailbox-cursor) )
     449(define (mailbox-cursor? obj)
     450  (%mailbox-cursor? obj) )
    434451
    435452(define (mailbox-cursor-mailbox mbc)
    436   (check-mailbox-cursor 'mailbox-cursor-mailbox mbc)
     453  (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)
    437454  (%mailbox-cursor-mailbox mbc) )
    438455
    439456(define (mailbox-cursor-rewound? mbc)
    440   (check-mailbox-cursor 'mailbox-cursor-rewound? mbc)
     457  (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc)
    441458  (not (%mailbox-cursor-winding? mbc)) )
    442459
     
    444461
    445462(define (mailbox-cursor-rewind mbc)
    446   (check-mailbox-cursor 'mailbox-cursor-rewind mbc)
     463  (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)
    447464  (%mailbox-cursor-rewind mbc) )
    448465
    449466(define (mailbox-cursor-next mbc #!optional to-tim (to-def (%undefined-value)))
    450   (check-mailbox-cursor 'mailbox-cursor-next mbc)
    451   (check-timeout 'mailbox-cursor-next to-tim)
     467  (%check-mailbox-cursor 'mailbox-cursor-next mbc)
     468  (when to-tim (%check-timeout 'mailbox-cursor-next to-tim))
    452469  ; Waiting mailbox peek.
    453470  (let ([mb (%mailbox-cursor-mailbox mbc)])
    454471    (let-values ([(mailbox-waiter cursor-pair-getter)
    455472                  (if (%mailbox-cursor-winding? mbc)
    456                       ; then wait for something to be appended
     473                      ;then wait for something to be appended
    457474                      (values wait-mailbox!
    458475                              (lambda () (%mailbox-queue-last-pair mb)))
    459                       ; else grab the start of a, probably, non-empty queue
     476                      ;else grab the start of a, probably, non-empty queue
    460477                      (values wait-mailbox-if-empty!
    461478                              (lambda () (%mailbox-queue-first-pair mb))) ) ] )
     
    463480        ; Anything next?
    464481        (if (not (%null? next-pair))
    465             ; then peek into the queue for the next item
     482            ;then peek into the queue for the next item
    466483            (let ([item (%car next-pair)])
    467484              (%mailbox-cursor-prev-pair-set! mbc next-pair)
    468485              (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
    469486              item )
    470             ; else wait for something in the mailbox
     487            ;else wait for something in the mailbox
    471488            (let ([res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)])
    472489              (cond
    473                 [(%undefined-value? res)  ; then still scanning
     490                [(%eq? MESSAGE-WAITING-TAG res)  ; so continue scanning
    474491                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    475492                  (scanning (%mailbox-cursor-next-pair mbc)) ]
    476                 [else               ; otherwise return timeout default value
     493                [else                            ; otherwise timedout
    477494                  res ] ) ) ) ) ) ) )
    478495
    479496(define (mailbox-cursor-extract-and-rewind! mbc)
    480   (check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
     497  (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
    481498  (%mailbox-cursor-extract! mbc)
    482499  (%mailbox-cursor-rewind mbc) )
     
    489506      (display "#<mailbox ")
    490507      (display (%mailbox-name mb))
    491       (display " queued = ") (display (%mailbox-queue-count mb)) 
    492       (display " waiters = ") (display (%mailbox-waiters-count mb)) 
     508      (display " queued = ") (display (%mailbox-queue-count mb))
     509      (display " waiters = ") (display (%mailbox-waiters-count mb))
    493510      (display ">") ) ) )
    494511
  • release/4/mailbox/trunk/mailbox.scm

    r13510 r13529  
    44;; Issues
    55;;
    6 ;; - Depends on "library.scm" declaring '(disable-interrupts)'.
     6;; - All operations inlined & primitive due to high-performance nature of IPC.
    77;;
    88;; - Uses ##sys#current-thread & ##sys#thread-unblock!
    9 ;;
    10 ;; - Note use of 'undefined-value' to signal an empty mailbox.
    119
    1210(declare
     
    5957  (%null? (%queue-first-pair q)) )
    6058
    61 (define-inline (%queue-size q)
     59(define-inline (%queue-count q)
    6260  (%length (%queue-first-pair q)) )
     61
     62;; Queue Operations
     63
     64(define-inline (%queue-add! q datum)
     65  (let ([new-pair (%cons datum '())])
     66    (if (%null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
     67        (%set-cdr! (%queue-last-pair q) new-pair) )
     68    (%queue-last-pair-set! q new-pair) ) )
     69
     70(define-inline (%queue-remove! q)
     71  (let* ([first-pair (%queue-first-pair q)]
     72         [next-pair (%cdr first-pair)])
     73    (%queue-first-pair-set! q next-pair)
     74    (when (%null? next-pair) (%queue-last-pair-empty! q) )
     75    (%car first-pair) ) )
     76
     77(define-inline (%queue-push-back! q item)
     78  (let ([newlist (%cons item (%queue-first-pair q))])
     79    (%queue-first-pair-set! q newlist)
     80    (when (%null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
     81
     82(define-inline (%queue-push-back-list! q itemlist)
     83  (let ([newlist (%append! (%list-copy itemlist) (%queue-first-pair q))])
     84    (%queue-first-pair-set! q newlist)
     85    (if (%null? newlist) (%queue-last-pair-empty! q)
     86        (%queue-last-pair-set! q (%last-pair newlist) ) ) ) )
     87
     88(define-inline (%queue-extract-pair! q targ-pair)
     89  ; Scan queue list until we find the item to remove
     90  (let scanning ([this-pair (%queue-first-pair q)] [prev-pair '()])
     91    ; Found it?
     92    (if (%eq? this-pair targ-pair)
     93        ;then cut out the pair
     94        (let ([next-pair (%cdr this-pair)])
     95          ; At the head of the list, or in the body?
     96          (if (%null? prev-pair) (%queue-first-pair-set! q next-pair)
     97              (%set-cdr! prev-pair next-pair) )
     98          ; When the cut pair is the last item update the last pair ref.
     99          (when (%eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) )
     100        ;else keep looking for the pair
     101        (scanning (%cdr this-pair) this-pair) ) ) )
    63102
    64103
     
    68107  (%make-structure 'mailbox nm (%make-queue) '()) )
    69108
     109(define-inline (%mailbox? obj)
     110  (%structure-instance? obj 'mailbox) )
     111
    70112(define-inline (%mailbox-name mb)
    71113  (%structure-ref mb 1) )
     
    80122
    81123(define-inline (%mailbox-queue-count mb)
    82   (%queue-size (%mailbox-queue mb)) )
     124  (%queue-count (%mailbox-queue mb)) )
    83125
    84126(define-inline (%mailbox-queue-add! mb x)
     
    131173  (%make-structure 'mailbox-cursor '() #f mb) )
    132174
     175(define-inline (%mailbox-cursor? obj)
     176  (%structure-instance? obj 'mailbox-cursor) )
     177
    133178(define-inline (%mailbox-cursor-next-pair mbc)
    134179  (%structure-ref mbc 1) )
     
    164209  (and-let* ([prev-pair (%mailbox-cursor-prev-pair mbc)])
    165210    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
     211
     212
     213;;; Time Support
     214
     215(define-inline (%time? obj)
     216  (%structure-instance? obj 'time) )
     217
     218(define-inline (%timeout? obj)
     219  (or (%time? obj) (%number? obj)) )
     220
     221
     222;;; Unique Object Support
     223
     224(define-inline (%make-unique-object #!optional ident)
     225  (if ident (%make-vector 1 ident)
     226      '#() ) )
     227
     228
     229;;; Argument Checking
     230
     231(define-inline (%check-mailbox loc obj)
     232  (##sys#check-structure obj 'mailbox loc) )
     233
     234(define-inline (%check-mailbox-cursor loc obj)
     235  (##sys#check-structure obj 'mailbox-cursor loc) )
     236
     237(define-inline (%check-timeout loc obj)
     238  (unless (%timeout? obj)
     239    (##sys#signal-hook #:type-error loc "bad argument type - invalid timeout object" obj) ) )
     240
     241(define-inline (%check-symbol loc obj)
     242  (##sys#check-symbol obj loc) )
     243
     244(define-inline (%check-list loc obj)
     245  (##sys#check-list obj loc) )
    166246
    167247
     
    213293
    214294
    215 ;;; Queue Operations
    216 
    217 (define (%queue-add! q datum)
    218   (let ([new-pair (%cons datum '())])
    219     (if (%null? (%queue-first-pair q))
    220         (%queue-first-pair-set! q new-pair)
    221         (%set-cdr! (%queue-last-pair q) new-pair) )
    222     (%queue-last-pair-set! q new-pair) ) )
    223 
    224 (define (%queue-remove! q)
    225   (let* ([first-pair (%queue-first-pair q)]
    226          [next-pair (%cdr first-pair)])
    227     (%queue-first-pair-set! q next-pair)
    228     (when (%null? next-pair) (%queue-last-pair-empty! q) )
    229     (%car first-pair) ) )
    230 
    231 (define (%queue-push-back! q item)
    232   (let ([newlist (%cons item (%queue-first-pair q))])
    233     (%queue-first-pair-set! q newlist)
    234     (when (%null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
    235 
    236 (define (%queue-push-back-list! q itemlist)
    237   (let ([newlist (%append! (%list-copy itemlist) (%queue-first-pair q))])
    238     (%queue-first-pair-set! q newlist)
    239     (if (%null? newlist)
    240         (%queue-last-pair-empty! q)
    241         (%queue-last-pair-set! q (%last-pair newlist) ) ) ) )
    242 
    243 (define (%queue-extract-pair! q targ-pair)
    244   ; Scan queue list until we find the item to remove
    245   (let scanning ([this-pair (%queue-first-pair q)] [prev-pair '()])
    246     ; Found it?
    247     (if (%eq? this-pair targ-pair)
    248         ; then cut out the pair
    249         (let ([next-pair (%cdr this-pair)])
    250           ; At the head of the list, or in the body?
    251           (if (%null? prev-pair)
    252               (%queue-first-pair-set! q next-pair)
    253               (%set-cdr! prev-pair next-pair) )
    254           ; When the cut pair is the last item update the last pair ref.
    255           (when (%eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair)) )
    256         ; else keep looking for the pair
    257         (scanning (%cdr this-pair) this-pair) ) ) )
    258 
    259 
    260 ;;; Argument checking
    261 
    262 (define (check-mailbox loc obj)
    263   (##sys#check-structure obj 'mailbox loc) )
    264 
    265 (define (check-mailbox-cursor loc obj)
    266   (##sys#check-structure obj 'mailbox-cursor loc) )
    267 
    268 (define (check-timeout loc obj)
    269   (unless (or (not obj)
    270               (%structure-instance? obj 'time)
    271               (%number? obj))
    272     (##sys#signal-hook #:type-error loc "bad argument type - invalid timeout" obj) ) )
    273 
    274 
    275295;;; Mailbox Exceptions
    276296
     
    279299   (make-property-condition 'exn
    280300    'location loc
    281     'message "mailbox timeout occured"
     301    'message "mailbox wait timeout occured"
    282302    'arguments (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def)))
    283303   (make-property-condition 'mailbox)
     
    287307;;; Mailbox Threading
    288308
    289 (define UNBLOCKED-TAG '#())
     309(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
    290310
    291311(define (ready-mailbox! mb)
     
    294314    (let ([thread (%mailbox-waiters-pop! mb)])
    295315      ; Ready the thread based on wait mode
    296       (if (%thread-blocked? thread)
    297           ; then wake early if sleeping
     316      (if (not (%thread-blocked? thread)) (thread-resume! thread)
     317          ;else wake early if sleeping
    298318          (when (%thread-blocked-for-timeout? thread)
     319            ; Ready the thread
    299320            (##sys#thread-unblock! thread)
    300             (thread-signal! thread UNBLOCKED-TAG) )
    301           ; else suspended
    302           (thread-resume! thread) ) ) )
    303   ; Ensure unspecified result
     321            ; Tell 'wait-mailbox!' we unblocked early
     322            (thread-signal! thread UNBLOCKED-TAG) ) ) ) )
     323  ; Side-effect only
    304324  (%undefined-value) )
     325
     326(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
    305327
    306328(define (wait-mailbox! loc mb to-tim to-def)
     
    314336        (condition-case (thread-sleep! to-tim)
    315337          [exn ()
    316             ; Unless unblocked "early" propagate exception
    317             (if (eq? UNBLOCKED-TAG exn)
    318                 (set! early? #t)
     338            ; Unless unblocked "early" then a real exception so propagate
     339            (if (%eq? UNBLOCKED-TAG exn) (set! early? #t)
    319340                (signal exn) ) ] )
    320341        ; Awake
    321342        (cond
    322           [early?       ; Do nothing when unblocked early
    323             ; Ensure unspecified result
    324             (%undefined-value) ]
    325           [else         ; Report timeout
     343          [early?       ; Unblocked early so we have a message
     344            MESSAGE-WAITING-TAG ]
     345          [else         ; Timedout
    326346            ; Remove from wait queue
    327347            (%mailbox-waiters-delete! mb (%current-thread))
    328             ; Timeout result
    329             (cond
    330               [(%undefined-value? to-def) ; Signal an timeout exception
    331                 (thread-signal!
    332                   (%current-thread)
    333                   (make-mailbox-timeout-condition loc to-tim to-def))
    334                 ; Ensure unspecified result
    335                 (%undefined-value) ]
    336               [else                 ; Default result provided
    337                 to-def ] ) ] ) ) ]
     348            ; Signal timeout when no default
     349            (when (%undefined-value? to-def)
     350              (thread-signal! (%current-thread)
     351                              (make-mailbox-timeout-condition loc to-tim to-def)) )
     352            ; No message waiting
     353            to-def ] ) ) ]
    338354      [else           ; Suspend until something delivered
    339355        (thread-suspend! (%current-thread))
    340         ; Ensure unspecified result
    341         (%undefined-value) ] ) )
     356        MESSAGE-WAITING-TAG ] ) )
    342357
    343358(define (wait-mailbox-if-empty! loc mb to-tim to-def)
    344   (when (%mailbox-queue-empty? mb)
    345     (wait-mailbox! loc mb to-tim to-def) ) )
     359  (if (%mailbox-queue-empty? mb)
     360      (wait-mailbox! loc mb to-tim to-def)
     361      MESSAGE-WAITING-TAG ) )
    346362
    347363
     
    360376
    361377(define (make-mailbox #!optional (nm (gensym 'mailbox)))
    362   (##sys#check-symbol nm 'make-mailbox)
     378  (%check-symbol 'make-mailbox nm)
    363379  (%make-mailbox nm) )
    364380
     381(define (mailbox? obj)
     382  (%mailbox? obj) )
     383
    365384;; Mailbox Properties
    366385
    367 (define (mailbox? x)
    368   (%structure-instance? x 'mailbox) )
    369 
    370386(define (mailbox-name mb)
    371   (check-mailbox 'mailbox-name mb)
     387  (%check-mailbox 'mailbox-name mb)
    372388  (%mailbox-name mb) )
    373389
    374390(define (mailbox-empty? mb)
    375   (check-mailbox 'mailbox-empty? mb)
     391  (%check-mailbox 'mailbox-empty? mb)
    376392  (%mailbox-queue-empty? mb) )
    377393
    378394(define (mailbox-count mb)
    379   (check-mailbox 'mailbox-count mb)
     395  (%check-mailbox 'mailbox-count mb)
    380396  (%mailbox-queue-count mb) )
    381397
    382398(define (mailbox-waiting? mb)
    383   (check-mailbox 'mailbox-waiting? mb)
     399  (%check-mailbox 'mailbox-waiting? mb)
    384400  (not (%null? (%mailbox-waiters mb))) )
    385401
    386402(define (mailbox-waiters mb)
    387   (check-mailbox 'mailbox-waiters mb)
     403  (%check-mailbox 'mailbox-waiters mb)
    388404  (%list-copy (%mailbox-waiters mb)) )
    389405
     
    391407
    392408(define (mailbox-send! mb x)
    393   (check-mailbox 'mailbox-send! mb)
     409  (%check-mailbox 'mailbox-send! mb)
    394410  (%mailbox-queue-add! mb x)
    395411  (ready-mailbox! mb) )
    396412
    397413(define (mailbox-wait! mb #!optional to-tim)
    398   (check-mailbox 'mailbox-wait! mb)
    399   (check-timeout 'mailbox-wait! to-tim)
     414  (%check-mailbox 'mailbox-wait! mb)
     415  (when to-tim (%check-timeout 'mailbox-wait! to-tim))
    400416  (wait-mailbox-if-empty! 'mailbox-wait! mb to-tim (%undefined-value)) )
    401417
    402418(define (mailbox-receive! mb #!optional to-tim (to-def (%undefined-value)))
    403   (check-mailbox 'mailbox-receive! mb)
    404   (check-timeout 'mailbox-receive! to-tim)
     419  (%check-mailbox 'mailbox-receive! mb)
     420  (when to-tim (%check-timeout 'mailbox-receive! to-tim))
    405421  (let ([res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)])
    406     (if (%undefined-value? res)
    407         (%mailbox-queue-remove! mb)
     422    ; Return next item in mailbox, if any
     423    (if (%eq? MESSAGE-WAITING-TAG res) (%mailbox-queue-remove! mb)
     424        ;else return the timeout default
    408425        res ) ) )
    409426
    410427(define (mailbox-push-back! mb x)
    411   (check-mailbox 'mailbox-send! mb)
     428  (%check-mailbox 'mailbox-send! mb)
    412429  (%mailbox-queue-push-back! mb x)
    413430  (ready-mailbox! mb) )
    414431
    415432(define (mailbox-push-back-list! mb ls)
    416   (check-mailbox 'mailbox-send! mb)
    417   (##sys#check-list ls 'mailbox-send!)
     433  (%check-mailbox 'mailbox-send! mb)
     434  (%check-list ls 'mailbox-send!)
    418435  (%mailbox-queue-push-back-list! mb ls)
    419436  (ready-mailbox! mb) )
     
    425442
    426443(define (make-mailbox-cursor mb)
    427   (check-mailbox 'make-mailbox-cursor mb)
     444  (%check-mailbox 'make-mailbox-cursor mb)
    428445  (%make-mailbox-cursor mb) )
    429446
    430447;; Mailbox Cursor Properties
    431448
    432 (define (mailbox-cursor? x)
    433   (%structure-instance? x 'mailbox-cursor) )
     449(define (mailbox-cursor? obj)
     450  (%mailbox-cursor? obj) )
    434451
    435452(define (mailbox-cursor-mailbox mbc)
    436   (check-mailbox-cursor 'mailbox-cursor-mailbox mbc)
     453  (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)
    437454  (%mailbox-cursor-mailbox mbc) )
    438455
    439456(define (mailbox-cursor-rewound? mbc)
    440   (check-mailbox-cursor 'mailbox-cursor-rewound? mbc)
     457  (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc)
    441458  (not (%mailbox-cursor-winding? mbc)) )
    442459
     
    444461
    445462(define (mailbox-cursor-rewind mbc)
    446   (check-mailbox-cursor 'mailbox-cursor-rewind mbc)
     463  (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)
    447464  (%mailbox-cursor-rewind mbc) )
    448465
    449466(define (mailbox-cursor-next mbc #!optional to-tim (to-def (%undefined-value)))
    450   (check-mailbox-cursor 'mailbox-cursor-next mbc)
    451   (check-timeout 'mailbox-cursor-next to-tim)
     467  (%check-mailbox-cursor 'mailbox-cursor-next mbc)
     468  (when to-tim (%check-timeout 'mailbox-cursor-next to-tim))
    452469  ; Waiting mailbox peek.
    453470  (let ([mb (%mailbox-cursor-mailbox mbc)])
    454471    (let-values ([(mailbox-waiter cursor-pair-getter)
    455472                  (if (%mailbox-cursor-winding? mbc)
    456                       ; then wait for something to be appended
     473                      ;then wait for something to be appended
    457474                      (values wait-mailbox!
    458475                              (lambda () (%mailbox-queue-last-pair mb)))
    459                       ; else grab the start of a, probably, non-empty queue
     476                      ;else grab the start of a, probably, non-empty queue
    460477                      (values wait-mailbox-if-empty!
    461478                              (lambda () (%mailbox-queue-first-pair mb))) ) ] )
     
    463480        ; Anything next?
    464481        (if (not (%null? next-pair))
    465             ; then peek into the queue for the next item
     482            ;then peek into the queue for the next item
    466483            (let ([item (%car next-pair)])
    467484              (%mailbox-cursor-prev-pair-set! mbc next-pair)
    468485              (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
    469486              item )
    470             ; else wait for something in the mailbox
     487            ;else wait for something in the mailbox
    471488            (let ([res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)])
    472489              (cond
    473                 [(%undefined-value? res)  ; then still scanning
     490                [(%eq? MESSAGE-WAITING-TAG res)  ; so continue scanning
    474491                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    475492                  (scanning (%mailbox-cursor-next-pair mbc)) ]
    476                 [else               ; otherwise return timeout default value
     493                [else                            ; otherwise timedout
    477494                  res ] ) ) ) ) ) ) )
    478495
    479496(define (mailbox-cursor-extract-and-rewind! mbc)
    480   (check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
     497  (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc)
    481498  (%mailbox-cursor-extract! mbc)
    482499  (%mailbox-cursor-rewind mbc) )
     
    489506      (display "#<mailbox ")
    490507      (display (%mailbox-name mb))
    491       (display " queued = ") (display (%mailbox-queue-count mb)) 
    492       (display " waiters = ") (display (%mailbox-waiters-count mb)) 
     508      (display " queued = ") (display (%mailbox-queue-count mb))
     509      (display " waiters = ") (display (%mailbox-waiters-count mb))
    493510      (display ">") ) ) )
    494511
Note: See TracChangeset for help on using the changeset viewer.