diff options
author | Ludovic Courtès <ludo@gnu.org> | 2017-05-28 15:49:11 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2017-05-28 23:13:39 +0200 |
commit | aa401f9ba6410095370ce0c4e5a01c02203a2b9f (patch) | |
tree | 4451b41722f90e538626e3c703a467b0e752b5df /guix/build | |
parent | 2b95f247215345c9130b5d6623d739f810224313 (diff) | |
download | gnu-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.
Diffstat (limited to 'guix/build')
-rw-r--r-- | guix/build/syscalls.scm | 49 |
1 files changed, 49 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. ;;; |