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

49
knots/resource-pool.scm
View file

@ -365,12 +365,7 @@
((reply . timeout) ((reply . timeout)
(if (and timeout (if (and timeout
(< timeout current-internal-time)) (< timeout current-internal-time))
(if (q-empty? waiters) (waiter-loop (deq! waiters))
(loop resources
(cons resource available)
waiters)
(waiter-loop (deq! waiters)))
(begin
(if timeout (if timeout
(let ((reply-timeout (let ((reply-timeout
(/ (- timeout (/ (- timeout
@ -384,11 +379,11 @@
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))))
#:unwind? #t))))
(('list-resources reply) (('list-resources reply)
(spawn-fiber (spawn-fiber
@ -799,14 +794,7 @@
((reply . timeout) ((reply . timeout)
(if (and timeout (if (and timeout
(< timeout current-internal-time)) (< timeout current-internal-time))
(if (q-empty? waiters) (waiter-loop (deq! waiters))
(loop (cons resource resources)
(cons resource available)
waiters
(cons (get-internal-real-time)
resources-last-used))
(waiter-loop (deq! waiters)))
(begin
(if timeout (if timeout
(let ((reply-timeout (let ((reply-timeout
(/ (- timeout (/ (- timeout
@ -820,13 +808,13 @@
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))))))
#:unwind? #t))))))
(('checkout reply timeout-time max-waiters) (('checkout reply timeout-time max-waiters)
(if (null? available) (if (null? available)
@ -948,20 +936,7 @@
((reply . timeout) ((reply . timeout)
(if (and timeout (if (and timeout
(< timeout current-internal-time)) (< timeout current-internal-time))
(if (q-empty? waiters) (waiter-loop (deq! 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 (if timeout
(let ((reply-timeout (let ((reply-timeout
(/ (- timeout (/ (- timeout
@ -975,7 +950,8 @@
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
@ -986,8 +962,7 @@
(eq? x resource)) (eq? x resource))
resources) resources)
current-internal-time) current-internal-time)
resources-last-used)))))))) resources-last-used)))))
#:unwind? #t))))
(('remove resource) (('remove resource)
(let ((index (let ((index