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

Don't loop inside exception handlers
All checks were successful
/ test (push) Successful in 9s
Details

Browse source 
The resource pools seemed to become slower and slower over time, this
might help?
This commit is contained in:
Christopher Baines 2025-07-09 12:06:20 +01:00
parent f4b48a1499
commit d18b5b8d5d
1 changed files with 67 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

159
knots/resource-pool.scm
View file

@ -365,30 +365,25 @@
((reply . timeout)
(if (and timeout
(< timeout current-internal-time))
(if (q-empty? waiters)
(loop resources
(cons resource available)
waiters)
(waiter-loop (deq! waiters)))
(begin
(if timeout
(let ((reply-timeout
(/ (- timeout
current-internal-time)
internal-time-units-per-second)))
;; Don't sleep in this fiber, so spawn a
;; new fiber to handle handing over the
;; resource, and returning it if there's
;; a timeout
(spawn-fiber-for-checkout reply
reply-timeout
resource))
(put-message reply (cons 'success
resource)))
(loop resources
available
waiters)))))))
#:unwind? #t))))
(waiter-loop (deq! waiters))
(if timeout
(let ((reply-timeout
(/ (- timeout
current-internal-time)
internal-time-units-per-second)))
;; Don't sleep in this fiber, so spawn a
;; new fiber to handle handing over the
;; resource, and returning it if there's
;; a timeout
(spawn-fiber-for-checkout reply
reply-timeout
resource))
(put-message reply (cons 'success
resource))))))))
#:unwind? #t)
(loop resources
available
waiters))))
(('list-resources reply)
(spawn-fiber
@ -799,34 +794,27 @@
((reply . timeout)
(if (and timeout
(< timeout current-internal-time))
(if (q-empty? waiters)
(loop (cons resource resources)
(cons resource available)
waiters
(cons (get-internal-real-time)
resources-last-used))
(waiter-loop (deq! waiters)))
(begin
(if timeout
(let ((reply-timeout
(/ (- timeout
current-internal-time)
internal-time-units-per-second)))
;; Don't sleep in this fiber, so spawn a
;; new fiber to handle handing over the
;; resource, and returning it if there's
;; a timeout
(spawn-fiber-for-checkout reply
reply-timeout
resource))
(put-message reply (cons 'success
resource)))
(loop (cons resource resources)
available
waiters
(cons current-internal-time
resources-last-used)))))))
#:unwind? #t))))))
(waiter-loop (deq! waiters))
(if timeout
(let ((reply-timeout
(/ (- timeout
current-internal-time)
internal-time-units-per-second)))
;; Don't sleep in this fiber, so spawn a
;; new fiber to handle handing over the
;; resource, and returning it if there's
;; a timeout
(spawn-fiber-for-checkout reply
reply-timeout
resource))
(put-message reply (cons 'success
resource))))))))
#:unwind? #t)
(loop (cons resource resources)
available
waiters
(cons current-internal-time
resources-last-used))))))
(('checkout reply timeout-time max-waiters)
(if (null? available)
@ -948,46 +936,33 @@
((reply . timeout)
(if (and timeout
(< timeout current-internal-time))
(if (q-empty? waiters)
(loop resources
(cons resource available)
waiters
(begin
(list-set!
resources-last-used
(list-index (lambda (x)
(eq? x resource))
resources)
(get-internal-real-time))
resources-last-used))
(waiter-loop (deq! waiters)))
(begin
(if timeout
(let ((reply-timeout
(/ (- timeout
current-internal-time)
internal-time-units-per-second)))
;; Don't sleep in this fiber, so spawn a
;; new fiber to handle handing over the
;; resource, and returning it if there's
;; a timeout
(spawn-fiber-for-checkout reply
reply-timeout
resource))
(put-message reply (cons 'success
resource)))
(loop resources
available
waiters
(begin
(list-set!
resources-last-used
(list-index (lambda (x)
(eq? x resource))
resources)
current-internal-time)
resources-last-used))))))))
#:unwind? #t))))
(waiter-loop (deq! waiters))
(if timeout
(let ((reply-timeout
(/ (- timeout
current-internal-time)
internal-time-units-per-second)))
;; Don't sleep in this fiber, so spawn a
;; new fiber to handle handing over the
;; resource, and returning it if there's
;; a timeout
(spawn-fiber-for-checkout reply
reply-timeout
resource))
(put-message reply (cons 'success
resource))))))))
#:unwind? #t)
(loop resources
available
waiters
(begin
(list-set!
resources-last-used
(list-index (lambda (x)
(eq? x resource))
resources)
current-internal-time)
resources-last-used)))))
(('remove resource)
(let ((index