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

4 files changed, 244 insertions, 3 deletions

diff --git a/Makefile.am b/Makefile.am
index 459f3f4b6b7..1fa00ccbd96 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 00000000000..edb9a565adf
--- /dev/null
+++ b/guix/build/io.scm
@@ -0,0 +1,56 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 Maxim Cournoyer <maxim@guixotic.coop>
+;;;
+;;; 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 d40b1ae5d93..0ffa9e70f77 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
@@ -1108,6 +1119,145 @@ backend device."
 
 
 ;;;
+;;; 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 a0483e68f08..bebc3aaa72d 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))