cbaines/guile-knots
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix issue with parallel creating resource pool resources

Browse source
This commit is contained in:
Christopher Baines 2025-01-31 17:55:18 +01:00
parent 61451907a9
commit 2910e66150
2 changed files with 58 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

75
knots/resource-pool.scm
View file

@ -109,8 +109,8 @@
(define checkout-failure-count 0) (define checkout-failure-count 0)
(define spawn-fiber-to-return-new-resource (define spawn-fiber-to-return-new-resource
(let ((thunk (if add-resources-parallelism
(if add-resources-parallelism (let ((thunk
(fiberize (fiberize
(lambda () (lambda ()
(let ((max-size (let ((max-size
@ -118,44 +118,38 @@
'max-size)) 'max-size))
(size (assq-ref (resource-pool-stats pool) (size (assq-ref (resource-pool-stats pool)
'resources))) 'resources)))
(if (= size max-size) (unless (= size max-size)
(raise-exception (let ((new-resource
(make-resource-pool-abort-add-resource-error)) (return-new-resource)))
(return-new-resource)))) (put-message channel
#:parallelism add-resources-parallelism (list 'add-resource new-resource))))))
#:show-backtrace? #:parallelism add-resources-parallelism)))
(lambda (key . args) (lambda ()
(not (spawn-fiber thunk)))
(and (eq? key '%exception) (lambda ()
(resource-pool-abort-add-resource-error? (spawn-fiber
(car args)))))) (lambda ()
return-new-resource))) (let ((new-resource
(lambda () (with-exception-handler
(spawn-fiber (lambda (exn)
(lambda ()
(let ((new-resource
(with-exception-handler
(lambda (exn)
(unless (resource-pool-abort-add-resource-error? exn)
(simple-format (simple-format
(current-error-port) (current-error-port)
"exception adding resource to pool ~A: ~A:\n ~A\n" "exception adding resource to pool ~A: ~A:\n ~A\n"
name name
return-new-resource return-new-resource
exn)) exn)
#f) #f)
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
thunk (lambda (exn)
(lambda (key . args) (backtrace)
(unless (and (eq? key '%exception) (raise-exception exn))
(resource-pool-abort-add-resource-error? (lambda ()
(car args))) (start-stack #t (return-new-resource)))))
(backtrace))))) #:unwind? #t)))
#:unwind? #t))) (when new-resource
(when new-resource (put-message channel
(put-message channel (list 'add-resource new-resource)))))))))
(list 'add-resource new-resource)))))))))
(define (spawn-fiber-to-destroy-resource resource) (define (spawn-fiber-to-destroy-resource resource)
(spawn-fiber (spawn-fiber
@ -172,12 +166,13 @@
exn) exn)
#f) #f)
(lambda () (lambda ()
(with-throw-handler #t (with-exception-handler
(lambda (exn)
(backtrace)
(raise-exception exn))
(lambda () (lambda ()
(destructor resource) (start-stack #t (destructor resource))
#t) #t)))
(lambda _
(backtrace))))
#:unwind? #t))) #:unwind? #t)))
(if success? (if success?

23
tests/resource-pool.scm
View file

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