diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2022-05-26 00:14:29 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2022-05-26 11:41:05 +0200 |
| commit | 98a6642298be6663b9d318b7dea46d1dba275839 (patch) | |
| tree | 2e88f3d44c168bedc301833fff1f8219637d5ce0 /build-aux/cuirass | |
| parent | dcb7ce1eb6911f9d503e7cd2bfe380058cee956b (diff) | |
cuirass: Fork inferior processes before creating threads.
Works around <https://issues.guix.gnu.org/55441#12>.
Start from commit bd86bbd300474204878e927f6cd3f0defa1662a5,
'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'.
Diffstat (limited to 'build-aux/cuirass')
| -rw-r--r-- | build-aux/cuirass/evaluate.scm | 53 |
1 files changed, 29 insertions, 24 deletions
diff --git a/build-aux/cuirass/evaluate.scm b/build-aux/cuirass/evaluate.scm index 0bd9e2481f..5beac1b37c 100644 --- a/build-aux/cuirass/evaluate.scm +++ b/build-aux/cuirass/evaluate.scm @@ -1,5 +1,5 @@ ;;; 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 © 2021 Mathieu Othacehe <othacehe@gnu.org> ;;; @@ -78,29 +78,34 @@ ;; up the evaluation speed as the evaluations can be performed ;; concurrently. It also decreases the amount of memory needed per ;; evaluation process. - (n-par-for-each - (/ (current-processor-count) 2) - (lambda (system) - (with-store store - (let ((inferior - (open-inferior (derivation->output-path derivation))) - (channels (map channel-instance->sexp instances))) - (inferior-eval '(use-modules (gnu ci)) inferior) - (let ((jobs - (inferior-eval-with-store - inferior store - `(lambda (store) - (cuirass-jobs store - '((subset . all) - (systems . ,(list system)) - (channels . ,channels)))))) - (file - (string-append directory "/jobs-" system ".scm"))) - (close-inferior inferior) - (call-with-output-file file - (lambda (port) - (write jobs port))))))) - %cuirass-supported-systems)))))) + ;; + ;; Fork inferior processes upfront before we have created any + ;; threads. + (let ((inferiors (map (lambda _ + (open-inferior (derivation->output-path derivation))) + %cuirass-supported-systems))) + (n-par-for-each + (/ (current-processor-count) 2) + (lambda (system inferior) + (with-store store + (let ((channels (map channel-instance->sexp instances))) + (inferior-eval '(use-modules (gnu ci)) inferior) + (let ((jobs + (inferior-eval-with-store + inferior store + `(lambda (store) + (cuirass-jobs store + '((subset . all) + (systems . ,(list system)) + (channels . ,channels)))))) + (file + (string-append directory "/jobs-" system ".scm"))) + (close-inferior inferior) + (call-with-output-file file + (lambda (port) + (write jobs port))))))) + %cuirass-supported-systems + inferiors))))))) (x (format (current-error-port) "Wrong command: ~a~%." x) (exit 1))) |