summaryrefslogtreecommitdiff
path: root/build-aux/cuirass
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-05-26 00:14:29 +0200
committerLudovic Courtès <ludo@gnu.org>2022-05-26 11:41:05 +0200
commit98a6642298be6663b9d318b7dea46d1dba275839 (patch)
tree2e88f3d44c168bedc301833fff1f8219637d5ce0 /build-aux/cuirass
parentdcb7ce1eb6911f9d503e7cd2bfe380058cee956b (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.scm53
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)))