[shepherd] 01/08: shepherd: Replace 'primitive-load' with a Scheme implementation.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 567360b3dc9918d6d24bd023de0edb2df4f73409
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Mar 24 23:15:47 2023 +0100

    shepherd: Replace 'primitive-load' with a Scheme implementation.
    
    As of Guile 3.0.9, 'primitive-load' is implemented in C, which makes it
    a continuation barrier.  This patch addresses that.
    
    This is necessary because 'guix system reconfigure' does something like
    "herd eval root '(map primitive-load files)'" where each file might
    evaluate code that needs to suspend the current fiber.
    
    * modules/shepherd.scm (main): Replace 'primitive-load' with
    'primitive-load*'.
    * modules/shepherd/support.scm (primitive-load*): Export.
    * tests/eval-load.sh: New file.
    * Makefile.am (TESTS): Add it.
---
 Makefile.am                  |  1 +
 modules/shepherd.scm         | 13 +++++++---
 modules/shepherd/support.scm |  1 +
 tests/eval-load.sh           | 61 ++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 72 insertions(+), 4 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 3a6d622..d3f7a82 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -261,6 +261,7 @@ TESTS =                                             \
   tests/signals.sh                             \
   tests/system-star.sh                         \
   tests/close-on-exec.sh                       \
+  tests/eval-load.sh                           \
   tests/services/monitoring.sh                 \
   tests/services/repl.sh
 
diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 29225e2..0b4728c 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -393,14 +393,18 @@ already ~a threads running, disabling 'signalfd' support")
                (lambda ()
                  (with-process-monitor
                    ;; Replace the default 'system*' binding with one that
-                   ;; cooperates instead of blocking on 'waitpid'.
+                   ;; cooperates instead of blocking on 'waitpid'.  Replace
+                   ;; 'primitive-load' (in C as of 3.0.9) with one that does
+                   ;; not introduce a continuation barrier.
                    (let ((real-system* system*)
-                         (real-system  system))
+                         (real-system  system)
+                         (real-primitive-load primitive-load))
                      (set! system* (lambda command
                                      (spawn-command command)))
                      (set! system spawn-shell-command)
+                     (set! primitive-load primitive-load*)
 
-                     ;; Restore 'system*' after fork.
+                     ;; Restore those bindings after fork.
                      (set! primitive-fork
                            (let ((real-fork primitive-fork))
                              (lambda ()
@@ -408,7 +412,8 @@ already ~a threads running, disabling 'signalfd' support")
                                  (when (zero? result)
                                    (set! primitive-fork real-fork)
                                    (set! system* real-system*)
-                                   (set! system real-system))
+                                   (set! system real-system)
+                                   (set! primitive-load real-primitive-load))
                                  result)))))
 
                    (run-daemon #:socket-file socket-file
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 96c1c70..45dfd1f 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -54,6 +54,7 @@
             default-socket-file
             %system-socket-file
 
+            primitive-load*
             load-in-user-module
             eval-in-user-module
 
diff --git a/tests/eval-load.sh b/tests/eval-load.sh
new file mode 100755
index 0000000..c273797
--- /dev/null
+++ b/tests/eval-load.sh
@@ -0,0 +1,61 @@
+# GNU Shepherd --- Check whether config can be loaded with 'primitive-load'
+# Copyright © 2023 Ludovic Courtès <ludo@gnu.org>
+#
+# This file is part of the GNU Shepherd.
+#
+# The GNU Shepherd is free software; you can redistribute it and/or modify it
+# under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or (at
+# your option) any later version.
+#
+# The GNU Shepherd is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.
+
+shepherd --version
+herd --version
+
+socket="t-socket-$$"
+conf="t-conf-$$"
+log="t-log-$$"
+pid="t-pid-$$"
+
+herd="herd -s $socket"
+
+trap "rm -f $socket $conf $log;
+      test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+
+cat > "$conf" <<EOF
+(register-services
+ (make <service>
+   #:provides '(a)
+   #:start (const #t)
+   #:respawn? #f)
+ (make <service>
+   #:provides '(b)
+   #:start (const #t)
+   #:respawn? #f))
+EOF
+
+rm -f "$pid" "$stamp" "$socket"
+shepherd -I -s "$socket" -c /dev/null --pid="$pid" --log="$log" &
+
+while ! test -f "$pid"; do sleep 0.5 ; done
+
+$herd status
+
+# 'guix system reconfigure' does something similar to what's shown below.  As
+# of Guile 3.0.9, 'primitive-load' is in C and thus introduces a continuation
+# barrier, which makes it unsuitable in this context.  Check that we're not
+# hitting a continuation barrier.
+$herd eval root '(primitive-load "'$conf'")'
+
+$herd status
+$herd status | grep ' - a'
+$herd status | grep ' - b'
+$herd start a
+$herd start b