bartronx7/guix
1
0
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2026-01-25 12:05:19 -06:00
Code Issues Projects Releases Packages Wiki Activity Actions

syscalls: Add mmap support.

Browse source 
* 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
This commit is contained in:
Maxim Cournoyer 2025-10-21 23:22:24 +09:00
parent 0368fbf205
commit fdc13e85a6
No known key found for this signature in database
GPG key ID: 1260E46482E63562
4 changed files with 244 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -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 \

56
guix/build/io.scm Normal file
View file

@ -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)))))

154
guix/build/syscalls.scm
View file

@ -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
@ -1106,6 +1117,145 @@ backend device."
(list file key value (strerror err))
(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.

36
tests/syscalls.scm
View file

@ -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))