aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-05-28 15:49:11 +0200
committerLudovic Courtès <ludo@gnu.org>2017-05-28 23:13:39 +0200
commitaa401f9ba6410095370ce0c4e5a01c02203a2b9f (patch)
tree4451b41722f90e538626e3c703a467b0e752b5df
parent2b95f247215345c9130b5d6623d739f810224313 (diff)
downloadgnu-guix-aa401f9ba6410095370ce0c4e5a01c02203a2b9f.tar
gnu-guix-aa401f9ba6410095370ce0c4e5a01c02203a2b9f.tar.gz
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.
-rw-r--r--guix/build/syscalls.scm49
-rw-r--r--tests/syscalls.scm8
2 files changed, 57 insertions, 0 deletions
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 0529c228a5..52439afd44 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 8db45b41b6..e20f0600bc 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)