02/05: scripts: Set thread names.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 8902d0f2676a500c785044fff54b8675f96cef6d
Author: Ludovic Courtès <address@hidden>
Date:   Sun May 28 16:09:32 2017 +0200

    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.
---
 guix/scripts/offload.scm    |  4 +++-
 guix/scripts/publish.scm    | 11 ++++++++++-
 guix/scripts/substitute.scm |  4 ++++
 guix/workers.scm            | 18 ++++++++++++++----
 4 files changed, 31 insertions(+), 6 deletions(-)

diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 74c0c54..77b340c 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -34,7 +34,8 @@
                 #:select (nar-error? nar-error-file))
   #:use-module (guix nar)
   #:use-module (guix utils)
-  #:use-module ((guix build syscalls) #:select (fcntl-flock))
+  #:use-module ((guix build syscalls)
+                #:select (fcntl-flock set-thread-name))
   #:use-module ((guix build utils) #:select (which mkdir-p))
   #:use-module (guix ui)
   #:use-module (srfi srfi-1)
@@ -641,6 +642,7 @@ machine."
      (let ((max-silent-time    (string->number max-silent-time))
            (build-timeout      (string->number build-timeout))
            (print-build-trace? (string=? print-build-trace? "1")))
+       (set-thread-name "guix offload")
        (parameterize ((%current-system system))
          (let loop ((line (read-line)))
            (unless (eof-object? line)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index c306b80..c49c0c3 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -58,6 +58,7 @@
                 #:select (with-atomic-file-output compressed-file?))
   #:use-module ((guix build utils)
                 #:select (dump-port mkdir-p find-files))
+  #:use-module ((guix build syscalls) #:select (set-thread-name))
   #:export (%public-key
             %private-key
 
@@ -649,6 +650,7 @@ blocking."
      ;; thread so that the main thread can keep working in the meantime.
      (call-with-new-thread
       (lambda ()
+        (set-thread-name "publish nar")
         (let* ((response (write-response (sans-content-length response)
                                          client))
                (port     (begin
@@ -670,6 +672,7 @@ blocking."
      ;; Send a raw file in a separate thread.
      (call-with-new-thread
       (lambda ()
+        (set-thread-name "publish file")
         (catch 'system-error
           (lambda ()
             (call-with-input-file (utf8->string body)
@@ -858,10 +861,16 @@ consider using the '--user' option!~%")))
                 (sockaddr:port address))
         (when repl-port
           (repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
+
+        ;; Set the name of the main thread.
+        (set-thread-name "guix publish")
+
         (with-store store
           (run-publish-server socket store
                               #:cache cache
-                              #:pool (and cache (make-pool workers))
+                              #:pool (and cache (make-pool workers
+                                                           #:thread-name
+                                                           "publish worker"))
                               #:nar-path nar-path
                               #:compression compression
                               #:narinfo-ttl ttl))))))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 73d4f6e..4ee15ba 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -39,6 +39,8 @@
                            . guix:open-connection-for-uri)
                           close-connection
                           store-path-abbreviation byte-count->string))
+  #:use-module ((guix build syscalls)
+                #:select (set-thread-name))
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -1015,6 +1017,8 @@ default value."
     (#f     #f)
     (locale (false-if-exception (setlocale LC_ALL locale))))
 
+  (set-thread-name "guix substitute")
+
   (with-networking
    (with-error-handling                           ; for signature errors
      (match args
diff --git a/guix/workers.scm b/guix/workers.scm
index e3452d2..846f5e5 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)