[no subject]

[Ludovic Courtès]

branch: master
commit 1d49240cc19de45e6ccfa1bfd58bf0f205b79804
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue May 9 11:40:48 2023 +0200

    Require Fibers >= 1.1.0.
    
    Fixes <https://issues.guix.gnu.org/63389>.
    
    We were hitting an old bug from Fibers 1.0.x.
    
    * configure.ac: Check for (fibers scheduler).
    * src/cuirass/base.scm <top level>: Remove workaround for Fibers <= 1.0.0.
    * src/cuirass/utils.scm (make-worker-thread-channel): Do not
    parameterize 'current-fiber'.
    (%non-blocking): Likewise.
    (call-with-worker-thread): Remove references to 'current-fiber'.
    * src/cuirass/watchdog.scm (start-watchdog): Annihilate.
---
 configure.ac             |  6 +++++
 src/cuirass/base.scm     | 10 -------
 src/cuirass/utils.scm    | 68 +++++++++++++++++++++++-------------------------
 src/cuirass/watchdog.scm |  8 ++++--
 4 files changed, 45 insertions(+), 47 deletions(-)

diff --git a/configure.ac b/configure.ac
index b36b4dc..3bb8553 100644
--- a/configure.ac
+++ b/configure.ac
@@ -48,6 +48,12 @@ AS_IF([test -z "$ac_cv_path_GUILD"],
 
 GUILE_MODULE_REQUIRED([avahi])
 GUILE_MODULE_REQUIRED([fibers])
+
+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
+
 GUILE_MODULE_REQUIRED([guix])
 GUILE_MODULE_REQUIRED([guix git])
 GUILE_MODULE_REQUIRED([guix config])
diff --git a/src/cuirass/base.scm b/src/cuirass/base.scm
index ff1cc2c..668a97d 100644
--- a/src/cuirass/base.scm
+++ b/src/cuirass/base.scm
@@ -197,16 +197,6 @@ any."
     (fcntl port F_SETFL (logior O_NONBLOCK flags))
     port))
 
-(match (resolve-module '(fibers internal) #t #f #:ensure #f)
-  (#f #t)                                         ;Fibers > 1.0.0
-  ((? module? internal)                           ;Fibers <= 1.0.0
-   ;; Work around <https://github.com/wingo/fibers/issues/19>.
-   ;; This monkey-patching aims to replace EPOLLERR occurrences in
-   ;; 'schedule-fibers-for-fd' with EPOLLERR | EPOLLHUP.
-   (module-define! internal 'EPOLLERR
-                   (logior (@ (fibers epoll) EPOLLERR)
-                           (@ (fibers epoll) EPOLLHUP)))))
-
 (define %cuirass-state-directory
   ;; Directory where state files are stored, usually "/var".
   (make-parameter (or (getenv "CUIRASS_STATE_DIRECTORY")
diff --git a/src/cuirass/utils.scm b/src/cuirass/utils.scm
index ee5245c..6bf0983 100644
--- a/src/cuirass/utils.scm
+++ b/src/cuirass/utils.scm
@@ -98,31 +98,30 @@ value."
                                      #:key (parallelism 1))
   "Return a channel used to offload work to a dedicated thread.  ARGS are the
 arguments of the worker thread procedure."
-  (parameterize (((@@ (fibers internal) current-fiber) #f))
-    (let ((channel (make-channel)))
-      (for-each
-       (lambda _
-         (let ((args (initializer)))
-           (call-with-new-thread
-            (parameterize ((current-read-waiter (lambda (port)
-                                                  (port-poll port "r")))
-                           (current-write-waiter (lambda (port)
-                                                   (port-poll port "w"))))
-              (lambda ()
-                (parameterize ((%worker-thread-args args))
-                  (let loop ()
-                    (match (get-message channel)
-                      (((? channel? reply) . (? procedure? proc))
-                       (put-message
-                        reply
-                        (catch #t
-                          (lambda ()
-                            (apply proc args))
-                          (lambda (key . args)
-                            (cons* 'worker-thread-error key args))))))
-                    (loop))))))))
-       (iota parallelism))
-      channel)))
+  (let ((channel (make-channel)))
+    (for-each
+     (lambda _
+       (let ((args (initializer)))
+         (call-with-new-thread
+          (parameterize ((current-read-waiter (lambda (port)
+                                                (port-poll port "r")))
+                         (current-write-waiter (lambda (port)
+                                                 (port-poll port "w"))))
+            (lambda ()
+              (parameterize ((%worker-thread-args args))
+                (let loop ()
+                  (match (get-message channel)
+                    (((? channel? reply) . (? procedure? proc))
+                     (put-message
+                      reply
+                      (catch #t
+                        (lambda ()
+                          (apply proc args))
+                        (lambda (key . args)
+                          (cons* 'worker-thread-error key args))))))
+                  (loop))))))))
+     (iota parallelism))
+    channel))
 
 (define* (with-timeout op #:key (seconds 0.05) (wrap values))
   "Return an operation that succeeds if the given OP succeeds or if SECONDS
@@ -207,12 +206,12 @@ to."
         (apply proc args)
         (let* ((reply (make-channel))
                (message (cons reply proc)))
-          (if (and send-timeout (current-fiber))
+          (if send-timeout
               (put-message-with-timeout channel message
                                         #:seconds send-timeout
                                         #:timeout-proc send-timeout-proc)
               (put-message channel message))
-          (match (if (and receive-timeout (current-fiber))
+          (match (if receive-timeout
                      (get-message-with-timeout reply
                                                #:seconds
                                                receive-timeout
@@ -233,14 +232,13 @@ VARS... are bound to the arguments of the worker thread."
   (let ((channel (make-channel)))
     (call-with-new-thread
      (lambda ()
-       (parameterize (((@@ (fibers internal) current-fiber) #f))
-         (catch #t
-           (lambda ()
-             (call-with-values thunk
-               (lambda values
-                 (put-message channel `(values ,@values)))))
-           (lambda args
-             (put-message channel `(exception ,@args)))))))
+       (catch #t
+         (lambda ()
+           (call-with-values thunk
+             (lambda values
+               (put-message channel `(values ,@values)))))
+         (lambda args
+           (put-message channel `(exception ,@args))))))
 
     (match (get-message channel)
       (('values . results)
diff --git a/src/cuirass/watchdog.scm b/src/cuirass/watchdog.scm
index 4b677e3..62a6b64 100644
--- a/src/cuirass/watchdog.scm
+++ b/src/cuirass/watchdog.scm
@@ -21,7 +21,7 @@
   #:use-module (cuirass utils)
   #:use-module (fibers)
   #:use-module (fibers channels)
-  #:use-module (fibers internal)
+  ;; #:use-module (fibers internal)
   #:use-module (fibers operations)
   #:use-module (ice-9 match)
   #:use-module (ice-9 threads)
@@ -66,7 +66,11 @@ printed."
             cur-time)
           last-check)))
 
-  (let ((watchdog-channel (make-channel)))
+  ;; FIXME: Fibers 1.1.0 removed 'fold-all-schedulers' and it's not clear how
+  ;; to implement this watchdog using the 1.1.0 API.
+  *unspecified*
+
+  #;(let ((watchdog-channel (make-channel)))
     (parameterize (((@@ (fibers internal) current-fiber) #f))
       (call-with-new-thread
        (lambda ()