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