diff options
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)) |