Support getting resource pool stats
This commit is contained in:
parent
7251c7d653
commit
899bd1387e
|
@ -35,6 +35,7 @@
|
|||
make-resource-pool
|
||||
call-with-resource-from-pool
|
||||
with-resource-from-pool
|
||||
resource-pool-stats
|
||||
|
||||
parallel-via-fibers
|
||||
par-map&
|
||||
|
@ -158,6 +159,23 @@
|
|||
(cons resource available)
|
||||
;; clear waiters, as they've been notified
|
||||
'()))
|
||||
(('stats reply)
|
||||
(let ((stats
|
||||
`((resources . ,(length resources))
|
||||
(available . ,(length available))
|
||||
(waiters . ,(length waiters)))))
|
||||
|
||||
(perform-operation
|
||||
(choice-operation
|
||||
(wrap-operation
|
||||
(put-operation reply stats)
|
||||
(const #t))
|
||||
(wrap-operation (sleep-operation 0.2)
|
||||
(const #f)))))
|
||||
|
||||
(loop resources
|
||||
available
|
||||
waiters))
|
||||
(unknown
|
||||
(simple-format
|
||||
(current-error-port)
|
||||
|
@ -255,6 +273,11 @@ available. Return the resource once PROC has returned."
|
|||
pool
|
||||
(lambda (resource) exp ...)))
|
||||
|
||||
(define (resource-pool-stats pool)
|
||||
(let ((reply (make-channel)))
|
||||
(put-message pool `(stats ,reply))
|
||||
(get-message reply)))
|
||||
|
||||
(define (defer-to-parallel-fiber thunk)
|
||||
(let ((reply (make-channel)))
|
||||
(spawn-fiber
|
||||
|
|
Loading…
Reference in New Issue