Always assume that resource pool waiters will stick around

As I think this is a more efficient design.
This commit is contained in:
Christopher Baines 2024-11-05 09:36:31 +00:00
parent d310632f26
commit 6bf1747f55
2 changed files with 14 additions and 32 deletions

View file

@ -1839,7 +1839,6 @@ SELECT 1 FROM derivation_source_file_nars WHERE derivation_source_file_id = $1"
db-conn)
1
#:name "postgres"
#:assume-reliable-waiters? #t
#:min-size 0))
(define package-ids-promise

View file

@ -121,8 +121,7 @@
destructor
lifetime
scheduler
(name "unnamed")
assume-reliable-waiters?)
(name "unnamed"))
(define (initializer/safe)
(with-exception-handler
(lambda (exn)
@ -246,8 +245,18 @@
waiters
resources-last-used)))))
(('return resource)
(if (and assume-reliable-waiters?
(not (null? waiters)))
(if (null? waiters)
(loop resources
(cons resource available)
waiters
(begin
(list-set!
resources-last-used
(list-index (lambda (x)
(eq? x resource))
resources)
(get-internal-real-time))
resources-last-used))
(let ((checkout-success?
(perform-operation
(choice-operation
@ -294,33 +303,7 @@
(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 10))))))
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)))))
resources-last-used)))))))
(('stats reply)
(let ((stats
`((resources . ,(length resources))