cbaines/guile-knots
1
Fork 0
Code Issues Pull requests Activity Actions

Simplify using the waiters queue in the resource pool

Browse source 
Use a custom dequeue procedure that returns #f rather than raising an
exception on an empty queue.
This commit is contained in:
Christopher Baines 2025-11-17 10:46:46 +00:00
parent 52092e7a99
commit 86fb460d6a
1 changed files with 120 additions and 148 deletions
Download patch file Download diff file Expand all files Collapse all files

106
knots/resource-pool.scm
View file

@ -101,6 +101,16 @@
start start
(cdr end)))) (cdr end))))
(define (safe-deq q)
(if (null? (car q))
#f
(let ((it (caar q))
(next (cdar q)))
(if (null? next)
(set-cdr! q #f))
(set-car! q next)
it)))
(define* (make-fixed-size-resource-pool resources (define* (make-fixed-size-resource-pool resources
#:key #:key
(delay-logger (const #f)) (delay-logger (const #f))
@ -345,27 +355,18 @@
(set! checkout-failure-count (set! checkout-failure-count
(+ 1 checkout-failure-count))) (+ 1 checkout-failure-count)))
(if (q-empty? waiters)
(loop resources
(cons resource available)
waiters)
(let ((current-internal-time (let ((current-internal-time
(get-internal-real-time))) (get-internal-real-time)))
(with-exception-handler (let waiter-loop ((waiter (safe-deq waiters)))
(lambda (exn) (match waiter
(if (eq? (exception-kind exn) 'q-empty) (#f
(loop resources (loop resources
(cons resource available) (cons resource available)
waiters) waiters))
(raise-exception exn)))
(lambda ()
(let waiter-loop ((waiter (deq! waiters)))
(match waiter
((reply . timeout) ((reply . timeout)
(if (and timeout (if (and timeout
(< timeout current-internal-time)) (< timeout current-internal-time))
(waiter-loop (deq! waiters)) (waiter-loop (safe-deq waiters))
(if timeout (if timeout
(let ((reply-timeout (let ((reply-timeout
(/ (- timeout (/ (- timeout
@ -379,11 +380,10 @@
reply-timeout reply-timeout
resource)) resource))
(put-message reply (cons 'success (put-message reply (cons 'success
resource)))))))) resource))))
#:unwind? #t)
(loop resources (loop resources
available available
waiters)))) waiters))))))
(('list-resources reply) (('list-resources reply)
(spawn-fiber (spawn-fiber
@ -770,31 +770,20 @@
(cons (get-internal-real-time) (cons (get-internal-real-time)
resources-last-used)))) resources-last-used))))
(if (q-empty? waiters)
(loop (cons resource resources)
(cons resource available)
waiters
(cons (get-internal-real-time)
resources-last-used))
(let ((current-internal-time (let ((current-internal-time
(get-internal-real-time))) (get-internal-real-time)))
(with-exception-handler (let waiter-loop ((waiter (safe-deq waiters)))
(lambda (exn) (match waiter
(if (eq? (exception-kind exn) 'q-empty) (#f
(loop (cons resource resources) (loop (cons resource resources)
(cons resource available) (cons resource available)
waiters waiters
(cons current-internal-time (cons current-internal-time
resources-last-used)) resources-last-used)))
(raise-exception exn)))
(lambda ()
(let waiter-loop ((waiter (deq! waiters)))
(match waiter
((reply . timeout) ((reply . timeout)
(if (and timeout (if (and timeout
(< timeout current-internal-time)) (< timeout current-internal-time))
(waiter-loop (deq! waiters)) (waiter-loop (safe-deq waiters))
(if timeout (if timeout
(let ((reply-timeout (let ((reply-timeout
(/ (- timeout (/ (- timeout
@ -808,13 +797,12 @@
reply-timeout reply-timeout
resource)) resource))
(put-message reply (cons 'success (put-message reply (cons 'success
resource)))))))) resource))))
#:unwind? #t)
(loop (cons resource resources) (loop (cons resource resources)
available available
waiters waiters
(cons current-internal-time (cons current-internal-time
resources-last-used)))))) resources-last-used))))))))
(('checkout reply timeout-time max-waiters) (('checkout reply timeout-time max-waiters)
(if (null? available) (if (null? available)
@ -899,24 +887,15 @@
(set! checkout-failure-count (set! checkout-failure-count
(+ 1 checkout-failure-count))) (+ 1 checkout-failure-count)))
(if (q-empty? waiters) (let ((current-internal-time
(loop resources (get-internal-real-time))
(cons resource available) (resource-index
waiters
(begin
(list-set!
resources-last-used
(list-index (lambda (x) (list-index (lambda (x)
(eq? x resource)) (eq? x resource))
resources) resources)))
(get-internal-real-time)) (let waiter-loop ((waiter (safe-deq waiters)))
resources-last-used)) (match waiter
(#f
(let ((current-internal-time
(get-internal-real-time)))
(with-exception-handler
(lambda (exn)
(if (eq? (exception-kind exn) 'q-empty)
(loop resources (loop resources
(cons resource available) (cons resource available)
waiters waiters
@ -924,19 +903,13 @@
(when (eq? return-type 'return) (when (eq? return-type 'return)
(list-set! (list-set!
resources-last-used resources-last-used
(list-index (lambda (x) resource-index
(eq? x resource))
resources)
current-internal-time)) current-internal-time))
resources-last-used)) resources-last-used)))
(raise-exception exn)))
(lambda ()
(let waiter-loop ((waiter (deq! waiters)))
(match waiter
((reply . timeout) ((reply . timeout)
(if (and timeout (if (and timeout
(< timeout current-internal-time)) (< timeout current-internal-time))
(waiter-loop (deq! waiters)) (waiter-loop (safe-deq waiters))
(if timeout (if timeout
(let ((reply-timeout (let ((reply-timeout
(/ (- timeout (/ (- timeout
@ -950,25 +923,24 @@
reply-timeout reply-timeout
resource)) resource))
(put-message reply (cons 'success (put-message reply (cons 'success
resource)))))))) resource))))
#:unwind? #t)
(loop resources (loop resources
available available
waiters waiters
(begin (begin
(list-set! (list-set!
resources-last-used resources-last-used
(list-index (lambda (x) resource-index
(eq? x resource))
resources)
current-internal-time) current-internal-time)
resources-last-used))))) resources-last-used)))))))
(('remove resource) (('remove resource)
(let ((index (let ((index
(list-index (lambda (x) (list-index (lambda (x)
(eq? x resource)) (eq? x resource))
resources))) resources)))
(loop (if index (loop (if index
(remove-at-index! resources index) (remove-at-index! resources index)
(begin (begin