From 0831dfab75b4db9c8bcbc9b2d1e52d8db54d0ad9 Mon Sep 17 00:00:00 2001
From: Josselin Poiret <dev@jpoiret.xyz>
Date: Mon, 15 Nov 2021 20:26:29 +0000
Subject: [PATCH] system: Add swap flags.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* gnu/system/file-systems.scm (swap-space)[priority, discard?]: Add
them.
* guix/build/syscalls.scm (SWAP_FLAG_PREFER, SWAP_FLAG_PRIO_MASK,
SWAP_FLAG_PRIO_SHIFT, SWAP_FLAG_DISCARD): Add them.
* gnu/build/file-systems.scm (swap-space->flags-bit-mask): Add it.
* gnu/services/base.scm (swap-service-type): Use it.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 gnu/build/file-systems.scm  | 36 +++++++++++++++++++++++++++++++++++-
 gnu/services/base.scm       |  7 +++++--
 gnu/system/file-systems.scm | 10 ++++++++--
 guix/build/syscalls.scm     | 12 ++++++++++++
 4 files changed, 60 insertions(+), 5 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index d8a5ddf1e5..d95340df83 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -29,6 +29,8 @@
   #:use-module (guix build bournish)
   #:use-module ((guix build syscalls)
                 #:hide (file-system-type))
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
@@ -54,7 +56,9 @@
 
             mount-flags->bit-mask
             check-file-system
-            mount-file-system))
+            mount-file-system
+
+            swap-space->flags-bit-mask))
 
 ;;; Commentary:
 ;;;
@@ -227,6 +231,36 @@ if DEVICE does not contain an linux-swap file system."
   "Return the label of Linux-swap superblock SBLOCK as a string."
   (null-terminated-latin1->string
    (sub-bytevector sblock (+ 1024 4 4 4 16) 16)))
+
+(define (swap-space->flags-bit-mask swap)
+  "Return the number suitable for the 'flags' argument of 'mount'
+that corresponds to the swap-space SWAP."
+  (define prio-flag
+    (let ((p (swap-space-priority swap))
+          (max (ash SWAP_FLAG_PRIO_MASK (- SWAP_FLAG_PRIO_SHIFT))))
+      (if p
+          (logior SWAP_FLAG_PREFER
+                  (ash (cond
+                        ((< p 0)
+                         (begin (warning
+                                 (G_ "Given swap priority ~a is
+negative, defaulting to 0.~%") p)
+                                0))
+                        ((> p max)
+                         (begin (warning
+                                 (G_ "Limiting swap priority ~a to
+~a.~%")
+                                 p max)
+                                max))
+                        (else p))
+                       SWAP_FLAG_PRIO_SHIFT))
+          0)))
+  (define delayed-flag
+    (if (swap-space-discard? swap)
+        SWAP_FLAG_DISCARD
+        0))
+  (logior prio-flag delayed-flag))
+
 
 
 ;;;
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 35f38c7e09..20736eb13f 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -58,7 +58,8 @@
   #:use-module (gnu packages linux)
   #:use-module (gnu packages terminals)
   #:use-module ((gnu build file-systems)
-                #:select (mount-flags->bit-mask))
+                #:select (mount-flags->bit-mask
+                          swap-space->flags-bit-mask))
   #:use-module (guix gexp)
   #:use-module (guix records)
   #:use-module (guix modules)
@@ -2223,7 +2224,9 @@ instance."
                    (let ((device #$device-lookup))
                      (and device
                           (begin
-                            (restart-on-EINTR (swapon device))
+                            (restart-on-EINTR (swapon device
+                                                      #$(swap-space->flags-bit-mask
+                                                         swap)))
                             #t)))))
         (stop #~(lambda _
                   (let ((device #$device-lookup))
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 027df7e966..e1d1fb72cc 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -102,7 +102,9 @@
             swap-space
             swap-space?
             swap-space-target
-            swap-space-dependencies))
+            swap-space-dependencies
+            swap-space-priority
+            swap-space-discard?))
 
 ;;; Commentary:
 ;;;
@@ -726,6 +728,10 @@ subvolume name is unknown."))
   this-swap-space
   (target swap-space-target)
   (dependencies swap-space-dependencies
-                (default '())))
+                (default '()))
+  (priority swap-space-priority
+            (default #f))
+  (discard? swap-space-discard?
+           (default #f)))
 
 ;;; file-systems.scm ends here
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index b305133c37..63bd017d1d 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -71,6 +71,11 @@
             mounts
             mount-points
 
+            SWAP_FLAG_PREFER
+            SWAP_FLAG_PRIO_MASK
+            SWAP_FLAG_PRIO_SHIFT
+            SWAP_FLAG_DISCARD
+
             swapon
             swapoff
 
@@ -685,6 +690,13 @@ current process."
   "Return the mounts points for currently mounted file systems."
   (map mount-point (mounts)))
 
+;; Pulled from glibc's sysdeps/unix/sysv/linux/sys/swap.h
+
+(define SWAP_FLAG_PREFER     #x8000) ;; Set if swap priority is specified.
+(define SWAP_FLAG_PRIO_MASK  #x7fff)
+(define SWAP_FLAG_PRIO_SHIFT 0)
+(define SWAP_FLAG_DISCARD    #x10000) ;; Discard swap cluster after use.
+
 (define swapon
   (let ((proc (syscall->procedure int "swapon" (list '* int))))
     (lambda* (device #:optional (flags 0))