Changeset 39720 in project


Ignore:
Timestamp:
03/16/21 16:14:53 (5 weeks ago)
Author:
Kon Lovett
Message:

queue depth limit cursor (wip)

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

Legend:

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

    r39719 r39720  
    1818  (tl %queue-unlimited-last-pair %queue-unlimited-last-pair-set!) )
    1919
     20(define-inline (%make-empty-queue-unlimited)
     21  (%make-queue-unlimited 0 '() '()) )
     22
    2023(define-inline (%queue-unlimited-limit q) most-positive-fixnum)
    2124
     
    3336
    3437(define-inline (%queue-unlimited-room q) most-positive-fixnum)
    35 
    36 (define-inline (%queue-unlimited-add! q v)
    37   (let ((new-pair (cons v '())))
    38     (if (null? (%queue-unlimited-first-pair q))
    39       (%queue-unlimited-first-pair-set! q new-pair)
    40       (set-cdr! (%queue-unlimited-last-pair q) new-pair) )
    41     (%queue-unlimited-last-pair-set! q new-pair)
    42     (%queue-unlimited-count-inc! q)) )
    43 
    44 (define-inline (%queue-unlimited-remove! q)
    45   (let* ((first-pair (%queue-unlimited-first-pair q))
    46          (next-pair (cdr first-pair)))
    47     (%queue-unlimited-first-pair-set! q next-pair)
    48     (when (null? next-pair) (%queue-unlimited-last-pair-set! q '()))
    49     (%queue-unlimited-count-dec! q)
    50     (car first-pair) ) )
    51 
    52 (define-inline (%queue-unlimited-push-back! q v)
    53   (let ((newlist (cons v (%queue-unlimited-first-pair q))))
    54     (%queue-unlimited-first-pair-set! q newlist)
    55     (when (null? (%queue-unlimited-last-pair q))
    56       (%queue-unlimited-last-pair-set! q newlist) )
    57     (%queue-unlimited-count-inc! q) ) )
    58 
    59 (define-inline (%queue-unlimited-push-back-list! q ls)
    60   (let ((newlist (append! (list-copy ls) (%queue-unlimited-first-pair q))))
    61     (%queue-unlimited-first-pair-set! q newlist)
    62     (if (null? newlist)
    63       (%queue-unlimited-last-pair-set! q '())
    64       (%queue-unlimited-last-pair-set! q (last-pair newlist) ) )
    65     (%queue-unlimited-count-add! q (length ls)) ) )
    6638
    6739(define-inline (%queue-unlimited-extract-pair! q targ-pair)
     
    9062        (scanning (cdr this-pair) this-pair) ) ) ) )
    9163
     64(define-inline (%queue-unlimited-add! q v)
     65  (let ((new-pair (cons v '())))
     66    (if (null? (%queue-unlimited-first-pair q))
     67      (%queue-unlimited-first-pair-set! q new-pair)
     68      (set-cdr! (%queue-unlimited-last-pair q) new-pair) )
     69    (%queue-unlimited-last-pair-set! q new-pair)
     70    (%queue-unlimited-count-inc! q)) )
     71
     72(define-inline (%queue-unlimited-remove! q)
     73  (let* ((first-pair (%queue-unlimited-first-pair q))
     74         (next-pair (cdr first-pair)))
     75    (%queue-unlimited-first-pair-set! q next-pair)
     76    (when (null? next-pair) (%queue-unlimited-last-pair-set! q '()))
     77    (%queue-unlimited-count-dec! q)
     78    (car first-pair) ) )
     79
     80(define-inline (%queue-unlimited-push-back! q v)
     81  (let ((newlist (cons v (%queue-unlimited-first-pair q))))
     82    (%queue-unlimited-first-pair-set! q newlist)
     83    (when (null? (%queue-unlimited-last-pair q))
     84      (%queue-unlimited-last-pair-set! q newlist) )
     85    (%queue-unlimited-count-inc! q) ) )
     86
     87(define-inline (%queue-unlimited-push-back-list! q ls)
     88  (let ((newlist (append! (list-copy ls) (%queue-unlimited-first-pair q))))
     89    (%queue-unlimited-first-pair-set! q newlist)
     90    (if (null? newlist)
     91      (%queue-unlimited-last-pair-set! q '())
     92      (%queue-unlimited-last-pair-set! q (last-pair newlist) ) )
     93    (%queue-unlimited-count-add! q (length ls)) ) )
     94
     95(define-inline (%make-queue-unlimited-cursor) (cons '() #f))
     96(define-inline (%queue-unlimited-cursor? c) (pair? c))
     97(define-inline (%queue-unlimited-cursor-next-pair c) (car c))
     98(define-inline (%queue-unlimited-cursor-next-pair-set! c v) (set-car! c v))
     99(define-inline (%queue-unlimited-cursor-prev-pair c) (cdr c))
     100(define-inline (%queue-unlimited-cursor-prev-pair-set! c v) (set-cdr! c v))
     101
     102(define-inline (%queue-unlimited-cursor-winding? q c)
     103  (%->boolean (%queue-unlimited-cursor-prev-pair c)) )
     104
     105(define (%queue-unlimited-cursor-unwound? q c)
     106  (null? (%queue-unlimited-cursor-next-pair c)) )
     107
     108(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) )
     111
     112(define-inline (%queue-unlimited-cursor-extract! q c)
     113  ;unless 'mailbox-cursor-next' has been called don't remove
     114  (and-let* ((prev-pair (%queue-unlimited-cursor-prev-pair c)))
     115    (%queue-unlimited-extract-pair! q prev-pair) ) )
     116
    92117;; Queue Limited
    93118
     
    101126  (ed %queue-limited-end %queue-limited-end-set!) )
    102127
     128(define-inline (%make-empty-queue-limited lm)
     129  (%make-queue-limited (make-vector (fx+ lm 1) (void)) 0 0) )
     130
    103131;circular buffer: vec[n] s <= e: s = e -> empty, s < e -> some, |e - s| = n -> full
    104132;
    105 ; inc i: (i + 1)          mod (n+1)
    106 ; dec i: (i + ((n+1)-1))  mod (n+1)
     133; inc i: (i + 1)      mod n
     134; dec i: (i + (n-1))  mod n
    107135
    108136(define-inline (%queue-limited-peek q i)
     
    116144
    117145(define-inline (%queue-limited-index-add1 q i)
    118   (fxmod (fx+ i 1) (fx+ (%queue-limited-limit q) 1)) )
     146  (fxmod (fx+ i 1) (%queue-limited-limit q)) )
    119147
    120148(define-inline (%queue-limited-limit-set! q v)
     
    139167
    140168(define-inline (%queue-limited-add! q v)
    141   (when (fx= (%queue-limited-end q) (%queue-limited-limit q))
    142     (%queue-limited-end-set! q 0) )
    143169  (%queue-limited-poke! q (%queue-limited-end q) v)
    144170  (%queue-limited-end-set! q (%queue-limited-index-add1 q (%queue-limited-end q))) )
    145171
    146172(define-inline (%queue-limited-remove! q)
    147   (when (fx= (%queue-limited-start q) (%queue-limited-limit q))
    148     (%queue-limited-start-set! q 0) )
    149173  (let ((v (%queue-limited-peek q (%queue-limited-start q))))
    150174    (%queue-limited-start-set! q (%queue-limited-index-add1 q (%queue-limited-start q)))
     
    170194  (vl %queue-unbuffered-value %queue-unbuffered-value-set!) )
    171195
     196(define-inline (%make-empty-queue-unbuffered)
     197  (%make-queue-unbuffered #f (void)) )
     198
    172199(define-inline (%queue-unbuffered-limit q) 1)
    173200
     
    209236  ;(assert (%valid-queue-limit? lm))
    210237  (cond
    211     ((not lm)       (%make-queue-unlimited 0 '() '()))
    212     ((fixnum? lm)   (%make-queue-limited (make-vector lm (void)) 0 0))
    213     (else           (%make-queue-unbuffered #f (void))) ) )
     238    ((not lm)       (%make-empty-queue-unlimited))
     239    ((fixnum? lm)   (%make-empty-queue-limited lm))
     240    (else           (%make-empty-queue-unbuffered)) ) )
    214241
    215242(define-inline (%queue? x)
     
    300327;;FIXME should be Queue Cursor
    301328
    302 (define-inline (%queue-first-pair q) (%queue-unlimited-first-pair q))
    303 (define-inline (%queue-last-pair q) (%queue-unlimited-last-pair q))
    304 (define-inline (%queue-extract-pair! q t) (%queue-unlimited-extract-pair! q t))
     329(define-inline (%make-queue-cursor q)
     330  (cond
     331    ((%queue-unlimited? q) (%make-queue-unlimited-cursor)) ) )
     332
     333(define-inline (%queue-cursor-winding? q c)
     334  (cond
     335    ((%queue-unlimited? q) (%queue-unlimited-cursor-winding? q c)) ) )
     336
     337(define (%queue-cursor-unwound? q c)
     338  (cond
     339    ((%queue-unlimited? q) (%queue-unlimited-cursor-unwound? q c)) ) )
     340
     341(define-inline (%queue-cursor-rewind! q c)
     342  (cond
     343    ((%queue-unlimited? q) (%queue-unlimited-cursor-rewind! q c)) ) )
     344
     345(define-inline (%queue-cursor-extract! q c)
     346  (cond
     347    ((%queue-unlimited? q) (%queue-unlimited-cursor-extract! q c)) ) )
  • release/5/mailbox/trunk/mailbox.scm

    r39718 r39720  
    3737  mailbox-timeout-condition?
    3838  ;Mailbox API
     39  make-unlimited-mailbox
    3940  make-limited-mailbox
     41  make-unbuffered-mailbox
    4042  make-mailbox
    4143  mailbox?
     
    8587
    8688(: mailbox-timeout-condition?         (* -> boolean : condition))
    87 (: make-limited-mailbox               (#!optional buffering * -> mailbox))
     89
     90(: make-unlimited-mailbox             (#!optional * -> mailbox))
     91(: make-limited-mailbox               (fixnum #!optional * -> mailbox))
     92(: make-unbuffered-mailbox            (#!optional * -> mailbox))
    8893(: make-mailbox                       (#!optional * buffering -> mailbox))
     94
    8995(: mailbox?                           (* -> boolean : mailbox))
    9096(: mailbox-name                       (mailbox --> *))
     
    94100(: mailbox-waiting?                   (mailbox -> boolean))
    95101(: mailbox-waiters                    (mailbox -> list))
     102
    96103(: mailbox-send!                      (mailbox * -> void))
    97104(: mailbox-wait!                      (mailbox #!optional timeout -> void))
     
    99106(: mailbox-push-back!                 (mailbox * -> void))
    100107(: mailbox-push-back-list!            (mailbox list -> void))
     108
    101109(: make-mailbox-cursor                (mailbox -> mailbox-cursor))
     110
    102111(: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
    103112(: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
    104113(: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
    105114(: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
     115
    106116(: mailbox-cursor-rewind              (mailbox-cursor -> void))
    107117(: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
     
    275285;; Message queue
    276286
    277 (define-inline (%mailbox-queue-first-pair mb)
    278   (%queue-first-pair (%mailbox-queue mb)) )
    279 
    280 (define-inline (%mailbox-queue-last-pair mb)
    281   (%queue-last-pair (%mailbox-queue mb)) )
    282 
    283287(define-inline (%mailbox-queue-empty? mb)
    284288  (%queue-empty? (%mailbox-queue mb)) )
     
    326330(define mailbox-cursor 'mailbox-cursor)
    327331(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
    328   (%raw-make-mailbox-cursor np pp mb)
     332  (%raw-make-mailbox-cursor mb st)
    329333  (%mailbox-cursor?)
    330   (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
    331   (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
    332   (mb %mailbox-cursor-mailbox) )
     334  (mb %mailbox-cursor-mailbox)
     335  (st %mailbox-cursor-state) )
    333336
    334337(define-inline (%make-mailbox-cursor mb)
    335   (%raw-make-mailbox-cursor '() #f mb) )
     338  (%raw-make-mailbox-cursor mb (%make-queue-cursor (%mailbox-queue mb))) )
    336339
    337340(define (error-mailbox-cursor loc obj #!optional argnam)
     
    341344
    342345(define-inline (%mailbox-cursor-winding? mbc)
    343   (%->boolean (%mailbox-cursor-prev-pair mbc)) )
    344 
    345 (define-inline (%mailbox-cursor-next-pair-empty! mbc)
    346   (%mailbox-cursor-next-pair-set! mbc '()) )
    347 
    348 (define-inline (%mailbox-cursor-prev-pair-clear! mbc)
    349   (%mailbox-cursor-prev-pair-set! mbc #f) )
     346  (%queue-cursor-winding?
     347    (%mailbox-queue (%mailbox-cursor-mailbox mbc))
     348    (%mailbox-cursor-state mbc)) )
     349
     350(define (%mailbox-cursor-unwound? mbc)
     351  (%queue-cursor-unwound?
     352    (%mailbox-queue (%mailbox-cursor-mailbox mbc))
     353    (%mailbox-cursor-state mbc)) )
    350354
    351355(define-inline (%mailbox-cursor-rewind! mbc)
    352   (%mailbox-cursor-next-pair-empty! mbc)
    353   (%mailbox-cursor-prev-pair-clear! mbc) )
     356  (%queue-cursor-rewind!
     357    (%mailbox-queue (%mailbox-cursor-mailbox mbc))
     358    (%mailbox-cursor-state mbc)) )
    354359
    355360(define-inline (%mailbox-cursor-extract! mbc)
    356   ;unless 'mailbox-cursor-next' has been called don't remove
    357   (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
    358     (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
     361  (%queue-cursor-extract!
     362    (%mailbox-queue (%mailbox-cursor-mailbox mbc))
     363    (%mailbox-cursor-state mbc)) )
    359364
    360365;;;
     
    514519;; Mailbox Constructor
    515520
    516 (define (make-limited-mailbox #!optional (lm #t) (nm (gensym 'mailbox)))
     521(define (make-unlimited-mailbox #!optional (nm (gensym 'mailbox)))
     522  (%make-mailbox nm #f) )
     523
     524(define (make-limited-mailbox lm #!optional (nm (gensym 'mailbox)))
    517525  (%make-mailbox nm lm) )
    518526
     527(define (make-unbuffered-mailbox #!optional (nm (gensym 'mailbox)))
     528  (%make-mailbox nm #t) )
     529
    519530(define (make-mailbox #!optional (nm (gensym 'mailbox)) (lm #f))
    520   (make-limited-mailbox lm nm) )
     531  (%make-mailbox nm lm) )
     532
     533;; Mailbox Properties
    521534
    522535(define (mailbox? obj)
    523536  (%mailbox? obj) )
    524 
    525 ;; Mailbox Properties
    526537
    527538(define (mailbox-name mb)
     
    603614
    604615(define (mailbox-cursor-unwound? mbc)
    605   (null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
     616  (null?
     617    (%queue-unlimited-cursor-next-pair
     618      (%mailbox-cursor-state (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)))) )
    606619
    607620;; Mailbox Cursor Operations
     
    612625(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
    613626  (when timout (%check-timeout 'mailbox-cursor-next timout))
    614   (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
     627  (let* (
     628    (mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc)))
     629    (q (%mailbox-queue mb))
     630    (c (%mailbox-cursor-state mbc)) )
    615631    ;seed rewound cursor
    616     (unless (%mailbox-cursor-winding? mbc)
    617       (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
     632    (unless (%queue-cursor-winding? q c)
     633      (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-first-pair q)) )
    618634    ;pull next item from queue at cursor
    619635    (let scanning ()
    620       (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
     636      (let ((curr-pair (%queue-unlimited-cursor-next-pair c)))
    621637        ;anything next?
    622638        (if (not (null? curr-pair))
    623639          ;then peek into the queue for the next item
    624640          (let ((item (car curr-pair)))
    625             (%mailbox-cursor-prev-pair-set! mbc curr-pair)
    626             (%mailbox-cursor-next-pair-set! mbc (cdr curr-pair))
     641            (%queue-unlimited-cursor-prev-pair-set! c curr-pair)
     642            (%queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
    627643            item )
    628644          ;else wait for something in the mailbox
     
    631647              ;continue scanning?
    632648              ((eq? UNBLOCKED-TAG res)
    633                 (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
     649                (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-last-pair q))
    634650                (scanning) )
    635651              ;some problem (timeout maybe)
Note: See TracChangeset for help on using the changeset viewer.