Changeset 39721 in project


Ignore:
Timestamp:
03/16/21 17:28:56 (5 weeks ago)
Author:
Kon Lovett
Message:

queue depth limit cursor (wip, limited/unbuffered tbd)

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

Legend:

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

    r39720 r39721  
    44;; Issues
    55;;
    6 ;; - Requires (only record-variants define-record-type-variant)
    7 ;; & (include "chicken-primitive-object-inlines")
     6;; - Uses (chicken fixnum) & (only record-variants define-record-type-variant)
    87
    98;; Queue Unlimited
     
    3130(define-inline (%queue-unlimited-count-sub! q n)
    3231  (%queue-unlimited-count-set! q (fx- (%queue-unlimited-count q) n)) )
    33 
    34 (define-inline (%queue-unlimited-count-inc! q) (%queue-unlimited-count-add! q 1))
    35 (define-inline (%queue-unlimited-count-dec! q) (%queue-unlimited-count-sub! q 1))
    36 
    37 (define-inline (%queue-unlimited-room q) most-positive-fixnum)
    3832
    3933(define-inline (%queue-unlimited-extract-pair! q targ-pair)
     
    5751          (when (eq? this-pair (%queue-unlimited-last-pair q))
    5852            (%queue-unlimited-last-pair-set! q prev-pair) )
    59           (%queue-unlimited-count-dec! q) ) )
     53          (%queue-unlimited-count-sub! q 1) ) )
    6054      ;not found
    6155      (else
     
    6862      (set-cdr! (%queue-unlimited-last-pair q) new-pair) )
    6963    (%queue-unlimited-last-pair-set! q new-pair)
    70     (%queue-unlimited-count-inc! q)) )
     64    (%queue-unlimited-count-add! q 1)) )
    7165
    7266(define-inline (%queue-unlimited-remove! q)
     
    7569    (%queue-unlimited-first-pair-set! q next-pair)
    7670    (when (null? next-pair) (%queue-unlimited-last-pair-set! q '()))
    77     (%queue-unlimited-count-dec! q)
     71    (%queue-unlimited-count-sub! q 1)
    7872    (car first-pair) ) )
    7973
     
    8377    (when (null? (%queue-unlimited-last-pair q))
    8478      (%queue-unlimited-last-pair-set! q newlist) )
    85     (%queue-unlimited-count-inc! q) ) )
     79    (%queue-unlimited-count-add! q 1) ) )
    8680
    8781(define-inline (%queue-unlimited-push-back-list! q ls)
     
    106100  (null? (%queue-unlimited-cursor-next-pair c)) )
    107101
     102(define-inline (%queue-unlimited-cursor-start! q c)
     103  ;(%queue-unlimited-cursor-prev-pair-set! c #f)
     104  (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-first-pair q)) )
     105
     106;#!eof | *
     107(define-inline (%queue-unlimited-cursor-next! q c)
     108  (let ((curr-pair (%queue-unlimited-cursor-next-pair c)))
     109    ;anything next?
     110    (if (null? curr-pair)
     111      #!eof
     112      ;then peek into the queue for the next item
     113      (let ((item (car curr-pair)))
     114        (%queue-unlimited-cursor-prev-pair-set! c curr-pair)
     115        (%queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
     116        item ) ) ) )
     117
     118(define-inline (%queue-unlimited-cursor-continue! q c)
     119  ;NOTE assumes 1 next item, so prev-pair is still correct
     120  (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-last-pair q)) )
     121
    108122(define-inline (%queue-unlimited-cursor-rewind! q c)
    109   (%queue-unlimited-cursor-next-pair-set! c '())
    110   (%queue-unlimited-cursor-prev-pair-set! c #f) )
     123  (%queue-unlimited-cursor-prev-pair-set! c #f)
     124  (%queue-unlimited-cursor-next-pair-set! c '()) )
    111125
    112126(define-inline (%queue-unlimited-cursor-extract! q c)
     
    181195  (error '%queue-limited-push-back-list! "unsupported" q ls) )
    182196
    183 (define-inline (%queue-limited-extract-target! q targ)
    184   (void) )
     197(define-inline (%make-queue-limited-cursor) (void))
     198(define-inline (%queue-limited-cursor? c) #f)
     199
     200(define-inline (%queue-limited-cursor-winding? q c)
     201  (error '%queue-limited-cursor-winding? "unsupported" q c) )
     202
     203(define (%queue-limited-cursor-unwound? q c)
     204  (error '%queue-limited-cursor-unwound? "unsupported" q c) )
     205
     206(define-inline (%queue-limited-cursor-start! q c)
     207  (error '%queue-limited-cursor-start! "unsupported" q c) )
     208
     209;#!eof | *
     210(define-inline (%queue-limited-cursor-next! q c)
     211  (error '%queue-limited-cursor-next! "unsupported" q c) )
     212
     213(define-inline (%queue-limited-cursor-continue! q c)
     214  (error '%queue-limited-cursor-continue! "unsupported" q c) )
     215
     216(define-inline (%queue-limited-cursor-rewind! q c)
     217  (error '%queue-limited-cursor-rewind! "unsupported" q c) )
     218
     219(define-inline (%queue-limited-cursor-extract! q c)
     220  (error '%queue-limited-cursor-extract! "unsupported" q c) )
    185221
    186222;; Queue Unbuffered
     
    225261  (%queue-unbuffered-add! q (car ls)) )
    226262
    227 (define-inline (%queue-unbuffered-extract-target! q targ)
    228   (void) )
     263(define-inline (%make-queue-unbuffered-cursor) (void))
     264(define-inline (%queue-unbuffered-cursor? c) #f)
     265
     266(define-inline (%queue-unbuffered-cursor-winding? q c)
     267  (error '%queue-unbuffered-cursor-winding? "unsupported" q c) )
     268
     269(define (%queue-unbuffered-cursor-unwound? q c)
     270  (error '%queue-unbuffered-cursor-unwound? "unsupported" q c) )
     271
     272(define-inline (%queue-unbuffered-cursor-start! q c)
     273  (error '%queue-unbuffered-cursor-start! "unsupported" q c) )
     274
     275;#!eof | *
     276(define-inline (%queue-unbuffered-cursor-next! q c)
     277  (error '%queue-unbuffered-cursor-next! "unsupported" q c) )
     278
     279(define-inline (%queue-unbuffered-cursor-continue! q c)
     280  (error '%queue-unbuffered-cursor-continue! "unsupported" q c) )
     281
     282(define-inline (%queue-unbuffered-cursor-rewind! q c)
     283  (error '%queue-unbuffered-cursor-rewind! "unsupported" q c) )
     284
     285(define-inline (%queue-unbuffered-cursor-extract! q c)
     286  (error '%queue-unbuffered-cursor-extract! "unsupported" q c) )
    229287
    230288;; Queue Generic
     
    285343(define (queue-full-error loc q v) (error loc "queue full" q v))
    286344
     345(define-inline (%queue-add!? q v)
     346  (if (%queue-full? q)
     347    (values #f (void))
     348    (values #t
     349      (cond
     350        ((%queue-unlimited? q)  (%queue-unlimited-add! q v))
     351        ((%queue-limited? q)    (%queue-limited-add! q v))
     352        (else                   (%queue-unbuffered-add! q v)))) ) )
     353
     354(define-inline (%queue-remove!? q)
     355  (if (%queue-empty? q)
     356    (values #f (void))
     357    (values #t
     358      (cond
     359        ((%queue-unlimited? q)  (%queue-unlimited-remove! q))
     360        ((%queue-limited? q)    (%queue-limited-remove! q))
     361        (else                   (%queue-unbuffered-remove! q)))) ) )
     362
     363(define-inline (%queue-push-back!? q v)
     364  (if (%queue-full? q)
     365    (values #f (void))
     366    (values #t
     367      (cond
     368        ((%queue-unlimited? q)  (%queue-unlimited-push-back! q v))
     369        ((%queue-limited? q)    (%queue-limited-push-back! q v))
     370        (else                   (%queue-unbuffered-push-back! q v)))) ) )
     371
     372(define-inline (%queue-push-back-list!? q ls)
     373  (if (%queue-full? q (length ls))
     374    (values #f (void))
     375    (values #t
     376      (cond
     377        ((%queue-unlimited? q)  (%queue-unlimited-push-back-list! q ls))
     378        ((%queue-limited? q)    (%queue-limited-push-back-list! q ls))
     379        (else                   (%queue-unbuffered-push-back-list! q ls)))) ) )
     380
    287381(define-inline (%queue-add! q v
    288382                  #!optional
    289383                  (on-full (lambda () (queue-full-error '%queue-add! q v))))
    290   (cond
    291     ((%queue-full? q)
    292       (on-full))
    293     ((%queue-unlimited? q)  (%queue-unlimited-add! q v))
    294     ((%queue-limited? q)    (%queue-limited-add! q v))
    295     (else                   (%queue-unbuffered-add! q v)) ) )
     384  (let loop ()
     385    (let-values (((succ? val) (%queue-add!? q v)))
     386      (unless succ?
     387        (on-full)
     388        (loop) ) ) ) )
    296389
    297390(define-inline (%queue-remove! q
    298391                  #!optional
    299392                  (on-empty (lambda () (queue-empty-error '%queue-remove! q))))
    300   (cond
    301     ((%queue-empty? q)
    302       (on-empty))
    303     ((%queue-unlimited? q)  (%queue-unlimited-remove! q))
    304     ((%queue-limited? q)    (%queue-limited-remove! q))
    305     (else                   (%queue-unbuffered-remove! q)) ) )
     393  (let loop ()
     394    (let-values (((succ? val) (%queue-remove!? q)))
     395      (unless succ?
     396        (on-empty)
     397        (loop) ) ) ) )
    306398
    307399(define-inline (%queue-push-back! q v
    308400                  #!optional
    309401                  (on-full (lambda () (queue-full-error '%queue-push-back! q v))))
    310   (cond
    311     ((%queue-full? q)
    312       (on-full))
    313     ((%queue-unlimited? q)  (%queue-unlimited-push-back! q v))
    314     ((%queue-limited? q)    (%queue-limited-push-back! q v))
    315     (else                   (%queue-unbuffered-push-back! q v)) ) )
     402  (let loop ()
     403    (let-values (((succ? val) (%queue-push-back!? q v)))
     404      (unless succ?
     405        (on-full)
     406        (loop) ) ) ) )
    316407
    317408(define-inline (%queue-push-back-list! q ls
    318409                  #!optional
    319410                  (on-full (lambda () (queue-full-error '%queue-push-back-list! q ls))))
    320   (cond
    321     ((%queue-full? q (length ls))
    322       (on-full))
    323     ((%queue-unlimited? q)  (%queue-unlimited-push-back-list! q ls))
    324     ((%queue-limited? q)    (%queue-limited-push-back-list! q ls))
    325     (else                   (%queue-unbuffered-push-back-list! q ls)) ) )
    326 
    327 ;;FIXME should be Queue Cursor
     411  (let loop ()
     412    (let-values (((succ? val) (%queue-push-back-list!? q ls)))
     413      (unless succ?
     414        (on-full)
     415        (loop) ) ) ) )
    328416
    329417(define-inline (%make-queue-cursor q)
    330418  (cond
    331     ((%queue-unlimited? q) (%make-queue-unlimited-cursor)) ) )
     419    ((%queue-unlimited? q)  (%make-queue-unlimited-cursor))
     420    ((%queue-limited? q)    (%make-queue-limited-cursor))
     421    (else                   (%make-queue-unbuffered-cursor)) ) )
    332422
    333423(define-inline (%queue-cursor-winding? q c)
    334424  (cond
    335     ((%queue-unlimited? q) (%queue-unlimited-cursor-winding? q c)) ) )
     425    ((%queue-unlimited? q)  (%queue-unlimited-cursor-winding? q c))
     426    ((%queue-limited? q)    (%queue-limited-cursor-winding? q c))
     427    (else                   (%queue-unbuffered-cursor-winding? q c)) ) )
    336428
    337429(define (%queue-cursor-unwound? q c)
    338430  (cond
    339     ((%queue-unlimited? q) (%queue-unlimited-cursor-unwound? q c)) ) )
     431    ((%queue-unlimited? q)  (%queue-unlimited-cursor-unwound? q c))
     432    ((%queue-limited? q)    (%queue-limited-cursor-unwound? q c))
     433    (else                   (%queue-unbuffered-cursor-unwound? q c)) ) )
    340434
    341435(define-inline (%queue-cursor-rewind! q c)
    342436  (cond
    343     ((%queue-unlimited? q) (%queue-unlimited-cursor-rewind! q c)) ) )
     437    ((%queue-unlimited? q)  (%queue-unlimited-cursor-rewind! q c))
     438    ((%queue-limited? q)    (%queue-limited-cursor-rewind! q c))
     439    (else                   (%queue-unbuffered-cursor-rewind! q c)) ) )
     440
     441(define-inline (%queue-cursor-start! q c)
     442  (cond
     443    ((%queue-unlimited? q)  (%queue-unlimited-cursor-start! q c))
     444    ((%queue-limited? q)    (%queue-limited-cursor-start! q c))
     445    (else                   (%queue-unbuffered-cursor-start! q c)) ))
     446
     447;#!eof | *
     448(define-inline (%queue-cursor-next! q c)
     449 (cond
     450    ((%queue-unlimited? q)  (%queue-unlimited-cursor-next! q c))
     451    ((%queue-limited? q)    (%queue-limited-cursor-next! q c))
     452    (else                   (%queue-unbuffered-cursor-next! q c)) ))
     453
     454(define-inline (%queue-cursor-continue! q c)
     455 (cond
     456    ((%queue-unlimited? q)  (%queue-unlimited-cursor-continue! q c))
     457    ((%queue-limited? q)    (%queue-limited-cursor-continue! q c))
     458    (else                   (%queue-unbuffered-cursor-continue! q c)) ))
    344459
    345460(define-inline (%queue-cursor-extract! q c)
    346461  (cond
    347     ((%queue-unlimited? q) (%queue-unlimited-cursor-extract! q c)) ) )
     462    ((%queue-unlimited? q)  (%queue-unlimited-cursor-extract! q c))
     463    ((%queue-limited? q)    (%queue-limited-cursor-extract! q c))
     464    (else                   (%queue-unbuffered-cursor-extract! q c)) ) )
  • release/5/mailbox/trunk/mailbox.scm

    r39720 r39721  
    631631    ;seed rewound cursor
    632632    (unless (%queue-cursor-winding? q c)
    633       (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-first-pair q)) )
     633      (%queue-cursor-start! q c) )
    634634    ;pull next item from queue at cursor
    635635    (let scanning ()
    636       (let ((curr-pair (%queue-unlimited-cursor-next-pair c)))
     636      (let ((item (%queue-cursor-next! q c)))
    637637        ;anything next?
    638         (if (not (null? curr-pair))
    639           ;then peek into the queue for the next item
    640           (let ((item (car curr-pair)))
    641             (%queue-unlimited-cursor-prev-pair-set! c curr-pair)
    642             (%queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
    643             item )
     638        (if (not (eof-object? item))
     639          ;then next item
     640          item
    644641          ;else wait for something in the mailbox
    645642          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
     
    647644              ;continue scanning?
    648645              ((eq? UNBLOCKED-TAG res)
    649                 (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-last-pair q))
     646                (%queue-cursor-continue! q c)
    650647                (scanning) )
    651648              ;some problem (timeout maybe)
  • release/5/mailbox/trunk/tests/reader-writer-test.scm

    r39700 r39721  
    33;;;
    44
    5 (import mailbox)
    6 (import srfi-18)
     5(import (chicken condition) (srfi-18) mailbox)
    76
    87;;; Test support
Note: See TracChangeset for help on using the changeset viewer.