From aa401f9ba6410095370ce0c4e5a01c02203a2b9f Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 28 May 2017 15:49:11 +0200
Subject: 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 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 49 insertions(+)

(limited to 'guix/build/syscalls.scm')

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
@@ -882,6 +885,52 @@ exception if it's already taken."
           ;; Presumably we got EAGAIN or so.
           (throw 'flock-error err))))))
 
+
+;;;
+;;; 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.
-- 
cgit v1.2.3


From 65f224dc8d9568232baa07f28474ba5c90f07428 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Wed, 31 May 2017 15:23:51 +0200
Subject: syscalls: Provide 'free-disk-space'.

* guix/build/syscalls.scm (free-disk-space): New procedure.
* guix/scripts/gc.scm (guix-gc)[ensure-free-space]: Use it instead of
'statfs'.
---
 guix/build/syscalls.scm | 7 +++++++
 guix/scripts/gc.scm     | 8 +++-----
 2 files changed, 10 insertions(+), 5 deletions(-)

(limited to 'guix/build/syscalls.scm')

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 52439afd44..2def2a108f 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -62,6 +62,7 @@
             file-system-fragment-size
             file-system-mount-flags
             statfs
+            free-disk-space
 
             processes
             mkdtemp!
@@ -697,6 +698,12 @@ mounted at FILE."
                    (list file (strerror err))
                    (list err)))))))
 
+(define (free-disk-space file)
+  "Return the free disk space, in bytes, on the file system that hosts FILE."
+  (let ((fs (statfs file)))
+    (* (file-system-block-size fs)
+       (file-system-blocks-available fs))))
+
 
 ;;;
 ;;; Containers.
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 221467a108..0a9719d259 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -20,7 +20,7 @@
   #:use-module (guix ui)
   #:use-module (guix scripts)
   #:use-module (guix store)
-  #:autoload   (guix build syscalls) (statfs)
+  #:autoload   (guix build syscalls) (free-disk-space)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (srfi srfi-1)
@@ -184,9 +184,7 @@ Invoke the garbage collector.\n"))
 
   (define (ensure-free-space store space)
     ;; Attempt to have at least SPACE bytes available in STORE.
-    (let* ((fs    (statfs (%store-prefix)))
-           (free  (* (file-system-block-size fs)
-                     (file-system-blocks-available fs))))
+    (let ((free (free-disk-space (%store-prefix))))
       (if (> free space)
           (info (G_ "already ~h bytes available on ~a, nothing to do~%")
                 free (%store-prefix))
-- 
cgit v1.2.3