graft: Perform grafts with guile-final.

* guix/build/graft.scm (rewrite-directory): Rewrite store directories in
individual files sequentially.
(exit-on-exception): Remove procedure.
* guix/packages.scm (guile-for-grafts): Switch to guile-final.

Change-Id: I50f7b23a3ceff8bb1495dc1f4bc772746147d924
This commit is contained in:
Efraim Flashner 2024-04-09 13:06:56 +03:00
parent 20c4e778a9
commit c74401749a
No known key found for this signature in database
GPG Key ID: 41AAE7DCCA3D8351
2 changed files with 6 additions and 24 deletions

View File

@ -299,19 +299,6 @@ a list of store file name pairs."
(string-append (dirname file) "/" target))))
matches)))
(define (exit-on-exception proc)
"Return a procedure that wraps PROC so that 'primitive-exit' is called when
an exception is caught."
(lambda (arg)
(catch #t
(lambda ()
(proc arg))
(lambda (key . args)
;; Since ports are not thread-safe as of Guile 2.0, reopen stderr.
(let ((port (fdopen 2 "w0")))
(print-exception port #f key args)
(primitive-exit 1))))))
(define* (rewrite-directory directory output mapping
#:optional (store (%store-directory)))
"Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of
@ -383,13 +370,10 @@ file name pairs."
(else
(error "unsupported file type" stat)))))
;; Use 'exit-on-exception' to force an exit upon I/O errors, given that
;; 'n-par-for-each' silently swallows exceptions.
;; See <http://bugs.gnu.org/23581>.
(n-par-for-each (parallel-job-count)
(exit-on-exception rewrite-leaf)
(find-files directory (const #t)
#:directories? #t))
;; n-par-for-each can lead to segfaults in the grafting code?
(for-each rewrite-leaf
(find-files directory (const #t)
#:directories? #t))
(rename-matching-files output mapping))
(define %graft-hooks

View File

@ -932,10 +932,8 @@ derivations."
(define (guile-for-grafts)
"Return the Guile package used to build grafting derivations."
;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when
;; grafting packages.
(let ((distro (resolve-interface '(gnu packages guile))))
(module-ref distro 'guile-2.0)))
(let ((distro (resolve-interface '(gnu packages commencement))))
(module-ref distro 'guile-final)))
(define* (default-guile-derivation #:optional (system (%current-system)))
"Return the derivation for SYSTEM of the default Guile package used to run