diff --git a/a-sync/thread-pool.scm b/a-sync/thread-pool.scm index 38142fc..1e111ee 100755 --- a/a-sync/thread-pool.scm +++ b/a-sync/thread-pool.scm @@ -388,10 +388,11 @@ ;; (iv) the attempt to launch new threads failed with ;; an exception without launching even one of them. ;; In such a case we should be able to launch a rescue - ;; thread because no other threads could be running in - ;; the pool. If we still cannot launch a thread the - ;; program and/or system must be totally borked anyway - ;; and there is little we can do. + ;; thread while holding the mutex because no other + ;; threads could be running in the pool. If we still + ;; cannot launch a thread the program and/or system + ;; must be totally borked and there is little we can + ;; do. (when (zero? (num-threads-get pool)) ;; if this fails, all is lost (that is, we may have ;; queued tasks in the pool with no thread startable @@ -528,10 +529,11 @@ ;; using catch). ;; ;; If this procedure starts a new thread (see above), it may throw an -;; exception if the system is unable to start the thread correctly. -;; This procedure will throw a 'thread-pool-error exception if it is -;; invoked after the thread pool object concerned has been closed by a -;; call to thread-pool-stop!. +;; exception if the system is unable to start the thread correctly, +;; and if it does so the task will not be added. This procedure will +;; throw a 'thread-pool-error exception if it is invoked after the +;; thread pool object concerned has been closed by a call to +;; thread-pool-stop!. ;; ;; This procedure is first available in version 0.18 of this library. (define* (thread-pool-add! pool task #:optional fail-handler) @@ -571,12 +573,36 @@ (call-with-new-thread (lambda () (thread-loop pool #f)))) (lambda args (with-mutex mutex - (num-tasks-set! pool (1- (num-tasks-get pool))) - (num-threads-set! pool (1- (num-threads-get pool))) - (when (and (stopped-get pool) - (blocking-get pool)) - (broadcast-condition-variable (condvar-get pool))) - (apply throw args)))))) + ;; If min-threads is 0 we could be down to 0 threads + ;; with tasks still pending if in the period between + ;; releasing the mutex acquired on entry to this + ;; procedure and acquiring it again on handling this + ;; exception, there have been concurrent calls to + ;; thread-pool-set-max-threads! increasing and reducing + ;; the maximum thread count by at least two other + ;; threads where the launching of all new threads via + ;; that procedure and this one fails. In such a case we + ;; should be able to launch a rescue thread while + ;; holding the mutex because no other threads could be + ;; running in the pool. If we still cannot launch a + ;; thread the program and/or system must be totally + ;; borked and there is little we can do. + (let ((retry + (if (= (num-threads-get pool) 1) + (catch #t + (lambda () + (call-with-new-thread (lambda () (thread-loop pool #f))) + #t) + (lambda args + #f)) + #f))) + (when (not retry) + (num-tasks-set! pool (1- (num-tasks-get pool))) + (num-threads-set! pool (1- (num-threads-get pool))) + (when (and (stopped-get pool) + (blocking-get pool)) + (broadcast-condition-variable (condvar-get pool))) + (apply throw args)))))))) ;; we need to check again whether thread-pool-stop! has been ;; called between us releasing the mutex above and reaching here. ;; We need to hold the mutex when adding the task so that the diff --git a/docs/guile-a-sync.info b/docs/guile-a-sync.info index 722b219..aef3f75 100644 --- a/docs/guile-a-sync.info +++ b/docs/guile-a-sync.info @@ -2393,10 +2393,11 @@ the already accumulated tasks has reduced. using catch). If this procedure starts a new thread (see above), it may throw an - exception if the system is unable to start the thread correctly. - This procedure will throw a 'thread-pool-error exception if it is - invoked after the thread pool object concerned has been closed by a - call to thread-pool-stop!. + exception if the system is unable to start the thread correctly, + and if it does so the task will not be added. This procedure will + throw a 'thread-pool-error exception if it is invoked after the + thread pool object concerned has been closed by a call to + thread-pool-stop!. This procedure is first available in version 0.18 of this library. @@ -3804,9 +3805,9 @@ Node: coroutines4756 Node: event loop23080 Node: sockets107788 Node: thread pool111166 -Node: monotonic time132388 -Node: gnome glib133823 -Node: compose173921 -Node: meeting181130 +Node: monotonic time132440 +Node: gnome glib133875 +Node: compose173973 +Node: meeting181182 End Tag Table diff --git a/docs/html/thread-pool.html b/docs/html/thread-pool.html index 2dedfaf..64a4e48 100644 --- a/docs/html/thread-pool.html +++ b/docs/html/thread-pool.html @@ -319,10 +319,10 @@
If this procedure starts a new thread (see above), it may throw an -exception if the system is unable to start the thread correctly. This -procedure will throw a ’thread-pool-error exception if it is invoked -after the thread pool object concerned has been closed by a call to -thread-pool-stop!. +exception if the system is unable to start the thread correctly, and +if it does so the task will not be added. This procedure will throw a +’thread-pool-error exception if it is invoked after the thread pool +object concerned has been closed by a call to thread-pool-stop!.
This procedure is first available in version 0.18 of this library.
diff --git a/docs/thread-pool.texi b/docs/thread-pool.texi index 12f3a9b..a109142 100644 --- a/docs/thread-pool.texi +++ b/docs/thread-pool.texi @@ -254,10 +254,10 @@ arguments as if it were a guile catch handler (it is implemented using catch). If this procedure starts a new thread (see above), it may throw an -exception if the system is unable to start the thread correctly. This -procedure will throw a 'thread-pool-error exception if it is invoked -after the thread pool object concerned has been closed by a call to -thread-pool-stop!. +exception if the system is unable to start the thread correctly, and +if it does so the task will not be added. This procedure will throw a +'thread-pool-error exception if it is invoked after the thread pool +object concerned has been closed by a call to thread-pool-stop!. This procedure is first available in version 0.18 of this library. @end deffn