[shepherd] 03/05: shepherd: No longer send SIGALRM every second.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 03a354e9987383f005b39348ab150608fdfbada9
Author: Ludovic Courtès <address@hidden>
AuthorDate: Mon Apr 20 15:04:58 2020 +0200

    shepherd: No longer send SIGALRM every second.
    
    This kludge was mostly unnecessary since commit
    0ce1076eab9659c29c74bb6aeafb2fec6ef1efd8 on Guile 2.2+.
    
    * modules/shepherd.scm (main): Remove calls to 'sigaction' and 'alarm'.
    Call 'handle-SIGCHLD' each time 'select' returns.
    * modules/shepherd/service.scm (waitpid*): Remove warning in exception
    handler.
    (handle-SIGCHLD): Make 'signum' optional.
    * modules/shepherd/system.scm.in <top level> [guile-2.0]: Replace
    'select'.
    
    fixlet
---
 modules/shepherd.scm           | 26 ++++++++++++++------------
 modules/shepherd/service.scm   | 14 +++++---------
 modules/shepherd/system.scm.in | 17 +++++++++++++++++
 3 files changed, 36 insertions(+), 21 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 3812f8a..704ea47 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -1,5 +1,5 @@
 ;; shepherd.scm -- The daemon shepherd.
-;; Copyright (C) 2013, 2014, 2016, 2018, 2019 Ludovic Courtès <address@hidden>
+;; Copyright (C) 2013, 2014, 2016, 2018, 2019, 2020 Ludovic Courtès 
<address@hidden>
 ;; Copyright (C) 2002, 2003 Wolfgang Jährling <address@hidden>
 ;; Copyright (C) 2018 Carlo Zancanaro <address@hidden>
 ;; Copyright (C) 2018 Danny Milosavljevic <address@hidden>
@@ -255,15 +255,6 @@ socket file at FILE-NAME upon exit of PROC.  Return the 
values of PROC."
                (apply format #f (gettext (cadr args)) (caddr args))
                (quit 1))))
 
-      (when (provided? 'threads)
-        ;; XXX: This terrible hack allows us to make sure that signal handlers
-        ;; get a chance to run in a timely fashion.  Without it, after an 
EINTR,
-        ;; we could restart the accept(2) call below before the corresponding
-        ;; async has been queued.  See the thread at
-        ;; 
<https://lists.gnu.org/archive/html/guile-devel/2013-07/msg00004.html>.
-        (sigaction SIGALRM (lambda _ (alarm 1)))
-        (alarm 1))
-
       ;; Ignore SIGPIPE so that we don't die if a client closes the connection
       ;; prematurely.
       (sigaction SIGPIPE SIG_IGN)
@@ -292,11 +283,22 @@ socket file at FILE-NAME upon exit of PROC.  Return the 
values of PROC."
                     (setvbuf command-source (buffering-mode block) 1024)
                     (process-connection command-source))
                    (_ #f)))
-               (match (select (list sock) (list) (list) (if poll-services? 0.5 
#f))
+
+               ;; XXX: Until we use signalfd(2), there's always a time window
+               ;; before 'select' during which a handler async can be queued
+               ;; but not executed.  Work around it by exiting 'select' every
+               ;; few seconds.
+               (match (select (list sock) (list) (list)
+                              (if poll-services? 0.5 30))
                  (((sock) _ _)
                   (read-from sock))
                  (_
-                  #f))
+                  ;; 'select' returned an empty set, probably due to EINTR.
+                  ;; Explicitly call the SIGCHLD handler because we cannot be
+                  ;; sure the async will be queued and executed before we call
+                  ;; 'select' again.
+                  (handle-SIGCHLD)))
+
                (when poll-services?
                  (check-for-dead-services))
                (next-command))))))))
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 64b0664..8604d2f 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -880,7 +880,7 @@ false."
                              (default-environment-variables)))
   "Spawn a process that executed COMMAND as per 'exec-command', and return
 its PID."
-  ;; Install the SIGCHLD handler if this is the first fork+exec-command call
+  ;; 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))
@@ -1063,15 +1063,11 @@ returned in unspecified."
       (lambda ()
         (waitpid what flags))
       (lambda args
-        ;; Did we get ECHILD or something?  If we did, that's a problem,
-        ;; because this procedure is supposed to be called only upon
-        ;; SIGCHLD.
-        (let ((errno (system-error-errno args)))
-          (local-output (l10n "warning: 'waitpid' ~a failed unexpectedly: ~a")
-                        what (strerror errno))
-          '(0 . #f))))))
+        (if (memv (system-error-errno args) (list ECHILD EINTR))
+            '(0 . #f)
+            (apply throw args))))))
 
-(define (handle-SIGCHLD signum)
+(define* (handle-SIGCHLD #:optional (signum SIGCHLD))
   "Handle SIGCHLD, possibly by respawning the service that just died, or
 otherwise by updating its state."
   (let loop ()
diff --git a/modules/shepherd/system.scm.in b/modules/shepherd/system.scm.in
index 5594adf..adf303c 100644
--- a/modules/shepherd/system.scm.in
+++ b/modules/shepherd/system.scm.in
@@ -217,3 +217,20 @@ Turning finalization off shuts down the finalization 
thread as a side effect."
      ;; Nothing to do here: Guile 2.0 does not have a separate finalization
      ;; thread.
      (begin exp ...))))
+
+(cond-expand
+  ((and guile-2 (not guile-2.2))
+   ;; On Guile 2.0, 'select' throws upon EINTR or EAGAIN.  The trick below
+   ;; enables the sane behavior found on 2.2/3.0.
+   (set! select
+     (let ((real-select select))
+       (lambda args
+         (catch 'system-error
+           (lambda ()
+             (apply real-select args))
+           (lambda args
+             (if (memv (system-error-errno args) (list EINTR EAGAIN))
+                 '(() () ())
+                 (apply throw args))))))))
+  (else #t))
+