[shepherd] 01/04: service: Move non-signalfd setup to (shepherd).

[Ludovic Courtès]

civodul pushed a commit to branch main
in repository shepherd.

commit 877d638a8c83695db0f69cd24d4bb9d6292c3f0a
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Dec 23 23:14:07 2023 +0100

    service: Move non-signalfd setup to (shepherd).
    
    This change simplifies things and ensures that, on systems that do not
    support signalfd(2), the SIGCHLD handler is called with the right
    dynamic extent, in particular with the correct value of
    ‘current-process-monitor’ instead of #f.
    
    * modules/shepherd/service.scm (fork+exec-command)
    (make-inetd-forkexec-constructor): Remove call to ‘sigaction’ and
    modification of ‘%sigchld-handler-installed?’.
    (%sigchld-handler-installed?): Remove.
    * modules/shepherd.scm (capture-dynamic-state): New procedure.
    (main): Call ‘sigaction’ when SIGNAL-PORT is false; wrap
    ‘handle-SIGCHLD’ in ‘capture-dynamic-state’.
---
 modules/shepherd.scm         | 18 ++++++++++++++++++
 modules/shepherd/service.scm | 14 --------------
 2 files changed, 18 insertions(+), 14 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 3303de3..9040ae1 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -269,6 +269,16 @@ already ~a threads running, disabling 'signalfd' support")
 
            (next-command))))))
 
+(define (capture-dynamic-state proc)
+  (let ((dynamic-state (current-dynamic-state)))
+    ;; (pk 'capturing ((@@ (shepherd service) current-process-monitor)))
+    (lambda args
+      (with-dynamic-state dynamic-state
+                          (lambda ()
+                            ;; (pk 'captured
+                            ;;     ((@@ (shepherd-service) 
current-process-monitor)))
+                            (apply proc args))))))
+
 (define-syntax replace-core-bindings!
   (syntax-rules (<>)
     "Replace the given core bindings in the current process, restoring them 
upon
@@ -457,6 +467,14 @@ fork in the child process."
                (register-services (list root-service))
                (start-service root-service)
 
+               ;; Install the SIGCHLD handler on systems that don't support
+               ;; signalfd(2).  Capture the current dynamic state so that
+               ;; 'current-process-monitor' has the right value when the
+               ;; handler is invoked.
+               (unless signal-port
+                 (sigaction SIGCHLD (capture-dynamic-state handle-SIGCHLD)
+                            SA_NOCLDSTOP))
+
                ;; Replace the default 'system*' binding with one that
                ;; cooperates instead of blocking on 'waitpid'.  Replace
                ;; 'primitive-load' (in C as of 3.0.9) with one that does
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 5fc3332..24224c0 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -181,9 +181,6 @@
 
 (define sleep (@ (fibers) sleep))
 
-;; Keep track of lazy initialization of SIGCHLD handler
-(define %sigchld-handler-installed? #f)
-
 ;; Type of service actions.
 (define-record-type <action>
   (make-action name proc doc)
@@ -1599,11 +1596,6 @@ false."
 return its PID.  When @var{listen-pid-variable?} is true, augment
 @var{environment-variables} with a definition of the @env{LISTEN_PID}
 environment variable used for systemd-style \"socket activation\"."
-  ;; Install the SIGCHLD handler if this is the first fork+exec-command call.
-  (unless %sigchld-handler-installed?
-    (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP)
-    (set! %sigchld-handler-installed? #t))
-
   ;; Child processes inherit signal handlers until they exec.  If one of
   ;; %PRECIOUS-SIGNALS is received by the child before it execs, the installed
   ;; handler, which stops shepherd, is called.  To avoid this, block signals
@@ -1925,12 +1917,6 @@ thrown an previously-opened sockets are closed."
                                            (default-environment-variables))
                                           (resource-limits '()))
   (lambda ()
-    ;; XXX: This is partly copied from 'make-forkexec-constructor'.
-    ;; Install the SIGCHLD handler if this is the first fork+exec-command call.
-    (unless %sigchld-handler-installed?
-      (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP)
-      (set! %sigchld-handler-installed? #t))
-
     (with-blocked-signals %precious-signals
       (let ((pid (primitive-fork)))
         (if (zero? pid)