Changeset 13617 in project


Ignore:
Timestamp:
03/09/09 19:36:40 (11 years ago)
Author:
Kon Lovett
Message:

Added primitive inlines.

Location:
release/4/mailbox
Files:
4 added
3 edited

Legend:

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

    r13556 r13617  
    99 (synopsis "Thread-safe queues with timeout")
    1010 (files
     11  "chicken-primitive-object-inlines.scm"
     12  "chicken-thread-object-inlines.scm"
    1113  "mailbox.scm"
    1214  "mailbox.setup"
  • release/4/mailbox/trunk/mailbox.meta

    r13556 r13617  
    99 (synopsis "Thread-safe queues with timeout")
    1010 (files
     11  "chicken-primitive-object-inlines.scm"
     12  "chicken-thread-object-inlines.scm"
    1113  "mailbox.scm"
    1214  "mailbox.setup"
  • release/4/mailbox/trunk/mailbox.scm

    r13533 r13617  
    6666
    6767(define-inline (%queue-add! q datum)
    68   (let ([new-pair (%cons datum '())])
     68  (let ((new-pair (%cons datum '())))
    6969    (if (%null? (%queue-first-pair q)) (%queue-first-pair-set! q new-pair)
    7070        (%set-cdr! (%queue-last-pair q) new-pair) )
     
    7272
    7373(define-inline (%queue-remove! q)
    74   (let* ([first-pair (%queue-first-pair q)]
    75          [next-pair (%cdr first-pair)])
     74  (let* ((first-pair (%queue-first-pair q))
     75         (next-pair (%cdr first-pair)))
    7676    (%queue-first-pair-set! q next-pair)
    7777    (when (%null? next-pair) (%queue-last-pair-empty! q) )
     
    7979
    8080(define-inline (%queue-push-back! q item)
    81   (let ([newlist (%cons item (%queue-first-pair q))])
     81  (let ((newlist (%cons item (%queue-first-pair q))))
    8282    (%queue-first-pair-set! q newlist)
    8383    (when (%null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
    8484
    8585(define-inline (%queue-push-back-list! q itemlist)
    86   (let ([newlist (%append! (%list-copy itemlist) (%queue-first-pair q))])
     86  (let ((newlist (%append! (%list-copy itemlist) (%queue-first-pair q))))
    8787    (%queue-first-pair-set! q newlist)
    8888    (if (%null? newlist) (%queue-last-pair-empty! q)
     
    9191(define-inline (%queue-extract-pair! q targ-pair)
    9292  ; Scan queue list until we find the item to remove
    93   (let scanning ([this-pair (%queue-first-pair q)] [prev-pair '()])
     93  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
    9494    ; Found it?
    9595    (if (%eq? this-pair targ-pair)
    9696        ;then cut out the pair
    97         (let ([next-pair (%cdr this-pair)])
     97        (let ((next-pair (%cdr this-pair)))
    9898          ; At the head of the list, or in the body?
    9999          (if (%null? prev-pair) (%queue-first-pair-set! q next-pair)
     
    166166
    167167(define-inline (%mailbox-waiters-pop! mb)
    168   (let ([ts (%mailbox-waiters mb)])
     168  (let ((ts (%mailbox-waiters mb)))
    169169    (%mailbox-waiters-set! mb (%cdr ts))
    170170    (%car ts) ) )
     
    210210(define-inline (%mailbox-cursor-extract! mbc)
    211211  ; Unless 'mailbox-cursor-next' has been called don't remove
    212   (and-let* ([prev-pair (%mailbox-cursor-prev-pair mbc)])
     212  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
    213213    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
    214214
     
    315315  ; Ready oldest waiting thread
    316316  (unless (%mailbox-waiters-empty? mb)
    317     (let ([thread (%mailbox-waiters-pop! mb)])
     317    (let ((thread (%mailbox-waiters-pop! mb)))
    318318      ; Ready the thread based on wait mode
    319319      (if (not (%thread-blocked? thread)) (thread-resume! thread)
     
    334334  ; Waiting action
    335335  (cond
    336     [to-tim           ; Timeout wanted so sleep until something happens
    337       (let ([early? #f])
     336    (to-tim           ; Timeout wanted so sleep until something happens
     337      (let ((early? #f))
    338338        ; Sleep current thread until desired seconds elapsed
    339339        (condition-case (thread-sleep! to-tim)
    340           [exn ()
     340          (exn ()
    341341            ; Unless unblocked "early" then a real exception so propagate
    342342            (if (%eq? UNBLOCKED-TAG exn) (set! early? #t)
    343                 (signal exn) ) ] )
     343                (signal exn) ) ) )
    344344        ; Awake
    345345        (cond
    346           [early?       ; Unblocked early so we have a message
    347             MESSAGE-WAITING-TAG ]
    348           [else         ; Timedout
     346          (early?       ; Unblocked early so we have a message
     347            MESSAGE-WAITING-TAG )
     348          (else         ; Timedout
    349349            ; Remove from wait queue
    350350            (%mailbox-waiters-delete! mb (%current-thread))
     
    354354                              (make-mailbox-timeout-condition loc to-tim to-def)) )
    355355            ; No message waiting
    356             to-def ] ) ) ]
    357       [else           ; Suspend until something delivered
     356            to-def ) ) ) )
     357      (else           ; Suspend until something delivered
    358358        (thread-suspend! (%current-thread))
    359         MESSAGE-WAITING-TAG ] ) )
     359        MESSAGE-WAITING-TAG ) ) )
    360360
    361361(define (wait-mailbox-if-empty! loc mb to-tim to-def)
     
    370370
    371371(define mailbox-timeout-exception?
    372   (let ([exf (condition-predicate 'exn)]
    373         [mbf (condition-predicate 'mailbox)]
    374         [tmf (condition-predicate 'timeout)])
     372  (let ((exf (condition-predicate 'exn))
     373        (mbf (condition-predicate 'mailbox))
     374        (tmf (condition-predicate 'timeout)))
    375375    (lambda (obj)
    376376      (and (exf obj) (mbf obj) (tmf obj)) ) ) )
     
    422422  (%check-mailbox 'mailbox-receive! mb)
    423423  (when to-tim (%check-timeout 'mailbox-receive! to-tim))
    424   (let ([res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)])
     424  (let ((res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)))
    425425    ; Return next item in mailbox, if any
    426426    (if (%eq? MESSAGE-WAITING-TAG res) (%mailbox-queue-remove! mb)
     
    471471  (when to-tim (%check-timeout 'mailbox-cursor-next to-tim))
    472472  ; Waiting mailbox peek.
    473   (let ([mb (%mailbox-cursor-mailbox mbc)])
    474     (let-values ([(mailbox-waiter cursor-pair-getter)
     473  (let ((mb (%mailbox-cursor-mailbox mbc)))
     474    (let-values (((mailbox-waiter cursor-pair-getter)
    475475                  (if (%mailbox-cursor-winding? mbc)
    476476                      ;then wait for something to be appended
     
    479479                      ;else grab the start of a, probably, non-empty queue
    480480                      (values wait-mailbox-if-empty!
    481                               (lambda () (%mailbox-queue-first-pair mb))) ) ] )
    482       (let scanning ([next-pair (%mailbox-cursor-next-pair mbc)])
     481                              (lambda () (%mailbox-queue-first-pair mb))) ) ) )
     482      (let scanning ((next-pair (%mailbox-cursor-next-pair mbc)))
    483483        ; Anything next?
    484484        (if (not (%null? next-pair))
    485485            ;then peek into the queue for the next item
    486             (let ([item (%car next-pair)])
     486            (let ((item (%car next-pair)))
    487487              (%mailbox-cursor-prev-pair-set! mbc next-pair)
    488488              (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
    489489              item )
    490490            ;else wait for something in the mailbox
    491             (let ([res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)])
     491            (let ((res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)))
    492492              (cond
    493                 [(%eq? MESSAGE-WAITING-TAG res)  ; so continue scanning
     493                ((%eq? MESSAGE-WAITING-TAG res)  ; so continue scanning
    494494                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    495                   (scanning (%mailbox-cursor-next-pair mbc)) ]
    496                 [else                            ; otherwise timedout
    497                   res ] ) ) ) ) ) ) )
     495                  (scanning (%mailbox-cursor-next-pair mbc)) )
     496                (else                            ; otherwise timedout
     497                  res ) ) ) ) ) ) ) )
    498498
    499499(define (mailbox-cursor-extract-and-rewind! mbc)
Note: See TracChangeset for help on using the changeset viewer.