11 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 ++++++++++++++++++++++++++++++++++++++- modified Makefile.am @@ -14,7 +14,7 @@ # Copyright © 2018 Oleg Pykhalov # Copyright © 2018 Alex Vong # Copyright © 2019, 2023 Efraim Flashner -# Copyright © 2020, 2021, 2023 Maxim Cournoyer +# Copyright © 2020, 2021, 2023, 2025 Maxim Cournoyer # Copyright © 2021 Chris Marusich # Copyright © 2021 Andrew Tropin # Copyright © 2023 Clément Lassieur @@ -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 \ modified gnu/packages/gnuzilla.scm @@ -996,16 +996,10 @@ (define-public icecat-minimal (search-input-file inputs "lib/libavcodec.so"))))) (add-after 'fix-ffmpeg-runtime-linker 'build-sandbox-whitelist (lambda* (#:key inputs #:allow-other-keys) - (define (runpath-of lib) - (call-with-input-file lib - (compose elf-dynamic-info-runpath - elf-dynamic-info - parse-elf - get-bytevector-all))) (define (runpaths-of-input label) (let* ((dir (string-append (assoc-ref inputs label) "/lib")) (libs (find-files dir "\\.so$"))) - (append-map runpath-of libs))) + (append-map file-runpath libs))) ;; Populate the sandbox read-path whitelist as needed by ffmpeg. (let* ((whitelist (map (cut string-append <> "/") modified gnu/packages/librewolf.scm @@ -530,15 +530,11 @@ (define-public librewolf ;; The following two functions are from Guix's icecat package in ;; (gnu packages gnuzilla). See commit ;; b7a0935420ee630a29b7e5ac73a32ba1eb24f00b. - (define (runpath-of lib) - (call-with-input-file lib - (compose elf-dynamic-info-runpath elf-dynamic-info - parse-elf get-bytevector-all))) (define (runpaths-of-input label) (let* ((dir (string-append (assoc-ref inputs label) "/lib")) (libs (find-files dir "\\.so$"))) - (append-map runpath-of libs))) + (append-map file-runpath libs))) (let* ((out (assoc-ref outputs "out")) (lib (string-append out "/lib")) (libs (map modified guix/build/debug-link.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2023 Ludovic Courtès +;;; Copyright © 2025 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -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) @@ -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))))) ;;; modified guix/build/gremlin.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2018, 2020 Ludovic Courtès +;;; Copyright © 2025 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -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) @@ -248,9 +250,7 @@ (define (elf-dynamic-info elf) (define (file-dynamic-info file) "Return the 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 @@ -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 @@ -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) @@ -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? @@ -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))))) @@ -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)))) new file guix/build/io.scm @@ -0,0 +1,58 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Maxim Cournoyer +;;; +;;; 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 . + +(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))))) modified guix/build/syscalls.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2021 Tobias Geerinckx-Rice ;;; Copyright © 2022 Oleg Pykhalov ;;; Copyright © 2024 Noah Evans +;;; Copyright © 2025 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -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 @@ -1100,6 +1117,89 @@ (define setxattr (list file key value (strerror err)) (list err))))))) + +;;; +;;; Memory maps. +;;; + +;;; Constants from +(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. modified guix/scripts/pack.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2018 Chris Marusich ;;; Copyright © 2018 Efraim Flashner ;;; Copyright © 2020 Tobias Geerinckx-Rice -;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer +;;; Copyright © 2020-2023, 2025 Maxim Cournoyer ;;; Copyright © 2020 Eric Bavier ;;; Copyright © 2022 Alex Griffin ;;; Copyright © 2023 Graham James Addis @@ -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) @@ -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) @@ -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 modified tests/debug-link.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2025 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -16,16 +17,19 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . -(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) @@ -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)) @@ -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") modified tests/gremlin.scm @@ -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) @@ -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++"))) @@ -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)) @@ -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"))) @@ -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") modified tests/syscalls.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2015 David Thompson ;;; Copyright © 2020 Simon South ;;; Copyright © 2020 Mathieu Othacehe +;;; Copyright © 2025 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -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. @@ -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]