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

Implement lifetime support in the resource pool

Browse source
This commit is contained in:
Christopher Baines 2025-11-17 11:20:10 +00:00
parent e78e41b542
commit 1a476b5aa8
1 changed files with 108 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

148
knots/resource-pool.scm
View file

@ -749,6 +749,7 @@
(let loop ((resources '()) (let loop ((resources '())
(available '()) (available '())
(waiters (make-q)) (waiters (make-q))
(resources-checkout-count '())
(resources-last-used '())) (resources-last-used '()))
(match (get-message channel) (match (get-message channel)
@ -762,11 +763,13 @@
(loop (cons resource resources) (loop (cons resource resources)
available available
waiters waiters
(cons 0 resources-checkout-count)
(cons (get-internal-real-time) (cons (get-internal-real-time)
resources-last-used))) resources-last-used)))
(loop resources (loop resources
available available
waiters waiters
resources-checkout-count
resources-last-used))) resources-last-used)))
(let ((current-internal-time (let ((current-internal-time
@ -777,6 +780,7 @@
(loop (cons resource resources) (loop (cons resource resources)
(cons resource available) (cons resource available)
waiters waiters
(cons 0 resources-checkout-count)
(cons current-internal-time (cons current-internal-time
resources-last-used))) resources-last-used)))
((reply . timeout) ((reply . timeout)
@ -800,6 +804,7 @@
(loop (cons resource resources) (loop (cons resource resources)
available available
waiters waiters
(cons 1 resources-checkout-count)
(cons current-internal-time (cons current-internal-time
resources-last-used)))))))) resources-last-used))))))))
@ -836,10 +841,12 @@
(loop resources (loop resources
available available
waiters waiters
resources-checkout-count
resources-last-used)) resources-last-used))
(loop resources (loop resources
available available
(enq! waiters (cons reply timeout-time)) (enq! waiters (cons reply timeout-time))
resources-checkout-count
resources-last-used)))) resources-last-used))))
(if timeout-time (if timeout-time
@ -862,10 +869,21 @@
(loop resources (loop resources
(cdr available) (cdr available)
waiters waiters
(let ((resource-index
(list-index (lambda (x)
(eq? x (car available)))
resources)))
(list-set! resources-checkout-count
resource-index
(+ 1 (list-ref
resources-checkout-count
resource-index)))
resources-checkout-count)
resources-last-used)) resources-last-used))
(loop resources (loop resources
available available
waiters waiters
resources-checkout-count
resources-last-used))) resources-last-used)))
(begin (begin
(put-message reply (cons 'success (put-message reply (cons 'success
@ -874,6 +892,16 @@
(loop resources (loop resources
(cdr available) (cdr available)
waiters waiters
(let ((resource-index
(list-index (lambda (x)
(eq? x (car available)))
resources)))
(list-set! resources-checkout-count
resource-index
(+ 1 (list-ref
resources-checkout-count
resource-index)))
resources-checkout-count)
resources-last-used))))) resources-last-used)))))
(((and (or 'return (((and (or 'return
@ -892,46 +920,77 @@
(list-index (lambda (x) (list-index (lambda (x)
(eq? x resource)) (eq? x resource))
resources))) resources)))
(let waiter-loop ((waiter (safe-deq waiters))) (if (and lifetime
(match waiter (>= (list-ref resources-checkout-count
(#f resource-index)
(loop resources lifetime))
(cons resource available) (begin
waiters (spawn-fiber-to-destroy-resource resource)
(begin (loop resources
(when (eq? return-type 'return) available
(list-set! waiters
resources-last-used resources-checkout-count
resource-index resources-last-used))
current-internal-time)) (let waiter-loop ((waiter (safe-deq waiters)))
resources-last-used))) (match waiter
((reply . timeout) (#f
(if (and timeout (loop resources
(< timeout current-internal-time)) (cons resource available)
(waiter-loop (safe-deq waiters)) waiters
(if timeout (if (eq? 'return-failed-checkout
(let ((reply-timeout return-type)
(/ (- timeout (begin
current-internal-time) (list-set! resources-checkout-count
internal-time-units-per-second))) resource-index
;; Don't sleep in this fiber, so spawn a (- (list-ref resources-checkout-count
;; new fiber to handle handing over the resource-index)
;; resource, and returning it if there's 1))
;; a timeout resources-checkout-count)
(spawn-fiber-for-checkout reply resources-checkout-count)
reply-timeout (begin
resource)) (when (eq? return-type 'return)
(put-message reply (cons 'success (list-set!
resource)))) resources-last-used
(loop resources resource-index
available current-internal-time))
waiters resources-last-used)))
(begin ((reply . timeout)
(list-set! (if (and timeout
resources-last-used (< timeout current-internal-time))
resource-index (waiter-loop (safe-deq waiters))
current-internal-time) (if timeout
resources-last-used))))))) (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
(if (eq? 'return-failed-checkout
return-type)
(begin
(list-set! resources-checkout-count
resource-index
(- (list-ref resources-checkout-count
resource-index)
1))
resources-checkout-count)
resources-checkout-count)
(begin
(list-set!
resources-last-used
resource-index
current-internal-time)
resources-last-used))))))))
(('remove resource) (('remove resource)
(let ((index (let ((index
@ -954,6 +1013,9 @@
resources)) resources))
available ; resource shouldn't be in this list available ; resource shouldn't be in this list
waiters waiters
(remove-at-index!
resources-checkout-count
index)
(remove-at-index! (remove-at-index!
resources-last-used resources-last-used
index)))) index))))
@ -964,6 +1026,7 @@
(loop resources (loop resources
available available
waiters waiters
resources-checkout-count
resources-last-used)) resources-last-used))
(('list-resources reply) (('list-resources reply)
@ -974,6 +1037,7 @@
(loop resources (loop resources
available available
waiters waiters
resources-checkout-count
resources-last-used)) resources-last-used))
(('stats reply timeout-time) (('stats reply timeout-time)
@ -981,6 +1045,7 @@
`((resources . ,(length resources)) `((resources . ,(length resources))
(available . ,(length available)) (available . ,(length available))
(waiters . ,(q-length waiters)) (waiters . ,(q-length waiters))
(resources-checkout-count . ,resources-checkout-count)
(checkout-failure-count . ,checkout-failure-count)))) (checkout-failure-count . ,checkout-failure-count))))
(spawn-fiber (spawn-fiber
@ -1000,6 +1065,7 @@
(loop resources (loop resources
available available
waiters waiters
resources-checkout-count
resources-last-used)) resources-last-used))
(('check-for-idle-resources) (('check-for-idle-resources)
@ -1040,6 +1106,7 @@
(loop resources (loop resources
(lset-difference eq? available resources-to-destroy) (lset-difference eq? available resources-to-destroy)
waiters waiters
resources-checkout-count
resources-last-used)))) resources-last-used))))
(('destroy) (('destroy)
@ -1103,6 +1170,7 @@
(loop resources (loop resources
available available
waiters waiters
resources-checkout-count
resources-last-used))))) resources-last-used)))))
(spawn-fiber (spawn-fiber