branch master updated: remote-worker: Prevent non-local exits in child processes.

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script.

civodul pushed a commit to branch master
in repository guix-cuirass.

The following commit(s) were added to refs/heads/master by this push:
     new 9fb6f21  remote-worker: Prevent non-local exits in child processes.
9fb6f21 is described below

commit 9fb6f21d29c5398b35f4c1a77cf6c20f207c9ebb
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Nov 23 15:23:52 2022 +0100

    remote-worker: Prevent non-local exits in child processes.
    
    Previously, a non-local exit (such as an uncaught exception) in the
    child process would cause it to execute the same code as its parent.
    
    * src/cuirass/scripts/remote-worker.scm (start-worker): Wrap child body
    in 'dynamic-wind'.
---
 src/cuirass/scripts/remote-worker.scm | 61 +++++++++++++++++++----------------
 1 file changed, 33 insertions(+), 28 deletions(-)

diff --git a/src/cuirass/scripts/remote-worker.scm 
b/src/cuirass/scripts/remote-worker.scm
index bc64cbd..1c47950 100644
--- a/src/cuirass/scripts/remote-worker.scm
+++ b/src/cuirass/scripts/remote-worker.scm
@@ -365,34 +365,39 @@ and executing them.  The worker can reply on the same 
socket."
 
   (match (primitive-fork)
     (0
-     (set-thread-name (worker-name wrk))
-     (let* ((socket (zmq-dealer-socket))
-            (address (server-address serv))
-            (port (server-port serv))
-            (endpoint (zmq-backend-endpoint address port)))
-       (zmq-connect socket endpoint)
-       (let* ((srv-info (read-server-info socket))
-              (server (server-info->server srv-info serv))
-              (worker (server-info->worker srv-info wrk)))
-         (ready socket worker)
-         (worker-ping worker server)
-         (let loop ()
-           (if (low-disk-space?)
-               (log-info (G_ "warning: low disk space, doing nothing"))
-               (begin
-                 (log-info (G_ "~a: request work.") (worker-name wrk))
-                 (request-work socket worker)
-                 (match (zmq-get-msg-parts-bytevector socket '())
-                   ((empty) ;server reconnection
-                    (log-info (G_ "~a: received a bootstrap message.")
-                              (worker-name wrk)))
-                   ((empty command)
-                    (run-command (bv->string command) server
-                                 #:reply (reply socket)
-                                 #:worker worker)))))
-
-           (sleep (%request-period))
-           (loop)))))
+     (dynamic-wind
+       (const #t)
+       (lambda ()
+         (set-thread-name (worker-name wrk))
+         (let* ((socket (zmq-dealer-socket))
+                (address (server-address serv))
+                (port (server-port serv))
+                (endpoint (zmq-backend-endpoint address port)))
+           (zmq-connect socket endpoint)
+           (let* ((srv-info (read-server-info socket))
+                  (server (server-info->server srv-info serv))
+                  (worker (server-info->worker srv-info wrk)))
+             (ready socket worker)
+             (worker-ping worker server)
+             (let loop ()
+               (if (low-disk-space?)
+                   (log-info (G_ "warning: low disk space, doing nothing"))
+                   (begin
+                     (log-info (G_ "~a: request work.") (worker-name wrk))
+                     (request-work socket worker)
+                     (match (zmq-get-msg-parts-bytevector socket '())
+                       ((empty)                   ;server reconnect
+                        (log-info (G_ "~a: received a bootstrap message.")
+                                  (worker-name wrk)))
+                       ((empty command)
+                        (run-command (bv->string command) server
+                                     #:reply (reply socket)
+                                     #:worker worker)))))
+
+               (sleep (%request-period))
+               (loop)))))
+       (lambda ()
+         (primitive-exit 1))))
     (pid pid)))