TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

cuirass: Fork inferior processes before creating threads. 

Works around <https://issues.guix.gnu.org/55441#12>.

Start from commit bd86bbd300,
'open-inferior' uses 'primitive-fork' instead of 'open-pipe*'.  As a
result, child process could potentially hang before calling 'execl' due
to undefined behavior when forking a multi-threaded process.

* build-aux/cuirass/evaluate.scm <top level>: Call 'open-inferior'
before 'n-par-for-each'.
This commit is contained in:
Ludovic Courtès 2022-05-26 00:14:29 +02:00
parent dcb7ce1eb6
commit 98a6642298
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 29 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
build-aux/cuirass/evaluate.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016-2018, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> ;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org>
;;; ;;;
@ -78,29 +78,34 @@
;; up the evaluation speed as the evaluations can be performed ;; up the evaluation speed as the evaluations can be performed
;; concurrently. It also decreases the amount of memory needed per ;; concurrently. It also decreases the amount of memory needed per
;; evaluation process. ;; evaluation process.
(n-par-for-each ;;
(/ (current-processor-count) 2) ;; Fork inferior processes upfront before we have created any
(lambda (system) ;; threads.
(with-store store (let ((inferiors (map (lambda _
(let ((inferior (open-inferior (derivation->output-path derivation)))
(open-inferior (derivation->output-path derivation))) %cuirass-supported-systems)))
(channels (map channel-instance->sexp instances))) (n-par-for-each
(inferior-eval '(use-modules (gnu ci)) inferior) (/ (current-processor-count) 2)
(let ((jobs (lambda (system inferior)
(inferior-eval-with-store (with-store store
inferior store (let ((channels (map channel-instance->sexp instances)))
`(lambda (store) (inferior-eval '(use-modules (gnu ci)) inferior)
(cuirass-jobs store (let ((jobs
'((subset . all) (inferior-eval-with-store
(systems . ,(list system)) inferior store
(channels . ,channels)))))) `(lambda (store)
(file (cuirass-jobs store
(string-append directory "/jobs-" system ".scm"))) '((subset . all)
(close-inferior inferior) (systems . ,(list system))
(call-with-output-file file (channels . ,channels))))))
(lambda (port) (file
(write jobs port))))))) (string-append directory "/jobs-" system ".scm")))
%cuirass-supported-systems)))))) (close-inferior inferior)
(call-with-output-file file
(lambda (port)
(write jobs port)))))))
%cuirass-supported-systems
inferiors)))))))
(x (x
(format (current-error-port) "Wrong command: ~a~%." x) (format (current-error-port) "Wrong command: ~a~%." x)
(exit 1))) (exit 1)))