01/05: syscalls: Add 'thread-name' and 'set-thread-name'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit aa401f9ba6410095370ce0c4e5a01c02203a2b9f
Author: Ludovic Courtès <address@hidden>
Date:   Sun May 28 15:49:11 2017 +0200

    syscalls: Add 'thread-name' and 'set-thread-name'.
    
    * guix/build/syscalls.scm (PR_SET_NAME, PR_GET_NAME)
    (%max-thread-name-length): New variables.
    (%prctl, set-thread-name, thread-name): New procedures.
    * tests/syscalls.scm ("set-thread-name"): New test.
---
 guix/build/syscalls.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++++
 tests/syscalls.scm      |  8 ++++++++
 2 files changed, 57 insertions(+)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 0529c22..52439af 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -69,6 +69,9 @@
             pivot-root
             fcntl-flock
 
+            set-thread-name
+            thread-name
+
             CLONE_CHILD_CLEARTID
             CLONE_CHILD_SETTID
             CLONE_NEWNS
@@ -884,6 +887,52 @@ exception if it's already taken."
 
 
 ;;;
+;;; Miscellaneous, aka. 'prctl'.
+;;;
+
+(define %prctl
+  ;; Should it win the API contest against 'ioctl'?  You tell us!
+  (syscall->procedure int "prctl"
+                      (list int unsigned-long unsigned-long
+                            unsigned-long unsigned-long)))
+
+(define PR_SET_NAME 15)                           ;<linux/prctl.h>
+(define PR_GET_NAME 16)
+
+(define %max-thread-name-length
+  ;; Maximum length in bytes of the process name, including the terminating
+  ;; zero.
+  16)
+
+(define (set-thread-name name)
+  "Set the name of the calling thread to NAME.  NAME is truncated to 15
+bytes."
+  (let ((ptr (string->pointer name)))
+    (let-values (((ret err)
+                  (%prctl PR_SET_NAME
+                          (pointer-address ptr) 0 0 0)))
+      (unless (zero? ret)
+        (throw 'set-process-name "set-process-name"
+               "set-process-name: ~A"
+               (list (strerror err))
+               (list err))))))
+
+(define (thread-name)
+  "Return the name of the calling thread as a string."
+  (let ((buf (make-bytevector %max-thread-name-length)))
+    (let-values (((ret err)
+                  (%prctl PR_GET_NAME
+                          (pointer-address (bytevector->pointer buf))
+                          0 0 0)))
+      (if (zero? ret)
+          (bytes->string (bytevector->u8-list buf))
+          (throw 'process-name "process-name"
+                 "process-name: ~A"
+                 (list (strerror err))
+                 (list err))))))
+
+
+;;;
 ;;; Network interfaces.
 ;;;
 
diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index 8db45b4..e20f060 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -266,6 +266,14 @@
                (close-port file)
                result)))))))))
 
+(test-equal "set-thread-name"
+  "Syscall Test"
+  (let ((name (thread-name)))
+    (set-thread-name "Syscall Test")
+    (let ((new-name (thread-name)))
+      (set-thread-name name)
+      new-name)))
+
 (test-assert "all-network-interface-names"
   (match (all-network-interface-names)
     (((? string? names) ..1)