guix_mirror_bot pushed a commit to branch add-compress-debug-symbols-phase in repository guix.
commit 0e3f04e7c74ce1addbb573aa11829af76fd7f0ca Author: Maxim Cournoyer <[email protected]> AuthorDate: Tue Oct 21 23:22:24 2025 +0900 syscalls: Add mmap support. * guix/build/syscalls.scm (protection, protection-set, mmap-flag) (mmap-flag-set, %mmap-guardian, %unmapped-bytevectors): New variables. (hurd?, protection-symbol->value, protection-set->value) (mmap-flag-symbol->value, mmap-flag-set->value, pump-mmap-guardian) (%map-failed, %mmap, mmap, %munmap, munmap, %msync, msync): New procedures. * guix/build/io.scm: New file. * Makefile.am: Register it. * tests/syscalls.scm: ("mmap", "file->bytevector, reading") ("file->bytevector, writing"): New tests. Change-Id: I19ec687899eda635559e91200dd8d98669b0e35f --- Makefile.am | 1 + guix/build/io.scm | 56 ++++++++++++++++++ guix/build/syscalls.scm | 154 +++++++++++++++++++++++++++++++++++++++++++++++- tests/syscalls.scm | 36 ++++++++++- 4 files changed, 244 insertions(+), 3 deletions(-) diff --git a/Makefile.am b/Makefile.am index 459f3f4b6b..1fa00ccbd9 100644 --- a/Makefile.am +++ b/Makefile.am @@ -267,6 +267,7 @@ MODULES = \ guix/build/kconfig.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ + guix/build/io.scm \ guix/build/json.scm \ guix/build/pack.scm \ guix/build/utils.scm \ diff --git a/guix/build/io.scm b/guix/build/io.scm new file mode 100644 index 0000000000..edb9a565ad --- /dev/null +++ b/guix/build/io.scm @@ -0,0 +1,56 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Maxim Cournoyer <[email protected]> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build io) + #:use-module (guix build syscalls) + #:use-module (ice-9 format) + #:use-module (rnrs bytevectors) + #:use-module (rnrs enums) + #:use-module (rnrs io ports) + #:use-module (system foreign) + #:export (file->bytevector) + ;; For convenience. + #:re-export (protection + protection-set + mmap-flag + mmap-flag-set)) + +;;; +;;; Memory mapped files. +;;; + +(define* (file->bytevector file #:key + (protections (protection-set read)) + (flags (if (enum-set-member? (protection write) + protections) + (mmap-flag-set shared) + (mmap-flag-set private))) + (offset 0)) + "Return a bytevector object that is backed by a memory mapped FILE. This +avoids eagerly copying the full file contents into memory, instead letting the +kernel lazily page it in on demand. The underlying memory map is +automatically unmapped when the bytevector is no longer referenced. Refer to +the documentation of `mmap' for details about the accepted arguments." + (let* ((mode (format #f "rb~:[~;+~]" + (and (enum-set-member? (protection write) protections) + (enum-set-member? (mmap-flag shared) flags)))) + (port (open-file file mode))) + (call-with-port port + (lambda (port) + (mmap (fileno port) (- (stat:size (stat file)) offset) + #:protections protections #:flags flags #:offset offset))))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index d40b1ae5d9..0ffa9e70f7 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -31,6 +31,7 @@ #:use-module (system foreign) #:use-module (system base target) #:use-module (rnrs bytevectors) + #:use-module (rnrs enums) #:autoload (ice-9 binary-ports) (get-bytevector-n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -42,8 +43,18 @@ #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 ftw) - #:use-module (ice-9 threads) - #:export (MS_RDONLY + #:export (protection + protection-set + mmap-flag + mmap-flag-set + mmap + + MS_ASYNC + MS_INVALIDATE + MS_SYNC + msync + + MS_RDONLY MS_NOSUID MS_NODEV MS_NOEXEC @@ -1107,6 +1118,145 @@ backend device." (list err))))))) +;;; +;;; Memory maps. +;;; + +;;; Constants from <sys/mman.h>. Enums are used given the actual values vary +;;; between Linux and the Hurd, hence must be lazily resolved at the time of +;;; use (runtime). +(define-enumeration protection + (none ;page can not be accessed + read ;page can be read + write ;page can be written + exec) ;page can be executed + protection-set) + +(define-enumeration mmap-flag + (shared ;share changes with other processes + private) ;private copy-on-write mapping + mmap-flag-set) + +(define (hurd?) + (string=? "GNU" (utsname:sysname (uname)))) + +(define (protection-symbol->value s) + ;; The values for the Hurd are taken from glibc's bits/mman.h, while those + ;; for Linux from include/uapi/asm-generic/mman-common.h. + (let ((hurd? (hurd?))) + (cond + ((eq? (protection none) s) + #x0) + ((eq? (protection read) s) + (if hurd? #x4 #x1)) + ((eq? (protection write) s) + #x2) + ((eq? (protection exec) s) + (if hurd? #x1 #x4)) + (else (error "unexpected protection symbol" s))))) + +(define (protection-set->value protections) + "Take PROTECTIONS, a set of protection set, and compute the platform-specific +value for use with `mmap'." + (unless (enum-set-subset? protections (enum-set-universe (protection-set))) + (error "invalid mmap protection value; expected a protection enum set" + protections)) + (apply logior (map protection-symbol->value (enum-set->list protections)))) + +(define (mmap-flag-symbol->value s) + ;; The values for the Hurd are taken from glibc's bits/mman.h, while those + ;; for Linux from include/uapi/linux/mman.h. + (let ((hurd? (hurd?))) + (cond + ((eq? (mmap-flag private) s) + (if hurd? #x0 #x2)) + ((eq? (mmap-flag shared) s) + (if hurd? #x10 #x1)) + (else (error "unexpected mmap-flag symbol" s))))) + +(define (mmap-flag-set->value flags) + (unless (enum-set-subset? flags (enum-set-universe (mmap-flag-set))) + (error "invalid mmap flags value; expected a mmap-flag enum set" + flags)) + (apply logior (map mmap-flag-symbol->value (enum-set->list flags)))) + +(define (%map-failed) ;mmap failure sentinel + (if (= 8 (sizeof '*)) + #xffffffffffffffff ;64-bit + #xffffffff)) ;32-bit + +(define %mmap + (syscall->procedure '* "mmap" (list '* size_t int int int long))) + +(define %mmap-guardian + (make-guardian)) + +(define (pump-mmap-guardian) + (let ((bv (%mmap-guardian))) + (when bv + (munmap bv) + (pump-mmap-guardian)))) + +(add-hook! after-gc-hook pump-mmap-guardian) + +(define* (mmap fd len #:key + (protections (protection-set read)) + (flags (if (enum-set-member? (protection write) protections) + (mmap-flag-set shared) + (mmap-flag-set private))) + (offset 0)) + "Return a bytevector to a memory-mapped region of length LEN bytes +for the open file descriptor FD. The mapping is created with the given memory +PROTECTIONS and FLAGS, which are PROTECTION and MMAP-FLAGS enum sets, +respectively. These values are internally converted to the correct values and +bitwise OR'd, and determine whether updates are visible to other processes +and/or carried through to the underlying file. Raise a 'system-error' +exception on error. The memory is automatically unmapped with `munmap' when +the bytevector object is no longer referenced." + (let*-values (((protections*) (protection-set->value protections)) + ((flags*) (mmap-flag-set->value flags)) + ((ptr err) (%mmap %null-pointer len protections* flags* + fd offset))) + (when (= (%map-failed) (pointer-address ptr)) + (throw 'system-error "mmap" "mmap ~S with len ~S: ~A" + (list fd len (strerror err)) + (list err))) + (let ((bv (pointer->bytevector ptr len))) + (%mmap-guardian bv) + bv))) + +(define %munmap + (syscall->procedure int "munmap" (list '* size_t))) + +(define (munmap bv) + "Unmap the memory region described by BV, a bytevector object." + (let*-values (((ptr) (bytevector->pointer bv)) + ((len) (bytevector-length bv)) + ((ret err) (%munmap ptr len))) + (unless (zero? ret) + (throw 'system-error "munmap" "munmap ~S with len ~S: ~A" + (list ptr len (strerror err)) + (list err))))) + +(define MS_ASYNC 1) ;sync memory asynchronously +(define MS_INVALIDATE 2) ;invalidate the caches +(define MS_SYNC 4) ;synchronous memory sync + +(define %msync + (syscall->procedure int "msync" (list '* size_t int))) + +(define* (msync bv #:key (flags MS_SYNC)) + "Flush changes made to the in-core copy of a file that was mapped into memory +using `mmap' back to the file system." + (let*-values (((ptr) (bytevector->pointer bv)) + ((len) (bytevector-length bv)) + ((ret err) (%msync ptr len flags))) + (unless (zero? ret) + (throw 'system-error "msync" "msync ~S with len ~S: ~A" + (list ptr len (strerror err)) + (list err))))) + + ;;; ;;; Random. ;;; diff --git a/tests/syscalls.scm b/tests/syscalls.scm index a0483e68f0..bebc3aaa72 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -22,8 +22,11 @@ (define-module (test-syscalls) #:use-module (guix utils) + #:use-module (guix build io) #:use-module (guix build syscalls) + #:use-module (guix build utils) #:use-module (gnu build linux-container) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) @@ -31,7 +34,7 @@ #:use-module (system foreign) #:use-module ((ice-9 ftw) #:select (scandir)) #:use-module (ice-9 match) - #:use-module (ice-9 threads)) + #:use-module (ice-9 textual-ports)) ;; Test the (guix build syscalls) module, although there's not much that can ;; actually be tested without being root. @@ -735,6 +738,37 @@ (member (system-error-errno args) (list EPERM ENOSYS))))) +(test-assert "mmap" + (begin + (call-with-output-file temp-file + (lambda (p) + (display "abcdefghij"))) + (mmap (open-fdes temp-file O_RDONLY) 5))) + +(test-equal "file->bytevector, reading" + #\6 + (begin + (call-with-output-file temp-file + (lambda (p) + (display "0123456789\n" p))) + (sync) + (integer->char + (bytevector-u8-ref (file->bytevector temp-file) 6)))) + +(test-equal "file->bytevector, writing" + "0000000700" + (begin + (call-with-output-file temp-file + (lambda (p) + (display "0000000000" p))) + (sync) + (let ((bv (file->bytevector temp-file + #:protections (protection-set write)))) + + (bytevector-u8-set! bv 7 (char->integer #\7)) + (msync bv)) ;ensure the file gets written + (call-with-input-file temp-file get-string-all))) + (test-end) (false-if-exception (delete-file temp-file))
