From 86fb460d6a35a7170611d81b9d7280f793f3d34b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 10:46:46 +0000 Subject: [PATCH] Simplify using the waiters queue in the resource pool Use a custom dequeue procedure that returns #f rather than raising an exception on an empty queue. --- knots/resource-pool.scm | 268 ++++++++++++++++++---------------------- 1 file changed, 120 insertions(+), 148 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 6e9c353..c233e29 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -101,6 +101,16 @@ start (cdr end)))) +(define (safe-deq q) + (if (null? (car q)) + #f + (let ((it (caar q)) + (next (cdar q))) + (if (null? next) + (set-cdr! q #f)) + (set-car! q next) + it))) + (define* (make-fixed-size-resource-pool resources #:key (delay-logger (const #f)) @@ -345,45 +355,35 @@ (set! checkout-failure-count (+ 1 checkout-failure-count))) - (if (q-empty? waiters) - (loop resources - (cons resource available) - waiters) - - (let ((current-internal-time - (get-internal-real-time))) - (with-exception-handler - (lambda (exn) - (if (eq? (exception-kind exn) 'q-empty) - (loop resources - (cons resource available) - waiters) - (raise-exception exn))) - (lambda () - (let waiter-loop ((waiter (deq! waiters))) - (match waiter - ((reply . timeout) - (if (and timeout - (< timeout current-internal-time)) - (waiter-loop (deq! waiters)) - (if timeout - (let ((reply-timeout - (/ (- timeout - current-internal-time) - internal-time-units-per-second))) - ;; Don't sleep in this fiber, so spawn a - ;; new fiber to handle handing over the - ;; resource, and returning it if there's - ;; a timeout - (spawn-fiber-for-checkout reply - reply-timeout - resource)) - (put-message reply (cons 'success - resource)))))))) - #:unwind? #t) - (loop resources - available - waiters)))) + (let ((current-internal-time + (get-internal-real-time))) + (let waiter-loop ((waiter (safe-deq waiters))) + (match waiter + (#f + (loop resources + (cons resource available) + waiters)) + ((reply . timeout) + (if (and timeout + (< timeout current-internal-time)) + (waiter-loop (safe-deq waiters)) + (if timeout + (let ((reply-timeout + (/ (- timeout + current-internal-time) + internal-time-units-per-second))) + ;; Don't sleep in this fiber, so spawn a + ;; new fiber to handle handing over the + ;; resource, and returning it if there's + ;; a timeout + (spawn-fiber-for-checkout reply + reply-timeout + resource)) + (put-message reply (cons 'success + resource)))) + (loop resources + available + waiters)))))) (('list-resources reply) (spawn-fiber @@ -770,51 +770,39 @@ (cons (get-internal-real-time) resources-last-used)))) - (if (q-empty? waiters) - (loop (cons resource resources) - (cons resource available) - waiters - (cons (get-internal-real-time) - resources-last-used)) - - (let ((current-internal-time - (get-internal-real-time))) - (with-exception-handler - (lambda (exn) - (if (eq? (exception-kind exn) 'q-empty) - (loop (cons resource resources) - (cons resource available) - waiters - (cons current-internal-time - resources-last-used)) - (raise-exception exn))) - (lambda () - (let waiter-loop ((waiter (deq! waiters))) - (match waiter - ((reply . timeout) - (if (and timeout - (< timeout current-internal-time)) - (waiter-loop (deq! waiters)) - (if timeout - (let ((reply-timeout - (/ (- timeout - current-internal-time) - internal-time-units-per-second))) - ;; Don't sleep in this fiber, so spawn a - ;; new fiber to handle handing over the - ;; resource, and returning it if there's - ;; a timeout - (spawn-fiber-for-checkout reply - reply-timeout - resource)) - (put-message reply (cons 'success - resource)))))))) - #:unwind? #t) - (loop (cons resource resources) - available - waiters - (cons current-internal-time - resources-last-used)))))) + (let ((current-internal-time + (get-internal-real-time))) + (let waiter-loop ((waiter (safe-deq waiters))) + (match waiter + (#f + (loop (cons resource resources) + (cons resource available) + waiters + (cons current-internal-time + resources-last-used))) + ((reply . timeout) + (if (and timeout + (< timeout current-internal-time)) + (waiter-loop (safe-deq waiters)) + (if timeout + (let ((reply-timeout + (/ (- timeout + current-internal-time) + internal-time-units-per-second))) + ;; Don't sleep in this fiber, so spawn a + ;; new fiber to handle handing over the + ;; resource, and returning it if there's + ;; a timeout + (spawn-fiber-for-checkout reply + reply-timeout + resource)) + (put-message reply (cons 'success + resource)))) + (loop (cons resource resources) + available + waiters + (cons current-internal-time + resources-last-used)))))))) (('checkout reply timeout-time max-waiters) (if (null? available) @@ -899,76 +887,60 @@ (set! checkout-failure-count (+ 1 checkout-failure-count))) - (if (q-empty? waiters) - (loop resources - (cons resource available) - waiters - (begin - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - (get-internal-real-time)) - resources-last-used)) - - (let ((current-internal-time - (get-internal-real-time))) - (with-exception-handler - (lambda (exn) - (if (eq? (exception-kind exn) 'q-empty) - (loop resources - (cons resource available) - waiters - (begin - (when (eq? return-type 'return) - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - current-internal-time)) - resources-last-used)) - (raise-exception exn))) - (lambda () - (let waiter-loop ((waiter (deq! waiters))) - (match waiter - ((reply . timeout) - (if (and timeout - (< timeout current-internal-time)) - (waiter-loop (deq! waiters)) - (if timeout - (let ((reply-timeout - (/ (- timeout - current-internal-time) - internal-time-units-per-second))) - ;; Don't sleep in this fiber, so spawn a - ;; new fiber to handle handing over the - ;; resource, and returning it if there's - ;; a timeout - (spawn-fiber-for-checkout reply - reply-timeout - resource)) - (put-message reply (cons 'success - resource)))))))) - #:unwind? #t) - (loop resources - available - waiters - (begin - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - current-internal-time) - resources-last-used))))) + (let ((current-internal-time + (get-internal-real-time)) + (resource-index + (list-index (lambda (x) + (eq? x resource)) + resources))) + (let waiter-loop ((waiter (safe-deq waiters))) + (match waiter + (#f + (loop resources + (cons resource available) + waiters + (begin + (when (eq? return-type 'return) + (list-set! + resources-last-used + resource-index + current-internal-time)) + resources-last-used))) + ((reply . timeout) + (if (and timeout + (< timeout current-internal-time)) + (waiter-loop (safe-deq waiters)) + (if timeout + (let ((reply-timeout + (/ (- timeout + current-internal-time) + internal-time-units-per-second))) + ;; Don't sleep in this fiber, so spawn a + ;; new fiber to handle handing over the + ;; resource, and returning it if there's + ;; a timeout + (spawn-fiber-for-checkout reply + reply-timeout + resource)) + (put-message reply (cons 'success + resource)))) + (loop resources + available + waiters + (begin + (list-set! + resources-last-used + resource-index + current-internal-time) + resources-last-used))))))) (('remove resource) (let ((index (list-index (lambda (x) (eq? x resource)) resources))) + + (loop (if index (remove-at-index! resources index) (begin