[no subject]

[Ludovic Courtès]

branch: wip-bug-55441
commit 0e61131dd5b3dc8cd8e4483dcd392290fb8a419c
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed May 25 17:51:38 2022 +0200

    evaluate: Fork inferior processes before creating threads.
    
    Fixes <https://issues.guix.gnu.org/55441>.
    
    Regression introduced by Guix commit
    bd86bbd300474204878e927f6cd3f0defa1662a5, where 'open-inferior' switched
    from 'open-pipe*' to 'primitive-fork', thereby introducing a window
    before 'execl' where the child process could get stuck on a mutex or
    similar.
    
    * src/cuirass/scripts/evaluate.scm (inferior-evaluation): Remove
    'profile' argument and replace it by 'inferior'.  Remove 'open-inferior'
    and 'close-inferior' calls.
    (cuirass-evaluate): Call 'open-inferior' upfront.  Adjust 'par-for-each'
    call accordingly.
---
 src/cuirass/scripts/evaluate.scm | 35 +++++++++++++++++++++--------------
 1 file changed, 21 insertions(+), 14 deletions(-)

diff --git a/src/cuirass/scripts/evaluate.scm b/src/cuirass/scripts/evaluate.scm
index 9c9e7a9..8b7d1bf 100644
--- a/src/cuirass/scripts/evaluate.scm
+++ b/src/cuirass/scripts/evaluate.scm
@@ -46,13 +46,12 @@ CHECKOUTS."
                                        #:commit commit)))
        checkouts))
 
-(define* (inferior-evaluation store profile
+(define* (inferior-evaluation store inferior
                               #:key
                               eval-id instances
                               spec build systems)
-  "Spawn an inferior that uses the given STORE and PROFILE. Withing that
-inferior, call EVAL-PROC from the EVAL-MODULE.  Register the returned jobs in
-database for the EVAL-ID evaluation of the SPEC specification.
+  "Call EVAL-PROC in INFERIOR from the EVAL-MODULE.  Register the returned
+jobs in database for the EVAL-ID evaluation of the SPEC specification.
 
 Pass the BUILD, CHANNELS and SYSTEMS arguments to the EVAL-PROC procedure."
   ;; The module where the below procedure is defined.
@@ -64,17 +63,15 @@ Pass the BUILD, CHANNELS and SYSTEMS arguments to the 
EVAL-PROC procedure."
   (define channels
     (map channel-instance->sexp instances))
 
-  (let* ((inferior (open-inferior profile))
-         (args `((channels . ,channels)
-                 (systems . ,systems)
-                 (subset . ,build))))
+  (let ((args `((channels . ,channels)
+                (systems . ,systems)
+                (subset . ,build))))
     (inferior-eval `(use-modules ,eval-module) inferior)
     (let ((jobs
            (inferior-eval-with-store
             inferior store
             `(lambda (store)
                (,eval-proc store ',args)))))
-      (close-inferior inferior)
       (db-register-builds jobs eval-id spec))))
 
 (define (channel-instances->profile instances)
@@ -104,22 +101,32 @@ registered in database."
                   (instances (checkouts->channel-instances checkouts))
                   (profile (channel-instances->profile instances))
                   (build (specification-build spec))
-                  (systems (specification-systems spec)))
+                  (systems (specification-systems spec))
+
+                  ;; Fork inferior processes upfront before we have created
+                  ;; any threads.  This is necessary since Guix commit
+                  ;; bd86bbd300474204878e927f6cd3f0defa1662a5, where
+                  ;; 'open-inferior' switched from 'open-pipe*' to
+                  ;; 'primitive-fork'.
+                  (inferiors (map (lambda _
+                                    (open-inferior profile))
+                                  systems)))
 
              ;; Evaluate jobs on a per-system basis for two reasons.  It
              ;; speeds up the evaluation as the evaluations can be performed
              ;; concurrently.  It also decreases the amount of memory needed
              ;; per evaluation process.
              (par-for-each
-              (lambda (system)
+              (lambda (system inferior)
                 (with-store store
-                  (inferior-evaluation store profile
+                  (inferior-evaluation store inferior
                                        #:eval-id eval-id
                                        #:instances instances
                                        #:spec spec
                                        #:build build
-                                       #:systems (list system))))
-              systems)
+                                       #:systems (list system))
+                  (close-inferior inferior)))
+              systems inferiors)
              (display 'done)))))
     (x
      (format (current-error-port) "Wrong command: ~a~%." x)