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