diff options
| -rw-r--r-- | gnu/build/file-systems.scm | 36 | ||||
| -rw-r--r-- | gnu/services/base.scm | 7 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 10 | ||||
| -rw-r--r-- | 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)) |