cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Use a condition for destroying resource pools

Browse source 
This avoids the situation where the resource pool is destroyed, so
there's no fiber to listen to the destroy request.
This commit is contained in:
Christopher Baines 2025-04-27 10:03:06 +01:00
parent 4f0eafef0a
commit 68cfbe0380
1 changed files with 33 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

70
knots/resource-pool.scm
View file

@ -29,6 +29,7 @@
#:use-module (fibers channels)
#:use-module (fibers scheduler)
#:use-module (fibers operations)
#:use-module (fibers conditions)
#:use-module (knots)
#:use-module (knots parallelism)
#:export (resource-pool?
@ -71,11 +72,12 @@
(record-predicate &resource-pool-abort-add-resource))
(define-record-type <resource-pool>
(make-resource-pool-record name channel configuration)
(make-resource-pool-record name channel destroy-condition configuration)
resource-pool?
(name resource-pool-name)
(channel resource-pool-channel)
(configuration resource-pool-configuration))
(name resource-pool-name)
(channel resource-pool-channel)
(destroy-condition resource-pool-destroy-condition)
(configuration resource-pool-configuration))
(set-record-type-printer!
<resource-pool>
@ -98,11 +100,14 @@
default-checkout-timeout
default-max-waiters)
(define channel (make-channel))
(define destroy-condition
(make-condition))
(define pool
(make-resource-pool-record
name
channel
destroy-condition
`((max-size . ,max-size)
(min-size . ,min-size)
(idle-seconds . ,idle-seconds)
@ -208,16 +213,14 @@
channel
(list 'return-failed-checkout resource)))))))
(define (destroy-loop resources destroy-waiters)
(let loop ((resources resources)
(destroy-waiters destroy-waiters))
(define (destroy-loop resources)
(let loop ((resources resources))
(match (get-message channel)
(('add-resource resource)
(when destructor
(spawn-fiber-to-destroy-resource resource))
(loop resources
destroy-waiters))
(loop resources))
(('checkout reply timeout-time max-waiters)
(spawn-fiber
(lambda ()
@ -237,8 +240,7 @@
internal-time-units-per-second))
(const #f)))
op)))))
(loop resources
destroy-waiters))
(loop resources))
(((and (or 'return
'return-failed-checkout
'remove)
@ -270,17 +272,11 @@
resources))))
(if (null? new-resources)
(begin
(for-each
(lambda (destroy-waiter)
(spawn-fiber
(lambda ()
(put-message destroy-waiter 'destroy-success))))
destroy-waiters)
(signal-condition! destroy-condition)
;; No loop
*unspecified*)
(loop new-resources
destroy-waiters)))))
(loop new-resources)))))
(('stats reply)
(let ((stats
@ -299,24 +295,20 @@
(wrap-operation (sleep-operation 5)
(const #f)))))))
(loop resources
destroy-waiters))
(loop resources))
(('check-for-idle-resources)
(loop resources
destroy-waiters))
(loop resources))
(('destroy reply)
(loop resources
(cons reply destroy-waiters)))
(loop resources))
(unknown
(simple-format
(current-error-port)
"unrecognised message to ~A resource pool channel: ~A\n"
name
unknown)
(loop resources
destroy-waiters)))))
(loop resources)))))
(define (main-loop)
(let loop ((resources '())
@ -625,10 +617,11 @@
waiters
resources-last-used))))
(('destroy reply)
(('destroy)
(if (and (null? resources)
(null? waiters))
(put-message reply 'destroy-success)
(signal-condition!
destroy-condition)
(begin
(for-each
@ -668,8 +661,7 @@
op))))))))
waiters))
(destroy-loop resources
(list reply)))))
(destroy-loop resources))))
(unknown
(simple-format
@ -724,12 +716,16 @@
pool)
(define (destroy-resource-pool pool)
(let ((reply (make-channel)))
(put-message (resource-pool-channel pool)
(list 'destroy reply))
(let ((msg (get-message reply)))
(unless (eq? msg 'destroy-success)
(error msg)))))
(perform-operation
(choice-operation
(wrap-operation
(put-operation (resource-pool-channel pool)
(list 'destroy))
(lambda _
(wait (resource-pool-destroy-condition pool))))
(wait-operation
(resource-pool-destroy-condition pool))))
#t)
(define &resource-pool-timeout
(make-exception-type '&recource-pool-timeout