all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: Josselin Poiret via Guix-patches via <guix-patches@gnu.org>
To: Tobias Geerinckx-Rice <me@tobias.gr>
Cc: Josselin Poiret <dev@jpoiret.xyz>, 51346@debbugs.gnu.org
Subject: [bug#51346] [PATCH v2 2/4] gnu: system: Add swap flags.
Date: Wed, 27 Oct 2021 15:09:11 +0000	[thread overview]
Message-ID: <20211027150913.6038-3-dev@jpoiret.xyz> (raw)
In-Reply-To: <20211027150913.6038-1-dev@jpoiret.xyz>

* 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  | 35 ++++++++++++++++++++++++++++++++++-
 gnu/services/base.scm       |  7 +++++--
 gnu/system/file-systems.scm | 10 ++++++++--
 guix/build/syscalls.scm     | 12 ++++++++++++
 4 files changed, 59 insertions(+), 5 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index d8a5ddf1e5..39a408e8c1 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,35 @@ (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))
+
 \f
 
 ;;;
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index c816381198..cf43a78fd0 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 7aa19069a1..fba4ebf65d 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -101,7 +101,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:
 ;;;
@@ -685,6 +687,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 99a3b45004..f2b18abf5a 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
 
@@ -677,6 +682,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





  parent reply	other threads:[~2021-10-27 15:49 UTC|newest]

Thread overview: 21+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2021-10-23  9:46 [bug#51346] [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Josselin Poiret via Guix-patches via
2021-10-23  8:55 ` [bug#51346] [PATCH 1/1] gnu: system: Add support for swap " Josselin Poiret via Guix-patches via
2021-10-24 13:58   ` Tobias Geerinckx-Rice via Guix-patches via
2021-10-27 15:09     ` [bug#51346] [PATCH v2 0/4] Rework swap, add flags and dependencies Josselin Poiret via Guix-patches via
2021-10-27 15:09       ` [bug#51346] [PATCH v2 1/4] gnu: system: Rework swap space support, add dependencies Josselin Poiret via Guix-patches via
2021-11-15 10:56         ` [bug#51346] [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Ludovic Courtès
2021-11-15 11:04         ` Ludovic Courtès
2021-11-15 20:26           ` [bug#51346] [PATCH v3 0/5] " Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 1/5] gnu: system: Rework swap space support, add dependencies Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 2/5] gnu: system: Warn about swap-devices format change Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 3/5] gnu: system: Add swap flags Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 4/5] gnu: system: Filter out boot dependencies from swap-space Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 5/5] doc: Add new Swap Space section Josselin Poiret via Guix-patches via
2021-11-23  9:23             ` bug#51346: [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Ludovic Courtès
2021-10-27 15:09       ` Josselin Poiret via Guix-patches via [this message]
2021-11-15 10:59         ` [bug#51346] " Ludovic Courtès
2021-10-27 15:09       ` [bug#51346] [PATCH v2 3/4] gnu: system: Filter out boot dependencies from swap-space Josselin Poiret via Guix-patches via
2021-10-27 15:09       ` [bug#51346] [PATCH v2 4/4] doc: Add new Swap Space section Josselin Poiret via Guix-patches via
2021-11-15 11:01         ` [bug#51346] [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Ludovic Courtès
2021-10-24  2:05 ` Tobias Geerinckx-Rice via Guix-patches via
2021-10-25 14:17   ` Josselin Poiret via Guix-patches via

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20211027150913.6038-3-dev@jpoiret.xyz \
    --to=guix-patches@gnu.org \
    --cc=51346@debbugs.gnu.org \
    --cc=dev@jpoiret.xyz \
    --cc=me@tobias.gr \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.