[shepherd] 07/13: service: 'read-pid-file' uses (@ (guile) sleep) when it's not suspendable.

[Ludovic Courtès]

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

commit af3c8673fedc001e55560b8a0f94b1e422bed3bb
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Mar 21 22:50:32 2022 +0100

    service: 'read-pid-file' uses (@ (guile) sleep) when it's not suspendable.
    
    * modules/shepherd/service.scm (read-pid-file)[sleep*]: New procedure.
    [try-again]: Use it instead of 'sleep'.
    * tests/pid-file.sh: Call 'start' from the config file top-level.  Check
    that 'test-works' is running right at the beginning.
    * configure.ac: Check for (fibers scheduler).
---
 configure.ac                 |  5 +++++
 modules/shepherd/service.scm | 17 ++++++++++++++++-
 tests/pid-file.sh            | 13 ++++++++++++-
 3 files changed, 33 insertions(+), 2 deletions(-)

diff --git a/configure.ac b/configure.ac
index 1b9676c..40598ec 100644
--- a/configure.ac
+++ b/configure.ac
@@ -39,6 +39,11 @@ if test "x$have_fibers" != "xyes"; then
   AC_MSG_ERROR([Fibers is missing; please install it.])
 fi
 
+GUILE_MODULE_AVAILABLE([have_recent_fibers], [(fibers scheduler)])
+if test "x$have_recent_fibers" != "xyes"; then
+  AC_MSG_ERROR([Fibers appears to be too old; please install version 1.1.0 or 
later.])
+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],
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 13f1a77..71e06b8 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -25,6 +25,7 @@
 
 (define-module (shepherd service)
   #:use-module (fibers)
+  #:use-module ((fibers scheduler) #:select (yield-current-task))
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -736,12 +737,26 @@ be used if FILE might contain a PID from another PID 
namespace--i.e., the
 daemon writing FILE is running in a separate PID namespace."
   (define start (current-time))
 
+  (define (sleep* n)
+    ;; In general we want to use (@ (fibers) sleep) to yield to the scheduler.
+    ;; However, this code might be non-suspendable--e.g., if the user calls
+    ;; the 'start' method right from their config file, which is loaded with
+    ;; 'primitive-load', which is a continuation barrier.  Thus, this variant
+    ;; checks whether it can suspend and picks the right 'sleep'.
+    (if (yield-current-task)
+        (begin
+          (set! sleep* (@ (fibers) sleep))
+          (sleep n))
+        (begin
+          (set! sleep* (@ (guile) sleep))
+          ((@ (guile) sleep) n))))
+
   (let loop ()
     (define (try-again)
       (and (< (current-time) (+ start max-delay))
            (begin
              ;; FILE does not exist yet, so wait and try again.
-             (sleep 1)                          ;yield to the Fibers scheduler
+             (sleep* 1)                         ;yield to the Fibers scheduler
              (loop))))
 
     (catch 'system-error
diff --git a/tests/pid-file.sh b/tests/pid-file.sh
index db11abd..5fb0f2b 100644
--- a/tests/pid-file.sh
+++ b/tests/pid-file.sh
@@ -1,5 +1,5 @@
 # GNU Shepherd --- Test the #:pid-file option of 'make-forkexec-constructor'.
-# Copyright © 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2016, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 #
 # This file is part of the GNU Shepherd.
 #
@@ -92,6 +92,10 @@ cat > "$conf"<<EOF
                                       #:pid-file-timeout 6)
    #:stop  (make-kill-destructor)
    #:respawn? #f))
+
+;; Start it upfront.  This ensures the whole machinery works even
+;; when called in a non-suspendable context (continuation barrier).
+(start 'test-works)
 EOF
 
 rm -f "$pid"
@@ -102,6 +106,13 @@ while ! test -f "$pid" ; do sleep 0.3 ; done
 
 shepherd_pid="`cat $pid`"
 
+# This service should already be running.
+$herd status test-works | grep started
+test -f "$service_pid"
+kill -0 `cat "$service_pid"`
+$herd stop test-works
+rm "$service_pid"
+
 # The service is expected to fail to start.
 if $herd start test
 then false; else true; fi