Package: guix-patches;
Reported by: Josselin Poiret <dev <at> jpoiret.xyz>
Date: Sat, 23 Oct 2021 09:47:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Ludovic Courtès <ludo <at> gnu.org> Cc: Josselin Poiret <dev <at> jpoiret.xyz>, Tobias Geerinckx-Rice <me <at> tobias.gr>, 51346 <at> debbugs.gnu.org Subject: [bug#51346] [PATCH v3 3/5] gnu: system: Add swap flags. Date: Mon, 15 Nov 2021 20:26:29 +0000
* 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.
---
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 @@ (define-module (gnu build file-systems)
#: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 @@ (define-module (gnu build file-systems)
mount-flags->bit-mask
check-file-system
- mount-file-system))
+ mount-file-system
+
+ swap-space->flags-bit-mask))
;;; Commentary:
;;;
@@ -227,6 +231,36 @@ (define (linux-swap-superblock-volume-name sblock)
"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 @@ (define-module (gnu services base)
#: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 @@ (define device-lookup
(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 @@ (define-module (gnu system file-systems)
swap-space
swap-space?
swap-space-target
- swap-space-dependencies))
+ swap-space-dependencies
+ swap-space-priority
+ swap-space-discard?))
;;; Commentary:
;;;
@@ -726,6 +728,10 @@ (define-record-type* <swap-space> swap-space make-swap-space
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 @@ (define-module (guix build syscalls)
mounts
mount-points
+ SWAP_FLAG_PREFER
+ SWAP_FLAG_PRIO_MASK
+ SWAP_FLAG_PRIO_SHIFT
+ SWAP_FLAG_DISCARD
+
swapon
swapoff
@@ -685,6 +690,13 @@ (define (mount-points)
"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))
--
2.33.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.