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 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?

23
tests/resource-pool.scm
View file

@ -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")