cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Tweak the resource pool return behaviour

Browse source 
If there's lots of contention for the resource pool, there will be lots of
waiters, so telling all of them to retry whenever a resource is returned seems
wasteful. This commit adds a new option (assume-reliable-waiters?) which will
have the resource pool try to give a returned resource to the oldest waiter,
if this fails, it'll go back to the old behaviour of telling all waiters to
retry.
This commit is contained in:
Christopher Baines 2024-10-31 16:46:43 +00:00
parent de5e036ab1
commit af93bdcf5e
1 changed files with 76 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

101
guix-data-service/utils.scm
View file

@ -121,7 +121,8 @@
destructor destructor
lifetime lifetime
scheduler scheduler
(name "unnamed")) (name "unnamed")
assume-reliable-waiters?)
(define (initializer/safe) (define (initializer/safe)
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
@ -245,31 +246,81 @@
waiters waiters
resources-last-used))))) resources-last-used)))))
(('return resource) (('return resource)
;; When a resource is returned, prompt all the waiters to request (if (and assume-reliable-waiters?
;; again. This is to avoid the pool waiting on channels that may (not (null? waiters)))
;; be dead. (let ((checkout-success?
(for-each (perform-operation
(lambda (waiter) (choice-operation
(spawn-fiber (wrap-operation
(lambda () (put-operation (last waiters)
(perform-operation resource)
(choice-operation (const #t))
(put-operation waiter 'resource-pool-retry-checkout) (wrap-operation (sleep-operation 1)
(sleep-operation 0.2)))))) (const #f))))))
waiters) (unless checkout-success?
(set! checkout-failure-count
(+ 1 checkout-failure-count)))
(loop resources (if checkout-success?
(cons resource available) (loop resources
;; clear waiters, as they've been notified available
'() (drop-right! waiters 1)
(begin (begin
(list-set! (list-set!
resources-last-used resources-last-used
(list-index (lambda (x) (list-index (lambda (x)
(eq? x resource)) (eq? x resource))
resources) resources)
(get-internal-real-time)) (get-internal-real-time))
resources-last-used))) resources-last-used))
(begin
(for-each
(lambda (waiter)
(spawn-fiber
(lambda ()
(perform-operation
(choice-operation
(put-operation waiter 'resource-pool-retry-checkout)
(sleep-operation 0.2))))))
waiters)
(loop resources
(cons resource available)
'()
(begin
(list-set!
resources-last-used
(list-index (lambda (x)
(eq? x resource))
resources)
(get-internal-real-time))
resources-last-used)))))
(begin
;; When a resource is returned, prompt all the waiters
;; to request again. This is to avoid the pool waiting
;; on channels that may be dead.
(for-each
(lambda (waiter)
(spawn-fiber
(lambda ()
(perform-operation
(choice-operation
(put-operation waiter 'resource-pool-retry-checkout)
(sleep-operation 0.2))))))
waiters)
(loop resources
(cons resource available)
;; clear waiters, as they've been notified
'()
(begin
(list-set!
resources-last-used
(list-index (lambda (x)
(eq? x resource))
resources)
(get-internal-real-time))
resources-last-used)))))
(('stats reply) (('stats reply)
(let ((stats (let ((stats
`((resources . ,(length resources)) `((resources . ,(length resources))