[shepherd] 03/16: Use Fibers.

[Ludovic Courtès]

civodul pushed a commit to branch wip-fibers
in repository shepherd.

commit 4c7a857827d3e279232bf1378d6c83791e8934ac
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Mar 21 10:20:23 2022 +0100

    Use Fibers.
    
    * configure.ac: Add 'GUILE_MODULE_AVAILABLE' use for Fibers.
    Add 'AC_CACHE_CHECK' use for 'ac_cv_fibers_creates_pthreads'.
    * modules/shepherd.scm: Use (fibers).
    (signal-handler): In the SIGTERM/SIGHUP case, catch 'quit.
    (main): Wrap call to 'run-daemon' in 'run-fibers'.
    (quit-exception-handler): Call 'primitive-exit' in the default case.
---
 configure.ac         | 25 +++++++++++++++++++++++++
 modules/shepherd.scm | 29 +++++++++++++++++++++--------
 2 files changed, 46 insertions(+), 8 deletions(-)

diff --git a/configure.ac b/configure.ac
index ac6493d..f98dbb4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -33,6 +33,31 @@ 
guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache"
 AC_SUBST([guilemoduledir])
 AC_SUBST([guileobjectdir])
 
+dnl Check for extra dependencies.
+GUILE_MODULE_AVAILABLE([have_fibers], [(fibers)])
+if test "x$have_fibers" != "xyes"; then
+  AC_MSG_ERROR([Fibers is missing; please install it.])
+fi
+
+dnl Make sure Fibers does not create POSIX threads: since shepherd
+dnl forks, it must be single-threaded.
+AC_CACHE_CHECK([whether Fibers might create POSIX threads],
+  [ac_cv_fibers_creates_pthreads],
+  [GUILE_CHECK([retval],
+    [(use-modules (fibers))
+     (set! (@ (ice-9 threads) call-with-new-thread)
+       (lambda _ (throw 'new-thread!)))
+     (run-fibers (lambda () (spawn-fiber (lambda () 1)))
+                 #:parallelism 1 #:hz 0)])
+   if test "$retval" = 0; then
+     ac_cv_fibers_creates_pthreads="no"
+   else
+     ac_cv_fibers_creates_pthreads="yes"
+   fi])
+if test "x$ac_cv_fibers_creates_pthreads" = "xyes"; then
+  AC_MSG_ERROR([Fibers creates POSIX threads behind our back; aborting.])
+fi
+
 dnl
 dnl Low-level operating system interface.
 dnl
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 4365ca8..da2e509 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -20,6 +20,7 @@
 ;; along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (shepherd)
+  #:use-module (fibers)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 rdelim)   ;; Line-based I/O.
@@ -107,7 +108,11 @@ already ~a threads running, disabling 'signalfd' support")
         ((= signal SIGINT)
          (lambda _ (handle-SIGINT)))
         ((memv signal (list SIGTERM SIGHUP))
-         (lambda _ (stop root-service)))
+         (lambda _
+           (catch 'quit
+             (lambda ()
+               (stop root-service))
+             quit-exception-handler)))
         (else
          (const #f))))
 
@@ -366,12 +371,18 @@ already ~a threads running, disabling 'signalfd' support")
                   (sigaction signal (signal-handler signal)))
                 (delete SIGCHLD %precious-signals))
 
-      (run-daemon #:socket-file socket-file
-                  #:config-file config-file
-                  #:pid-file pid-file
-                  #:signal-port signal-port
-                  #:poll-services? poll-services?
-                  #:persistency persistency))))
+      ;; Run Fibers in such a way that it does not create any POSIX thread,
+      ;; because POSIX threads and 'fork' cannot be used together.
+      (run-fibers
+       (lambda ()
+         (run-daemon #:socket-file socket-file
+                     #:config-file config-file
+                     #:pid-file pid-file
+                     #:signal-port signal-port
+                     #:poll-services? poll-services?
+                     #:persistency persistency))
+       #:parallelism 1  ;don't create POSIX threads
+       #:hz 0))))       ;disable preemption, which would require POSIX threads
 
 ;; Start all of SERVICES, which is a list of canonical names (FIXME?),
 ;; but in a order where all dependencies are fulfilled before we
@@ -420,7 +431,9 @@ already ~a threads running, disabling 'signalfd' support")
       (begin
         (local-output (l10n "Rebooting..."))
         (reboot))
-      (quit)))
+      (begin
+        (local-output (l10n "Exiting."))
+        (primitive-exit 0))))              ;leave without going through Fibers
 
 (define (process-command command port)
   "Interpret COMMAND, a command sent by the user, represented as a