branch: main
commit 3c4b2fc54acacb8f0ccf29f4182c50f7e594a400
Author: Ludovic Courtès <l...@gnu.org>
AuthorDate: Mon Jul 8 16:22:56 2024 +0200
utils: Resource pool keeps track of contention.
* src/cuirass/utils.scm (make-resource-pool): Add optional ‘name’
argument. Keep track of ‘get’ requests and contention. Spawn fiber to
periodically display stats.
(display-resource-pool-statistics): New procedure.
* src/cuirass/base.scm (jobset-evaluator): Pass second argument to
‘make-resource-pool’.
* src/cuirass/database.scm (with-database): Likewise.
* src/cuirass/scripts/remote-server.scm (fetch-worker): Likewise.
---
src/cuirass/base.scm | 2 +-
src/cuirass/database.scm | 3 ++-
src/cuirass/scripts/remote-server.scm | 2 +-
src/cuirass/utils.scm | 40 +++++++++++++++++++++++++++++------
4 files changed, 38 insertions(+), 9 deletions(-)
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index f9cdf39..2bc9710 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -662,7 +662,7 @@ the ID of the new evaluation."
(max-parallel-evaluations
(current-processor-count)))
(define pool
- (make-resource-pool (iota max-parallel-evaluations)))
+ (make-resource-pool (iota max-parallel-evaluations) 'evaluations))
(lambda ()
(log-info "will perform up to ~a evaluations concurrently"
diff --git a/src/cuirass/database.scm b/src/cuirass/database.scm
index 2780e7a..686ae1c 100644
--- a/src/cuirass/database.scm
+++ b/src/cuirass/database.scm
@@ -385,7 +385,8 @@ dynamic extent."
(lambda () body ...))
(define result
(if (current-scheduler) ;fiber context?
- (parameterize ((%db-connection-pool (make-resource-pool
connections)))
+ (parameterize ((%db-connection-pool
+ (make-resource-pool connections 'database)))
(thunk))
(thunk)))
(close)
diff --git a/src/cuirass/scripts/remote-server.scm
b/src/cuirass/scripts/remote-server.scm
index 748477a..4bf3da9 100644
--- a/src/cuirass/scripts/remote-server.scm
+++ b/src/cuirass/scripts/remote-server.scm
@@ -329,7 +329,7 @@ directory."
(make-atomic-box 0))
(lambda ()
- (let ((pool (make-resource-pool (iota max-parallel-downloads))))
+ (let ((pool (make-resource-pool (iota max-parallel-downloads) 'fetch)))
(log-info "starting fetch worker with up to ~a concurrent downloads"
max-parallel-downloads)
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index 7061c84..1f78509 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -59,7 +59,7 @@ value."
((_ symbol) value)
...)))
-(define (make-resource-pool resources)
+(define* (make-resource-pool resources #:optional name)
"Return a channel implementing a pool over RESOURCES, a list of objects such
as database connections. The channel can then be passed to
'with-resource-from-pool'."
@@ -69,27 +69,55 @@ as database connections. The channel can then be passed to
(spawn-fiber
(lambda ()
(let loop ((pool resources)
- (waiters '()))
+ (waiters '())
+ (gets 0)
+ (contended 0))
(match (get-message channel)
(('get reply)
(match pool
(()
(log-debug "queuing request on resource pool ~x"
(object-address channel))
- (loop pool (cons reply waiters)))
+ (loop pool (cons reply waiters)
+ (+ 1 gets) (+ 1 contended)))
((head . tail)
(put-message reply head)
- (loop tail waiters))))
+ (loop tail waiters
+ (+ 1 gets) contended))))
(('put resource)
(match waiters
(()
- (loop (cons resource pool) waiters))
+ (loop (cons resource pool) waiters
+ gets contended))
((rest ... reply) ;XXX: linear
(put-message reply resource)
- (loop pool rest))))))))
+ (loop pool rest
+ gets contended))))
+ ('display-stats
+ (if (zero? gets)
+ (log-info "pool '~a' (~a) is unused"
+ name
+ (number->string (object-address channel) 16))
+ (log-info "pool '~a' (~a): ~a% contention (~a/~a)"
+ name
+ (number->string (object-address channel) 16)
+ (inexact->exact (round (* 100. (/ contended gets))))
+ contended gets))
+ (loop pool waiters gets contended))))))
+
+ (spawn-fiber
+ (lambda ()
+ (let loop ()
+ (sleep (* 15 60))
+ (display-resource-pool-statistics channel)
+ (loop))))
channel)
+(define (display-resource-pool-statistics pool)
+ "Display statistics about POOL usage."
+ (put-message pool 'display-stats))
+
(define (call-with-resource-from-pool pool proc)
"Call PROC with a resource from POOL, blocking until a resource becomes
available. Return the resource once PROC has returned."
