Changeset 34353 in project


Ignore:
Timestamp:
08/25/17 17:52:43 (4 weeks ago)
Author:
kon
Message:

rel 2.2.2 / 2.2.1

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

Legend:

Unmodified
Added
Removed
  • release/4/mailbox/trunk/mailbox.scm

    r33627 r34353  
    7373  (declare
    7474    (disable-interrupts) ;A MUST!
     75    (always-bound ##sys#primordial-thread)
    7576    (bound-to-procedure
    7677      ##sys#signal-hook
     
    210211
    211212(define (make-mailbox-timeout-condition loc timout timout-value)
    212   (let ((args (if ($eq? timout-value NO-TOVAL-TAG) (list timout)
    213                   (list timout timout-value))))
     213  (let ((args
     214          (if ($eq? timout-value NO-TOVAL-TAG)
     215            (list timout)
     216            (list timout timout-value))))
    214217    (make-exn-condition+ loc "mailbox wait timeout occurred" args 'mailbox 'timeout) ) )
    215218
     
    223226    (let ((thread (%mailbox-waiters-pop! mb)))
    224227      ;Ready the thread based on wait mode
    225       (if (not ($thread-blocked? thread)) (thread-resume! thread)
    226           ;else wake early if sleeping
    227           (when ($thread-blocked-for-timeout? thread)
    228             ;Ready the thread
    229             (##sys#thread-unblock! thread)
    230             ;Tell 'wait-mailbox-thread!' we unblocked early
    231             (thread-signal! thread UNBLOCKED-TAG) ) ) )
     228      (if (not ($thread-blocked? thread))
     229        (thread-resume! thread)
     230        ;else wake early if sleeping
     231        (when ($thread-blocked-for-timeout? thread)
     232          ;Ready the thread
     233          (##sys#thread-unblock! thread)
     234          ;Tell 'wait-mailbox-thread!' we unblocked early
     235          (thread-signal! thread UNBLOCKED-TAG) ) ) )
    232236    (void) ) )
    233237
     
    235239;; or some other condition
    236240
    237 (define-inline (thread-sleep/maybe-unblock! tim unblocked-tag)
     241(define (thread-sleep/maybe-unblock! tim unblocked-tag)
    238242  ;Sleep current thread for desired seconds, unless unblocked "early".
    239243  (call/cc
     
    241245      (with-exception-handler
    242246        (lambda (exp)
    243           (if ($eq? unblocked-tag exp) (return #f)
    244               ;Propagate any "real" exception.
    245               (signal exp)))
    246         (lambda () (thread-sleep! tim) #t)))) )
     247          (if ($eq? unblocked-tag exp)
     248            (return #f)
     249            ;Propagate any "real" exception.
     250            (signal exp) ) )
     251        (lambda () (thread-sleep! tim) #t) ) ) ) )
    247252
    248253;; Wait current thread on the mailbox until timeout, available message
     
    250255
    251256(define (wait-mailbox-thread! loc mb timout timout-value)
     257  ;no available message due to timeout
     258  (define (timeout-exit!)
     259    (if (not ($eq? timout-value NO-TOVAL-TAG))
     260      timout-value
     261      (begin
     262        (thread-signal!
     263          ($current-thread)
     264          (make-mailbox-timeout-condition loc timout timout-value))
     265        SEQ-FAIL-TAG ) ) )
    252266  ;Push current thread on mailbox waiting queue
    253267  (%mailbox-waiters-add! mb ($current-thread))
    254268  ;Waiting action
    255269  (cond
    256     (timout   ;Timeout wanted so sleep until something happens
    257       (cond
    258         ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
    259           ;Timed-out, so no message
    260           ;Remove from wait queue
    261           (%mailbox-waiters-delete! mb ($current-thread))
    262           ;Indicate no available message
    263           (if (not ($eq? timout-value NO-TOVAL-TAG)) timout-value
    264             (begin
    265               (thread-signal!
    266                 ($current-thread)
    267                 (make-mailbox-timeout-condition loc timout timout-value))
    268               SEQ-FAIL-TAG ) ) )
    269         (else
    270           ;Unblocked early
    271           UNBLOCKED-TAG ) ) )
    272     (else   ;No timeout so suspend until something delivered
     270    ;Timeout wanted so sleep until something happens
     271    (timout
     272      (if (eq? ($current-thread) ##sys#primordial-thread)
     273        (begin
     274          (warning 'mailbox "attempt to sleep primordial-thread")
     275          (timeout-exit!) )
     276        (cond
     277          ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
     278            ;Timed-out, so no message
     279            ;Remove from wait queue
     280            (%mailbox-waiters-delete! mb ($current-thread))
     281            ;Indicate no available message
     282            (timeout-exit!) )
     283          (else
     284            ;Unblocked early
     285            UNBLOCKED-TAG ) ) ) )
     286    ;No timeout so suspend until something delivered
     287    (else
    273288      (thread-suspend! ($current-thread))
    274289      ;We're resumed
     
    286301            (let ((res (wait-mailbox-thread! ?loc ?mb ?timout ?timout-value)))
    287302              ;When a thread ready then check mailbox again, could be empty.
    288               (if ($eq? UNBLOCKED-TAG res) (waiting)
    289                   ;else some sort of problem
    290                   res ) ) )
     303              (if ($eq? UNBLOCKED-TAG res)
     304                (waiting)
     305                ;else some sort of problem
     306                res ) ) )
    291307          (else
    292308            ?expr0 ... ) ) ) ) ) )
     
    402418    (receive (mailbox-waiter cursor-pair-getter)
    403419               (if (%mailbox-cursor-winding? mbc)
    404                    ;then unconditionally wait until something added
    405                    (values wait-mailbox-thread!
    406                            (lambda () (%mailbox-queue-last-pair mb)))
    407                    ;else grab the start of a, probably, non-empty queue
    408                    (values wait-mailbox-if-empty!
    409                            (lambda () (%mailbox-queue-first-pair mb))))
     420                 ;then unconditionally wait until something added
     421                 (values wait-mailbox-thread!
     422                         (lambda () (%mailbox-queue-last-pair mb)))
     423                 ;else grab the start of a, probably, non-empty queue
     424                 (values wait-mailbox-if-empty!
     425                         (lambda () (%mailbox-queue-first-pair mb))))
    410426      (let scanning ()
    411427        (let ((next-pair (%mailbox-cursor-next-pair mbc)))
    412428          ;Anything next?
    413429          (if (not (%null? next-pair))
    414               ;then peek into the queue for the next item
    415               (let ((item (%car next-pair)))
    416                 (%mailbox-cursor-prev-pair-set! mbc next-pair)
    417                 (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
    418                 item )
    419               ;else wait for something in the mailbox
    420               (let ((res (mailbox-waiter 'mailbox-cursor-next mb timout timout-value)))
    421                 (cond
    422                   ((or ($eq? MESSAGE-WAITING-TAG res) ;so continue scanning
    423                        ($eq? UNBLOCKED-TAG res))
    424                     (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    425                     (scanning) )
    426                   (else                               ;otherwise timed-out
    427                     res ) ) ) ) ) ) ) ) )
     430            ;then peek into the queue for the next item
     431            (let ((item (%car next-pair)))
     432              (%mailbox-cursor-prev-pair-set! mbc next-pair)
     433              (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
     434              item )
     435            ;else wait for something in the mailbox
     436            (let ((res (mailbox-waiter 'mailbox-cursor-next mb timout timout-value)))
     437              (cond
     438                ((or ($eq? MESSAGE-WAITING-TAG res) ;so continue scanning
     439                     ($eq? UNBLOCKED-TAG res))
     440                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
     441                  (scanning) )
     442                (else                               ;otherwise timed-out
     443                  res ) ) ) ) ) ) ) ) )
    428444
    429445(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
     
    439455        ;Anything next?
    440456        (if (not ($null? curr-pair))
    441             ;then peek into the queue for the next item
    442             (let ((item ($car curr-pair)))
    443               (%mailbox-cursor-prev-pair-set! mbc curr-pair)
    444               (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
    445               item )
    446             ;else wait for something in the mailbox
    447             (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
    448               (cond
    449                 (($eq? UNBLOCKED-TAG res) ;so continue scanning
    450                   (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
    451                   (scanning) )
    452                 (else                     ;some problem (timeout maybe)
    453                   res ) ) ) ) ) ) ) )
     457          ;then peek into the queue for the next item
     458          (let ((item ($car curr-pair)))
     459            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
     460            (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
     461            item )
     462          ;else wait for something in the mailbox
     463          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
     464            (cond
     465              (($eq? UNBLOCKED-TAG res) ;so continue scanning
     466                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
     467                (scanning) )
     468              (else                     ;some problem (timeout maybe)
     469                res ) ) ) ) ) ) ) )
    454470
    455471(define (mailbox-cursor-extract-and-rewind! mbc)
  • release/4/mailbox/trunk/mailbox.setup

    r34352 r34353  
    55(verify-extension-name 'mailbox)
    66
    7 (setup-shared-extension-module 'mailbox (extension-version "2.2.1")
     7(setup-shared-extension-module 'mailbox (extension-version "2.2.2")
    88  #:compile-options '(
    99    -scrutinize
  • release/4/mailbox/trunk/tests/reader-writer-test.scm

    r22517 r34353  
    1010(define-constant MESSAGE-LIMIT 5)
    1111
    12 (define-constant TIMEOUT #;0.5 0.25)
     12;(define-constant TIMEOUT 4)    ;slow but otherwise ok
     13;(define-constant TIMEOUT 0.5)
     14(define-constant TIMEOUT 0.25)
    1315
    1416(define (current-thread-name) (thread-name (current-thread)))
Note: See TracChangeset for help on using the changeset viewer.