Sort out resource pool delay and duration logging
This commit is contained in:
parent
781c8cf9db
commit
a44cc014a4
2 changed files with 168 additions and 43 deletions
|
|
@ -103,6 +103,14 @@
|
|||
'documentation
|
||||
"Return the configuration alist of the resource pool.")
|
||||
|
||||
(define (resource-pool-delay-logger resource-pool)
|
||||
(assq-ref (resource-pool-configuration resource-pool)
|
||||
'delay-logger))
|
||||
|
||||
(define (resource-pool-duration-logger resource-pool)
|
||||
(assq-ref (resource-pool-configuration resource-pool)
|
||||
'duration-logger))
|
||||
|
||||
(set-record-type-printer!
|
||||
<resource-pool>
|
||||
(lambda (resource-pool port)
|
||||
|
|
@ -164,8 +172,8 @@
|
|||
|
||||
(define* (make-fixed-size-resource-pool resources-list-or-vector
|
||||
#:key
|
||||
(delay-logger (const #f))
|
||||
(duration-logger (const #f))
|
||||
(delay-logger #f)
|
||||
(duration-logger #f)
|
||||
scheduler
|
||||
(name "unnamed")
|
||||
default-checkout-timeout
|
||||
|
|
@ -193,6 +201,19 @@ Maximum number of fibers that may queue waiting for a resource. When
|
|||
this limit is exceeded, @code{&resource-pool-too-many-waiters} is
|
||||
raised when a resource is requested. Defaults to @code{#f} (no limit).
|
||||
|
||||
@item #:delay-logger
|
||||
Called as @code{(delay-logger seconds)} with the time spent waiting
|
||||
for a resource to become available. Defaults to @code{#f} (no
|
||||
logging).
|
||||
|
||||
@item #:duration-logger
|
||||
Called as @code{(duration-logger seconds)} after the proc passed to
|
||||
@code{call-with-resource-from-pool} completes, whether it returned
|
||||
normally or raised an exception. Can be overridden per-call via the
|
||||
@code{#:duration-logger} keyword argument to
|
||||
@code{call-with-resource-from-pool}. Defaults to @code{#f} (no
|
||||
logging).
|
||||
|
||||
@item #:scheduler
|
||||
The Fibers scheduler to use for the pool's internal fiber. Defaults
|
||||
to the current scheduler.
|
||||
|
|
@ -547,8 +568,8 @@ to the current scheduler.
|
|||
(define* (make-resource-pool return-new-resource max-size
|
||||
#:key (min-size 0)
|
||||
(idle-seconds #f)
|
||||
(delay-logger (const #f))
|
||||
(duration-logger (const #f))
|
||||
(delay-logger #f)
|
||||
(duration-logger #f)
|
||||
destructor
|
||||
lifetime
|
||||
scheduler
|
||||
|
|
@ -605,6 +626,19 @@ Maximum number of fibers that may queue waiting for a resource. When
|
|||
this limit is exceeded, @code{&resource-pool-too-many-waiters} is
|
||||
raised when a resource is requested. Defaults to @code{#f} (no limit).
|
||||
|
||||
@item #:delay-logger
|
||||
Called as @code{(delay-logger seconds)} with the time spent waiting
|
||||
for a resource to become available. Defaults to @code{#f} (no
|
||||
logging).
|
||||
|
||||
@item #:duration-logger
|
||||
Called as @code{(duration-logger seconds)} after the proc passed to
|
||||
@code{call-with-resource-from-pool} completes, whether it returned
|
||||
normally or raised an exception. Can be overridden per-call via the
|
||||
@code{#:duration-logger} keyword argument to
|
||||
@code{call-with-resource-from-pool}. Defaults to @code{#f} (no
|
||||
logging).
|
||||
|
||||
@item #:scheduler
|
||||
The Fibers scheduler to use for the pool's internal fiber. Defaults
|
||||
to the current scheduler.
|
||||
|
|
@ -1374,9 +1408,20 @@ receive @code{&resource-pool-destroyed}."
|
|||
(timeout-handler (resource-pool-default-timeout-handler))
|
||||
(max-waiters 'default)
|
||||
(channel (resource-pool-channel pool))
|
||||
(destroy-resource-on-exception? #f))
|
||||
(destroy-resource-on-exception? #f)
|
||||
(delay-logger (resource-pool-delay-logger pool))
|
||||
(duration-logger (resource-pool-duration-logger pool)))
|
||||
"Call PROC with a resource from POOL, blocking until a resource becomes
|
||||
available. Return the resource once PROC has returned."
|
||||
available. Return the resource once PROC has returned.
|
||||
|
||||
@code{#:delay-logger} is called as @code{(delay-logger seconds)} with
|
||||
the time spent waiting for a resource to become available. Defaults
|
||||
to the pool's @code{#:delay-logger} if not specified.
|
||||
|
||||
@code{#:duration-logger} is called as @code{(duration-logger seconds)}
|
||||
after PROC completes, whether it returned normally or raised an
|
||||
exception. Defaults to the pool's @code{#:duration-logger} if not
|
||||
specified."
|
||||
|
||||
(define timeout-or-default
|
||||
(if (eq? timeout 'default)
|
||||
|
|
@ -1390,6 +1435,26 @@ available. Return the resource once PROC has returned."
|
|||
'default-max-waiters)
|
||||
max-waiters))
|
||||
|
||||
(define (delay-logger/safe seconds)
|
||||
(with-exception-handler
|
||||
;; Ignore exceptions, since this would break returning the
|
||||
;; resource
|
||||
(lambda (exn) #f)
|
||||
(lambda ()
|
||||
(delay-logger seconds))
|
||||
#:unwind? #t))
|
||||
|
||||
(define (duration-logger/safe seconds)
|
||||
(with-exception-handler
|
||||
;; Ignore exceptions, since this would break returning the
|
||||
;; resource
|
||||
(lambda (exn) #f)
|
||||
(lambda ()
|
||||
(duration-logger seconds))
|
||||
#:unwind? #t))
|
||||
|
||||
(define checkout-start-time (get-internal-real-time))
|
||||
|
||||
(unless channel
|
||||
(raise-exception
|
||||
(make-resource-pool-destroyed-error pool)))
|
||||
|
|
@ -1462,43 +1527,57 @@ available. Return the resource once PROC has returned."
|
|||
(raise-exception
|
||||
(make-resource-pool-destroyed-error pool)))
|
||||
(('success resource-id resource-value)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
;; Unwind the stack before calling put-message, as
|
||||
;; this avoids inconsistent behaviour with
|
||||
;; continuation barriers
|
||||
(put-message
|
||||
channel
|
||||
(list (if (or destroy-resource-on-exception?
|
||||
(resource-pool-destroy-resource-exception? exn))
|
||||
'destroy
|
||||
'return)
|
||||
resource-id))
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(let ((stack
|
||||
(match (fluid-ref %stacks)
|
||||
((stack-tag . prompt-tag)
|
||||
(make-stack #t
|
||||
0 prompt-tag
|
||||
0 (and prompt-tag 1)))
|
||||
(_
|
||||
(make-stack #t)))))
|
||||
(raise-exception
|
||||
(make-exception
|
||||
exn
|
||||
(make-knots-exception stack)))))
|
||||
(lambda ()
|
||||
(proc resource-value))))
|
||||
#:unwind? #t))
|
||||
(lambda vals
|
||||
(put-message channel
|
||||
`(return ,resource-id))
|
||||
(apply values vals)))))))
|
||||
(when delay-logger
|
||||
(delay-logger/safe
|
||||
(/ (- (get-internal-real-time) checkout-start-time)
|
||||
internal-time-units-per-second)))
|
||||
|
||||
(let ((proc-start-time (get-internal-real-time)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
;; Unwind the stack before calling put-message, as
|
||||
;; this avoids inconsistent behaviour with
|
||||
;; continuation barriers
|
||||
(when duration-logger
|
||||
(duration-logger/safe
|
||||
(/ (- (get-internal-real-time) proc-start-time)
|
||||
internal-time-units-per-second)))
|
||||
(put-message
|
||||
channel
|
||||
(list (if (or destroy-resource-on-exception?
|
||||
(resource-pool-destroy-resource-exception? exn))
|
||||
'destroy
|
||||
'return)
|
||||
resource-id))
|
||||
(raise-exception exn))
|
||||
(lambda ()
|
||||
(with-exception-handler
|
||||
(lambda (exn)
|
||||
(let ((stack
|
||||
(match (fluid-ref %stacks)
|
||||
((stack-tag . prompt-tag)
|
||||
(make-stack #t
|
||||
0 prompt-tag
|
||||
0 (and prompt-tag 1)))
|
||||
(_
|
||||
(make-stack #t)))))
|
||||
(raise-exception
|
||||
(make-exception
|
||||
exn
|
||||
(make-knots-exception stack)))))
|
||||
(lambda ()
|
||||
(proc resource-value))))
|
||||
#:unwind? #t))
|
||||
(lambda vals
|
||||
(when duration-logger
|
||||
(duration-logger/safe
|
||||
(/ (- (get-internal-real-time) proc-start-time)
|
||||
internal-time-units-per-second)))
|
||||
(put-message channel
|
||||
`(return ,resource-id))
|
||||
(apply values vals))))))))
|
||||
|
||||
(define-syntax-rule (with-resource-from-pool pool resource exp ...)
|
||||
"Evaluate EXP ... with RESOURCE bound to a resource checked out from
|
||||
|
|
|
|||
|
|
@ -282,4 +282,50 @@
|
|||
|
||||
(destroy-resource-pool resource-pool))))
|
||||
|
||||
;; Test delay-logger and duration-logger
|
||||
(run-fibers-for-tests
|
||||
(lambda ()
|
||||
(let* ((logged-delay #f)
|
||||
(logged-duration #f)
|
||||
(resource-pool (make-fixed-size-resource-pool
|
||||
(list 1)
|
||||
#:delay-logger
|
||||
(lambda (seconds)
|
||||
(set! logged-delay seconds))
|
||||
#:duration-logger
|
||||
(lambda (seconds)
|
||||
(set! logged-duration seconds)))))
|
||||
|
||||
(call-with-resource-from-pool resource-pool
|
||||
(lambda (res)
|
||||
(sleep 0.2)))
|
||||
|
||||
(assert-true (number? logged-delay))
|
||||
(assert-true (number? logged-duration))
|
||||
(assert-true (>= logged-duration 0.1))
|
||||
|
||||
(destroy-resource-pool resource-pool))))
|
||||
|
||||
;; Test per-call duration-logger overrides pool default
|
||||
(run-fibers-for-tests
|
||||
(lambda ()
|
||||
(let* ((pool-logged #f)
|
||||
(call-logged #f)
|
||||
(resource-pool (make-fixed-size-resource-pool
|
||||
(list 1)
|
||||
#:duration-logger
|
||||
(lambda (seconds)
|
||||
(set! pool-logged seconds)))))
|
||||
|
||||
(call-with-resource-from-pool resource-pool
|
||||
(lambda (res) #t)
|
||||
#:duration-logger
|
||||
(lambda (seconds)
|
||||
(set! call-logged seconds)))
|
||||
|
||||
(assert-true (not pool-logged))
|
||||
(assert-true (number? call-logged))
|
||||
|
||||
(destroy-resource-pool resource-pool))))
|
||||
|
||||
(display "resource-pool test finished successfully\n")
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue