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