Changeset 36201 in project


Ignore:
Timestamp:
08/12/18 01:01:58 (13 months ago)
Author:
Kon Lovett
Message:

C5 so explicit time-number (fix+float only), rel 3.0.1

Location:
release/5/mailbox
Files:
2 edited
7 copied

Legend:

Unmodified
Added
Removed
  • release/5/mailbox/tags/3.0.1/mailbox.egg

    r36192 r36201  
    44((synopsis "Thread-safe queues with timeout")
    55 (category hell)
    6  (version "3.0.0")
     6 (version "3.0.1")
    77 (author "[[felix winkelman]] and [[kon lovett]]")
    88 (license "BSD")
  • release/5/mailbox/tags/3.0.1/mailbox.scm

    r36192 r36201  
    1 ;;;; mailbox.scm
     1;;;; mailbox.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23;;;; Kon Lovett, Aug '17
    34;;;; Kon Lovett, Mar '09
     
    2627
    2728(declare
    28   (disable-interrupts) ;A MUST!
     29  (disable-interrupts) ;REQUIRED - see Issues above
    2930  (always-bound ##sys#primordial-thread)
    30   (bound-to-procedure
    31     ##sys#signal-hook
    32     ##sys#thread-unblock!) )
     31  (bound-to-procedure ##sys#signal-hook ##sys#thread-unblock!))
    3332
    3433(module mailbox
     
    6968  (only (srfi 1) append! delete! list-copy last-pair)
    7069  (only (srfi 18)
     70    time?
    7171    current-thread
    7272    thread-signal! thread-sleep!
    73     thread-suspend! thread-resume!
    74     time?)
     73    thread-suspend! thread-resume!)
    7574  (only type-errors define-error-type error-list)
    7675  (only condition-utils make-condition-predicate)
    7776  (only exn-condition make-exn-condition+)
    78   record-variants )
     77  record-variants)
    7978
    8079;;; Primitives
     
    135134
    136135(define-record-type-variant mailbox (unsafe unchecked inline)
    137   (%%make-mailbox nm qu wt)
     136  (%raw-make-mailbox nm qu wt)
    138137  %mailbox?
    139138  (nm %mailbox-name)
     
    142141
    143142(define-inline (%make-mailbox nm)
    144   (%%make-mailbox nm (%make-queue) '()) )
     143  (%raw-make-mailbox nm (%make-queue) '()) )
    145144
    146145(define-error-type mailbox)
     
    197196
    198197(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
    199   (%%make-mailbox-cursor np pp mb)
     198  (%raw-make-mailbox-cursor np pp mb)
    200199  %mailbox-cursor?
    201200  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
     
    204203
    205204(define-inline (%make-mailbox-cursor mb)
    206   (%%make-mailbox-cursor '() #f mb) )
     205  (%raw-make-mailbox-cursor '() #f mb) )
    207206
    208207(define-error-type mailbox-cursor)
     
    223222
    224223(define-inline (%mailbox-cursor-extract! mbc)
    225   ;Unless 'mailbox-cursor-next' has been called don't remove
     224  ;unless 'mailbox-cursor-next' has been called don't remove
    226225  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
    227226    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
     
    229228;; Time Support
    230229
    231 (define-type timeout (or number srfi-18-time))
     230(define-type time-number (or fixnum float))
     231
     232(define-inline (%time-number? obj)
     233  (or (fixnum? obj) (flonum? obj)) )
     234
     235(define-type timeout (or time-number srfi-18-time))
    232236
    233237(define-inline (%timeout? obj)
    234   (or (number? obj) (time? obj)) )
     238  (or (%time-number? obj) (time? obj)) )
    235239
    236240(define-error-type timeout)
     
    262266
    263267(define (ready-mailbox-thread! mb)
    264   ;Ready oldest waiting thread
     268  ;ready oldest waiting thread
    265269  (unless (%mailbox-waiters-empty? mb)
    266270    (let ((thread (%mailbox-waiters-pop! mb)))
    267       ;Ready the thread based on wait mode
     271      ;ready the thread based on wait mode
    268272      (if (not ($thread-blocked? thread))
    269273        (thread-resume! thread)
    270274        ;else wake early if sleeping
    271275        (when ($thread-blocked-for-timeout? thread)
    272           ;Ready the thread
     276          ;ready the thread
    273277          (##sys#thread-unblock! thread)
    274           ;Tell 'wait-mailbox-thread!' we unblocked early
     278          ;tell 'wait-mailbox-thread!' we unblocked early
    275279          (thread-signal! thread UNBLOCKED-TAG) ) ) )
    276280    (void) ) )
     
    281285(define (thread-sleep/maybe-unblock! tim unblocked-tag)
    282286;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
    283   ;Sleep current thread for desired seconds, unless unblocked "early".
     287  ;sleep current thread for desired seconds, unless unblocked "early".
    284288  (call/cc
    285289    (lambda (return)
     
    288292          (if ($eq? unblocked-tag exp)
    289293            (return #f)
    290             ;Propagate any "real" exception.
     294            ;propagate any "real" exception.
    291295            (signal exp) ) )
    292296        (lambda ()
     
    308312        SEQ-FAIL-TAG ) ) )
    309313  ;
    310   ;Push current thread on mailbox waiting queue
     314  ;push current thread on mailbox waiting queue
    311315  (%mailbox-waiters-add! mb ($current-thread))
    312   ;Waiting action
     316  ;waiting action
    313317  (cond
    314     ;Timeout wanted so sleep until something happens
     318    ;timeout wanted so sleep until something happens
    315319    (timout
    316320      (cond-expand
     
    319323          (cond
    320324            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
    321               ;Timed-out, so no message
    322               ;Remove from wait queue
     325              ;timed-out, so no message
     326              ;remove from wait queue
    323327              (%mailbox-waiters-delete! mb ($current-thread))
    324               ;Indicate no available message
     328              ;indicate no available message
    325329              (timeout-exit!) )
    326330            (else
    327               ;Unblocked early
     331              ;unblocked early
    328332              UNBLOCKED-TAG ) ) )
    329333        (else
     
    336340            (cond
    337341              ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
    338                 ;Timed-out, so no message
    339                 ;Remove from wait queue
     342                ;timed-out, so no message
     343                ;remove from wait queue
    340344                (%mailbox-waiters-delete! mb ($current-thread))
    341                 ;Indicate no available message
     345                ;indicate no available message
    342346                (timeout-exit!) )
    343347              (else
    344                 ;Unblocked early
     348                ;unblocked early
    345349                UNBLOCKED-TAG ) ) ) ) ) )
    346     ;No timeout so suspend until something delivered
     350    ;no timeout so suspend until something delivered
    347351    (else
    348352      (thread-suspend! ($current-thread))
    349       ;We're resumed
     353      ;we're resumed
    350354      UNBLOCKED-TAG ) ) )
    351355
     
    361365            ((%mailbox-queue-empty? _mb)
    362366              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
    363                 ;When a thread ready then check mailbox again, could be empty.
     367                ;when a thread ready then check mailbox again, could be empty.
    364368                (if ($eq? UNBLOCKED-TAG res)
    365369                  (waiting)
     
    515519    (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
    516520
    517 #; ;XXX
    518 (define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
    519   (%check-mailbox-cursor 'mailbox-cursor-next mbc)
    520   (when timout (%check-timeout 'mailbox-cursor-next timout))
    521   ;Waiting mailbox peek.
    522   (let ((mb (%mailbox-cursor-mailbox mbc)))
    523     (receive (mailbox-waiter cursor-pair-getter)
    524                (if (%mailbox-cursor-winding? mbc)
    525                  ;then unconditionally wait until something added
    526                  (values wait-mailbox-thread!
    527                          (lambda () (%mailbox-queue-last-pair mb)))
    528                  ;else grab the start of a, probably, non-empty queue
    529                  (values wait-mailbox-if-empty!
    530                          (lambda () (%mailbox-queue-first-pair mb))))
    531       (let scanning ()
    532         (let ((next-pair (%mailbox-cursor-next-pair mbc)))
    533           ;Anything next?
    534           (if (not (%null? next-pair))
    535             ;then peek into the queue for the next item
    536             (let ((item (%car next-pair)))
    537               (%mailbox-cursor-prev-pair-set! mbc next-pair)
    538               (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
    539               item )
    540             ;else wait for something in the mailbox
    541             (let ((res (mailbox-waiter 'mailbox-cursor-next mb timout timout-value)))
    542               (cond
    543                 ;continue scanning?
    544                 ((or ($eq? MESSAGE-WAITING-TAG res)
    545                      ($eq? UNBLOCKED-TAG res))
    546                   (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    547                   (scanning) )
    548                 ;otherwise timed-out
    549                 (else
    550                   res ) ) ) ) ) ) ) ) )
    551 
    552521(: mailbox-cursor-next (mailbox-cursor #!optional timeout * -> *))
    553522;
     
    555524  (when timout (%check-timeout 'mailbox-cursor-next timout))
    556525  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
    557     ;Seed rewound cursor
     526    ;seed rewound cursor
    558527    (unless (%mailbox-cursor-winding? mbc)
    559528      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
    560     ;Pull next item from queue at cursor
     529    ;pull next item from queue at cursor
    561530    (let scanning ()
    562531      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
    563         ;Anything next?
     532        ;anything next?
    564533        (if (not ($null? curr-pair))
    565534          ;then peek into the queue for the next item
  • release/5/mailbox/trunk/mailbox.egg

    r36192 r36201  
    44((synopsis "Thread-safe queues with timeout")
    55 (category hell)
    6  (version "3.0.0")
     6 (version "3.0.1")
    77 (author "[[felix winkelman]] and [[kon lovett]]")
    88 (license "BSD")
  • release/5/mailbox/trunk/mailbox.scm

    r36192 r36201  
    1 ;;;; mailbox.scm
     1;;;; mailbox.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Jul '18
    23;;;; Kon Lovett, Aug '17
    34;;;; Kon Lovett, Mar '09
     
    2627
    2728(declare
    28   (disable-interrupts) ;A MUST!
     29  (disable-interrupts) ;REQUIRED - see Issues above
    2930  (always-bound ##sys#primordial-thread)
    30   (bound-to-procedure
    31     ##sys#signal-hook
    32     ##sys#thread-unblock!) )
     31  (bound-to-procedure ##sys#signal-hook ##sys#thread-unblock!))
    3332
    3433(module mailbox
     
    6968  (only (srfi 1) append! delete! list-copy last-pair)
    7069  (only (srfi 18)
     70    time?
    7171    current-thread
    7272    thread-signal! thread-sleep!
    73     thread-suspend! thread-resume!
    74     time?)
     73    thread-suspend! thread-resume!)
    7574  (only type-errors define-error-type error-list)
    7675  (only condition-utils make-condition-predicate)
    7776  (only exn-condition make-exn-condition+)
    78   record-variants )
     77  record-variants)
    7978
    8079;;; Primitives
     
    135134
    136135(define-record-type-variant mailbox (unsafe unchecked inline)
    137   (%%make-mailbox nm qu wt)
     136  (%raw-make-mailbox nm qu wt)
    138137  %mailbox?
    139138  (nm %mailbox-name)
     
    142141
    143142(define-inline (%make-mailbox nm)
    144   (%%make-mailbox nm (%make-queue) '()) )
     143  (%raw-make-mailbox nm (%make-queue) '()) )
    145144
    146145(define-error-type mailbox)
     
    197196
    198197(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
    199   (%%make-mailbox-cursor np pp mb)
     198  (%raw-make-mailbox-cursor np pp mb)
    200199  %mailbox-cursor?
    201200  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
     
    204203
    205204(define-inline (%make-mailbox-cursor mb)
    206   (%%make-mailbox-cursor '() #f mb) )
     205  (%raw-make-mailbox-cursor '() #f mb) )
    207206
    208207(define-error-type mailbox-cursor)
     
    223222
    224223(define-inline (%mailbox-cursor-extract! mbc)
    225   ;Unless 'mailbox-cursor-next' has been called don't remove
     224  ;unless 'mailbox-cursor-next' has been called don't remove
    226225  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
    227226    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
     
    229228;; Time Support
    230229
    231 (define-type timeout (or number srfi-18-time))
     230(define-type time-number (or fixnum float))
     231
     232(define-inline (%time-number? obj)
     233  (or (fixnum? obj) (flonum? obj)) )
     234
     235(define-type timeout (or time-number srfi-18-time))
    232236
    233237(define-inline (%timeout? obj)
    234   (or (number? obj) (time? obj)) )
     238  (or (%time-number? obj) (time? obj)) )
    235239
    236240(define-error-type timeout)
     
    262266
    263267(define (ready-mailbox-thread! mb)
    264   ;Ready oldest waiting thread
     268  ;ready oldest waiting thread
    265269  (unless (%mailbox-waiters-empty? mb)
    266270    (let ((thread (%mailbox-waiters-pop! mb)))
    267       ;Ready the thread based on wait mode
     271      ;ready the thread based on wait mode
    268272      (if (not ($thread-blocked? thread))
    269273        (thread-resume! thread)
    270274        ;else wake early if sleeping
    271275        (when ($thread-blocked-for-timeout? thread)
    272           ;Ready the thread
     276          ;ready the thread
    273277          (##sys#thread-unblock! thread)
    274           ;Tell 'wait-mailbox-thread!' we unblocked early
     278          ;tell 'wait-mailbox-thread!' we unblocked early
    275279          (thread-signal! thread UNBLOCKED-TAG) ) ) )
    276280    (void) ) )
     
    281285(define (thread-sleep/maybe-unblock! tim unblocked-tag)
    282286;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
    283   ;Sleep current thread for desired seconds, unless unblocked "early".
     287  ;sleep current thread for desired seconds, unless unblocked "early".
    284288  (call/cc
    285289    (lambda (return)
     
    288292          (if ($eq? unblocked-tag exp)
    289293            (return #f)
    290             ;Propagate any "real" exception.
     294            ;propagate any "real" exception.
    291295            (signal exp) ) )
    292296        (lambda ()
     
    308312        SEQ-FAIL-TAG ) ) )
    309313  ;
    310   ;Push current thread on mailbox waiting queue
     314  ;push current thread on mailbox waiting queue
    311315  (%mailbox-waiters-add! mb ($current-thread))
    312   ;Waiting action
     316  ;waiting action
    313317  (cond
    314     ;Timeout wanted so sleep until something happens
     318    ;timeout wanted so sleep until something happens
    315319    (timout
    316320      (cond-expand
     
    319323          (cond
    320324            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
    321               ;Timed-out, so no message
    322               ;Remove from wait queue
     325              ;timed-out, so no message
     326              ;remove from wait queue
    323327              (%mailbox-waiters-delete! mb ($current-thread))
    324               ;Indicate no available message
     328              ;indicate no available message
    325329              (timeout-exit!) )
    326330            (else
    327               ;Unblocked early
     331              ;unblocked early
    328332              UNBLOCKED-TAG ) ) )
    329333        (else
     
    336340            (cond
    337341              ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
    338                 ;Timed-out, so no message
    339                 ;Remove from wait queue
     342                ;timed-out, so no message
     343                ;remove from wait queue
    340344                (%mailbox-waiters-delete! mb ($current-thread))
    341                 ;Indicate no available message
     345                ;indicate no available message
    342346                (timeout-exit!) )
    343347              (else
    344                 ;Unblocked early
     348                ;unblocked early
    345349                UNBLOCKED-TAG ) ) ) ) ) )
    346     ;No timeout so suspend until something delivered
     350    ;no timeout so suspend until something delivered
    347351    (else
    348352      (thread-suspend! ($current-thread))
    349       ;We're resumed
     353      ;we're resumed
    350354      UNBLOCKED-TAG ) ) )
    351355
     
    361365            ((%mailbox-queue-empty? _mb)
    362366              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
    363                 ;When a thread ready then check mailbox again, could be empty.
     367                ;when a thread ready then check mailbox again, could be empty.
    364368                (if ($eq? UNBLOCKED-TAG res)
    365369                  (waiting)
     
    515519    (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
    516520
    517 #; ;XXX
    518 (define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
    519   (%check-mailbox-cursor 'mailbox-cursor-next mbc)
    520   (when timout (%check-timeout 'mailbox-cursor-next timout))
    521   ;Waiting mailbox peek.
    522   (let ((mb (%mailbox-cursor-mailbox mbc)))
    523     (receive (mailbox-waiter cursor-pair-getter)
    524                (if (%mailbox-cursor-winding? mbc)
    525                  ;then unconditionally wait until something added
    526                  (values wait-mailbox-thread!
    527                          (lambda () (%mailbox-queue-last-pair mb)))
    528                  ;else grab the start of a, probably, non-empty queue
    529                  (values wait-mailbox-if-empty!
    530                          (lambda () (%mailbox-queue-first-pair mb))))
    531       (let scanning ()
    532         (let ((next-pair (%mailbox-cursor-next-pair mbc)))
    533           ;Anything next?
    534           (if (not (%null? next-pair))
    535             ;then peek into the queue for the next item
    536             (let ((item (%car next-pair)))
    537               (%mailbox-cursor-prev-pair-set! mbc next-pair)
    538               (%mailbox-cursor-next-pair-set! mbc (%cdr next-pair))
    539               item )
    540             ;else wait for something in the mailbox
    541             (let ((res (mailbox-waiter 'mailbox-cursor-next mb timout timout-value)))
    542               (cond
    543                 ;continue scanning?
    544                 ((or ($eq? MESSAGE-WAITING-TAG res)
    545                      ($eq? UNBLOCKED-TAG res))
    546                   (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    547                   (scanning) )
    548                 ;otherwise timed-out
    549                 (else
    550                   res ) ) ) ) ) ) ) ) )
    551 
    552521(: mailbox-cursor-next (mailbox-cursor #!optional timeout * -> *))
    553522;
     
    555524  (when timout (%check-timeout 'mailbox-cursor-next timout))
    556525  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
    557     ;Seed rewound cursor
     526    ;seed rewound cursor
    558527    (unless (%mailbox-cursor-winding? mbc)
    559528      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
    560     ;Pull next item from queue at cursor
     529    ;pull next item from queue at cursor
    561530    (let scanning ()
    562531      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
    563         ;Anything next?
     532        ;anything next?
    564533        (if (not ($null? curr-pair))
    565534          ;then peek into the queue for the next item
Note: See TracChangeset for help on using the changeset viewer.