diff options
| author | Christopher Baines <mail@cbaines.net> | 2024-10-31 16:46:43 +0000 |
|---|---|---|
| committer | Christopher Baines <mail@cbaines.net> | 2024-10-31 16:46:43 +0000 |
| commit | af93bdcf5ed2fafb85267ece1ed4e86f1883a0b2 (patch) | |
| tree | 65e68b37d6e19829e3ed79981d78701980a6240b /guix-data-service | |
| parent | de5e036ab1f7b67f3708546c7683a2de20d44a85 (diff) | |
| download | data-service-af93bdcf5ed2fafb85267ece1ed4e86f1883a0b2.tar data-service-af93bdcf5ed2fafb85267ece1ed4e86f1883a0b2.tar.gz | |
Tweak the resource pool return behaviour
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.
Diffstat (limited to 'guix-data-service')
| -rw-r--r-- | guix-data-service/utils.scm | 101 |
1 files changed, 76 insertions, 25 deletions
diff --git a/guix-data-service/utils.scm b/guix-data-service/utils.scm index 4b5d7e6..bd5009d 100644 --- a/guix-data-service/utils.scm +++ b/guix-data-service/utils.scm @@ -121,7 +121,8 @@ destructor lifetime scheduler - (name "unnamed")) + (name "unnamed") + assume-reliable-waiters?) (define (initializer/safe) (with-exception-handler (lambda (exn) @@ -245,31 +246,81 @@ waiters resources-last-used))))) (('return resource) - ;; 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) + (if (and assume-reliable-waiters? + (not (null? waiters))) + (let ((checkout-success? + (perform-operation + (choice-operation + (wrap-operation + (put-operation (last waiters) + resource) + (const #t)) + (wrap-operation (sleep-operation 1) + (const #f)))))) + (unless checkout-success? + (set! checkout-failure-count + (+ 1 checkout-failure-count))) - (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))) + (if checkout-success? + (loop resources + available + (drop-right! waiters 1) + (begin + (list-set! + resources-last-used + (list-index (lambda (x) + (eq? x resource)) + resources) + (get-internal-real-time)) + 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) (let ((stats `((resources . ,(length resources)) |