diff options
| -rw-r--r-- | knots/resource-pool.scm | 75 | ||||
| -rw-r--r-- | tests/resource-pool.scm | 23 |
2 files changed, 58 insertions, 40 deletions
diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 3c5fb23..17919a6 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -109,8 +109,8 @@ (define checkout-failure-count 0) (define spawn-fiber-to-return-new-resource - (let ((thunk - (if add-resources-parallelism + (if add-resources-parallelism + (let ((thunk (fiberize (lambda () (let ((max-size @@ -118,44 +118,38 @@ 'max-size)) (size (assq-ref (resource-pool-stats pool) 'resources))) - (if (= size max-size) - (raise-exception - (make-resource-pool-abort-add-resource-error)) - (return-new-resource)))) - #:parallelism add-resources-parallelism - #:show-backtrace? - (lambda (key . args) - (not - (and (eq? key '%exception) - (resource-pool-abort-add-resource-error? - (car args)))))) - return-new-resource))) - (lambda () - (spawn-fiber - (lambda () - (let ((new-resource - (with-exception-handler - (lambda (exn) - (unless (resource-pool-abort-add-resource-error? exn) + (unless (= size max-size) + (let ((new-resource + (return-new-resource))) + (put-message channel + (list 'add-resource new-resource)))))) + #:parallelism add-resources-parallelism))) + (lambda () + (spawn-fiber thunk))) + (lambda () + (spawn-fiber + (lambda () + (let ((new-resource + (with-exception-handler + (lambda (exn) (simple-format (current-error-port) "exception adding resource to pool ~A: ~A:\n ~A\n" name return-new-resource - exn)) - #f) - (lambda () - (with-throw-handler #t - thunk - (lambda (key . args) - (unless (and (eq? key '%exception) - (resource-pool-abort-add-resource-error? - (car args))) - (backtrace))))) - #:unwind? #t))) - (when new-resource - (put-message channel - (list 'add-resource new-resource))))))))) + exn) + #f) + (lambda () + (with-exception-handler + (lambda (exn) + (backtrace) + (raise-exception exn)) + (lambda () + (start-stack #t (return-new-resource))))) + #:unwind? #t))) + (when new-resource + (put-message channel + (list 'add-resource new-resource))))))))) (define (spawn-fiber-to-destroy-resource resource) (spawn-fiber @@ -172,12 +166,13 @@ exn) #f) (lambda () - (with-throw-handler #t + (with-exception-handler + (lambda (exn) + (backtrace) + (raise-exception exn)) (lambda () - (destructor resource) - #t) - (lambda _ - (backtrace)))) + (start-stack #t (destructor resource)) + #t))) #:unwind? #t))) (if success? diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm index 24a4f53..1d998ef 100644 --- a/tests/resource-pool.scm +++ b/tests/resource-pool.scm @@ -72,4 +72,27 @@ (destroy-resource-pool resource-pool)))) +(run-fibers-for-tests + (lambda () + (let* ((counter 0) + (resource-pool (make-resource-pool + (lambda () + (let ((start-val counter)) + (sleep 0.05) + (if (= start-val counter) + (set! counter (+ 1 counter)) + (error "collision detected"))) + (new-number)) + 1))) + (fibers-for-each + (lambda _ + (with-resource-from-pool + resource-pool res + (let ((start-val counter)) + (sleep 0.05) + (if (= start-val counter) + (set! counter (+ 1 counter)) + (error "collision detected"))))) + (iota 50))))) + (display "resource-pool test finished successfully\n") |