scripts: Set thread names.

This allows 'guix publish' threads as well as 'guix substitute' and
'guix offload' processes to be properly labeled in 'top', 'pstree', etc.

* guix/workers.scm (worker-thunk): Add #:thread-name parameter and honor it.
(make-pool): Likewise.
* guix/scripts/publish.scm (http-write): Add calls to 'set-thread-name'
in bodies of 'call-with-new-thread'.
(guix-publish): Call 'set-thread-name'.   Pass #:thread-name to 'make-pool'.
* guix/scripts/offload.scm (guix-offload): Call 'set-thread-name'.
* guix/scripts/substitute.scm (guix-substitute): Likewise.

1 files changed, 14 insertions, 4 deletions

diff --git a/guix/workers.scm b/guix/workers.scm
index e3452d249a..846f5e50a9 100644
--- a/guix/workers.scm
+++ b/guix/workers.scm
@@ -23,6 +23,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
+  #:use-module ((guix build syscalls) #:select (set-thread-name))
   #:export (pool?
             make-pool
             pool-enqueue!
@@ -60,7 +61,8 @@
     (lambda ()
       (lock-mutex mutex))))
 
-(define (worker-thunk mutex condvar pop-queue)
+(define* (worker-thunk mutex condvar pop-queue
+                       #:key (thread-name "guix worker"))
   "Return the thunk executed by worker threads."
   (define (loop)
     (match (pop-queue)
@@ -80,11 +82,18 @@
     (loop))
 
   (lambda ()
+    (catch 'system-error
+      (lambda ()
+        (set-thread-name thread-name))
+      (const #f))
+
     (with-mutex mutex
       (loop))))
 
-(define* (make-pool #:optional (count (current-processor-count)))
-  "Return a pool of COUNT workers."
+(define* (make-pool #:optional (count (current-processor-count))
+                    #:key (thread-name "guix worker"))
+  "Return a pool of COUNT workers.  Use THREAD-NAME as the name of these
+threads as reported by the operating system."
   (let* ((mutex   (make-mutex))
          (condvar (make-condition-variable))
          (queue   (make-q))
@@ -93,7 +102,8 @@
                             (worker-thunk mutex condvar
                                           (lambda ()
                                             (and (not (q-empty? queue))
-                                                 (q-pop! queue)))))
+                                                 (q-pop! queue)))
+                                          #:thread-name thread-name))
                           1+
                           0))
          (threads (map (lambda (proc)