Changeset 39716 in project


Ignore:
Timestamp:
03/15/21 05:15:31 (3 months ago)
Author:
Kon Lovett
Message:

queue depth limit (wip)

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

Legend:

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

    r39710 r39716  
    1414(define queue 'queue)
    1515(define-record-type-variant queue (unsafe unchecked inline)
    16   (%make-queue ln hd tl)
     16  (%make-queue lm ln hd tl)
    1717  (%queue?)
     18  (lm %queue-limit %queue-limit-set!)
    1819  (ln %queue-count %queue-count-set!)
    1920  (hd %queue-first-pair %queue-first-pair-set!)
    2021  (tl %queue-last-pair %queue-last-pair-set!) )
    2122
    22 (define-inline (%queue-count-inc! q) (%queue-count-set! q (add1 (%queue-count q))))
    23 (define-inline (%queue-count-dec! q) (%queue-count-set! q (sub1 (%queue-count q))))
     23(define-constant QUEUE-UNLIMITED -1)
     24(define-constant QUEUE-UNBUFFERED 0)
    2425
    25 (define-inline (%make-empty-queue) (%make-queue 0 '() '()))
     26(define-inline (%queue-count-inc! q) (%queue-count-set! q (fx+ 1 (%queue-count q))))
     27(define-inline (%queue-count-dec! q) (%queue-count-set! q (fx- 1 (%queue-count q))))
    2628
    27 (define-inline (%queue-empty? q) (zero? (%queue-count q)))
     29(define-inline (%make-empty-queue #!optional (lm QUEUE-UNLIMITED))
     30  (%make-queue lm 0 '() '()) )
     31
     32(define-inline (%queue-room q)
     33  (fx- (%queue-limit q) (%queue-count q)) )
     34
     35(define-inline (%queue-full? q)
     36  (and
     37    (not (fx= QUEUE-UNLIMITED (%queue-limit q)))
     38    (if (fx= QUEUE-UNBUFFERED (%queue-limit q))
     39      (fx= (%queue-count q) 1)
     40      (fx= (%queue-count q) (%queue-limit q)) ) ) )
     41
     42(define-inline (%queue-room? q rq)
     43  (or
     44    (fx= QUEUE-UNLIMITED (%queue-limit q))
     45    (if (fx= QUEUE-UNBUFFERED (%queue-limit q))
     46      (and (fx= (%queue-count q) 0) (fx= rq 1))
     47      (fx<= rq (%queue-room q)) ) ) )
     48
     49(define-inline (%queue-empty? q)
     50  (fx= 0 (%queue-count q)) )
    2851
    2952;; Operations
    3053
    31 (define-inline (%queue-last-pair-empty! q) (%queue-last-pair-set! q '()))
    32 
    33 (define-inline (%queue-add! q datum)
    34   (let ((new-pair (cons datum '())))
    35     (if (null? (%queue-first-pair q))
    36       (%queue-first-pair-set! q new-pair)
    37       (set-cdr! (%queue-last-pair q) new-pair) )
    38     (%queue-last-pair-set! q new-pair) )
    39   (%queue-count-inc! q) )
     54(define-inline (%queue-add! q item)
     55  (if (%queue-full? q)
     56    (warning 'queue-add! "queue full")
     57    (let ((new-pair (cons item '())))
     58      (if (null? (%queue-first-pair q))
     59        (%queue-first-pair-set! q new-pair)
     60        (set-cdr! (%queue-last-pair q) new-pair) )
     61      (%queue-last-pair-set! q new-pair)
     62      (%queue-count-inc! q) ) ) )
    4063
    4164(define-inline (%queue-remove! q)
    42   (let* ((first-pair (%queue-first-pair q))
    43          (next-pair (cdr first-pair)))
    44     (%queue-first-pair-set! q next-pair)
    45     (when (null? next-pair) (%queue-last-pair-empty! q))
    46     (%queue-count-dec! q)
    47     (car first-pair) ) )
     65  (if (%queue-empty? q)
     66    (warning 'queue-remove! "queue empty")
     67    (let* ((first-pair (%queue-first-pair q))
     68           (next-pair (cdr first-pair)))
     69      (%queue-first-pair-set! q next-pair)
     70      (when (null? next-pair) (%queue-last-pair-set! q '()))
     71      (%queue-count-dec! q)
     72      (car first-pair) ) ) )
    4873
    4974(define-inline (%queue-push-back! q item)
    50   (let ((newlist (cons item (%queue-first-pair q))))
    51     (%queue-first-pair-set! q newlist)
    52     (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) )
    53   (%queue-count-inc! q) )
     75  (if (%queue-full? q)
     76    (warning 'queue-push-back! "queue full")
     77    (let ((newlist (cons item (%queue-first-pair q))))
     78      (%queue-first-pair-set! q newlist)
     79      (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) )
     80      (%queue-count-inc! q) ) ) )
    5481
    5582(define-inline (%queue-push-back-list! q itemlist)
    56   (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
    57     (%queue-first-pair-set! q newlist)
    58     (if (null? newlist)
    59       (%queue-last-pair-empty! q)
    60       (%queue-last-pair-set! q (last-pair newlist) ) ) )
    61   (%queue-count-set! q (+ (length itemlist) (%queue-count q))) )
     83  (if (not (%queue-room? q (length itemlist)))
     84    (warning 'queue-push-back-list! "queue short" (%queue-room q))
     85    (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
     86      (%queue-first-pair-set! q newlist)
     87      (if (null? newlist)
     88        (%queue-last-pair-set! q '())
     89        (%queue-last-pair-set! q (last-pair newlist) ) )
     90      (%queue-count-set! q (+ (length itemlist) (%queue-count q))) ) ) )
    6291
    6392(define-inline (%queue-extract-pair! q targ-pair)
     
    79108            (set-cdr! prev-pair next-pair) )
    80109          ;when the cut pair is the last item update the last pair ref.
    81           (when (eq? this-pair (%queue-last-pair q))
    82             (%queue-last-pair-set! q prev-pair)) )
    83         (%queue-count-dec! q) )
     110          (when (eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair))
     111          (%queue-count-dec! q) ) )
    84112      ;not found
    85113      (else
  • release/5/mailbox/trunk/mailbox.scm

    r39702 r39716  
    3838  ;Mailbox API
    3939  make-mailbox
     40  make-limited-mailbox
    4041  mailbox?
    4142  mailbox-name
    4243  mailbox-empty?
    4344  mailbox-count
     45  mailbox-limit
    4446  mailbox-waiting?
    4547  mailbox-waiters
     
    6163(import scheme
    6264  (chicken base)
     65  (chicken fixnum)
    6366  (chicken syntax)
    6467  (chicken condition)
     
    7376    thread-signal! thread-sleep!
    7477    thread-suspend! thread-resume!))
     78
     79;;; Typoes
     80
     81(define-type srfi-18-time   (struct time))
     82(define-type mailbox        (struct mailbox))
     83(define-type mailbox-cursor (struct mailbox-cursor))
     84(define-type time-number    (or fixnum float))
     85(define-type timeout        (or time-number srfi-18-time))
     86(define-type unique-object  (vector-of symbol))
     87
     88(: mailbox-timeout-condition?         (* -> boolean : condition))
     89(: make-mailbox                       (#!optional * -> mailbox))
     90(: make-limited-mailbox               (#!optional (or boolean fixnum) * -> mailbox))
     91(: mailbox?                           (* -> boolean : mailbox))
     92(: mailbox-name                       (mailbox --> *))
     93(: mailbox-empty?                     (mailbox -> boolean))
     94(: mailbox-count                      (mailbox -> fixnum))
     95(: mailbox-limit                      (mailbox -> fixnum))
     96(: mailbox-waiting?                   (mailbox -> boolean))
     97(: mailbox-waiters                    (mailbox -> list))
     98(: mailbox-send!                      (mailbox * -> void))
     99(: mailbox-wait!                      (mailbox #!optional timeout -> void))
     100(: mailbox-receive!                   (mailbox #!optional timeout * -> *))
     101(: mailbox-push-back!                 (mailbox * -> void))
     102(: mailbox-push-back-list!            (mailbox list -> void))
     103(: make-mailbox-cursor                (mailbox -> mailbox-cursor))
     104(: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
     105(: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
     106(: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
     107(: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
     108(: mailbox-cursor-rewind              (mailbox-cursor -> void))
     109(: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
     110(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
    75111
    76112;;; Support
     
    218254(include-relative "inline-queue")
    219255
    220 ;;; Typoes
    221 
    222 (define-type srfi-18-time   (struct time))
    223 (define-type mailbox        (struct mailbox))
    224 (define-type mailbox-cursor (struct mailbox-cursor))
    225 (define-type time-number    (or fixnum float))
    226 (define-type timeout        (or time-number srfi-18-time))
    227 (define-type unique-object  (vector-of symbol))
    228 
    229 (: mailbox-timeout-condition?         (* -> boolean : condition))
    230 (: make-mailbox                       (#!optional * -> mailbox))
    231 (: mailbox?                           (* -> boolean : mailbox))
    232 (: mailbox-name                       (mailbox --> *))
    233 (: mailbox-empty?                     (mailbox -> boolean))
    234 (: mailbox-count                      (mailbox -> fixnum))
    235 (: mailbox-waiting?                   (mailbox -> boolean))
    236 (: mailbox-waiters                    (mailbox -> list))
    237 (: mailbox-send!                      (mailbox * -> void))
    238 (: mailbox-wait!                      (mailbox #!optional timeout -> void))
    239 (: mailbox-receive!                   (mailbox #!optional timeout * -> *))
    240 (: mailbox-push-back!                 (mailbox * -> void))
    241 (: mailbox-push-back-list!            (mailbox list -> void))
    242 (: make-mailbox-cursor                (mailbox -> mailbox-cursor))
    243 (: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
    244 (: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
    245 (: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
    246 (: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
    247 (: mailbox-cursor-rewind              (mailbox-cursor -> void))
    248 (: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
    249 (: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
    250 
    251256;;; Mailbox
    252257
     
    260265  (wt %mailbox-waiters %mailbox-waiters-set!) )
    261266
    262 (define-inline (%make-mailbox nm)
    263   (%raw-make-mailbox nm (%make-empty-queue) '()) )
     267(define-inline (%make-mailbox nm lm)
     268  (%raw-make-mailbox nm (%make-empty-queue lm) '()) )
    264269
    265270(define (error-mailbox loc obj #!optional argnam)
     
    281286(define-inline (%mailbox-queue-count mb)
    282287  (%queue-count (%mailbox-queue mb)) )
     288
     289(define-inline (%mailbox-queue-limit mb)
     290  (%queue-limit (%mailbox-queue mb)) )
    283291
    284292(define-inline (%mailbox-queue-add! mb x)
     
    475483(define-syntax on-mailbox-available
    476484  (syntax-rules ()
    477     ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
     485    ((on-mailbox-available ?loc ?mb ?timout ?timout-value ?expr0 ...)
    478486      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
    479487        (let waiting ()
     
    506514;; Mailbox Constructor
    507515
     516(define (make-limited-mailbox #!optional lm (nm (gensym 'mailbox)))
     517  (%make-mailbox nm
     518    (cond
     519      ((not lm)     QUEUE-UNBUFFERED)
     520      ((fixnum? lm) lm)
     521      (else         QUEUE-UNLIMITED))) )
     522
    508523(define (make-mailbox #!optional (nm (gensym 'mailbox)))
    509   (%make-mailbox nm) )
     524  (make-limited-mailbox #t nm) )
    510525
    511526(define (mailbox? obj)
     
    522537(define (mailbox-count mb)
    523538  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
     539
     540(define (mailbox-limit mb)
     541  (%mailbox-queue-limit (%check-mailbox 'mailbox-count mb)) )
    524542
    525543(define (mailbox-waiting? mb)
     
    564582  (with-output-to-port out
    565583    (lambda ()
    566       (printf "#<mailbox ~A queued: ~A waiters: ~A>"
     584      (printf "#<mailbox ~A queued: ~A waiters: ~A limit: ~A>"
    567585        (%mailbox-name mb)
    568586        (%mailbox-queue-count mb)
    569         (%mailbox-waiters-count mb)) ) ) )
     587        (%mailbox-waiters-count mb)
     588        (%mailbox-queue-limit mb)) ) ) )
    570589
    571590;;; Mailbox Cursor
Note: See TracChangeset for help on using the changeset viewer.