Attempt to make with-port-timeouts handle the GC restarting poll

From what I'm seeing in strace, I think the GC is breaking the timeout
behaviour by restarting the syscall, these changes should work around that
behaviour.

1 files changed, 25 insertions, 6 deletions

diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm
index e16b41a..0d2e39d 100644
--- a/guix-build-coordinator/utils.scm
+++ b/guix-build-coordinator/utils.scm
@@ -309,17 +309,36 @@ upcoming chunk."
   (record-predicate &port-timeout))
 
 (define* (with-port-timeouts thunk #:key (timeout (* 120 1000)))
+
+  ;; 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.
+  (define poll-timeout-ms 200)
+
+  (define (wait port mode)
+    (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
+                 (make-port-timeout-error))
+                (loop (port-poll port mode poll-timeout-ms)))
+            poll-value))))
+
   (parameterize
       ((current-read-waiter
         (lambda (port)
-          (when (= (port-poll port "r" timeout) 0)
-            (raise-exception
-             (make-port-timeout-error)))))
+          (wait port "r")))
        (current-write-waiter
         (lambda (port)
-          (when (= (port-poll port "w" timeout) 0)
-            (raise-exception
-             (make-port-timeout-error))))))
+          (wait port "w"))))
     (thunk)))
 
 (define* (set-store-connection-timeout store #:key (timeout 120))