diff options
| -rw-r--r-- | nar-herder/utils.scm | 64 |
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))) |