cbaines/guile-knots
1
Fork 0
Code Issues 1 Pull requests Activity Actions

Compare commits

base: cbaines:c2e1cd94d7a8c7cb64d90fd15a29738905cb8295
Branches Tags
cbaines:trunk
cbaines:pages
cbaines:actions-test
cbaines:0.1
..
compare: cbaines:d0ff89023b9fb0ff2617b95b45af90128fe6c8c7
Branches Tags
cbaines:pages
cbaines:trunk
cbaines:actions-test
cbaines:0.1

No commits in common. "c2e1cd94d7a8c7cb64d90fd15a29738905cb8295" and "d0ff89023b9fb0ff2617b95b45af90128fe6c8c7" have entirely different histories.
c2e1cd94d7 ... d0ff89023b

4 changed files with 68 additions and 278 deletions
Download patch file Download diff file Expand all files Collapse all files

98
knots/resource-pool.scm
View file

@ -60,9 +60,6 @@
make-resource-pool-destroy-resource-exception make-resource-pool-destroy-resource-exception
resource-pool-destroy-resource-exception? resource-pool-destroy-resource-exception?
resource-pool-delay-logger
resource-pool-duration-logger
resource-pool-default-timeout-handler resource-pool-default-timeout-handler
call-with-resource-from-pool call-with-resource-from-pool
@ -106,14 +103,6 @@
'documentation 'documentation
"Return the configuration alist of the resource pool.") "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! (set-record-type-printer!
<resource-pool> <resource-pool>
(lambda (resource-pool port) (lambda (resource-pool port)
@ -149,7 +138,7 @@
(define-inlinable (decrement-resource-checkout-count! resource) (define-inlinable (decrement-resource-checkout-count! resource)
(set-resource-details-checkout-count! (set-resource-details-checkout-count!
resource resource
(1- (resource-details-checkout-count resource)))) (1+ (resource-details-checkout-count resource))))
(define (spawn-fiber-for-checkout channel (define (spawn-fiber-for-checkout channel
reply-channel reply-channel
@ -175,8 +164,8 @@
(define* (make-fixed-size-resource-pool resources-list-or-vector (define* (make-fixed-size-resource-pool resources-list-or-vector
#:key #:key
(delay-logger #f) (delay-logger (const #f))
(duration-logger #f) (duration-logger (const #f))
scheduler scheduler
(name "unnamed") (name "unnamed")
default-checkout-timeout default-checkout-timeout
@ -204,19 +193,6 @@ Maximum number of fibers that may queue waiting for a resource. When
this limit is exceeded, @code{&resource-pool-too-many-waiters} is this limit is exceeded, @code{&resource-pool-too-many-waiters} is
raised when a resource is requested. Defaults to @code{#f} (no limit). 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 @item #:scheduler
The Fibers scheduler to use for the pool's internal fiber. Defaults The Fibers scheduler to use for the pool's internal fiber. Defaults
to the current scheduler. to the current scheduler.
@ -571,8 +547,8 @@ to the current scheduler.
(define* (make-resource-pool return-new-resource max-size (define* (make-resource-pool return-new-resource max-size
#:key (min-size 0) #:key (min-size 0)
(idle-seconds #f) (idle-seconds #f)
(delay-logger #f) (delay-logger (const #f))
(duration-logger #f) (duration-logger (const #f))
destructor destructor
lifetime lifetime
scheduler scheduler
@ -629,19 +605,6 @@ Maximum number of fibers that may queue waiting for a resource. When
this limit is exceeded, @code{&resource-pool-too-many-waiters} is this limit is exceeded, @code{&resource-pool-too-many-waiters} is
raised when a resource is requested. Defaults to @code{#f} (no limit). 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 @item #:scheduler
The Fibers scheduler to use for the pool's internal fiber. Defaults The Fibers scheduler to use for the pool's internal fiber. Defaults
to the current scheduler. to the current scheduler.
@ -1411,20 +1374,9 @@ receive @code{&resource-pool-destroyed}."
(timeout-handler (resource-pool-default-timeout-handler)) (timeout-handler (resource-pool-default-timeout-handler))
(max-waiters 'default) (max-waiters 'default)
(channel (resource-pool-channel pool)) (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 "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 (define timeout-or-default
(if (eq? timeout 'default) (if (eq? timeout 'default)
@ -1438,26 +1390,6 @@ specified."
'default-max-waiters) 'default-max-waiters)
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 (unless channel
(raise-exception (raise-exception
(make-resource-pool-destroyed-error pool))) (make-resource-pool-destroyed-error pool)))
@ -1530,12 +1462,6 @@ specified."
(raise-exception (raise-exception
(make-resource-pool-destroyed-error pool))) (make-resource-pool-destroyed-error pool)))
(('success resource-id resource-value) (('success resource-id resource-value)
(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 (call-with-values
(lambda () (lambda ()
(with-exception-handler (with-exception-handler
@ -1543,10 +1469,6 @@ specified."
;; Unwind the stack before calling put-message, as ;; Unwind the stack before calling put-message, as
;; this avoids inconsistent behaviour with ;; this avoids inconsistent behaviour with
;; continuation barriers ;; continuation barriers
(when duration-logger
(duration-logger/safe
(/ (- (get-internal-real-time) proc-start-time)
internal-time-units-per-second)))
(put-message (put-message
channel channel
(list (if (or destroy-resource-on-exception? (list (if (or destroy-resource-on-exception?
@ -1574,13 +1496,9 @@ specified."
(proc resource-value)))) (proc resource-value))))
#:unwind? #t)) #:unwind? #t))
(lambda vals (lambda vals
(when duration-logger
(duration-logger/safe
(/ (- (get-internal-real-time) proc-start-time)
internal-time-units-per-second)))
(put-message channel (put-message channel
`(return ,resource-id)) `(return ,resource-id))
(apply values vals)))))))) (apply values vals)))))))
(define-syntax-rule (with-resource-from-pool pool resource exp ...) (define-syntax-rule (with-resource-from-pool pool resource exp ...)
"Evaluate EXP ... with RESOURCE bound to a resource checked out from "Evaluate EXP ... with RESOURCE bound to a resource checked out from

80
knots/thread-pool.scm
View file

@ -55,8 +55,6 @@
;; thread pools ;; thread pools
thread-pool-arguments-parameter thread-pool-arguments-parameter
thread-pool-default-checkout-timeout thread-pool-default-checkout-timeout
thread-pool-delay-logger
thread-pool-duration-logger
destroy-thread-pool destroy-thread-pool
@ -173,15 +171,12 @@ from there, or #f if that would be an empty string."
(define-record-type <fixed-size-thread-pool> (define-record-type <fixed-size-thread-pool>
(fixed-size-thread-pool channel arguments-parameter current-procedures (fixed-size-thread-pool channel arguments-parameter current-procedures
default-checkout-timeout delay-logger default-checkout-timeout threads)
duration-logger threads)
fixed-size-thread-pool? fixed-size-thread-pool?
(channel fixed-size-thread-pool-channel) (channel fixed-size-thread-pool-channel)
(arguments-parameter fixed-size-thread-pool-arguments-parameter) (arguments-parameter fixed-size-thread-pool-arguments-parameter)
(current-procedures fixed-size-thread-pool-current-procedures) (current-procedures fixed-size-thread-pool-current-procedures)
(default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout) (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout)
(delay-logger fixed-size-thread-pool-delay-logger)
(duration-logger fixed-size-thread-pool-duration-logger)
(threads fixed-size-thread-pool-threads)) (threads fixed-size-thread-pool-threads))
(set-procedure-property! (set-procedure-property!
(macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?)) (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?))
@ -212,20 +207,6 @@ from there, or #f if that would be an empty string."
(thread-pool-resource-pool pool)) (thread-pool-resource-pool pool))
'default-checkout-timeout))) 'default-checkout-timeout)))
(define (thread-pool-delay-logger pool)
"Return the delay logger for POOL, dispatching on pool type."
(if (fixed-size-thread-pool? pool)
(fixed-size-thread-pool-delay-logger pool)
(resource-pool-delay-logger
(thread-pool-resource-pool pool))))
(define (thread-pool-duration-logger pool)
"Return the duration logger for POOL, dispatching on pool type."
(if (fixed-size-thread-pool? pool)
(fixed-size-thread-pool-duration-logger pool)
(resource-pool-duration-logger
(thread-pool-resource-pool pool))))
(define &thread-pool-timeout-error (define &thread-pool-timeout-error
(make-exception-type '&thread-pool-timeout-error (make-exception-type '&thread-pool-timeout-error
&error &error
@ -296,12 +277,12 @@ Seconds to wait for a free thread slot before raising
forever). forever).
@item #:delay-logger @item #:delay-logger
Called as @code{(delay-logger seconds)} with the time spent waiting Called as @code{(delay-logger seconds proc)} with the time spent
for a thread to become available. waiting for a thread to become available.
@item #:duration-logger @item #:duration-logger
Called as @code{(duration-logger seconds)} after each procedure Called as @code{(duration-logger seconds proc)} after each procedure
completes, whether it returned normally or raised an exception. completes.
@end table" @end table"
(define channel (define channel
(make-channel)) (make-channel))
@ -365,7 +346,15 @@ completes, whether it returned normally or raised an exception.
(let loop ((lifetime thread-lifetime)) (let loop ((lifetime thread-lifetime))
(match (get-message channel) (match (get-message channel)
('destroy #f) ('destroy #f)
((reply proc) ((reply sent-time proc)
(when delay-logger
(let ((time-delay
(- (get-internal-real-time)
sent-time)))
(delay-logger (/ time-delay
internal-time-units-per-second)
proc)))
(let* ((start-time (get-internal-real-time)) (let* ((start-time (get-internal-real-time))
(response (response
(with-exception-handler (with-exception-handler
@ -417,11 +406,11 @@ completes, whether it returned normally or raised an exception.
(match response (match response
(('thread-pool-error duration _) (('thread-pool-error duration _)
(when duration-logger (when duration-logger
(duration-logger duration)) (duration-logger duration proc))
#t) #t)
((duration . _) ((duration . _)
(when duration-logger (when duration-logger
(duration-logger duration)) (duration-logger duration proc))
#f)))) #f))))
(if (and exception? (if (and exception?
expire-on-exception?) expire-on-exception?)
@ -477,8 +466,6 @@ completes, whether it returned normally or raised an exception.
param param
thread-proc-vector thread-proc-vector
default-checkout-timeout default-checkout-timeout
delay-logger
duration-logger
threads)) threads))
(define* (make-thread-pool max-size (define* (make-thread-pool max-size
@ -487,8 +474,8 @@ completes, whether it returned normally or raised an exception.
scheduler scheduler
thread-initializer thread-initializer
thread-destructor thread-destructor
delay-logger (delay-logger (lambda _ #f))
duration-logger (duration-logger (const #f))
thread-lifetime thread-lifetime
(expire-on-exception? #f) (expire-on-exception? #f)
(name "unnamed") (name "unnamed")
@ -552,10 +539,7 @@ Maximum number of fibers that may queue waiting for a thread. Raises
(define* (call-with-thread thread-pool (define* (call-with-thread thread-pool
proc proc
#:key #:key
(delay-logger duration-logger
(thread-pool-delay-logger thread-pool))
(duration-logger
(thread-pool-duration-logger thread-pool))
checkout-timeout checkout-timeout
channel channel
destroy-thread-on-exception? destroy-thread-on-exception?
@ -581,15 +565,9 @@ When @code{#t}, destroy the thread after PROC raises an exception.
Equivalent to per-call @code{#:expire-on-exception?}. Defaults to Equivalent to per-call @code{#:expire-on-exception?}. Defaults to
@code{#f}. @code{#f}.
@item #:delay-logger
Called as @code{(delay-logger seconds)} with the time spent waiting
for a thread to become available. Defaults to the pool's
@code{#:delay-logger} if not specified.
@item #:duration-logger @item #:duration-logger
Called as @code{(duration-logger seconds)} after PROC completes Called as @code{(duration-logger seconds)} after PROC completes
(whether or not it raised an exception). Defaults to the pool's (whether or not it raised an exception).
@code{#:duration-logger} if not specified.
@item #:channel @item #:channel
Override the channel used to communicate with the thread. Override the channel used to communicate with the thread.
@ -597,8 +575,7 @@ Override the channel used to communicate with the thread.
(define (handle-proc fixed-size-thread-pool (define (handle-proc fixed-size-thread-pool
reply-channel reply-channel
start-time start-time
timeout timeout)
delay-logger)
(let* ((request-channel (let* ((request-channel
(or channel (or channel
(fixed-size-thread-pool-channel (fixed-size-thread-pool-channel
@ -609,6 +586,7 @@ Override the channel used to communicate with the thread.
(wrap-operation (wrap-operation
(put-operation request-channel (put-operation request-channel
(list reply-channel (list reply-channel
start-time
proc)) proc))
(const #t)))) (const #t))))
@ -623,11 +601,6 @@ Override the channel used to communicate with the thread.
(raise-exception (raise-exception
(make-thread-pool-timeout-error))) (make-thread-pool-timeout-error)))
(when delay-logger
(delay-logger
(/ (- (get-internal-real-time) start-time)
internal-time-units-per-second)))
(let ((reply (get-message reply-channel))) (let ((reply (get-message reply-channel)))
(match reply (match reply
(('thread-pool-error duration exn) (('thread-pool-error duration exn)
@ -648,8 +621,7 @@ Override the channel used to communicate with the thread.
(handle-proc thread-pool (handle-proc thread-pool
reply-channel reply-channel
start-time start-time
checkout-timeout checkout-timeout)
delay-logger)
(with-exception-handler (with-exception-handler
(lambda (exn) (lambda (exn)
(if (and (resource-pool-timeout-error? exn) (if (and (resource-pool-timeout-error? exn)
@ -670,17 +642,13 @@ Override the channel used to communicate with the thread.
(handle-proc fixed-size-thread-pool (handle-proc fixed-size-thread-pool
reply-channel reply-channel
start-time start-time
remaining-time remaining-time)
#f)
(raise-exception (raise-exception
(make-thread-pool-timeout-error thread-pool)))) (make-thread-pool-timeout-error thread-pool))))
(handle-proc fixed-size-thread-pool (handle-proc fixed-size-thread-pool
reply-channel reply-channel
start-time start-time
#f
#f))) #f)))
#:delay-logger delay-logger
#:duration-logger #f
#:max-waiters max-waiters #:max-waiters max-waiters
#:timeout checkout-timeout #:timeout checkout-timeout
#:destroy-resource-on-exception? #:destroy-resource-on-exception?

46
tests/resource-pool.scm
View file

@ -282,50 +282,4 @@
(destroy-resource-pool resource-pool)))) (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") (display "resource-pool test finished successfully\n")

50
tests/thread-pool.scm
View file

@ -172,54 +172,4 @@
(destroy-thread-pool thread-pool) (destroy-thread-pool thread-pool)
(assert-equal pool-size destructor-count)) (assert-equal pool-size destructor-count))
;; Test delay-logger and duration-logger for fixed-size thread pool
(let* ((logged-delay #f)
(logged-duration #f)
(thread-pool
(make-fixed-size-thread-pool
1
#:delay-logger
(lambda (seconds)
(set! logged-delay seconds))
#:duration-logger
(lambda (seconds)
(set! logged-duration seconds)))))
(call-with-thread
thread-pool
(lambda ()
(usleep 100000)))
(assert-true (number? logged-delay))
(assert-true (number? logged-duration))
(assert-true (>= logged-duration 0.1))
(destroy-thread-pool thread-pool))
;; Test delay-logger and duration-logger for dynamic thread pool
(run-fibers-for-tests
(lambda ()
(let* ((logged-delay #f)
(logged-duration #f)
(thread-pool
(make-thread-pool
1
#:delay-logger
(lambda (seconds)
(set! logged-delay seconds))
#:duration-logger
(lambda (seconds)
(set! logged-duration seconds)))))
(call-with-thread
thread-pool
(lambda ()
(usleep 100000)))
(assert-true (number? logged-delay))
(assert-true (number? logged-duration))
(assert-true (>= logged-duration 0.1))
(destroy-thread-pool thread-pool))))
(display "thread-pool test finished successfully\n") (display "thread-pool test finished successfully\n")