guix_mirror_bot pushed a commit to branch add-compress-debug-symbols-phase in repository guix.
commit 3a2adac024fa2c855ccd37e9a6bd2671087bbe46 Author: Maxim Cournoyer <[email protected]> AuthorDate: Tue Oct 21 23:22:24 2025 +0900 syscalls: Add mmap support. * guix/build/syscalls.scm (PROT_NONE, PROT_READ, PROT_WRITE, PROT_EXEC) (PROT_SEM, MAP_SHARED, MAP_PRIVATE, MAP_FAILED) (MS_ASYNC, MS_INVALIDATE, MS_SYNC) (%mmap-guardian, %unmapped-bytevectors): New variables. (unmapped-bytevector?, pump-mmap-guardian, %mmap, mmap, %munmap, munmap) (%msync, msync): New procedures. * guix/build/io.scm: New file. * Makefile.am: Register it. * tests/syscalls.scm (strace-output): New variable. ("mmap and munmap", "file->bytevector, reading", "file->bytevector, writing") ("manual munmap does not lead to double free"): New tests. Change-Id: I19ec687899eda635559e91200dd8d98669b0e35f --- Makefile.am | 1 + guix/build/io.scm | 58 +++++++++++++++++++++++++ guix/build/syscalls.scm | 112 +++++++++++++++++++++++++++++++++++++++++++++++- tests/syscalls.scm | 70 +++++++++++++++++++++++++++++- 4 files changed, 238 insertions(+), 3 deletions(-) diff --git a/Makefile.am b/Makefile.am index a4e7277d6d..a6c2e73388 100644 --- a/Makefile.am +++ b/Makefile.am @@ -265,6 +265,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..1dddbf239c --- /dev/null +++ b/guix/build/io.scm @@ -0,0 +1,58 @@ +;;; 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 io ports) + #:use-module (system foreign) + #:export (file->bytevector) + ;; For convenience. + #:re-export (PROT_READ + PROT_NONE + PROT_READ + PROT_WRITE + PROT_EXEC + PROT_SEM + MAP_SHARED + MAP_PRIVATE + MAP_FAILED + munmap)) + +;;; +;;; Memory mapped files. +;;; + +(define* (file->bytevector file #:key + (protection PROT_READ) + (flags (if (logtest PROT_WRITE protection) + MAP_SHARED + MAP_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." + (let* ((mode (format #f "rb~:[~;+~]" (and (logtest PROT_WRITE protection) + (logtest MAP_SHARED flags)))) + (port (open-file file mode))) + (call-with-port port + (lambda (port) + (mmap (fileno port) (- (stat:size (stat file)) offset) + #:protection protection #:flags flags #:offset offset))))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index d40b1ae5d9..ef67875470 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -42,8 +42,23 @@ #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 ftw) - #:use-module (ice-9 threads) - #:export (MS_RDONLY + #:export (PROT_NONE + PROT_READ + PROT_WRITE + PROT_EXEC + PROT_SEM + MAP_SHARED + MAP_PRIVATE + MAP_FAILED + mmap + munmap + + MS_ASYNC + MS_INVALIDATE + MS_SYNC + msync + + MS_RDONLY MS_NOSUID MS_NODEV MS_NOEXEC @@ -1107,6 +1122,99 @@ backend device." (list err))))))) +;;; +;;; Memory maps. +;;; + +;;; Constants from <sys/mman.h> +(define PROT_NONE #x0) ;page can not be accessed +(define PROT_READ #x1) ;page can be read +(define PROT_WRITE #x2) ;page can be written +(define PROT_EXEC #x4) ;page can be executed +(define PROT_SEM #x8) ;page can be used for atomic operations + +(define MAP_SHARED #x01) ;share changes with other processes +(define MAP_PRIVATE #x02) ;private copy-on-write mapping +(define MAP_FAILED #xffffffffffffffff) ;mmap failure sentinel + +(define %mmap + (syscall->procedure '* "mmap" (list '* size_t int int int long))) + +(define %mmap-guardian + (make-guardian)) + +(define %unmapped-bytevectors + (make-weak-key-hash-table)) + +(define (unmapped-bytevector? bv) + "True if the bytevector BV was already munmap'd." + (hashq-ref %unmapped-bytevectors bv #f)) + +(define (pump-mmap-guardian) + (let ((bv (%mmap-guardian))) + (when bv + (if (unmapped-bytevector? bv) + (hashq-remove! %unmapped-bytevectors bv) + (munmap bv)) + (pump-mmap-guardian)))) + +(add-hook! after-gc-hook pump-mmap-guardian) + +(define* (mmap fd len #:key + (protection PROT_READ) + (flags (if (logtest PROT_WRITE protection) + MAP_SHARED + MAP_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 +PROTECTION and FLAGS, biwise-or of PROT_* and MAP_* constants which +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 (((ptr err) (%mmap %null-pointer len protection 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))) + (hashq-set! %unmapped-bytevectors bv #t))) + +(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..1ea49b0acc 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. @@ -39,6 +42,9 @@ (define temp-file (string-append "t-utils-" (number->string (getpid)))) +(define strace-output + (string-append "t-utils-strace" (number->string (getpid)))) + (test-begin "syscalls") @@ -735,6 +741,68 @@ (member (system-error-errno args) (list EPERM ENOSYS))))) +(test-assert "mmap and munmap" + (begin + (call-with-output-file temp-file + (lambda (p) + (display "abcdefghij"))) + (let* ((len 5) + (bv (mmap (open-fdes temp-file O_RDONLY) len))) + (munmap bv)))) + +(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 + #:protection PROT_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))) + +(unless (which "strace") + (test-skip 1)) +;;; This test currently fails, due to protected items in a guardian being +;;; dropped from weak hash tables (see: +;;; <https://codeberg.org/guile/guile/issues/44>). +(test-expect-fail 1) +(test-equal "manual munmap does not lead to double free" + 1 ;single munmap call + (begin + (call-with-output-file temp-file + (lambda (p) + (display "something interesting\n" p))) + (sync) + (gc) + (system (string-append "strace -o " strace-output + " -p " (number->string (getpid)) + " -e trace=munmap &")) + (sleep 1) ;allow strace to start + (let ((bv (file->bytevector temp-file))) + (munmap bv)) + (gc) + (sync) + (let ((text (call-with-input-file strace-output get-string-all))) + ;; The address seen by strace is not the same as the one seen by Guile, + ;; so we can't use it in the pattern. + (length (filter (cut string-prefix? "munmap(0x" <>) + (string-split text #\newline)))))) + (test-end) (false-if-exception (delete-file temp-file)) +(false-if-exception (delete-file strace-output))
