From 8902d0f2676a500c785044fff54b8675f96cef6d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 May 2017 16:09:32 +0200 Subject: 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(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 74c0c5484c..77b340cff6 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -34,7 +34,8 @@ (define-module (guix scripts offload) #: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 @@ (define not-coma (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 c306b809a7..c49c0c3e20 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -58,6 +58,7 @@ (define-module (guix scripts publish) #: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 @@ (define (http-write server client response body) ;; 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 @@ (define (http-write server client response body) ;; 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 @@ (define (guix-publish . args) (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 73d4f6e2eb..4ee15ba67d 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -39,6 +39,8 @@ (define-module (guix scripts substitute) . 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 @@ (define (guix-substitute . args) (#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 e3452d249a..846f5e50a9 100644 --- a/guix/workers.scm +++ b/guix/workers.scm @@ -23,6 +23,7 @@ (define-module (guix workers) #: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 @@ (define-syntax-rule (without-mutex mutex exp ...) (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 @@ (define (loop) (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 @@ (define* (make-pool #:optional (count (current-processor-count))) (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) -- cgit v1.2.3