From 98a6642298be6663b9d318b7dea46d1dba275839 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Thu, 26 May 2022 00:14:29 +0200
Subject: [PATCH] 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'.
---
 build-aux/cuirass/evaluate.scm | 53 +++++++++++++++++++---------------
 1 file 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)))