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

4 files changed, 238 insertions, 3 deletions

diff --git a/Makefile.am b/Makefile.am
index a4e7277d6d4..a6c2e73388f 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 00000000000..1dddbf239cb
--- /dev/null
+++ b/guix/build/io.scm
@@ -0,0 +1,58 @@
+;;; 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 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 d40b1ae5d93..ef678754706 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
@@ -1108,6 +1123,99 @@ backend device."
 
 
 ;;;
+;;; 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 a0483e68f08..1ea49b0acc4 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))