fringe11 files changed, 347 insertions(+), 168 deletions(-)
Makefile.am | 3 ++-
gnu/packages/gnuzilla.scm | 8 +-------
gnu/packages/librewolf.scm | 6 +-----
guix/build/debug-link.scm | 17 ++++++++---------
guix/build/gremlin.scm | 62 ++++++++++++++++++++++++++++----------------------------------
guix/build/io.scm | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
guix/build/syscalls.scm | 102 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
guix/scripts/pack.scm | 13 +++++++------
tests/debug-link.scm | 189 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------------------------------------------------------------------------
tests/gremlin.scm | 18 +++++-------------
tests/syscalls.scm | 39 ++++++++++++++++++++++++++++++++++++++-
fringemodified Makefile.am
fringe@@ -14,7 +14,7 @@
# Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
# Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
# Copyright © 2019, 2023 Efraim Flashner <efraim@flashner.co.il>
-# Copyright © 2020, 2021, 2023 Maxim Cournoyer <maxim@guixotic.coop>
+# Copyright © 2020, 2021, 2023, 2025 Maxim Cournoyer <maxim@guixotic.coop>
# Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
# Copyright © 2021 Andrew Tropin <andrew@trop.in>
# Copyright © 2023 Clément Lassieur <clement@lassieur.org>
fringe@@ -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 \
fringemodified gnu/packages/gnuzilla.scm
fringemodified gnu/packages/librewolf.scm
fringemodified guix/build/debug-link.scm
fringe@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2025 Maxim Cournoyer <maxim@guixotic.coop>
;;;
;;; This file is part of GNU Guix.
;;;
fringe@@ -18,6 +19,7 @@
(define-module (guix build debug-link)
#:use-module (guix elf)
+ #:use-module (guix build io)
#:use-module ((guix build utils)
#:select (find-files elf-file? make-file-writable))
#:use-module (rnrs bytevectors)
fringe@@ -147,16 +149,13 @@ (define (elf-debuglink-crc-offset elf)
(define (set-debuglink-crc file debug-file)
"Compute the CRC of DEBUG-FILE and set it as the '.gnu_debuglink' CRC in
FILE."
- (let* ((elf (parse-elf (call-with-input-file file get-bytevector-all)))
+ (let* ((bv (file->bytevector file #:protection (logior PROT_READ PROT_WRITE)))
+ (elf (parse-elf bv))
(offset (elf-debuglink-crc-offset elf)))
- (and offset
- (let* ((crc (call-with-input-file debug-file debuglink-crc32))
- (bv (make-bytevector 4)))
- (bytevector-u32-set! bv 0 crc (elf-byte-order elf))
- (let ((port (open file O_RDWR)))
- (set-port-position! port offset)
- (put-bytevector port bv)
- (close-port port))))))
+ (when offset
+ (let ((crc (call-with-input-file debug-file debuglink-crc32)))
+ (bytevector-u32-set! bv offset crc (elf-byte-order elf))
+ (munmap bv)))))
;;;
fringemodified guix/build/gremlin.scm
fringe@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2025 Maxim Cournoyer <maxim@guixotic.coop>
;;;
;;; This file is part of GNU Guix.
;;;
fringe@@ -18,6 +19,7 @@
(define-module (guix build gremlin)
#:use-module (guix elf)
+ #:use-module (guix build io)
#:use-module ((guix build utils) #:select (store-file-name?))
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
fringe@@ -248,9 +250,7 @@ (define (elf-dynamic-info elf)
(define (file-dynamic-info file)
"Return the <elf-dynamic-info> record of FILE, or #f if FILE lacks dynamic
info."
- (call-with-input-file file
- (lambda (port)
- (elf-dynamic-info (parse-elf (get-bytevector-all port))))))
+ (elf-dynamic-info (parse-elf (file->bytevector file))))
(define (file-runpath file)
"Return the DT_RUNPATH dynamic entry of FILE as a list of strings, or #f if
fringe@@ -362,8 +362,7 @@ (define* (validate-needed-in-runpath file
(elf-segment-type segment))
#f)))
- (let* ((elf (call-with-input-file file
- (compose parse-elf get-bytevector-all)))
+ (let* ((elf (parse-elf (file->bytevector file)))
(expand (cute expand-origin <> (dirname file)))
(dyninfo (elf-dynamic-info elf)))
(when dyninfo
fringe@@ -402,12 +401,13 @@ (define (strip-runpath file)
needed)))
runpath))
- (define port
- (open-file file "r+b"))
+ (define bv (file->bytevector file #:protection
+ (logior PROT_READ PROT_WRITE)))
- (catch #t
+ (dynamic-wind
+ (const #t)
(lambda ()
- (let* ((elf (parse-elf (get-bytevector-all port)))
+ (let* ((elf (parse-elf bv))
(entries (dynamic-entries elf (dynamic-link-segment elf)))
(needed (filter-map (lambda (entry)
(and (= (dynamic-entry-type entry)
fringe@@ -425,15 +425,14 @@ (define (strip-runpath file)
"~a: stripping RUNPATH to ~s (removed ~s)~%"
file new
(lset-difference string=? old new))
- (seek port (dynamic-entry-offset runpath) SEEK_SET)
- (put-bytevector port (string->utf8 (string-join new ":")))
- (put-u8 port 0))
- (close-port port)
+ ;; Write to bytevector directly.
+ (let ((src (string->utf8 (string-append (string-join new ":")
+ "\0"))))
+ (bytevector-copy! src 0 bv (dynamic-entry-offset runpath)
+ (bytevector-length src))))
new))
- (lambda (key . args)
- (false-if-exception (close-port port))
- (apply throw key args))))
-
+ (lambda ()
+ (munmap bv))))
(define-condition-type &missing-runpath-error &elf-error
missing-runpath-error?
fringe@@ -447,20 +446,18 @@ (define (set-file-runpath file path)
"Set the value of the DT_RUNPATH dynamic entry of FILE, which must name an
ELF file, to PATH, a list of strings. Raise a &missing-runpath-error or
&runpath-too-long-error when appropriate."
- (define (call-with-input+output-file file proc)
- (let ((port (open-file file "r+b")))
- (guard (c (#t (close-port port) (raise c)))
- (proc port)
- (close-port port))))
-
- (call-with-input+output-file file
- (lambda (port)
- (let* ((elf (parse-elf (get-bytevector-all port)))
+ (define bv (file->bytevector file #:protection
+ (logior PROT_READ PROT_WRITE)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (let* ((elf (parse-elf bv))
(entries (dynamic-entries elf (dynamic-link-segment elf)))
(runpath (find (lambda (entry)
(= DT_RUNPATH (dynamic-entry-type entry)))
entries))
- (path (string->utf8 (string-join path ":"))))
+ (path (string->utf8 (string-append (string-join path ":")
+ "\0"))))
(unless runpath
(raise (condition (&missing-runpath-error (elf elf)
(file file)))))
fringe@@ -473,10 +470,7 @@ (define (set-file-runpath file path)
(raise (condition (&runpath-too-long-error (elf #f #;elf)
(file file)))))
- (seek port (dynamic-entry-offset runpath) SEEK_SET)
- (put-bytevector port path)
- (put-u8 port 0)))))
-
-;;; Local Variables:
-;;; eval: (put 'call-with-input+output-file 'scheme-indent-function 1)
-;;; End:
+ (bytevector-copy! path 0 bv (dynamic-entry-offset runpath)
+ (bytevector-length path))))
+ (lambda ()
+ (munmap bv))))
fringenew file guix/build/io.scm
fringe@@ -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)))))
fringemodified guix/build/syscalls.scm
fringe@@ -10,6 +10,7 @@
;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2022 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2024 Noah Evans <noahevans256@gmail.com>
+;;; Copyright © 2025 Maxim Cournoyer <maxim@guixotic.coop>
;;;
;;; This file is part of GNU Guix.
;;;
fringe@@ -41,7 +42,23 @@ (define-module (guix build syscalls)
#:use-module (ice-9 regex)
#:use-module (ice-9 match)
#:use-module (ice-9 ftw)
- #: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
fringe@@ -1100,6 +1117,89 @@ (define setxattr
(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 (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
+ (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)))))
+
+(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.
fringemodified guix/scripts/pack.scm
fringe@@ -5,7 +5,7 @@
;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
-;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim@guixotic.coop>
+;;; Copyright © 2020-2023, 2025 Maxim Cournoyer <maxim@guixotic.coop>
;;; Copyright © 2020 Eric Bavier <bavier@posteo.net>
;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2023 Graham James Addis <graham@addis.org.uk>
fringe@@ -1221,12 +1221,14 @@ (define* (wrapped-package package
(define build
(with-imported-modules (source-module-closure
- '((guix build utils)
+ '((guix build io)
+ (guix build utils)
(guix build union)
(guix build gremlin)
(guix elf)))
#~(begin
- (use-modules (guix build utils)
+ (use-modules (guix build io)
+ (guix build utils)
((guix build union) #:select (symlink-relative))
(guix elf)
(guix build gremlin)
fringe@@ -1260,7 +1262,7 @@ (define* (wrapped-package package
(match (find (lambda (segment)
(= (elf-segment-type segment) PT_INTERP))
(elf-segments elf))
- (#f #f) ;maybe a .so
+ (#f #f) ;maybe a .so
(segment
(let ((bv (make-bytevector (- (elf-segment-memsz segment) 1))))
(bytevector-copy! (elf-bytes elf)
fringe@@ -1280,8 +1282,7 @@ (define* (wrapped-package package
#$(if fakechroot?
;; TODO: Handle scripts by wrapping their interpreter.
#~(if (elf-file? program)
- (let* ((bv (call-with-input-file program
- get-bytevector-all))
+ (let* ((bv (file->bytevector program))
(elf (parse-elf bv))
(interp (elf-interpreter elf))
(gconv (and interp
fringemodified tests/debug-link.scm
fringe@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2025 Maxim Cournoyer <maxim@guixotic.coop>
;;;
;;; This file is part of GNU Guix.
;;;
fringe@@ -16,16 +17,19 @@
;;; 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 (test-debug-link)
+(define-module (guile-user)
#:use-module (guix elf)
#:use-module (guix build utils)
#:use-module (guix build debug-link)
+ #:use-module (guix build io)
#:use-module (guix gexp)
+ #:use-module (guix modules)
#:use-module (guix store)
#:use-module (guix tests)
#:use-module (guix monads)
#:use-module (guix derivations)
#:use-module (gnu packages bootstrap)
+ #:use-module ((gnu packages guile) #:select (guile-3.0))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
fringe@@ -40,15 +44,12 @@ (define %guile-executable
(_
#f)))
-(define read-elf
- (compose parse-elf get-bytevector-all))
-
(test-begin "debug-link")
(unless %guile-executable (test-skip 1))
-(test-assert "elf-debuglink"
- (let ((elf (call-with-input-file %guile-executable read-elf)))
+(test-assert "elf-debuglink, no .gnu_debuglink section"
+ (let ((elf (parse-elf (file->bytevector %guile-executable))))
(match (call-with-values (lambda () (elf-debuglink elf)) list)
((#f #f) ;no '.gnu_debuglink' section
(pk 'no-debuglink #t))
fringe@@ -56,95 +57,101 @@ (define read-elf
(string-suffix? ".debug" file)))))
;; Since we need %BOOTSTRAP-GCC and co., we have to skip the following tests
-;; when networking is unreachable because we'd fail to download it.
-(unless (network-reachable?) (test-skip 1))
-(test-assertm "elf-debuglink"
- ;; Check whether we can compute the CRC just like objcopy, and whether we
- ;; can retrieve it.
- (let* ((code (plain-file "test.c" "int main () { return 42; }"))
- (exp (with-imported-modules '((guix build utils)
- (guix build debug-link)
- (guix elf))
- #~(begin
- (use-modules (guix build utils)
- (guix build debug-link)
- (guix elf)
- (rnrs io ports))
+;; when networking is unreachable because we'd fail to download it. Since
+;; using mmap to load ELF more efficiently, we also need the regular Guile
+;; package, as guile-bootstrap cannot resolve dynamic symbols.
+(with-external-store store
+ (unless (and (network-reachable?) store) (test-skip 1))
+ (test-assertm "elf-debuglink"
+ ;; Check whether we can compute the CRC just like objcopy, and whether we
+ ;; can retrieve it.
+ (let* ((code (plain-file "test.c" "int main () { return 42; }"))
+ (exp (with-imported-modules (source-module-closure
+ '((guix build io)
+ (guix build utils)
+ (guix build debug-link)
+ (guix elf)))
+ #~(begin
+ (use-modules (guix build io)
+ (guix build utils)
+ (guix build debug-link)
+ (guix elf)
+ (rnrs io ports))
- (define read-elf
- (compose parse-elf get-bytevector-all))
+ (define read-elf
+ (compose parse-elf file->bytevector))
- (setenv "PATH" (string-join '(#$%bootstrap-gcc
- #$%bootstrap-binutils)
- "/bin:" 'suffix))
- (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
- (copy-file "exe" "exe.debug")
- (invoke "strip" "--only-keep-debug" "exe.debug")
- (invoke "strip" "--strip-debug" "exe")
- (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
- "exe")
- (call-with-values (lambda ()
- (elf-debuglink
- (call-with-input-file "exe"
- read-elf)))
- (lambda (file crc)
- (call-with-output-file #$output
- (lambda (port)
- (let ((expected (call-with-input-file "exe.debug"
- debuglink-crc32)))
- (write (list file (= crc expected))
- port))))))))))
- (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
- (x (built-derivations (list drv))))
- (call-with-input-file (derivation->output-path drv)
- (lambda (port)
- (return (match (read port)
- (("exe.debug" #t) #t)
- (x (pk 'fail x #f)))))))))
+ (setenv "PATH" (string-join '(#$%bootstrap-gcc
+ #$%bootstrap-binutils)
+ "/bin:" 'suffix))
+ (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
+ (copy-file "exe" "exe.debug")
+ (invoke "strip" "--only-keep-debug" "exe.debug")
+ (invoke "strip" "--strip-debug" "exe")
+ (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
+ "exe")
+ (call-with-values (lambda ()
+ (elf-debuglink (read-elf "exe")))
+ (lambda (file crc)
+ (call-with-output-file #$output
+ (lambda (port)
+ (let ((expected (call-with-input-file "exe.debug"
+ debuglink-crc32)))
+ (write (list file (= crc expected))
+ port))))))))))
+ (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
+ (x (built-derivations (list drv))))
+ (call-with-input-file (derivation->output-path drv)
+ (lambda (port)
+ (return (match (read port)
+ (("exe.debug" #t) #t)
+ (x (pk 'fail x #f)))))))))
-(unless (network-reachable?) (test-skip 1))
-(test-assertm "set-debuglink-crc"
- ;; Check whether 'set-debuglink-crc' successfully updates the CRC.
- (let* ((code (plain-file "test.c" "int main () { return 42; }"))
- (debug (plain-file "exe.debug" "a"))
- (exp (with-imported-modules '((guix build utils)
- (guix build debug-link)
- (guix elf))
- #~(begin
- (use-modules (guix build utils)
- (guix build debug-link)
- (guix elf)
- (rnrs io ports))
+ (unless (and (network-reachable?) store) (test-skip 1))
+ (test-assertm "set-debuglink-crc"
+ ;; Check whether 'set-debuglink-crc' successfully updates the CRC.
+ (let* ((code (plain-file "test.c" "int main () { return 42; }"))
+ (debug (plain-file "exe.debug" "a"))
+ (exp (with-imported-modules (source-module-closure
+ '((guix build io)
+ (guix build utils)
+ (guix build debug-link)
+ (guix elf)))
+ #~(begin
+ (use-modules (guix build io)
+ (guix build utils)
+ (guix build debug-link)
+ (guix elf)
+ (rnrs io ports))
- (define read-elf
- (compose parse-elf get-bytevector-all))
+ (define read-elf
+ (compose parse-elf file->bytevector))
- (setenv "PATH" (string-join '(#$%bootstrap-gcc
- #$%bootstrap-binutils)
- "/bin:" 'suffix))
- (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
- (copy-file "exe" "exe.debug")
- (invoke "strip" "--only-keep-debug" "exe.debug")
- (invoke "strip" "--strip-debug" "exe")
- (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
- "exe")
- (set-debuglink-crc "exe" #$debug)
- (call-with-values (lambda ()
- (elf-debuglink
- (call-with-input-file "exe"
- read-elf)))
- (lambda (file crc)
- (call-with-output-file #$output
- (lambda (port)
- (write (list file crc) port)))))))))
- (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
- (x (built-derivations (list drv))))
- (call-with-input-file (derivation->output-path drv)
- (lambda (port)
- (return (match (read port)
- (("exe.debug" crc)
- (= crc (debuglink-crc32 (open-input-string "a"))))
- (x
- (pk 'fail x #f)))))))))
+ (setenv "PATH" (string-join '(#$%bootstrap-gcc
+ #$%bootstrap-binutils)
+ "/bin:" 'suffix))
+ (invoke "gcc" "-O0" "-g" #$code "-o" "exe")
+ (copy-file "exe" "exe.debug")
+ (invoke "strip" "--only-keep-debug" "exe.debug")
+ (invoke "strip" "--strip-debug" "exe")
+ (invoke "objcopy" "--add-gnu-debuglink=exe.debug"
+ "exe")
+ (set-debuglink-crc "exe" #$debug)
+ (call-with-values (lambda ()
+ (elf-debuglink
+ (read-elf "exe")))
+ (lambda (file crc)
+ (call-with-output-file #$output
+ (lambda (port)
+ (write (list file crc) port)))))))))
+ (mlet* %store-monad ((drv (gexp->derivation "debuglink" exp))
+ (x (built-derivations (list drv))))
+ (call-with-input-file (derivation->output-path drv)
+ (lambda (port)
+ (return (match (read port)
+ (("exe.debug" crc)
+ (= crc (debuglink-crc32 (open-input-string "a"))))
+ (x
+ (pk 'fail x #f))))))))))
(test-end "debug-link")
fringemodified tests/gremlin.scm
fringe@@ -23,6 +23,7 @@ (define-module (test-gremlin)
#:use-module (guix tests)
#:use-module ((guix utils) #:select (call-with-temporary-directory
target-aarch64?))
+ #:use-module (guix build io)
#:use-module (guix build utils)
#:use-module (guix build gremlin)
#:use-module (gnu packages bootstrap)
fringe@@ -44,9 +45,6 @@ (define %guile-executable
(_
#f)))
-(define read-elf
- (compose parse-elf get-bytevector-all))
-
(define c-compiler
(or (which "gcc") (which "cc") (which "g++")))
fringe@@ -55,8 +53,7 @@ (define c-compiler
(unless %guile-executable (test-skip 1))
(test-assert "elf-dynamic-info-needed, executable"
- (let* ((elf (call-with-input-file %guile-executable read-elf))
- (dyninfo (elf-dynamic-info elf)))
+ (let ((dyninfo (file-dynamic-info %guile-executable)))
(or (not dyninfo) ;static executable
(lset<= string=?
(list (string-append "libguile-" (effective-version))
fringe@@ -140,9 +137,7 @@ (define c-compiler
(display "int main () { puts(\"hello\"); }" port)))
(invoke c-compiler "t.c"
"-Wl,--enable-new-dtags" "-Wl,-rpath=/foo" "-Wl,-rpath=/bar")
- (let* ((dyninfo (elf-dynamic-info
- (parse-elf (call-with-input-file "a.out"
- get-bytevector-all))))
+ (let* ((dyninfo (file-dynamic-info "a.out"))
(old (elf-dynamic-info-runpath dyninfo))
(new (strip-runpath "a.out"))
(new* (strip-runpath "a.out")))
fringe@@ -196,10 +191,7 @@ (define c-compiler
(display "// empty file" port)))
(invoke c-compiler "t.c"
"-shared" "-Wl,-soname,libfoo.so.2")
- (let* ((dyninfo (elf-dynamic-info
- (parse-elf (call-with-input-file "a.out"
- get-bytevector-all))))
- (soname (elf-dynamic-info-soname dyninfo)))
- soname)))))
+ (let ((dyninfo (file-dynamic-info "a.out")))
+ (elf-dynamic-info-soname dyninfo))))))
(test-end "gremlin")
fringemodified tests/syscalls.scm
fringe@@ -3,6 +3,7 @@
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2020 Simon South <simon@simonsouth.net>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2025 Maxim Cournoyer <maxim@guixotic.coop>
;;;
;;; This file is part of GNU Guix.
;;;
fringe@@ -21,15 +22,18 @@
(define-module (test-syscalls)
#:use-module (guix utils)
+ #:use-module (guix build io)
#:use-module (guix build syscalls)
#: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)
#:use-module (srfi srfi-71)
#:use-module (system foreign)
#:use-module ((ice-9 ftw) #:select (scandir))
- #:use-module (ice-9 match))
+ #:use-module (ice-9 match)
+ #: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.
fringe@@ -701,6 +705,39 @@ (define perform-container-tests?
(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)
+ (bytevector-u8-set! (file->bytevector temp-file
+ #:protection PROT_WRITE)
+
+ 7 (char->integer #\7))
+ ;; Finalizer called munmap, ensuring the file was written.
+ (call-with-input-file temp-file get-string-all)))
+
(test-end)
(false-if-exception (delete-file temp-file))
[back]