Make with-fibers-port-timeouts work without fibers

As it's easy to try and use code in both contexts, so try and support
that.

1 files changed, 47 insertions, 17 deletions

diff --git a/nar-herder/utils.scm b/nar-herder/utils.scm
index e9866aa..92584d9 100644
--- a/nar-herder/utils.scm
+++ b/nar-herder/utils.scm
@@ -32,7 +32,8 @@
   #:use-module (ice-9 exceptions)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 suspendable-ports)
-  #:use-module ((ice-9 ports internal) #:select (port-read-wait-fd
+  #:use-module ((ice-9 ports internal) #:select (port-poll
+                                                 port-read-wait-fd
                                                  port-write-wait-fd))
   #:use-module (web uri)
   #:use-module (web http)
@@ -772,25 +773,54 @@ If already in the worker thread, call PROC immediately."
                                     #:key timeout
                                     (read-timeout timeout)
                                     (write-timeout timeout))
+  (define (no-fibers-wait port mode timeout)
+    (define poll-timeout-ms 200)
+
+    ;; When the GC runs, it restarts the poll syscall, but the timeout
+    ;; remains unchanged! When the timeout is longer than the time
+    ;; between the syscall restarting, I think this renders the
+    ;; timeout useless. Therefore, this code uses a short timeout, and
+    ;; repeatedly calls poll while watching the clock to see if it has
+    ;; timed out overall.
+    (let ((timeout-internal
+           (+ (get-internal-real-time)
+              (* internal-time-units-per-second
+                 (/ timeout 1000)))))
+      (let loop ((poll-value
+                  (port-poll port mode poll-timeout-ms)))
+        (if (= poll-value 0)
+            (if (> (get-internal-real-time)
+                   timeout-internal)
+                (raise-exception
+                 (if (string=? mode "r")
+                     (make-port-read-timeout-error port)
+                     (make-port-write-timeout-error port)))
+                (loop (port-poll port mode poll-timeout-ms)))
+            poll-value))))
+
   (parameterize
       ((current-read-waiter
         (lambda (port)
-          (perform-operation
-           (choice-operation
-            (wait-until-port-readable-operation port)
-            (wrap-operation
-             (sleep-operation read-timeout)
-             (lambda ()
-               (raise-exception
-                (make-port-read-timeout-error thunk port))))))))
+          (if (current-scheduler)
+              (perform-operation
+               (choice-operation
+                (wait-until-port-readable-operation port)
+                (wrap-operation
+                 (sleep-operation read-timeout)
+                 (lambda ()
+                   (raise-exception
+                    (make-port-read-timeout-error thunk port))))))
+              (no-fibers-wait port "r" read-timeout))))
        (current-write-waiter
         (lambda (port)
-          (perform-operation
-           (choice-operation
-            (wait-until-port-writable-operation port)
-            (wrap-operation
-             (sleep-operation write-timeout)
-             (lambda ()
-               (raise-exception
-                (make-port-write-timeout-error thunk port)))))))))
+          (if (current-scheduler)
+              (perform-operation
+               (choice-operation
+                (wait-until-port-writable-operation port)
+                (wrap-operation
+                 (sleep-operation write-timeout)
+                 (lambda ()
+                   (raise-exception
+                    (make-port-write-timeout-error thunk port))))))
+              (no-fibers-wait port "w" write-timeout)))))
     (thunk)))