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

Improve resource pool destruction

Browse source
This commit is contained in:
Christopher Baines 2025-01-31 12:33:50 +01:00
parent eebb42e7a7
commit 61451907a9
2 changed files with 116 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

84
knots/resource-pool.scm
View file

@ -21,6 +21,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 exceptions)
#:use-module (fibers)
@ -179,10 +180,13 @@
(backtrace))))
#:unwind? #t)))
(unless success?
(sleep 5)
(if success?
(put-message channel
(list 'remove resource))
(begin
(sleep 5)
(loop)))))))
(loop))))))))
(define (spawn-fiber-for-checkout reply-channel resource)
(spawn-fiber
@ -221,12 +225,20 @@
(('add-resource resource)
(if (= (length resources) max-size)
(begin
(spawn-fiber-to-destroy-resource resource)
(if destructor
(begin
(spawn-fiber-to-destroy-resource resource)
(loop resources
available
waiters
resources-last-used))
(loop (cons resource resources)
available
waiters
(cons (get-internal-real-time)
resources-last-used)))
(loop resources
available
waiters
(cons (get-internal-real-time)
resources-last-used))))
(if (null? waiters)
(loop (cons resource resources)
@ -321,6 +333,26 @@
(get-internal-real-time))
resources-last-used)))))
(('remove resource)
(let ((index
(list-index (lambda (x)
(eq? x resource))
resources)))
(define (remove-at-index! lst i)
(let ((start
end
(split-at! lst i)))
(append
start
(cdr end))))
(loop (remove-at-index! resources index)
available ; resource shouldn't be in this list
waiters
(remove-at-index!
resources-last-used
index))))
(('stats reply)
(let ((stats
`((resources . ,(length resources))
@ -361,10 +393,11 @@
resources
resources-last-used-seconds)))
(for-each
(lambda (resource)
(spawn-fiber-to-destroy-resource resource))
resources-to-destroy)
(when destructor
(for-each
(lambda (resource)
(spawn-fiber-to-destroy-resource resource))
resources-to-destroy))
(loop (lset-difference eq? resources resources-to-destroy)
(lset-difference eq? available resources-to-destroy)
@ -378,22 +411,29 @@
resources-last-used))))
(('destroy reply)
(if (= (length resources) (length available))
(if (null? resources)
(put-message reply 'destroy-success)
(begin
(for-each
(lambda (resource)
(spawn-fiber-to-destroy-resource resource))
resources)
(put-message reply 'destroy-success))
(begin
(if destructor
(spawn-fiber-to-destroy-resource resource)
(spawn-fiber
(lambda ()
(put-message channel
(list 'remove resource)))
#:parallel? #t)))
available)
(spawn-fiber
(lambda ()
(perform-operation
(choice-operation
(put-operation reply 'resource-pool-destroy-failed)
(sleep-operation 10)))))
(sleep 0.1)
(put-message channel
(list 'destroy reply))))
(loop resources
available
'()
waiters
resources-last-used))))

72
tests/resource-pool.scm
View file

@ -1,32 +1,37 @@
(use-modules (tests)
(fibers)
(unit-test)
(knots parallelism)
(knots resource-pool))
(run-fibers-for-tests
(lambda ()
(let ((resource-pool (make-resource-pool
(lambda ()
2)
1)))
(assert-equal
(with-resource-from-pool resource-pool
res
res)
2))))
(define new-number
(let ((val 0))
(lambda ()
(set! val (1+ val))
val)))
(run-fibers-for-tests
(lambda ()
(let ((resource-pool (make-resource-pool
(lambda ()
2)
new-number
1)))
(assert-true
(number?
(with-resource-from-pool resource-pool
res
res))))))
(run-fibers-for-tests
(lambda ()
(let ((resource-pool (make-resource-pool
new-number
1
#:add-resources-parallelism 1)))
(assert-equal
(with-resource-from-pool resource-pool
res
res)
2))))
(assert-true
(number?
(with-resource-from-pool resource-pool
res
res))))))
(let* ((error-constructor
(record-constructor &resource-pool-timeout))
@ -36,4 +41,35 @@
(resource-pool-timeout-error-pool err)
'foo))
(run-fibers-for-tests
(lambda ()
(let ((resource-pool (make-resource-pool
new-number
2)))
(fibers-for-each
(lambda _
(with-resource-from-pool resource-pool
res
res))
(iota 20))
(destroy-resource-pool resource-pool))))
(run-fibers-for-tests
(lambda ()
(let ((resource-pool (make-resource-pool
new-number
2
#:destructor
(lambda (res)
#t))))
(fibers-for-each
(lambda _
(with-resource-from-pool resource-pool
res
res))
(iota 20))
(destroy-resource-pool resource-pool))))
(display "resource-pool test finished successfully\n")