guix_mirror_bot pushed a commit to branch master
in repository guix.
commit e1994a021437b3fd73089c08d7e8db876fad698d
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))
