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

Revert "syscalls: Add mmap support."

Browse source 
This reverts commit e1994a0214.
This commit is contained in:
Maxim Cournoyer 2025-10-30 16:19:51 +09:00
parent 0f39db9c19
commit 3ae5c9f2a7
No known key found for this signature in database
GPG key ID: 1260E46482E63562
4 changed files with 3 additions and 238 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -265,7 +265,6 @@ 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 \

58
guix/build/io.scm
View file

@ -1,58 +0,0 @@
;;; 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)))))

112
guix/build/syscalls.scm
View file

@ -42,23 +42,8 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#: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
#:use-module (ice-9 threads)
#:export (MS_RDONLY
MS_NOSUID
MS_NODEV
MS_NOEXEC
@ -1121,99 +1106,6 @@ backend device."
(list file key value (strerror err))
(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.

70
tests/syscalls.scm
View file

@ -22,11 +22,8 @@
(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)
@ -34,7 +31,7 @@
#:use-module (system foreign)
#:use-module ((ice-9 ftw) #:select (scandir))
#:use-module (ice-9 match)
#:use-module (ice-9 textual-ports))
#:use-module (ice-9 threads))
;; Test the (guix build syscalls) module, although there's not much that can
;; actually be tested without being root.
@ -42,9 +39,6 @@
(define temp-file
(string-append "t-utils-" (number->string (getpid))))
(define strace-output
(string-append "t-utils-strace" (number->string (getpid))))
(test-begin "syscalls")
@ -741,68 +735,6 @@
(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))