From 7c2c6f2de9e4ebeab8de78077cbb2a0b7c585e6b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 24 Jun 2025 11:59:22 +0200 Subject: [PATCH 01/78] WIP --- .forgejo/workflows/demo.yaml | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 .forgejo/workflows/demo.yaml diff --git a/.forgejo/workflows/demo.yaml b/.forgejo/workflows/demo.yaml new file mode 100644 index 0000000..935846f --- /dev/null +++ b/.forgejo/workflows/demo.yaml @@ -0,0 +1,13 @@ +on: + push: + branches: + - actions-test +jobs: + test: + runs-on: host + steps: + - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git knots-trunk + - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git --branch=pages knots-pages + - run: | + cd knots-trunk + guix shell -D -f guix-dev.scm -- documenta api knots From 7f5f05ef2b1d62ba0bc0b1a37986c3d4bb2a5f99 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 24 Jun 2025 20:56:56 +0200 Subject: [PATCH 02/78] WIP --- .forgejo/workflows/demo.yaml | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/.forgejo/workflows/demo.yaml b/.forgejo/workflows/demo.yaml index 935846f..87ff5f8 100644 --- a/.forgejo/workflows/demo.yaml +++ b/.forgejo/workflows/demo.yaml @@ -11,3 +11,12 @@ jobs: - run: | cd knots-trunk guix shell -D -f guix-dev.scm -- documenta api knots + guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -o pages/index.html doc/index.texi + + - run: | + cd knots-pages + git add . + git config user.email <> + git config user.name "Automatic website updater" + git commit -m "Automatic website update" + git push From 81dd3370e67c159175ecad6214398f57da0b25e8 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 24 Jun 2025 20:59:57 +0200 Subject: [PATCH 03/78] WIP --- .forgejo/workflows/demo.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.forgejo/workflows/demo.yaml b/.forgejo/workflows/demo.yaml index 87ff5f8..34fea34 100644 --- a/.forgejo/workflows/demo.yaml +++ b/.forgejo/workflows/demo.yaml @@ -16,7 +16,7 @@ jobs: - run: | cd knots-pages git add . - git config user.email <> + git config user.email "" git config user.name "Automatic website updater" git commit -m "Automatic website update" git push From eadfa53b36cbd3d78daacfacf0499efef73f6624 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 24 Jun 2025 21:00:54 +0200 Subject: [PATCH 04/78] WIP --- .forgejo/workflows/demo.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.forgejo/workflows/demo.yaml b/.forgejo/workflows/demo.yaml index 34fea34..8fb0304 100644 --- a/.forgejo/workflows/demo.yaml +++ b/.forgejo/workflows/demo.yaml @@ -11,7 +11,7 @@ jobs: - run: | cd knots-trunk guix shell -D -f guix-dev.scm -- documenta api knots - guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -o pages/index.html doc/index.texi + guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -o ../knots-pages/index.html doc/index.texi - run: | cd knots-pages From 003c5aa6b0078a9fa97ca54537e3798d911a77df Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 24 Jun 2025 21:03:34 +0200 Subject: [PATCH 05/78] WIP --- .forgejo/workflows/demo.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.forgejo/workflows/demo.yaml b/.forgejo/workflows/demo.yaml index 8fb0304..c3f4156 100644 --- a/.forgejo/workflows/demo.yaml +++ b/.forgejo/workflows/demo.yaml @@ -11,7 +11,7 @@ jobs: - run: | cd knots-trunk guix shell -D -f guix-dev.scm -- documenta api knots - guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -o ../knots-pages/index.html doc/index.texi + guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -c SHOW_TITLE=true -o ../knots-pages/index.html doc/index.texi - run: | cd knots-pages From 2e25c3b074ff218498631108559cdcb014e289c4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 24 Jun 2025 21:07:29 +0200 Subject: [PATCH 06/78] Add workflow for building the website --- .forgejo/workflows/build-website.yaml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 .forgejo/workflows/build-website.yaml diff --git a/.forgejo/workflows/build-website.yaml b/.forgejo/workflows/build-website.yaml new file mode 100644 index 0000000..ac6261f --- /dev/null +++ b/.forgejo/workflows/build-website.yaml @@ -0,0 +1,22 @@ +on: + push: + branches: + - trunk +jobs: + test: + runs-on: host + steps: + - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git knots-trunk + - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git --branch=pages knots-pages + - run: | + cd knots-trunk + guix shell -D -f guix-dev.scm -- documenta api knots + guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -c SHOW_TITLE=true -o ../knots-pages/index.html doc/index.texi + + - run: | + cd knots-pages + git add . + git config user.email "" + git config user.name "Automatic website updater" + git commit -m "Automatic website update" + git push From edf62414eebb661729b6b6f564c6ce7a1be27d07 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 24 Jun 2025 21:14:52 +0200 Subject: [PATCH 07/78] Avoid workflow erroring if there's nothing to change --- .forgejo/workflows/build-website.yaml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/.forgejo/workflows/build-website.yaml b/.forgejo/workflows/build-website.yaml index ac6261f..d859b76 100644 --- a/.forgejo/workflows/build-website.yaml +++ b/.forgejo/workflows/build-website.yaml @@ -16,7 +16,11 @@ jobs: - run: | cd knots-pages git add . - git config user.email "" - git config user.name "Automatic website updater" - git commit -m "Automatic website update" - git push + if [[ -z "$(git status -s)" ]]; then + echo "Nothing to push" + else + git config user.email "" + git config user.name "Automatic website updater" + git commit -m "Automatic website update" + git push + fi From ab5411da423043f2b8a0e27c7507f8d9c34686a2 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 25 Jun 2025 18:46:46 +0200 Subject: [PATCH 08/78] Make resource pool changes and add parallelism limiter This was motivated by trying to allow for completely cleaning up resource pools, which involved removing their use of fiberize which currently has no destroy mechanism. As part of this, there's a new parallelism limiter mechanism using resource pools rather than fibers, and also a fixed size resource pool. The tests now drain? and destroy the resource pools to check cleaning up. --- knots/parallelism.scm | 38 ++- knots/resource-pool.scm | 719 ++++++++++++++++++++++++++++++++-------- tests.scm | 6 +- tests/parallelism.scm | 12 + tests/resource-pool.scm | 47 ++- 5 files changed, 669 insertions(+), 153 deletions(-) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index f8b2b8b..9e80f5b 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -20,6 +20,8 @@ (define-module (knots parallelism) #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) #:use-module (ice-9 control) #:use-module (ice-9 exceptions) @@ -27,6 +29,7 @@ #:use-module (fibers channels) #:use-module (fibers operations) #:use-module (knots) + #:use-module (knots resource-pool) #:export (fibers-batch-map fibers-map @@ -38,7 +41,13 @@ fibers-parallel fibers-let - fiberize)) + fiberize + + make-parallelism-limiter + parallelism-limiter? + destroy-parallelism-limiter + call-with-parallelism-limiter + with-parallelism-limiter)) (define (defer-to-parallel-fiber thunk) (let ((reply (make-channel))) @@ -287,3 +296,30 @@ (('result . vals) (apply values vals)) (('exception exn) (raise-exception exn)))))) + +(define-record-type + (make-parallelism-limiter-record resource-pool) + parallelism-limiter? + (resource-pool parallelism-limiter-resource-pool)) + +(define* (make-parallelism-limiter limit #:key (name "unnamed")) + (make-parallelism-limiter-record + (make-fixed-size-resource-pool + (iota limit) + #:name name))) + +(define (destroy-parallelism-limiter parallelism-limiter) + (destroy-resource-pool + (parallelism-limiter-resource-pool + parallelism-limiter))) + +(define* (call-with-parallelism-limiter parallelism-limiter thunk) + (call-with-resource-from-pool + (parallelism-limiter-resource-pool parallelism-limiter) + (lambda _ + (thunk)))) + +(define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...) + (call-with-parallelism-limiter + parallelism-limiter + (lambda () exp ...))) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index da52051..71c378c 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -32,9 +32,10 @@ #:use-module (fibers conditions) #:use-module (knots) #:use-module (knots parallelism) - #:export (resource-pool? - + #:export (make-fixed-size-resource-pool make-resource-pool + + resource-pool? resource-pool-name resource-pool-channel resource-pool-configuration @@ -91,6 +92,429 @@ (resource-pool-name resource-pool)) port))) +(define (remove-at-index! lst i) + (let ((start + end + (split-at! lst i))) + (append + start + (cdr end)))) + +(define* (make-fixed-size-resource-pool resources + #:key + (delay-logger (const #f)) + (duration-logger (const #f)) + destructor + scheduler + (name "unnamed") + default-checkout-timeout + default-max-waiters) + (define channel (make-channel)) + (define destroy-condition + (make-condition)) + + (define pool + (make-resource-pool-record + name + channel + destroy-condition + `((delay-logger . ,delay-logger) + (duration-logger . ,duration-logger) + (destructor . ,destructor) + (scheduler . ,scheduler) + (name . ,name) + (default-checkout-timeout . ,default-checkout-timeout) + (default-max-waiters . ,default-max-waiters)))) + + (define checkout-failure-count 0) + + (define (spawn-fiber-to-destroy-resource resource) + (spawn-fiber + (lambda () + (let loop () + (let ((success? + (with-exception-handler + (lambda _ #f) + (lambda () + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception running resource pool destructor (~A): ~A\n" + name + destructor) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (start-stack #t (destructor resource)) + #t))) + #:unwind? #t))) + + (if success? + (put-message channel + (list 'remove resource)) + (begin + (sleep 5) + + (loop)))))))) + + (define (spawn-fiber-for-checkout reply-channel + reply-timeout + resource) + (spawn-fiber + (lambda () + (let ((checkout-success? + (perform-operation + (choice-operation + (wrap-operation + (put-operation reply-channel + (cons 'success resource)) + (const #t)) + (wrap-operation (sleep-operation + reply-timeout) + (const #f)))))) + (unless checkout-success? + (put-message + channel + (list 'return-failed-checkout resource))))))) + + (define (destroy-loop resources) + (let loop ((resources resources)) + (match (get-message channel) + (('checkout reply timeout-time max-waiters) + (spawn-fiber + (lambda () + (let ((op + (put-operation + reply + (cons 'resource-pool-destroyed + #f)))) + (perform-operation + (if timeout-time + (choice-operation + op + (wrap-operation + (sleep-operation + (/ (- timeout-time + (get-internal-real-time)) + internal-time-units-per-second)) + (const #f))) + op))))) + (loop resources)) + (((and (or 'return + 'return-failed-checkout + 'remove) + return-type) + resource) + (when (and (not (eq? return-type 'remove)) + destructor) + (spawn-fiber-to-destroy-resource resource)) + + (let ((index + (list-index (lambda (x) + (eq? x resource)) + resources))) + (let ((new-resources + (if index + (remove-at-index! resources index) + (begin + (simple-format + (current-error-port) + "resource pool error: unable to remove ~A\n" + resource) + resources)))) + (if (null? new-resources) + (begin + (signal-condition! destroy-condition) + + ;; No loop + *unspecified*) + (loop new-resources))))) + + (('stats reply timeout-time) + (let ((stats + `((resources . ,(length resources)) + (available . 0) + (waiters . 0) + (checkout-failure-count . ,checkout-failure-count)))) + + (spawn-fiber + (lambda () + (let ((op + (put-operation reply stats))) + (perform-operation + (if timeout-time + (choice-operation + op + (sleep-operation + (/ (- timeout-time + (get-internal-real-time)) + internal-time-units-per-second))) + op)))))) + + (loop resources)) + + (('destroy reply) + (loop resources)) + (unknown + (simple-format + (current-error-port) + "unrecognised message to ~A resource pool channel: ~A\n" + name + unknown) + (loop resources))))) + + (define (main-loop) + (let loop ((resources resources) + (available resources) + (waiters '())) + + (match (get-message channel) + (('checkout reply timeout-time max-waiters) + (if (null? available) + (let ((waiters-count + (length waiters))) + (if (and max-waiters + (>= waiters-count + max-waiters)) + (begin + (spawn-fiber + (lambda () + (let ((op + (put-operation + reply + (cons 'too-many-waiters + waiters-count)))) + (perform-operation + (if timeout-time + (choice-operation + op + (wrap-operation + (sleep-operation + (/ (- timeout-time + (get-internal-real-time)) + internal-time-units-per-second)) + (const #f))) + op))))) + (loop resources + available + waiters)) + (loop resources + available + (cons (cons reply timeout-time) + waiters)))) + + (if timeout-time + (let ((current-internal-time + (get-internal-real-time))) + ;; If this client is still waiting + (if (> timeout-time + current-internal-time) + (let ((reply-timeout + (/ (- timeout-time + 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 + (car available)) + (loop resources + (cdr available) + waiters)) + (loop resources + available + waiters))) + (begin + (put-message reply (cons 'success + (car available))) + + (loop resources + (cdr available) + waiters))))) + + (((and (or 'return + 'return-failed-checkout) + return-type) + resource) + + (when (eq? 'return-failed-checkout + return-type) + (set! checkout-failure-count + (+ 1 checkout-failure-count))) + + (if (null? waiters) + (loop resources + (cons resource available) + waiters) + + (let* ((current-internal-time (get-internal-real-time)) + (alive-waiters + dead-waiters + (partition! + (match-lambda + ((reply . timeout) + (or (not timeout) + (> timeout current-internal-time)))) + waiters))) + (if (null? alive-waiters) + (loop resources + (cons resource available) + '()) + (match (last alive-waiters) + ((waiter-channel . waiter-timeout) + (if waiter-timeout + (let ((reply-timeout + (/ (- waiter-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 waiter-channel + reply-timeout + resource)) + (put-message waiter-channel (cons 'success + resource))) + + (loop resources + available + (drop-right! alive-waiters 1)))))))) + + (('list-resources reply) + (spawn-fiber + (lambda () + (put-message reply (list-copy resources)))) + + (loop resources + available + waiters)) + + (('stats reply timeout-time) + (let ((stats + `((resources . ,(length resources)) + (available . ,(length available)) + (waiters . ,(length waiters)) + (checkout-failure-count . ,checkout-failure-count)))) + + (spawn-fiber + (lambda () + (let ((op + (put-operation reply stats))) + (perform-operation + (if timeout-time + (choice-operation + op + (sleep-operation + (/ (- timeout-time + (get-internal-real-time)) + internal-time-units-per-second))) + op)))))) + + (loop resources + available + waiters)) + + (('destroy) + (if (and (null? resources) + (null? waiters)) + (signal-condition! + destroy-condition) + + (let ((current-internal-time (get-internal-real-time))) + (for-each + (match-lambda + ((reply . timeout) + (when (or (not timeout) + (> timeout current-internal-time)) + (spawn-fiber + (lambda () + (let ((op + (put-operation + reply + (cons 'resource-pool-destroyed + #f)))) + (perform-operation + (if timeout + (choice-operation + op + (wrap-operation + (sleep-operation + (/ (- timeout + (get-internal-real-time)) + internal-time-units-per-second)) + (const #f))) + op)))))))) + waiters) + + (if destructor + (begin + (for-each + (lambda (resource) + (spawn-fiber-to-destroy-resource resource)) + available) + (destroy-loop resources)) + (let dl ((resources resources) + (available available)) + (if (null? available) + (if (null? resources) + (signal-condition! + destroy-condition) + (destroy-loop resources)) + (let ((index + (list-index (lambda (x) + (eq? x (car available))) + resources))) + (dl (remove-at-index! resources index) + (cdr available))))))))) + + (unknown + (simple-format + (current-error-port) + "unrecognised message to ~A resource pool channel: ~A\n" + name + unknown) + (loop resources + available + waiters))))) + + (spawn-fiber + (lambda () + (with-exception-handler + (lambda (exn) + #f) + (lambda () + (with-exception-handler + (lambda (exn) + (let* ((stack (make-stack #t)) + (error-string + (call-with-output-string + (lambda (port) + (display-backtrace stack port 3) + (simple-format + port + "exception in the ~A pool fiber, " name) + (print-exception + port + (stack-ref stack 3) + '%exception + (list exn)))))) + (display error-string + (current-error-port))) + (raise-exception exn)) + (lambda () + (start-stack + #t + (main-loop))))) + #:unwind? #t)) + (or scheduler + (current-scheduler))) + + pool) + (define* (make-resource-pool return-new-resource max-size #:key (min-size 0) (idle-seconds #f) @@ -126,46 +550,52 @@ (define checkout-failure-count 0) - (define spawn-fiber-to-return-new-resource - (if add-resources-parallelism - (let ((thunk - (fiberize - (lambda () - (let ((max-size - (assq-ref (resource-pool-configuration pool) - 'max-size)) - (size (assq-ref (resource-pool-stats pool) - 'resources))) - (unless (= size max-size) - (let ((new-resource - (return-new-resource))) - (put-message channel - (list 'add-resource new-resource)))))) - #:parallelism add-resources-parallelism))) - (lambda () - (spawn-fiber thunk))) - (lambda () - (spawn-fiber - (lambda () - (let ((new-resource + (define return-new-resource/parallelism-limiter + (make-parallelism-limiter + (or add-resources-parallelism + max-size) + #:name + (string-append + name + " resource pool new resource parallelism limiter"))) + + (define (spawn-fiber-to-return-new-resource) + (spawn-fiber + (lambda () + (with-exception-handler + (lambda (exn) + ;; This can happen if the resource pool is destroyed very + ;; quickly + (unless (resource-pool-destroyed-error? exn) + (raise-exception exn))) + (lambda () + (with-parallelism-limiter + return-new-resource/parallelism-limiter + (let ((max-size + (assq-ref (resource-pool-configuration pool) + 'max-size)) + (size (assq-ref (resource-pool-stats pool #:timeout #f) + 'resources))) + (unless (= size max-size) + (with-exception-handler + (lambda _ #f) + (lambda () (with-exception-handler - (lambda _ #f) + (lambda (exn) + (simple-format + (current-error-port) + "exception adding resource to pool ~A: ~A\n\n" + name + return-new-resource) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) (lambda () - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception adding resource to pool ~A: ~A\n\n" - name - return-new-resource) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (start-stack #t (return-new-resource))))) - #:unwind? #t))) - (when new-resource - (put-message channel - (list 'add-resource new-resource))))))))) + (let ((new-resource + (start-stack #t (return-new-resource)))) + (put-message channel + (list 'add-resource new-resource)))))) + #:unwind? #t))))) + #:unwind? #t)))) (define (spawn-fiber-to-destroy-resource resource) (spawn-fiber @@ -250,21 +680,14 @@ 'remove) return-type) resource) - (when destructor + (when (and (not (eq? return-type 'remove)) + destructor) (spawn-fiber-to-destroy-resource resource)) (let ((index (list-index (lambda (x) (eq? x resource)) resources))) - (define (remove-at-index! lst i) - (let ((start - end - (split-at! lst i))) - (append - start - (cdr end)))) - (let ((new-resources (if index (remove-at-index! resources index) @@ -276,13 +699,16 @@ resources)))) (if (null? new-resources) (begin + (and=> return-new-resource/parallelism-limiter + destroy-parallelism-limiter) + (signal-condition! destroy-condition) ;; No loop *unspecified*) (loop new-resources))))) - (('stats reply) + (('stats reply timeout-time) (let ((stats `((resources . ,(length resources)) (available . 0) @@ -291,13 +717,17 @@ (spawn-fiber (lambda () - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply stats) - (const #t)) - (wrap-operation (sleep-operation 5) - (const #f))))))) + (let ((op + (put-operation reply stats))) + (perform-operation + (if timeout-time + (choice-operation + op + (sleep-operation + (/ (- timeout-time + (get-internal-real-time)) + internal-time-units-per-second))) + op)))))) (loop resources)) @@ -537,14 +967,6 @@ (list-index (lambda (x) (eq? x resource)) resources))) - (define (remove-at-index! lst i) - (let ((start - end - (split-at! lst i))) - (append - start - (cdr end)))) - (loop (if index (remove-at-index! resources index) (begin @@ -577,7 +999,7 @@ waiters resources-last-used)) - (('stats reply) + (('stats reply timeout-time) (let ((stats `((resources . ,(length resources)) (available . ,(length available)) @@ -586,13 +1008,17 @@ (spawn-fiber (lambda () - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply stats) - (const #t)) - (wrap-operation (sleep-operation 5) - (const #f))))))) + (let ((op + (put-operation reply stats))) + (perform-operation + (if timeout-time + (choice-operation + op + (sleep-operation + (/ (- timeout-time + (get-internal-real-time)) + internal-time-units-per-second))) + op)))))) (loop resources available @@ -645,46 +1071,52 @@ (signal-condition! destroy-condition) - (begin + (let ((current-internal-time (get-internal-real-time))) (for-each - (lambda (resource) - (if destructor - (spawn-fiber-to-destroy-resource resource) - (spawn-fiber - (lambda () - (put-message channel - (list 'remove resource))) - #:parallel? #t))) - available) - - (let ((current-internal-time (get-internal-real-time))) - (for-each - (match-lambda - ((reply . timeout) - (when (or (not timeout) - (> timeout current-internal-time)) - (spawn-fiber - (lambda () - (let ((op - (put-operation - reply - (cons 'resource-pool-destroyed - #f)))) - (perform-operation - (if timeout - (choice-operation - op - (wrap-operation - (sleep-operation - (/ (- timeout - (get-internal-real-time)) - internal-time-units-per-second)) - (const #f))) - op)))))))) - waiters)) - - (destroy-loop resources)))) + (match-lambda + ((reply . timeout) + (when (or (not timeout) + (> timeout current-internal-time)) + (spawn-fiber + (lambda () + (let ((op + (put-operation + reply + (cons 'resource-pool-destroyed + #f)))) + (perform-operation + (if timeout + (choice-operation + op + (wrap-operation + (sleep-operation + (/ (- timeout + (get-internal-real-time)) + internal-time-units-per-second)) + (const #f))) + op)))))))) + waiters) + (if destructor + (begin + (for-each + (lambda (resource) + (spawn-fiber-to-destroy-resource resource)) + available) + (destroy-loop resources)) + (let dl ((resources resources) + (available available)) + (if (null? available) + (if (null? resources) + (signal-condition! + destroy-condition) + (destroy-loop resources)) + (let ((index + (list-index (lambda (x) + (eq? x (car available))) + resources))) + (dl (remove-at-index! resources index) + (cdr available))))))))) (unknown (simple-format (current-error-port) @@ -744,7 +1176,8 @@ (put-operation (resource-pool-channel pool) (list 'destroy)) (lambda _ - (wait (resource-pool-destroy-condition pool)))) + (wait + (resource-pool-destroy-condition pool)))) (wait-operation (resource-pool-destroy-condition pool)))) #t) @@ -949,34 +1382,42 @@ available. Return the resource once PROC has returned." (lambda (resource) exp ...))) (define* (resource-pool-stats pool #:key (timeout 5)) - (let ((reply (make-channel)) - (start-time (get-internal-real-time))) - (perform-operation - (choice-operation - (wrap-operation - (put-operation (resource-pool-channel pool) - `(stats ,reply)) - (const #t)) - (wrap-operation (sleep-operation timeout) - (lambda _ - (raise-exception - (make-resource-pool-timeout-error pool)))))) + (if timeout + (let* ((reply (make-channel)) + (start-time (get-internal-real-time)) + (timeout-time + (+ start-time + (* internal-time-units-per-second timeout)))) + (perform-operation + (choice-operation + (wrap-operation + (put-operation (resource-pool-channel pool) + `(stats ,reply ,timeout-time)) + (const #t)) + (wrap-operation (sleep-operation timeout) + (lambda _ + (raise-exception + (make-resource-pool-timeout-error pool)))))) - (let ((time-remaining - (- timeout - (/ (- (get-internal-real-time) - start-time) - internal-time-units-per-second)))) - (if (> time-remaining 0) - (perform-operation - (choice-operation - (get-operation reply) - (wrap-operation (sleep-operation time-remaining) - (lambda _ - (raise-exception - (make-resource-pool-timeout-error pool)))))) - (raise-exception - (make-resource-pool-timeout-error pool)))))) + (let ((time-remaining + (- timeout + (/ (- (get-internal-real-time) + start-time) + internal-time-units-per-second)))) + (if (> time-remaining 0) + (perform-operation + (choice-operation + (get-operation reply) + (wrap-operation (sleep-operation time-remaining) + (lambda _ + (raise-exception + (make-resource-pool-timeout-error pool)))))) + (raise-exception + (make-resource-pool-timeout-error pool))))) + (let ((reply (make-channel))) + (put-message (resource-pool-channel pool) + `(stats ,reply #f)) + (get-message reply)))) (define (resource-pool-list-resources pool) (let ((reply (make-channel))) diff --git a/tests.scm b/tests.scm index 2b24c6a..a58eff0 100644 --- a/tests.scm +++ b/tests.scm @@ -4,7 +4,7 @@ #:export (run-fibers-for-tests assert-no-heap-growth)) -(define (run-fibers-for-tests thunk) +(define* (run-fibers-for-tests thunk #:key (drain? #t)) (let ((result (run-fibers (lambda () @@ -12,6 +12,7 @@ (lambda (exn) exn) (lambda () + (simple-format #t "running ~A\n" thunk) (with-exception-handler (lambda (exn) (backtrace) @@ -20,7 +21,8 @@ #t) #:unwind? #t)) #:hz 0 - #:parallelism 1))) + #:parallelism 1 + #:drain? drain?))) (if (exception? result) (raise-exception result) result))) diff --git a/tests/parallelism.scm b/tests/parallelism.scm index 9881a4d..03ec376 100644 --- a/tests/parallelism.scm +++ b/tests/parallelism.scm @@ -111,4 +111,16 @@ (assert-equal a 1)))) +(run-fibers-for-tests + (lambda () + (let ((parallelism-limiter (make-parallelism-limiter 2))) + (fibers-for-each + (lambda _ + (with-parallelism-limiter + parallelism-limiter + #f)) + (iota 50)) + + (destroy-parallelism-limiter parallelism-limiter)))) + (display "parallelism test finished successfully\n") diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm index 1bc09e5..461d04b 100644 --- a/tests/resource-pool.scm +++ b/tests/resource-pool.scm @@ -19,7 +19,21 @@ (number? (with-resource-from-pool resource-pool res - res)))))) + res))) + + (destroy-resource-pool resource-pool)))) + +(run-fibers-for-tests + (lambda () + (let ((resource-pool (make-fixed-size-resource-pool + (list 1)))) + (assert-true + (number? + (with-resource-from-pool resource-pool + res + res))) + + (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () @@ -31,7 +45,9 @@ (number? (with-resource-from-pool resource-pool res - res)))))) + res))) + + (destroy-resource-pool resource-pool)))) (let* ((error-constructor (record-constructor &resource-pool-timeout)) @@ -88,10 +104,13 @@ res)) (iota 20)) - (let loop ((stats (resource-pool-stats resource-pool))) + (let loop ((stats (resource-pool-stats resource-pool + #:timeout #f))) (unless (= 0 (assq-ref stats 'resources)) (sleep 0.1) - (loop (resource-pool-stats resource-pool))))))) + (loop (resource-pool-stats resource-pool #:timeout #f)))) + + (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () @@ -115,7 +134,9 @@ (set! counter (+ 1 counter)) (error "collision detected"))))) 20 - (iota 50))))) + (iota 50)) + + (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () @@ -129,7 +150,7 @@ (error "collision detected"))) (new-number)) 1 - #:default-checkout-timeout 120))) + #:default-checkout-timeout 5))) (fibers-batch-for-each (lambda _ (with-resource-from-pool @@ -140,7 +161,9 @@ (set! counter (+ 1 counter)) (error "collision detected"))))) 20 - (iota 50))))) + (iota 50)) + + (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () @@ -164,14 +187,14 @@ (call-with-resource-from-pool resource-pool (lambda (res) - (error 'should-not-be-reached)))) + #f))) #:unwind? #t))) (while (= 0 (assq-ref - (resource-pool-stats resource-pool) + (resource-pool-stats resource-pool #:timeout #f) 'waiters)) - (sleep 0)) + (sleep 0.1)) (with-exception-handler (lambda (exn) @@ -184,6 +207,8 @@ resource-pool (lambda (res) (error 'should-not-be-reached)))) - #:unwind? #t)))))) + #:unwind? #t))) + + (destroy-resource-pool resource-pool)))) (display "resource-pool test finished successfully\n") From 09ca6cfb6bb24b94684f67daee5b1a8eae4aa3cb Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 26 Jun 2025 21:27:32 +0200 Subject: [PATCH 09/78] Fix resource-pool-destroy-resource-exception Raising the exception is more consistent, and avoids returning the resource. --- knots/resource-pool.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 71c378c..e55bdac 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -1351,8 +1351,7 @@ available. Return the resource once PROC has returned." 'destroy 'return) resource)) - (unless (resource-pool-destroy-resource-exception? exn) - (raise-exception exn))) + (raise-exception exn)) (lambda () (with-exception-handler (lambda (exn) From 8f3e0a9a1d8572f4e96651ec0ded21717644c6bb Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 26 Jun 2025 22:53:15 +0200 Subject: [PATCH 10/78] Fix exception handling in fibers-map-with-progress --- knots/parallelism.scm | 8 ++++---- tests/parallelism.scm | 18 ++++++++++++++++++ 2 files changed, 22 insertions(+), 4 deletions(-) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index 9e80f5b..a3b04c7 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -217,9 +217,9 @@ (if (null? active-channels) (map (match-lambda - ((#f . ('exception . exn)) + ((#f . ('exception exn)) (raise-exception exn)) - ((#f . ('result . val)) + ((#f . ('result val)) val)) channels-to-results) (loop @@ -239,10 +239,10 @@ (if (eq? channel c) (cons #f (match result - (('exception . exn) + (('exception exn) result) (_ - (cons 'result result)))) + (list 'result result)))) (cons c r)))) channels-to-results))) #f)))) diff --git a/tests/parallelism.scm b/tests/parallelism.scm index 03ec376..91b2f3d 100644 --- a/tests/parallelism.scm +++ b/tests/parallelism.scm @@ -61,6 +61,24 @@ identity '(())))) +(run-fibers-for-tests + (lambda () + (with-exception-handler + (lambda (exn) + (unless (and (exception-with-message? exn) + (string=? (exception-message exn) + "foo")) + (raise-exception exn))) + (lambda () + (fibers-map-with-progress + (lambda _ + (raise-exception + (make-exception-with-message "foo"))) + '((1))) + + (error 'should-not-reach-here)) + #:unwind? #t))) + (run-fibers-for-tests (lambda () (with-exception-handler From 163d775496f8413fe5c1edb5ed22289df9d4fd01 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jun 2025 00:16:18 +0200 Subject: [PATCH 11/78] Fix record-predicate that should be exception-predicate --- knots/resource-pool.scm | 10 +++++----- knots/thread-pool.scm | 2 +- knots/timeout.scm | 6 +++--- knots/web-server.scm | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index e55bdac..7da76b0 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -74,7 +74,7 @@ (record-constructor &resource-pool-abort-add-resource)) (define resource-pool-abort-add-resource-error? - (record-predicate &resource-pool-abort-add-resource)) + (exception-predicate &resource-pool-abort-add-resource)) (define-record-type (make-resource-pool-record name channel destroy-condition configuration) @@ -1196,7 +1196,7 @@ (record-constructor &resource-pool-timeout)) (define resource-pool-timeout-error? - (record-predicate &resource-pool-timeout)) + (exception-predicate &resource-pool-timeout)) (define &resource-pool-too-many-waiters (make-exception-type '&recource-pool-too-many-waiters @@ -1217,7 +1217,7 @@ (record-constructor &resource-pool-too-many-waiters)) (define resource-pool-too-many-waiters-error? - (record-predicate &resource-pool-too-many-waiters)) + (exception-predicate &resource-pool-too-many-waiters)) (define &resource-pool-destroyed (make-exception-type '&recource-pool-destroyed @@ -1233,7 +1233,7 @@ (record-constructor &resource-pool-destroyed)) (define resource-pool-destroyed-error? - (record-predicate &resource-pool-destroyed)) + (exception-predicate &resource-pool-destroyed)) (define &resource-pool-destroy-resource (make-exception-type '&recource-pool-destroy-resource @@ -1244,7 +1244,7 @@ (record-constructor &resource-pool-destroy-resource)) (define resource-pool-destroy-resource-exception? - (record-predicate &resource-pool-destroy-resource)) + (exception-predicate &resource-pool-destroy-resource)) (define resource-pool-default-timeout-handler (make-parameter #f)) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index b176162..70d7292 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -198,7 +198,7 @@ from there, or #f if that would be an empty string." (record-accessor &thread-pool-timeout-error 'pool))) (define thread-pool-timeout-error? - (record-predicate &thread-pool-timeout-error)) + (exception-predicate &thread-pool-timeout-error)) (define* (make-fixed-size-thread-pool size #:key diff --git a/knots/timeout.scm b/knots/timeout.scm index 58306e0..a65a095 100644 --- a/knots/timeout.scm +++ b/knots/timeout.scm @@ -85,7 +85,7 @@ (record-constructor &port-timeout-error)) (define port-timeout-error? - (record-predicate &port-timeout-error)) + (exception-predicate &port-timeout-error)) (define &port-read-timeout-error (make-exception-type '&port-read-timeout-error @@ -96,7 +96,7 @@ (record-constructor &port-read-timeout-error)) (define port-read-timeout-error? - (record-predicate &port-read-timeout-error)) + (exception-predicate &port-read-timeout-error)) (define &port-write-timeout-error (make-exception-type '&port-write-timeout-error @@ -107,7 +107,7 @@ (record-constructor &port-write-timeout-error)) (define port-write-timeout-error? - (record-predicate &port-write-timeout-error)) + (exception-predicate &port-write-timeout-error)) (define (readable? port) "Test if PORT is writable." diff --git a/knots/web-server.scm b/knots/web-server.scm index 453db44..a0a3641 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -130,7 +130,7 @@ closes PORT, unless KEEP-ALIVE? is true." (record-constructor &request-body-ended-prematurely)) (define request-body-ended-prematurely-error? - (record-predicate &request-body-ended-prematurely)) + (exception-predicate &request-body-ended-prematurely)) (define (request-body-port/knots r) (cond From d8f64399cd572fb1c6b19303ee710ce6529e77b4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jun 2025 00:16:37 +0200 Subject: [PATCH 12/78] Tweak spacing --- knots/parallelism.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index a3b04c7..c98ca3f 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -217,9 +217,9 @@ (if (null? active-channels) (map (match-lambda - ((#f . ('exception exn)) + ((#f . ('exception exn)) (raise-exception exn)) - ((#f . ('result val)) + ((#f . ('result val)) val)) channels-to-results) (loop From 6f6d57b189a7073718407df263bbe3c1245f2e51 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jun 2025 00:16:41 +0200 Subject: [PATCH 13/78] Use the knots backtrace printer for tests --- tests.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests.scm b/tests.scm index a58eff0..0cca3b4 100644 --- a/tests.scm +++ b/tests.scm @@ -1,6 +1,7 @@ (define-module (tests) #:use-module (ice-9 exceptions) #:use-module (fibers) + #:use-module (knots) #:export (run-fibers-for-tests assert-no-heap-growth)) @@ -15,9 +16,10 @@ (simple-format #t "running ~A\n" thunk) (with-exception-handler (lambda (exn) - (backtrace) + (print-backtrace-and-exception/knots exn) (raise-exception exn)) - thunk) + (lambda () + (start-stack #t (thunk)))) #t) #:unwind? #t)) #:hz 0 From 4140ef0bd67dfed419203713df497f94b0ac2e45 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jun 2025 22:43:25 +0200 Subject: [PATCH 14/78] More consistently handle results and exceptions In the parallelism module. --- knots/parallelism.scm | 62 +++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index c98ca3f..f15dbe8 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -22,6 +22,7 @@ #:use-module (srfi srfi-71) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 control) #:use-module (ice-9 exceptions) @@ -57,7 +58,7 @@ (lambda (exn) (put-message reply - (list 'exception exn))) + (cons 'exception exn))) (lambda () (with-exception-handler (lambda (exn) @@ -78,7 +79,7 @@ (lambda () (start-stack #t (thunk))) (lambda vals - (put-message reply vals)))))) + (put-message reply (cons 'result vals))))))) #:unwind? #t)) #:parallel? #t) reply)) @@ -88,10 +89,10 @@ reply-channels))) (map (match-lambda - (('exception exn) + (('exception . exn) (raise-exception exn)) - (result - (apply values result))) + (('result . vals) + (apply values vals))) responses))) (define (fibers-batch-map proc parallelism-limit . lists) @@ -114,9 +115,18 @@ (channel-indexes '())) (if (and (eq? #f next-to-process-index) (null? channel-indexes)) - (if (vector? (first lists)) - result-vec - (vector->list result-vec)) + (let ((processed-result-vec + (vector-map + (lambda (_ result-or-exn) + (match result-or-exn + (('exception . exn) + (raise-exception exn)) + (('result . vals) + (car vals)))) + result-vec))) + (if (vector? (first lists)) + processed-result-vec + (vector->list processed-result-vec))) (if (or (= (length channel-indexes) (min parallelism-limit vecs-length)) @@ -132,18 +142,13 @@ (get-operation (vector-ref result-vec index)) (lambda (result) - (match result - (('exception exn) - (raise-exception exn)) - (_ - (vector-set! result-vec - index - (first result)) - - (values next-to-process-index - (lset-difference = - channel-indexes - (list index)))))))) + (vector-set! result-vec + index + result) + (values next-to-process-index + (lset-difference = + channel-indexes + (list index)))))) channel-indexes))))) (loop new-index new-channel-indexes)) @@ -217,10 +222,10 @@ (if (null? active-channels) (map (match-lambda - ((#f . ('exception exn)) + ((#f . ('exception . exn)) (raise-exception exn)) - ((#f . ('result val)) - val)) + ((#f . ('result . vals)) + (car vals))) channels-to-results) (loop (perform-operation @@ -237,12 +242,7 @@ (map (match-lambda ((c . r) (if (eq? channel c) - (cons #f - (match result - (('exception exn) - result) - (_ - (list 'result result)))) + (cons #f result) (cons c r)))) channels-to-results))) #f)))) @@ -263,7 +263,7 @@ reply-channel (with-exception-handler (lambda (exn) - (list 'exception exn)) + (cons 'exception exn)) (lambda () (with-exception-handler (lambda (exn) @@ -294,7 +294,7 @@ (put-message input-channel (cons reply-channel args)) (match (get-message reply-channel) (('result . vals) (apply values vals)) - (('exception exn) + (('exception . exn) (raise-exception exn)))))) (define-record-type From 0fa6737a39f866bdbffc11fd16348c5411c11a7c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 27 Jun 2025 23:28:47 +0200 Subject: [PATCH 15/78] Document some things --- knots/parallelism.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index f15dbe8..7631055 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -96,6 +96,9 @@ responses))) (define (fibers-batch-map proc parallelism-limit . lists) + "Map PROC over LISTS in parallel, with a PARALLELISM-LIMIT. If any of +the invocations of PROC raise an exception, this will be raised once +all of the calls to PROC have finished." (define vecs (map (lambda (list-or-vec) (if (vector? list-or-vec) list-or-vec @@ -171,9 +174,14 @@ channel-indexes))))))) (define (fibers-map proc . lists) + "Map PROC over LISTS in parallel, running up to 20 fibers in + PARALLEL. If any of the invocations of PROC raise an exception, this +will be raised once all of the calls to PROC have finished." (apply fibers-batch-map proc 20 lists)) (define (fibers-batch-for-each proc parallelism-limit . lists) + "Call PROC on LISTS, running up to PARALLELISM-LIMIT fibers in +parallel." (apply fibers-batch-map (lambda args (apply proc args) @@ -184,10 +192,13 @@ *unspecified*) (define (fibers-for-each proc . lists) + "Call PROC on LISTS, running up to 20 fibers in parallel." (apply fibers-batch-for-each proc 20 lists)) (define-syntax fibers-parallel (lambda (x) + "Run each expression in parallel. If any expression raises an + exception, this will be raised after all exceptions have finished." (syntax-case x () ((_ e0 ...) (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) @@ -198,12 +209,16 @@ (apply values (fetch-result-of-defered-thunks tmp0 ...)))))))) (define-syntax-rule (fibers-let ((v e) ...) b0 b1 ...) + "Let, but run each binding in a fiber in parallel." (call-with-values (lambda () (fibers-parallel e ...)) (lambda (v ...) b0 b1 ...))) (define* (fibers-map-with-progress proc lists #:key report) + "Map PROC over LISTS, calling #:REPORT if specified after each +invocation of PROC finishes. REPORT is passed the results for each + element of LISTS, or #f if no result has been received yet." (let loop ((channels-to-results (apply map (lambda args From deae518b528485638bef89b4230616024f5009d7 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 29 Jun 2025 08:35:28 +0200 Subject: [PATCH 16/78] Use the buffer size for chunked output ports --- knots/web-server.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index a0a3641..fec349e 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -333,7 +333,8 @@ on the procedure being called at any particular time." (define (handle-request handler client read-request-exception-handler - write-response-exception-handler) + write-response-exception-handler + buffer-size) (let ((request (with-exception-handler read-request-exception-handler @@ -399,7 +400,8 @@ on the procedure being called at any particular time." client (make-chunked-output-port/knots client - #:keep-alive? #t)))) + #:keep-alive? #t + #:buffering buffer-size)))) (set-port-encoding! body-port charset) (let ((body-written? (with-exception-handler @@ -472,7 +474,8 @@ on the procedure being called at any particular time." (else (let ((keep-alive? (handle-request handler client read-request-exception-handler - write-response-exception-handler))) + write-response-exception-handler + buffer-size))) (if keep-alive? (loop) (close-port client))))))) From 7709ffe1d33ac9da62189f725a64d59f729b4463 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 30 Jun 2025 15:41:04 +0200 Subject: [PATCH 17/78] Tweak the knots chunked output port To try and reduce the number of write syscalls. --- knots/web-server.scm | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index fec349e..3e5f388 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -63,6 +63,14 @@ (bind sock family addr port) sock)) +(define crlf-bv + (string->utf8 "\r\n")) + +(define (chunked-output-port-overhead-bytes write-size) + (+ (string-length (number->string write-size 16)) + (bytevector-length crlf-bv) + (bytevector-length crlf-bv))) + (define* (make-chunked-output-port/knots port #:key (keep-alive? #f) (buffering 1200)) "Returns a new port which translates non-encoded data into a HTTP @@ -74,10 +82,12 @@ when done, as it will output the remaining data, and encode the final zero chunk. When the port is closed it will also close PORT, unless KEEP-ALIVE? is true." (define (write! bv start count) - (put-string port (number->string count 16)) - (put-string port "\r\n") + (let ((len-string + (number->string count 16))) + (put-string port len-string)) + (put-bytevector port crlf-bv 0 2) (put-bytevector port bv start count) - (put-string port "\r\n") + (put-bytevector port crlf-bv 0 2) (force-output port) count) @@ -401,7 +411,10 @@ on the procedure being called at any particular time." (make-chunked-output-port/knots client #:keep-alive? #t - #:buffering buffer-size)))) + #:buffering + (- buffer-size + (chunked-output-port-overhead-bytes + buffer-size)))))) (set-port-encoding! body-port charset) (let ((body-written? (with-exception-handler From ce1b710bcf4b1874bdd06a6f96cb3e268f4b5895 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 30 Jun 2025 22:57:08 +0100 Subject: [PATCH 18/78] Use a queue for the resource pool waiters As this will maybe improve performance. --- knots/resource-pool.scm | 277 ++++++++++++++++++++-------------------- 1 file changed, 141 insertions(+), 136 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 7da76b0..b27f329 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -22,6 +22,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-71) + #:use-module (ice-9 q) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module (fibers) @@ -267,13 +268,13 @@ (define (main-loop) (let loop ((resources resources) (available resources) - (waiters '())) + (waiters (make-q))) (match (get-message channel) (('checkout reply timeout-time max-waiters) (if (null? available) (let ((waiters-count - (length waiters))) + (q-length waiters))) (if (and max-waiters (>= waiters-count max-waiters)) @@ -301,8 +302,7 @@ waiters)) (loop resources available - (cons (cons reply timeout-time) - waiters)))) + (enq! waiters (cons reply timeout-time))))) (if timeout-time (let ((current-internal-time @@ -345,44 +345,46 @@ (set! checkout-failure-count (+ 1 checkout-failure-count))) - (if (null? waiters) + (if (q-empty? waiters) (loop resources (cons resource available) waiters) - (let* ((current-internal-time (get-internal-real-time)) - (alive-waiters - dead-waiters - (partition! - (match-lambda - ((reply . timeout) - (or (not timeout) - (> timeout current-internal-time)))) - waiters))) - (if (null? alive-waiters) - (loop resources - (cons resource available) - '()) - (match (last alive-waiters) - ((waiter-channel . waiter-timeout) - (if waiter-timeout - (let ((reply-timeout - (/ (- waiter-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 waiter-channel - reply-timeout - resource)) - (put-message waiter-channel (cons 'success - resource))) - - (loop resources - available - (drop-right! alive-waiters 1)))))))) + (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)) + (begin + (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))))))) + #:unwind? #t)))) (('list-resources reply) (spawn-fiber @@ -397,7 +399,7 @@ (let ((stats `((resources . ,(length resources)) (available . ,(length available)) - (waiters . ,(length waiters)) + (waiters . ,(q-length waiters)) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber @@ -420,7 +422,7 @@ (('destroy) (if (and (null? resources) - (null? waiters)) + (q-empty? waiters)) (signal-condition! destroy-condition) @@ -448,7 +450,7 @@ internal-time-units-per-second)) (const #f))) op)))))))) - waiters) + (car waiters)) (if destructor (begin @@ -747,7 +749,7 @@ (define (main-loop) (let loop ((resources '()) (available '()) - (waiters '()) + (waiters (make-q)) (resources-last-used '())) (match (get-message channel) @@ -769,50 +771,52 @@ (cons (get-internal-real-time) resources-last-used)))) - (if (null? waiters) + (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)) - (alive-waiters - dead-waiters - (partition! - (match-lambda - ((reply . timeout) - (or (not timeout) - (> timeout current-internal-time)))) - waiters))) - (if (null? alive-waiters) - (loop (cons resource resources) - (cons resource available) - '() - (cons (get-internal-real-time) - resources-last-used)) - (match (last alive-waiters) - ((waiter-channel . waiter-timeout) - (if waiter-timeout - (let ((reply-timeout - (/ (- waiter-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 waiter-channel - reply-timeout - resource)) - (put-message waiter-channel (cons 'success - resource))) - - (loop (cons resource resources) - available - (drop-right! alive-waiters 1) - (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)) + (begin + (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))))))) + #:unwind? #t)))))) (('checkout reply timeout-time max-waiters) (if (null? available) @@ -821,7 +825,7 @@ (spawn-fiber-to-return-new-resource)) (let ((waiters-count - (length waiters))) + (q-length waiters))) (if (and max-waiters (>= waiters-count max-waiters)) @@ -850,8 +854,7 @@ resources-last-used)) (loop resources available - (cons (cons reply timeout-time) - waiters) + (enq! waiters (cons reply timeout-time)) resources-last-used)))) (if timeout-time @@ -898,7 +901,7 @@ (set! checkout-failure-count (+ 1 checkout-failure-count))) - (if (null? waiters) + (if (q-empty? waiters) (loop resources (cons resource available) waiters @@ -911,56 +914,58 @@ (get-internal-real-time)) resources-last-used)) - (let* ((current-internal-time (get-internal-real-time)) - (alive-waiters - dead-waiters - (partition! - (match-lambda - ((reply . timeout) - (or (not timeout) - (> timeout current-internal-time)))) - waiters))) - (if (null? alive-waiters) - (loop resources - (cons resource available) - '() - (begin - (when (eq? return-type 'return) - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - (get-internal-real-time))) - resources-last-used)) - (match (last alive-waiters) - ((waiter-channel . waiter-timeout) - (if waiter-timeout - (let ((reply-timeout - (/ (- waiter-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 waiter-channel - reply-timeout - resource)) - (put-message waiter-channel (cons 'success - resource))) - - (loop resources - available - (drop-right! alive-waiters 1) + (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)) (begin - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - (get-internal-real-time)) - resources-last-used)))))))) + (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 + (list-index (lambda (x) + (eq? x resource)) + resources) + current-internal-time) + resources-last-used)))))))) + #:unwind? #t)))) (('remove resource) (let ((index @@ -1003,7 +1008,7 @@ (let ((stats `((resources . ,(length resources)) (available . ,(length available)) - (waiters . ,(length waiters)) + (waiters . ,(q-length waiters)) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber @@ -1067,7 +1072,7 @@ (('destroy) (if (and (null? resources) - (null? waiters)) + (q-empty? waiters)) (signal-condition! destroy-condition) @@ -1095,7 +1100,7 @@ internal-time-units-per-second)) (const #f))) op)))))))) - waiters) + (car waiters)) (if destructor (begin From ff93dc144284044255957de8870f0d848f8fa844 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 1 Jul 2025 12:45:12 +0100 Subject: [PATCH 19/78] Add a post-request-hook to the web server --- knots/web-server.scm | 51 +++++++++++++++++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 10 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index 3e5f388..4d7240b 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -341,16 +341,19 @@ on the procedure being called at any particular time." (string->utf8 "internal server error"))) -(define (handle-request handler client - read-request-exception-handler - write-response-exception-handler - buffer-size) +(define* (handle-request handler client + read-request-exception-handler + write-response-exception-handler + buffer-size + #:key post-request-hook) (let ((request (with-exception-handler read-request-exception-handler (lambda () (read-request client)) - #:unwind? #t))) + #:unwind? #t)) + (read-request-time + (get-internal-real-time))) (let ((response body (cond @@ -399,7 +402,9 @@ on the procedure being called at any particular time." (lambda () (write-response response client) - (let ((body-written? + (let ((response-start-time + (get-internal-real-time)) + (body-written? (if (procedure? body) (let* ((type (response-content-type response '(text/plain))) @@ -438,6 +443,11 @@ on the procedure being called at any particular time." (if body-written? (begin (force-output client) + (when post-request-hook + (post-request-hook request + #:read-request-time read-request-time + #:response-start-time response-start-time + #:response-end-time (get-internal-real-time))) (when (and (procedure? body) (response-content-length response)) (set-port-encoding! client "ISO-8859-1")) @@ -449,7 +459,8 @@ on the procedure being called at any particular time." read-request-exception-handler write-response-exception-handler connection-idle-timeout - buffer-size) + buffer-size + post-request-hook) ;; Always disable Nagle's algorithm, as we handle buffering ;; ourselves; when we force-output, we really want the data to go ;; out. @@ -488,11 +499,28 @@ on the procedure being called at any particular time." (let ((keep-alive? (handle-request handler client read-request-exception-handler write-response-exception-handler - buffer-size))) + buffer-size + #:post-request-hook + post-request-hook))) (if keep-alive? (loop) (close-port client))))))) +(define (post-request-hook/safe post-request-hook) + (if post-request-hook + (lambda args + (with-exception-handler + (lambda (exn) #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (apply post-request-hook args)))) + #:unwind? #t)) + #f)) + (define-record-type (make-web-server socket port) web-server? @@ -512,7 +540,8 @@ on the procedure being called at any particular time." (write-response-exception-handler default-write-response-exception-handler) (connection-idle-timeout #f) - (connection-buffer-size 1024)) + (connection-buffer-size 1024) + post-request-hook) "Run the knots web server. HANDLER should be a procedure that takes one argument, the HTTP @@ -548,7 +577,9 @@ before sending back to the client." read-request-exception-handler write-response-exception-handler connection-idle-timeout - connection-buffer-size)) + connection-buffer-size + (post-request-hook/safe + post-request-hook))) #:parallel? #t) (loop)))))) From ec2f2489a2394a9f426931cee2b7a4856349603e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 1 Jul 2025 23:13:31 +0100 Subject: [PATCH 20/78] Fix resource pool bug And remove unnecessary named let. --- knots/resource-pool.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index b27f329..6b28a27 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -1317,8 +1317,9 @@ available. Return the resource once PROC has returned." start-time) 'timeout) response)) - 'timeout))))) - (let loop ((reply (make-channel))) + 'timeout)) + 'timeout))) + (let ((reply (make-channel))) (put-message channel (list 'checkout reply From f4b48a149923fd5cb4ff77772f2fdcc0b694f676 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 6 Jul 2025 18:49:09 +0100 Subject: [PATCH 21/78] Avoid calling deq! if the queue is empty --- knots/resource-pool.scm | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 6b28a27..640978f 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -365,7 +365,11 @@ ((reply . timeout) (if (and timeout (< timeout current-internal-time)) - (waiter-loop (deq! waiters)) + (if (q-empty? waiters) + (loop resources + (cons resource available) + waiters) + (waiter-loop (deq! waiters))) (begin (if timeout (let ((reply-timeout @@ -795,7 +799,13 @@ ((reply . timeout) (if (and timeout (< timeout current-internal-time)) - (waiter-loop (deq! waiters)) + (if (q-empty? waiters) + (loop (cons resource resources) + (cons resource available) + waiters + (cons (get-internal-real-time) + resources-last-used)) + (waiter-loop (deq! waiters))) (begin (if timeout (let ((reply-timeout @@ -938,7 +948,19 @@ ((reply . timeout) (if (and timeout (< timeout current-internal-time)) - (waiter-loop (deq! waiters)) + (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)) + (waiter-loop (deq! waiters))) (begin (if timeout (let ((reply-timeout From d18b5b8d5de5beff3b9f84cfb359b73a4dcf2070 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 9 Jul 2025 12:06:20 +0100 Subject: [PATCH 22/78] Don't loop inside exception handlers The resource pools seemed to become slower and slower over time, this might help? --- knots/resource-pool.scm | 159 +++++++++++++++++----------------------- 1 file changed, 67 insertions(+), 92 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 640978f..6e9c353 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -365,30 +365,25 @@ ((reply . timeout) (if (and timeout (< timeout current-internal-time)) - (if (q-empty? waiters) - (loop resources - (cons resource available) - waiters) - (waiter-loop (deq! waiters))) - (begin - (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))))))) - #:unwind? #t)))) + (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)))) (('list-resources reply) (spawn-fiber @@ -799,34 +794,27 @@ ((reply . timeout) (if (and timeout (< timeout current-internal-time)) - (if (q-empty? waiters) - (loop (cons resource resources) - (cons resource available) - waiters - (cons (get-internal-real-time) - resources-last-used)) - (waiter-loop (deq! waiters))) - (begin - (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))))))) - #:unwind? #t)))))) + (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)))))) (('checkout reply timeout-time max-waiters) (if (null? available) @@ -948,46 +936,33 @@ ((reply . timeout) (if (and timeout (< timeout current-internal-time)) - (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)) - (waiter-loop (deq! waiters))) - (begin - (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 - (list-index (lambda (x) - (eq? x resource)) - resources) - current-internal-time) - resources-last-used)))))))) - #:unwind? #t)))) + (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))))) (('remove resource) (let ((index From 4468a3ef6d27556db35b0c6d07f7c5110ae362cc Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 10 Jul 2025 16:11:45 +0100 Subject: [PATCH 23/78] Generate documentation for (knots) as well As enabled by Guile Documenta 0.4. --- .forgejo/workflows/build-website.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.forgejo/workflows/build-website.yaml b/.forgejo/workflows/build-website.yaml index d859b76..ab24066 100644 --- a/.forgejo/workflows/build-website.yaml +++ b/.forgejo/workflows/build-website.yaml @@ -10,7 +10,7 @@ jobs: - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git --branch=pages knots-pages - run: | cd knots-trunk - guix shell -D -f guix-dev.scm -- documenta api knots + guix shell -D -f guix-dev.scm -- documenta api knots.scm knots guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -c SHOW_TITLE=true -o ../knots-pages/index.html doc/index.texi - run: | From 52092e7a99fb782a5e89a4b0ec42f93549b96437 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 10 Jul 2025 16:15:58 +0100 Subject: [PATCH 24/78] Fix call to documenta --- .forgejo/workflows/build-website.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.forgejo/workflows/build-website.yaml b/.forgejo/workflows/build-website.yaml index ab24066..ae6c4da 100644 --- a/.forgejo/workflows/build-website.yaml +++ b/.forgejo/workflows/build-website.yaml @@ -10,7 +10,7 @@ jobs: - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git --branch=pages knots-pages - run: | cd knots-trunk - guix shell -D -f guix-dev.scm -- documenta api knots.scm knots + guix shell -D -f guix-dev.scm -- documenta api "knots.scm knots/" guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -c SHOW_TITLE=true -o ../knots-pages/index.html doc/index.texi - run: | From 86fb460d6a35a7170611d81b9d7280f793f3d34b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 10:46:46 +0000 Subject: [PATCH 25/78] 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 From 40b64e269b34ebf4cfb95155b2aed99200ec1cfa Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 10:51:33 +0000 Subject: [PATCH 26/78] Fix resources-last-used inconsistency --- knots/resource-pool.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index c233e29..232df77 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -767,8 +767,7 @@ (loop resources available waiters - (cons (get-internal-real-time) - resources-last-used)))) + resources-last-used))) (let ((current-internal-time (get-internal-real-time))) From a13098494d59fb1e6f8cc980a12f408f58a60727 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 11:18:23 +0000 Subject: [PATCH 27/78] Fix a bug where resources pools could empty with waiters --- knots/resource-pool.scm | 4 ++++ tests/resource-pool.scm | 17 +++++++++++++++++ 2 files changed, 21 insertions(+) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 232df77..d802260 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -939,6 +939,10 @@ (eq? x resource)) resources))) + (when (and (not (q-empty? waiters)) + (< (- (length resources) 1) + max-size)) + (spawn-fiber-to-return-new-resource)) (loop (if index (remove-at-index! resources index) diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm index 461d04b..3999dde 100644 --- a/tests/resource-pool.scm +++ b/tests/resource-pool.scm @@ -211,4 +211,21 @@ (destroy-resource-pool resource-pool)))) +(run-fibers-for-tests + (lambda () + (let ((resource-pool (make-resource-pool + (const 'foo) + 1 + #:lifetime 1 + #:destructor + (const #t)))) + (for-each + (lambda _ + (with-resource-from-pool resource-pool + res + res)) + (iota 20)) + + (destroy-resource-pool resource-pool)))) + (display "resource-pool test finished successfully\n") From 244607865774eed9d3d7927091ddc3e2c3d3acac Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 11:19:01 +0000 Subject: [PATCH 28/78] Fix updating the thread-proc-vector in thread pools --- knots/thread-pool.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index 70d7292..49572db 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -269,7 +269,7 @@ from there, or #f if that would be an empty string." (sleep 1) (destructor/safe args))))) - (define (process channel args) + (define (process thread-index channel args) (let loop () (match (get-message channel) ('destroy #f) @@ -292,6 +292,9 @@ from there, or #f if that would be an empty string." internal-time-units-per-second) exn)) (lambda () + (vector-set! thread-proc-vector + thread-index + proc) (with-exception-handler (lambda (exn) (let ((stack @@ -319,6 +322,10 @@ from there, or #f if that would be an empty string." vals)))))) #:unwind? #t))) + (vector-set! thread-proc-vector + thread-index + #f) + (put-message reply response) @@ -358,7 +365,7 @@ from there, or #f if that would be an empty string." "knots: thread-pool: internal exception: ~A\n" exn)) (lambda () (parameterize ((param args)) - (process channel args))) + (process index channel args))) #:unwind? #t))) (when thread-destructor From e78e41b5423d7f79c07cdad2f3a26297475f8901 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 11:19:30 +0000 Subject: [PATCH 29/78] Pass through default-max-waiters in make-thread-pool --- knots/thread-pool.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index 49572db..df4352a 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -402,7 +402,8 @@ from there, or #f if that would be an empty string." (expire-on-exception? #f) (name "unnamed") (use-default-io-waiters? #t) - default-checkout-timeout) + default-checkout-timeout + default-max-waiters) "Return a channel used to offload work to a dedicated thread. ARGS are the arguments of the thread pool procedure." (define param @@ -425,7 +426,8 @@ arguments of the thread pool procedure." #:delay-logger delay-logger #:scheduler scheduler #:duration-logger duration-logger - #:default-checkout-timeout default-checkout-timeout))) + #:default-checkout-timeout default-checkout-timeout + #:default-max-waiters default-max-waiters))) (thread-pool resource-pool param))) From 1a476b5aa8b1fc2cd14ffb488b41da8d4eb95cef Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 11:20:10 +0000 Subject: [PATCH 30/78] Implement lifetime support in the resource pool --- knots/resource-pool.scm | 148 +++++++++++++++++++++++++++++----------- 1 file changed, 108 insertions(+), 40 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index d802260..301abbd 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -749,6 +749,7 @@ (let loop ((resources '()) (available '()) (waiters (make-q)) + (resources-checkout-count '()) (resources-last-used '())) (match (get-message channel) @@ -762,11 +763,13 @@ (loop (cons resource resources) available waiters + (cons 0 resources-checkout-count) (cons (get-internal-real-time) resources-last-used))) (loop resources available waiters + resources-checkout-count resources-last-used))) (let ((current-internal-time @@ -777,6 +780,7 @@ (loop (cons resource resources) (cons resource available) waiters + (cons 0 resources-checkout-count) (cons current-internal-time resources-last-used))) ((reply . timeout) @@ -800,6 +804,7 @@ (loop (cons resource resources) available waiters + (cons 1 resources-checkout-count) (cons current-internal-time resources-last-used)))))))) @@ -836,10 +841,12 @@ (loop resources available waiters + resources-checkout-count resources-last-used)) (loop resources available (enq! waiters (cons reply timeout-time)) + resources-checkout-count resources-last-used)))) (if timeout-time @@ -862,10 +869,21 @@ (loop resources (cdr available) waiters + (let ((resource-index + (list-index (lambda (x) + (eq? x (car available))) + resources))) + (list-set! resources-checkout-count + resource-index + (+ 1 (list-ref + resources-checkout-count + resource-index))) + resources-checkout-count) resources-last-used)) (loop resources available waiters + resources-checkout-count resources-last-used))) (begin (put-message reply (cons 'success @@ -874,6 +892,16 @@ (loop resources (cdr available) waiters + (let ((resource-index + (list-index (lambda (x) + (eq? x (car available))) + resources))) + (list-set! resources-checkout-count + resource-index + (+ 1 (list-ref + resources-checkout-count + resource-index))) + resources-checkout-count) resources-last-used))))) (((and (or 'return @@ -892,46 +920,77 @@ (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))))))) + (if (and lifetime + (>= (list-ref resources-checkout-count + resource-index) + lifetime)) + (begin + (spawn-fiber-to-destroy-resource resource) + (loop resources + available + waiters + resources-checkout-count + resources-last-used)) + (let waiter-loop ((waiter (safe-deq waiters))) + (match waiter + (#f + (loop resources + (cons resource available) + waiters + (if (eq? 'return-failed-checkout + return-type) + (begin + (list-set! resources-checkout-count + resource-index + (- (list-ref resources-checkout-count + resource-index) + 1)) + resources-checkout-count) + resources-checkout-count) + (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 + (if (eq? 'return-failed-checkout + return-type) + (begin + (list-set! resources-checkout-count + resource-index + (- (list-ref resources-checkout-count + resource-index) + 1)) + resources-checkout-count) + resources-checkout-count) + (begin + (list-set! + resources-last-used + resource-index + current-internal-time) + resources-last-used)))))))) (('remove resource) (let ((index @@ -954,6 +1013,9 @@ resources)) available ; resource shouldn't be in this list waiters + (remove-at-index! + resources-checkout-count + index) (remove-at-index! resources-last-used index)))) @@ -964,6 +1026,7 @@ (loop resources available waiters + resources-checkout-count resources-last-used)) (('list-resources reply) @@ -974,6 +1037,7 @@ (loop resources available waiters + resources-checkout-count resources-last-used)) (('stats reply timeout-time) @@ -981,6 +1045,7 @@ `((resources . ,(length resources)) (available . ,(length available)) (waiters . ,(q-length waiters)) + (resources-checkout-count . ,resources-checkout-count) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber @@ -1000,6 +1065,7 @@ (loop resources available waiters + resources-checkout-count resources-last-used)) (('check-for-idle-resources) @@ -1040,6 +1106,7 @@ (loop resources (lset-difference eq? available resources-to-destroy) waiters + resources-checkout-count resources-last-used)))) (('destroy) @@ -1103,6 +1170,7 @@ (loop resources available waiters + resources-checkout-count resources-last-used))))) (spawn-fiber From 05ad83c7031de9b0d1873a0d5aec630746342a06 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 17 Nov 2025 11:37:26 +0000 Subject: [PATCH 31/78] Implement lifetime support for thread pools --- knots/thread-pool.scm | 10 +++++++--- tests/thread-pool.scm | 22 ++++++++++++++++++++++ 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index df4352a..cbbaf21 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -270,7 +270,7 @@ from there, or #f if that would be an empty string." (destructor/safe args))))) (define (process thread-index channel args) - (let loop () + (let loop ((lifetime thread-lifetime)) (match (get-message channel) ('destroy #f) ((reply sent-time proc) @@ -342,7 +342,11 @@ from there, or #f if that would be an empty string." (if (and exception? expire-on-exception?) #t - (loop)))))))) + (if lifetime + (if (<= 1 lifetime) + #t + (loop (- lifetime 1))) + (loop lifetime))))))))) (define (start-thread index channel) (call-with-new-thread @@ -416,7 +420,6 @@ arguments of the thread pool procedure." 1 #:thread-initializer thread-initializer #:thread-destructor thread-destructor - #:thread-lifetime thread-lifetime #:expire-on-exception? expire-on-exception? #:name name #:use-default-io-waiters? use-default-io-waiters?)) @@ -424,6 +427,7 @@ arguments of the thread pool procedure." #:destructor destroy-thread-pool #:min-size min-size #:delay-logger delay-logger + #:lifetime thread-lifetime #:scheduler scheduler #:duration-logger duration-logger #:default-checkout-timeout default-checkout-timeout diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm index 1c51cb3..dd0b852 100644 --- a/tests/thread-pool.scm +++ b/tests/thread-pool.scm @@ -85,4 +85,26 @@ (+ 1 'a)))) #:unwind? #t))))) +(let ((thread-pool + (make-fixed-size-thread-pool 1 #:thread-lifetime 1))) + + (for-each + (lambda _ + (call-with-thread + thread-pool + (lambda () #f))) + (iota 10))) + +(run-fibers-for-tests + (lambda () + (let ((thread-pool + (make-thread-pool 1 #:thread-lifetime 1))) + + (for-each + (lambda _ + (call-with-thread + thread-pool + (lambda () #f))) + (iota 10))))) + (display "thread-pool test finished successfully\n") From 95200eccfd5668fa94a0dfad6eab93d7b7731c9d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 19 Nov 2025 13:18:39 +0000 Subject: [PATCH 32/78] Fix fixed size thread pool lifetimes --- knots/thread-pool.scm | 2 +- tests/thread-pool.scm | 39 +++++++++++++++++++++++++++++++++++++-- 2 files changed, 38 insertions(+), 3 deletions(-) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index cbbaf21..22c1b5c 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -343,7 +343,7 @@ from there, or #f if that would be an empty string." expire-on-exception?) #t (if lifetime - (if (<= 1 lifetime) + (if (<= lifetime 1) #t (loop (- lifetime 1))) (loop lifetime))))))))) diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm index dd0b852..e3a1cdd 100644 --- a/tests/thread-pool.scm +++ b/tests/thread-pool.scm @@ -1,4 +1,5 @@ (use-modules (tests) + (ice-9 atomic) (srfi srfi-71) (fibers) (unit-test) @@ -86,13 +87,21 @@ #:unwind? #t))))) (let ((thread-pool - (make-fixed-size-thread-pool 1 #:thread-lifetime 1))) + (make-fixed-size-thread-pool + 1 + #:thread-lifetime 1 + #:thread-initializer + (lambda () + (list (make-atomic-box #t)))))) (for-each (lambda _ (call-with-thread thread-pool - (lambda () #f))) + (lambda (box) + (if (atomic-box-ref box) + (atomic-box-set! box #f) + (error (atomic-box-ref box)))))) (iota 10))) (run-fibers-for-tests @@ -107,4 +116,30 @@ (lambda () #f))) (iota 10))))) +(let ((thread-pool + (make-fixed-size-thread-pool + 1 + #:thread-lifetime 2 + #:thread-initializer + (lambda () + (list (make-atomic-box 2)))))) + + (define (ref-and-decrement box) + (let ((val (atomic-box-ref box))) + (atomic-box-set! box (- val 1)) + val)) + + (unless (= 2 (call-with-thread + thread-pool + ref-and-decrement)) + (error)) + (unless (= 1 (call-with-thread + thread-pool + ref-and-decrement)) + (error)) + (unless (= 2 (call-with-thread + thread-pool + ref-and-decrement)) + (error))) + (display "thread-pool test finished successfully\n") From d07e309566cec93aa9f630bd4558ae464c37ad3a Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 24 Nov 2025 17:06:27 +0000 Subject: [PATCH 33/78] Fix a bug with resource pool idle checking The fiber would never finish. --- knots/resource-pool.scm | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 301abbd..2efbeab 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -1178,9 +1178,16 @@ (when idle-seconds (spawn-fiber (lambda () - (while #t - (sleep idle-seconds) - (put-message channel '(check-for-idle-resources)))))) + (let loop () + (put-message channel '(check-for-idle-resources)) + (when (choice-operation + (wrap-operation + (sleep-operation idle-seconds) + (const #t)) + (wrap-operation + (wait-operation destroy-condition) + (const #f))) + (loop)))))) (with-exception-handler (lambda (exn) From 3eba6fc8209f254b8068459a59d0056a629528d9 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 24 Nov 2025 21:54:00 +0000 Subject: [PATCH 34/78] Rework the resource pool implementations Don't rely on resource equality for keeping track of resources and make some other tweaks. --- knots/resource-pool.scm | 1017 +++++++++++++++++++-------------------- tests/resource-pool.scm | 24 + 2 files changed, 507 insertions(+), 534 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 2efbeab..3638500 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -21,6 +21,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-43) #:use-module (srfi srfi-71) #:use-module (ice-9 q) #:use-module (ice-9 match) @@ -81,7 +82,8 @@ (make-resource-pool-record name channel destroy-condition configuration) resource-pool? (name resource-pool-name) - (channel resource-pool-channel) + (channel resource-pool-channel + set-resource-pool-channel!) (destroy-condition resource-pool-destroy-condition) (configuration resource-pool-configuration)) @@ -93,14 +95,6 @@ (resource-pool-name resource-pool)) port))) -(define (remove-at-index! lst i) - (let ((start - end - (split-at! lst i))) - (append - start - (cdr end)))) - (define (safe-deq q) (if (null? (car q)) #f @@ -111,11 +105,51 @@ (set-car! q next) it))) -(define* (make-fixed-size-resource-pool resources +(define-record-type + (make-resource-details value checkout-count last-used) + resource-details? + (value resource-details-value) + (checkout-count resource-details-checkout-count + set-resource-details-checkout-count!) + (last-used resource-details-last-used + set-resource-details-last-used!)) + +(define-inlinable (increment-resource-checkout-count! resource) + (set-resource-details-checkout-count! + resource + (1+ (resource-details-checkout-count resource)))) + +(define-inlinable (decrement-resource-checkout-count! resource) + (set-resource-details-checkout-count! + resource + (1+ (resource-details-checkout-count resource)))) + +(define (spawn-fiber-for-checkout channel + reply-channel + reply-timeout + resource-id + resource) + (spawn-fiber + (lambda () + (let ((checkout-success? + (perform-operation + (choice-operation + (wrap-operation + (put-operation reply-channel + (list 'success resource-id resource)) + (const #t)) + (wrap-operation (sleep-operation + reply-timeout) + (const #f)))))) + (unless checkout-success? + (put-message + channel + (list 'return-failed-checkout resource-id))))))) + +(define* (make-fixed-size-resource-pool resources-list-or-vector #:key (delay-logger (const #f)) (duration-logger (const #f)) - destructor scheduler (name "unnamed") default-checkout-timeout @@ -131,7 +165,6 @@ destroy-condition `((delay-logger . ,delay-logger) (duration-logger . ,duration-logger) - (destructor . ,destructor) (scheduler . ,scheduler) (name . ,name) (default-checkout-timeout . ,default-checkout-timeout) @@ -139,58 +172,24 @@ (define checkout-failure-count 0) - (define (spawn-fiber-to-destroy-resource resource) - (spawn-fiber - (lambda () - (let loop () - (let ((success? - (with-exception-handler - (lambda _ #f) - (lambda () - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception running resource pool destructor (~A): ~A\n" - name - destructor) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (start-stack #t (destructor resource)) - #t))) - #:unwind? #t))) + (define resources + (vector-map + (lambda (_ resource) + (make-resource-details + resource + 0 + #f)) + (if (vector? resources-list-or-vector) + resources-list-or-vector + (list->vector resources-list-or-vector)))) - (if success? - (put-message channel - (list 'remove resource)) - (begin - (sleep 5) + (define (destroy-loop) + (define (empty?) + (vector-every (lambda (r) + (eq? r #f)) + resources)) - (loop)))))))) - - (define (spawn-fiber-for-checkout reply-channel - reply-timeout - resource) - (spawn-fiber - (lambda () - (let ((checkout-success? - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply-channel - (cons 'success resource)) - (const #t)) - (wrap-operation (sleep-operation - reply-timeout) - (const #f)))))) - (unless checkout-success? - (put-message - channel - (list 'return-failed-checkout resource))))))) - - (define (destroy-loop resources) - (let loop ((resources resources)) + (let loop () (match (get-message channel) (('checkout reply timeout-time max-waiters) (spawn-fiber @@ -211,40 +210,27 @@ internal-time-units-per-second)) (const #f))) op))))) - (loop resources)) + (loop)) (((and (or 'return - 'return-failed-checkout - 'remove) + 'return-failed-checkout) return-type) - resource) - (when (and (not (eq? return-type 'remove)) - destructor) - (spawn-fiber-to-destroy-resource resource)) + resource-id) + (vector-set! resources + resource-id + #f) - (let ((index - (list-index (lambda (x) - (eq? x resource)) - resources))) - (let ((new-resources - (if index - (remove-at-index! resources index) - (begin - (simple-format - (current-error-port) - "resource pool error: unable to remove ~A\n" - resource) - resources)))) - (if (null? new-resources) - (begin - (signal-condition! destroy-condition) + (if (empty?) + (begin + (set-resource-pool-channel! pool #f) + (signal-condition! destroy-condition) - ;; No loop - *unspecified*) - (loop new-resources))))) + ;; No loop + *unspecified*) + (loop))) (('stats reply timeout-time) (let ((stats - `((resources . ,(length resources)) + `((resources . ,(vector-length resources)) (available . 0) (waiters . 0) (checkout-failure-count . ,checkout-failure-count)))) @@ -263,21 +249,20 @@ internal-time-units-per-second))) op)))))) - (loop resources)) + (loop)) - (('destroy reply) - (loop resources)) + (('destroy) + (loop)) (unknown (simple-format (current-error-port) "unrecognised message to ~A resource pool channel: ~A\n" name unknown) - (loop resources))))) + (loop))))) (define (main-loop) - (let loop ((resources resources) - (available resources) + (let loop ((available (iota (vector-length resources))) (waiters (make-q))) (match (get-message channel) @@ -307,11 +292,9 @@ internal-time-units-per-second)) (const #f))) op))))) - (loop resources - available + (loop available waiters)) - (loop resources - available + (loop available (enq! waiters (cons reply timeout-time))))) (if timeout-time @@ -323,32 +306,45 @@ (let ((reply-timeout (/ (- timeout-time current-internal-time) - internal-time-units-per-second))) + internal-time-units-per-second)) + (resource-id + new-available + (car+cdr available))) ;; 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 - (car available)) - (loop resources - (cdr available) + (spawn-fiber-for-checkout + channel + reply + reply-timeout + resource-id + (resource-details-value + (vector-ref resources + resource-id))) + (loop new-available waiters)) - (loop resources - available + (loop available waiters))) - (begin - (put-message reply (cons 'success - (car available))) + (let* ((resource-id + next-available + (car+cdr available)) + (resource-details + (vector-ref resources + resource-id))) + (put-message reply + (list 'success + resource-id + (resource-details-value + resource-details))) - (loop resources - (cdr available) + (loop next-available waiters))))) (((and (or 'return 'return-failed-checkout) return-type) - resource) + resource-id) (when (eq? 'return-failed-checkout return-type) @@ -360,8 +356,7 @@ (let waiter-loop ((waiter (safe-deq waiters))) (match waiter (#f - (loop resources - (cons resource available) + (loop (cons resource-id available) waiters)) ((reply . timeout) (if (and timeout @@ -376,13 +371,21 @@ ;; 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 + (spawn-fiber-for-checkout + channel + reply + reply-timeout + resource-id + (resource-details-value + (vector-ref resources + resource-id)))) + (put-message reply + (list 'success + resource-id + (resource-details-value + (vector-ref resources + resource-id)))))) + (loop available waiters)))))) (('list-resources reply) @@ -390,13 +393,12 @@ (lambda () (put-message reply (list-copy resources)))) - (loop resources - available + (loop available waiters)) (('stats reply timeout-time) (let ((stats - `((resources . ,(length resources)) + `((resources . ,(vector-length resources)) (available . ,(length available)) (waiters . ,(q-length waiters)) (checkout-failure-count . ,checkout-failure-count)))) @@ -415,62 +417,46 @@ internal-time-units-per-second))) op)))))) - (loop resources - available + (loop available waiters)) (('destroy) - (if (and (null? resources) - (q-empty? waiters)) - (signal-condition! - destroy-condition) + (let ((current-internal-time (get-internal-real-time))) + ;; Notify all waiters that the pool has been destroyed + (for-each + (match-lambda + ((reply . timeout) + (when (or (not timeout) + (> timeout current-internal-time)) + (spawn-fiber + (lambda () + (let ((op + (put-operation + reply + (cons 'resource-pool-destroyed + #f)))) + (perform-operation + (if timeout + (choice-operation + op + (wrap-operation + (sleep-operation + (/ (- timeout + (get-internal-real-time)) + internal-time-units-per-second)) + (const #f))) + op)))))))) + (car waiters)) - (let ((current-internal-time (get-internal-real-time))) - (for-each - (match-lambda - ((reply . timeout) - (when (or (not timeout) - (> timeout current-internal-time)) - (spawn-fiber - (lambda () - (let ((op - (put-operation - reply - (cons 'resource-pool-destroyed - #f)))) - (perform-operation - (if timeout - (choice-operation - op - (wrap-operation - (sleep-operation - (/ (- timeout - (get-internal-real-time)) - internal-time-units-per-second)) - (const #f))) - op)))))))) - (car waiters)) + (if (= (vector-length resources) + (length available)) + (begin + (set-resource-pool-channel! pool #f) + (signal-condition! destroy-condition) - (if destructor - (begin - (for-each - (lambda (resource) - (spawn-fiber-to-destroy-resource resource)) - available) - (destroy-loop resources)) - (let dl ((resources resources) - (available available)) - (if (null? available) - (if (null? resources) - (signal-condition! - destroy-condition) - (destroy-loop resources)) - (let ((index - (list-index (lambda (x) - (eq? x (car available))) - resources))) - (dl (remove-at-index! resources index) - (cdr available))))))))) + ;; No loop + *unspecified*) + (destroy-loop)))) (unknown (simple-format @@ -478,8 +464,7 @@ "unrecognised message to ~A resource pool channel: ~A\n" name unknown) - (loop resources - available + (loop available waiters))))) (spawn-fiber @@ -551,6 +536,12 @@ (define checkout-failure-count 0) + (define resources + (make-hash-table)) + + (define-inlinable (count-resources resources) + (hash-count (const #t) resources)) + (define return-new-resource/parallelism-limiter (make-parallelism-limiter (or add-resources-parallelism @@ -575,9 +566,8 @@ (let ((max-size (assq-ref (resource-pool-configuration pool) 'max-size)) - (size (assq-ref (resource-pool-stats pool #:timeout #f) - 'resources))) - (unless (= size max-size) + (size (count-resources resources))) + (unless (>= size max-size) (with-exception-handler (lambda _ #f) (lambda () @@ -598,64 +588,51 @@ #:unwind? #t))))) #:unwind? #t)))) - (define (spawn-fiber-to-destroy-resource resource) + (define (spawn-fiber-to-destroy-resource resource-id resource-details) (spawn-fiber (lambda () (let loop () - (let ((success? - (with-exception-handler - (lambda _ #f) - (lambda () - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception running resource pool destructor (~A): ~A\n" - name - destructor) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (start-stack #t (destructor resource)) - #t))) - #:unwind? #t))) + (let* ((resource + (resource-details-value resource-details)) + (success? + (with-exception-handler + (lambda _ #f) + (lambda () + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception running resource pool destructor (~A): ~A\n" + name + destructor) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (start-stack #t (destructor resource)) + #t))) + #:unwind? #t))) (if success? (put-message channel - (list 'remove resource)) + (list 'remove resource-id)) (begin (sleep 5) (loop)))))))) - (define (spawn-fiber-for-checkout reply-channel - reply-timeout - resource) - (spawn-fiber - (lambda () - (let ((checkout-success? - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply-channel - (cons 'success resource)) - (const #t)) - (wrap-operation (sleep-operation - reply-timeout) - (const #f)))))) - (unless checkout-success? - (put-message - channel - (list 'return-failed-checkout resource))))))) - - (define (destroy-loop resources) - (let loop ((resources resources)) + (define (destroy-loop resources next-resource-id) + (let loop ((next-resource-id next-resource-id)) (match (get-message channel) (('add-resource resource) - (when destructor - (spawn-fiber-to-destroy-resource resource)) + (if destructor + (begin + (spawn-fiber-to-destroy-resource next-resource-id + resource) + (hash-set! resources next-resource-id resource) + + (loop (1+ next-resource-id))) + (loop next-resource-id))) - (loop resources)) (('checkout reply timeout-time max-waiters) (spawn-fiber (lambda () @@ -675,43 +652,31 @@ internal-time-units-per-second)) (const #f))) op))))) - (loop resources)) + (loop next-resource-id)) (((and (or 'return 'return-failed-checkout 'remove) return-type) - resource) + resource-id) (when (and (not (eq? return-type 'remove)) destructor) - (spawn-fiber-to-destroy-resource resource)) + (spawn-fiber-to-destroy-resource + resource-id + (hash-ref resources resource-id))) - (let ((index - (list-index (lambda (x) - (eq? x resource)) - resources))) - (let ((new-resources - (if index - (remove-at-index! resources index) - (begin - (simple-format - (current-error-port) - "resource pool error: unable to remove ~A\n" - resource) - resources)))) - (if (null? new-resources) - (begin - (and=> return-new-resource/parallelism-limiter - destroy-parallelism-limiter) + (hash-remove! resources resource-id) - (signal-condition! destroy-condition) - - ;; No loop - *unspecified*) - (loop new-resources))))) + (if (= 0 (count-resources resources)) + (begin + (set-resource-pool-channel! pool #f) + (signal-condition! destroy-condition) + ;; No loop + *unspecified*) + (loop next-resource-id))) (('stats reply timeout-time) (let ((stats - `((resources . ,(length resources)) + `((resources . ,(count-resources resources)) (available . 0) (waiters . 0) (checkout-failure-count . ,checkout-failure-count)))) @@ -730,59 +695,63 @@ internal-time-units-per-second))) op)))))) - (loop resources)) + (loop next-resource-id)) (('check-for-idle-resources) - (loop resources)) + (loop next-resource-id)) - (('destroy reply) - (loop resources)) + (('destroy) + (loop next-resource-id)) (unknown (simple-format (current-error-port) "unrecognised message to ~A resource pool channel: ~A\n" name unknown) - (loop resources))))) + (loop next-resource-id))))) (define (main-loop) - (let loop ((resources '()) + (let loop ((next-resource-id 0) (available '()) - (waiters (make-q)) - (resources-checkout-count '()) - (resources-last-used '())) + (waiters (make-q))) (match (get-message channel) (('add-resource resource) - (if (= (length resources) max-size) - (begin - (if destructor - (begin - (spawn-fiber-to-destroy-resource resource) + (if (= (count-resources resources) max-size) + (if destructor + (begin + (hash-set! resources + next-resource-id + (make-resource-details + resource + 0 + (get-internal-real-time))) + (spawn-fiber-to-destroy-resource next-resource-id + resource) - (loop (cons resource resources) - available - waiters - (cons 0 resources-checkout-count) - (cons (get-internal-real-time) - resources-last-used))) - (loop resources + (loop (1+ next-resource-id) available - waiters - resources-checkout-count - resources-last-used))) + waiters)) + (loop next-resource-id + available + waiters)) - (let ((current-internal-time - (get-internal-real-time))) + (let* ((current-internal-time + (get-internal-real-time)) + (resource-details + (make-resource-details + resource + 0 + current-internal-time))) + (hash-set! resources + next-resource-id + resource-details) (let waiter-loop ((waiter (safe-deq waiters))) (match waiter (#f - (loop (cons resource resources) - (cons resource available) - waiters - (cons 0 resources-checkout-count) - (cons current-internal-time - resources-last-used))) + (loop (1+ next-resource-id) + (cons resource-details available) + waiters)) ((reply . timeout) (if (and timeout (< timeout current-internal-time)) @@ -796,22 +765,24 @@ ;; new fiber to handle handing over the ;; resource, and returning it if there's ;; a timeout - (spawn-fiber-for-checkout reply + (spawn-fiber-for-checkout channel + reply reply-timeout + next-resource-id resource)) - (put-message reply (cons 'success + (put-message reply (list 'success + next-resource-id resource)))) - (loop (cons resource resources) + (set-resource-details-checkout-count! resource-details + 1) + (loop (1+ next-resource-id) available - waiters - (cons 1 resources-checkout-count) - (cons current-internal-time - resources-last-used)))))))) + waiters))))))) (('checkout reply timeout-time max-waiters) (if (null? available) (begin - (unless (= (length resources) max-size) + (unless (= (count-resources resources) max-size) (spawn-fiber-to-return-new-resource)) (let ((waiters-count @@ -838,16 +809,12 @@ internal-time-units-per-second)) (const #f))) op))))) - (loop resources + (loop next-resource-id available - waiters - resources-checkout-count - resources-last-used)) - (loop resources + waiters)) + (loop next-resource-id available - (enq! waiters (cons reply timeout-time)) - resources-checkout-count - resources-last-used)))) + (enq! waiters (cons reply timeout-time)))))) (if timeout-time (let ((current-internal-time @@ -855,59 +822,55 @@ ;; If this client is still waiting (if (> timeout-time current-internal-time) - (let ((reply-timeout - (/ (- timeout-time - current-internal-time) - internal-time-units-per-second))) + (let* ((reply-timeout + (/ (- timeout-time + current-internal-time) + internal-time-units-per-second)) + (resource-id + (car available)) + (resource-details + (hash-ref resources resource-id))) + + (increment-resource-checkout-count! + resource-details) ;; 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 + (spawn-fiber-for-checkout channel + reply reply-timeout - (car available)) - (loop resources + resource-id + (resource-details-value + resource-details)) + (loop next-resource-id (cdr available) - waiters - (let ((resource-index - (list-index (lambda (x) - (eq? x (car available))) - resources))) - (list-set! resources-checkout-count - resource-index - (+ 1 (list-ref - resources-checkout-count - resource-index))) - resources-checkout-count) - resources-last-used)) - (loop resources + waiters)) + (loop next-resource-id available - waiters - resources-checkout-count - resources-last-used))) - (begin - (put-message reply (cons 'success - (car available))) + waiters))) + (let* ((resource-id + next-available + (car+cdr available)) + (resource-details + (hash-ref resources + resource-id))) + (increment-resource-checkout-count! resource-details) - (loop resources - (cdr available) - waiters - (let ((resource-index - (list-index (lambda (x) - (eq? x (car available))) - resources))) - (list-set! resources-checkout-count - resource-index - (+ 1 (list-ref - resources-checkout-count - resource-index))) - resources-checkout-count) - resources-last-used))))) + (put-message reply + (list 'success + resource-id + (resource-details-value + resource-details))) + + (loop next-resource-id + next-available + waiters))))) (((and (or 'return 'return-failed-checkout) return-type) - resource) + resource-id) (when (eq? 'return-failed-checkout return-type) @@ -916,44 +879,30 @@ (let ((current-internal-time (get-internal-real-time)) - (resource-index - (list-index (lambda (x) - (eq? x resource)) - resources))) + (resource-details + (hash-ref resources resource-id))) (if (and lifetime - (>= (list-ref resources-checkout-count - resource-index) + (>= (resource-details-checkout-count resource-details) lifetime)) (begin - (spawn-fiber-to-destroy-resource resource) - (loop resources + (spawn-fiber-to-destroy-resource resource-id + resource-details) + (loop next-resource-id available - waiters - resources-checkout-count - resources-last-used)) + waiters)) (let waiter-loop ((waiter (safe-deq waiters))) (match waiter (#f - (loop resources - (cons resource available) - waiters - (if (eq? 'return-failed-checkout - return-type) - (begin - (list-set! resources-checkout-count - resource-index - (- (list-ref resources-checkout-count - resource-index) - 1)) - resources-checkout-count) - resources-checkout-count) - (begin - (when (eq? return-type 'return) - (list-set! - resources-last-used - resource-index - current-internal-time)) - resources-last-used))) + (if (eq? 'return-failed-checkout + return-type) + (decrement-resource-checkout-count! resource-details) + (set-resource-details-last-used! + resource-details + current-internal-time)) + + (loop next-resource-id + (cons resource-id available) + waiters)) ((reply . timeout) (if (and timeout (< timeout current-internal-time)) @@ -967,85 +916,74 @@ ;; 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 + (spawn-fiber-for-checkout + channel + reply + reply-timeout + resource-id + (resource-details-value resource-details))) + (put-message reply + (list 'success + resource-id + (resource-details-value + resource-details))))) + + (set-resource-details-last-used! resource-details + current-internal-time) + (when (eq? 'return-failed-checkout + return-type) + (decrement-resource-checkout-count! resource-details)) + + (loop next-resource-id available - waiters - (if (eq? 'return-failed-checkout - return-type) - (begin - (list-set! resources-checkout-count - resource-index - (- (list-ref resources-checkout-count - resource-index) - 1)) - resources-checkout-count) - resources-checkout-count) - (begin - (list-set! - resources-last-used - resource-index - current-internal-time) - resources-last-used)))))))) + waiters))))))) - (('remove resource) - (let ((index - (list-index (lambda (x) - (eq? x resource)) - resources))) + (('remove resource-id) + (hash-remove! resources + resource-id) - (when (and (not (q-empty? waiters)) - (< (- (length resources) 1) - max-size)) - (spawn-fiber-to-return-new-resource)) + (when (and (not (q-empty? waiters)) + (< (- (count-resources resources) 1) + max-size)) + (spawn-fiber-to-return-new-resource)) - (loop (if index - (remove-at-index! resources index) - (begin - (simple-format - (current-error-port) - "resource pool error: unable to remove ~A\n" - resource) - resources)) - available ; resource shouldn't be in this list - waiters - (remove-at-index! - resources-checkout-count - index) - (remove-at-index! - resources-last-used - index)))) + (loop next-resource-id + available ; resource shouldn't be in this list + waiters)) - (('destroy resource) - (spawn-fiber-to-destroy-resource resource) + (('destroy resource-id) + (let ((resource-details + (hash-ref resources + resource-id))) + (spawn-fiber-to-destroy-resource resource-id + resource-details) - (loop resources - available - waiters - resources-checkout-count - resources-last-used)) + (loop next-resource-id + available + waiters))) (('list-resources reply) (spawn-fiber (lambda () (put-message reply (list-copy resources)))) - (loop resources + (loop next-resource-id available - waiters - resources-checkout-count - resources-last-used)) + waiters)) (('stats reply timeout-time) (let ((stats - `((resources . ,(length resources)) + `((resources . ,(count-resources resources)) (available . ,(length available)) (waiters . ,(q-length waiters)) - (resources-checkout-count . ,resources-checkout-count) + (resources-checkout-count + . ,(hash-fold + (lambda (_ resource-details result) + (cons (resource-details-checkout-count + resource-details) + result)) + '() + resources)) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber @@ -1062,116 +1000,109 @@ internal-time-units-per-second))) op)))))) - (loop resources + (loop next-resource-id available - waiters - resources-checkout-count - resources-last-used)) + waiters)) (('check-for-idle-resources) - (let* ((resources-last-used-seconds - (map - (lambda (internal-time) - (/ (- (get-internal-real-time) internal-time) - internal-time-units-per-second)) - resources-last-used)) - (candidate-resources-to-destroy + (let* ((internal-real-time + (get-internal-real-time)) + (candidate-resource-ids-to-destroy (filter-map - (lambda (resource last-used-seconds) - (if (and (member resource available) - (> last-used-seconds idle-seconds)) - resource - #f)) - resources - resources-last-used-seconds))) + (lambda (resource-id) + (let ((resource-details + (hash-ref resources resource-id))) + (if (> (/ (- internal-real-time + (resource-details-last-used + resource-details)) + internal-time-units-per-second) + idle-seconds) + resource-id + #f))) + available)) + (max-resources-to-destroy + (max 0 + (- (count-resources resources) + min-size))) + (resources-to-destroy + (take candidate-resource-ids-to-destroy + (min max-resources-to-destroy + (length candidate-resource-ids-to-destroy))))) + (when destructor + (for-each + (lambda (resource-id) + (spawn-fiber-to-destroy-resource + resource-id + (hash-ref resources resource-id))) + resources-to-destroy)) - (let* ((available-resources-to-destroy - (lset-intersection eq? - available - candidate-resources-to-destroy)) - (max-resources-to-destroy - (max 0 - (- (length resources) - min-size))) - (resources-to-destroy - (take available-resources-to-destroy - (min max-resources-to-destroy - (length available-resources-to-destroy))))) - (when destructor - (for-each - (lambda (resource) - (spawn-fiber-to-destroy-resource resource)) - resources-to-destroy)) - - (loop resources - (lset-difference eq? available resources-to-destroy) - waiters - resources-checkout-count - resources-last-used)))) + (loop next-resource-id + (lset-difference = available resources-to-destroy) + waiters))) (('destroy) - (if (and (null? resources) - (q-empty? waiters)) - (signal-condition! - destroy-condition) + (let ((current-internal-time (get-internal-real-time))) + (for-each + (match-lambda + ((reply . timeout) + (when (or (not timeout) + (> timeout current-internal-time)) + (spawn-fiber + (lambda () + (let ((op + (put-operation + reply + (cons 'resource-pool-destroyed + #f)))) + (perform-operation + (if timeout + (choice-operation + op + (wrap-operation + (sleep-operation + (/ (- timeout + (get-internal-real-time)) + internal-time-units-per-second)) + (const #f))) + op)))))))) + (car waiters)) - (let ((current-internal-time (get-internal-real-time))) - (for-each - (match-lambda - ((reply . timeout) - (when (or (not timeout) - (> timeout current-internal-time)) - (spawn-fiber - (lambda () - (let ((op - (put-operation - reply - (cons 'resource-pool-destroyed - #f)))) - (perform-operation - (if timeout - (choice-operation - op - (wrap-operation - (sleep-operation - (/ (- timeout - (get-internal-real-time)) - internal-time-units-per-second)) - (const #f))) - op)))))))) - (car waiters)) + (when destructor + (for-each + (lambda (resource-id) + (spawn-fiber-to-destroy-resource + resource-id + (hash-ref resources + resource-id))) + available)) + + ;; Do this in parallel to avoid deadlocks between the + ;; limiter and returning new resources to this pool + (and=> return-new-resource/parallelism-limiter + (lambda (limiter) + (spawn-fiber + (lambda () + (destroy-parallelism-limiter limiter))))) + + (if (or (= 0 (count-resources resources)) + (not destructor)) + (begin + (set-resource-pool-channel! pool #f) + (signal-condition! destroy-condition) + + ;; No loop + *unspecified*) + (destroy-loop resources next-resource-id)))) - (if destructor - (begin - (for-each - (lambda (resource) - (spawn-fiber-to-destroy-resource resource)) - available) - (destroy-loop resources)) - (let dl ((resources resources) - (available available)) - (if (null? available) - (if (null? resources) - (signal-condition! - destroy-condition) - (destroy-loop resources)) - (let ((index - (list-index (lambda (x) - (eq? x (car available))) - resources))) - (dl (remove-at-index! resources index) - (cdr available))))))))) (unknown (simple-format (current-error-port) "unrecognised message to ~A resource pool channel: ~A\n" name unknown) - (loop resources + (loop next-resource-id available - waiters - resources-checkout-count - resources-last-used))))) + waiters))))) (spawn-fiber (lambda () @@ -1322,6 +1253,10 @@ available. Return the resource once PROC has returned." 'default-max-waiters) max-waiters)) + (unless channel + (raise-exception + (make-resource-pool-destroyed-error pool))) + (let ((reply (if timeout-or-default (let loop ((reply (make-channel)) @@ -1389,7 +1324,7 @@ available. Return the resource once PROC has returned." (('resource-pool-destroyed . #f) (raise-exception (make-resource-pool-destroyed-error pool))) - (('success . resource) + (('success resource-id resource-value) (call-with-values (lambda () (with-exception-handler @@ -1398,12 +1333,12 @@ available. Return the resource once PROC has returned." ;; this avoids inconsistent behaviour with ;; continuation barriers (put-message - (resource-pool-channel pool) + channel (list (if (or destroy-resource-on-exception? (resource-pool-destroy-resource-exception? exn)) 'destroy 'return) - resource)) + resource-id)) (raise-exception exn)) (lambda () (with-exception-handler @@ -1421,11 +1356,11 @@ available. Return the resource once PROC has returned." exn (make-knots-exception stack))))) (lambda () - (proc resource)))) + (proc resource-value)))) #:unwind? #t)) (lambda vals - (put-message (resource-pool-channel pool) - `(return ,resource)) + (put-message channel + `(return ,resource-id)) (apply values vals))))))) (define-syntax-rule (with-resource-from-pool pool resource exp ...) @@ -1434,6 +1369,13 @@ available. Return the resource once PROC has returned." (lambda (resource) exp ...))) (define* (resource-pool-stats pool #:key (timeout 5)) + (define channel + (resource-pool-channel pool)) + + (unless channel + (raise-exception + (make-resource-pool-destroyed-error pool))) + (if timeout (let* ((reply (make-channel)) (start-time (get-internal-real-time)) @@ -1443,7 +1385,7 @@ available. Return the resource once PROC has returned." (perform-operation (choice-operation (wrap-operation - (put-operation (resource-pool-channel pool) + (put-operation channel `(stats ,reply ,timeout-time)) (const #t)) (wrap-operation (sleep-operation timeout) @@ -1467,11 +1409,18 @@ available. Return the resource once PROC has returned." (raise-exception (make-resource-pool-timeout-error pool))))) (let ((reply (make-channel))) - (put-message (resource-pool-channel pool) + (put-message channel `(stats ,reply #f)) (get-message reply)))) (define (resource-pool-list-resources pool) + (define channel + (resource-pool-channel pool)) + + (unless channel + (raise-exception + (make-resource-pool-destroyed-error pool))) + (let ((reply (make-channel))) (put-message (resource-pool-channel pool) (list 'list-resources reply)) diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm index 3999dde..2e30cb9 100644 --- a/tests/resource-pool.scm +++ b/tests/resource-pool.scm @@ -1,9 +1,33 @@ (use-modules (tests) (fibers) + (fibers channels) (unit-test) (knots parallelism) (knots resource-pool)) +(run-fibers-for-tests + (lambda () + (let ((parallelism-limiter (make-parallelism-limiter + 1))) + (with-parallelism-limiter parallelism-limiter + #f) + + (destroy-parallelism-limiter parallelism-limiter)))) + +(run-fibers-for-tests + (lambda () + (let ((parallelism-limiter (make-parallelism-limiter + 1)) + (channel + (make-channel))) + (spawn-fiber + (lambda () + (with-parallelism-limiter parallelism-limiter + (put-message channel #t) + (sleep 1)))) + (get-message channel) + (destroy-parallelism-limiter parallelism-limiter)))) + (define new-number (let ((val 0)) (lambda () From 04d964a9f8ce007ed2fc53f47eca6435c83973b9 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 25 Nov 2025 09:37:29 +0000 Subject: [PATCH 35/78] Fix adding the resource id to the available list --- knots/resource-pool.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 3638500..73f7083 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -750,7 +750,7 @@ (match waiter (#f (loop (1+ next-resource-id) - (cons resource-details available) + (cons next-resource-id available) waiters)) ((reply . timeout) (if (and timeout From 9cce89fc0122126b1ccd180d637f83a3d1f00cd7 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 25 Nov 2025 09:58:45 +0000 Subject: [PATCH 36/78] Change how spawn-fiber-to-destroy-resource is used And fix a couple of incorrect uses. --- knots/resource-pool.scm | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 73f7083..739ec4f 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -588,13 +588,11 @@ #:unwind? #t))))) #:unwind? #t)))) - (define (spawn-fiber-to-destroy-resource resource-id resource-details) + (define (spawn-fiber-to-destroy-resource resource-id resource-value) (spawn-fiber (lambda () (let loop () - (let* ((resource - (resource-details-value resource-details)) - (success? + (let* ((success? (with-exception-handler (lambda _ #f) (lambda () @@ -608,7 +606,7 @@ (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () - (start-stack #t (destructor resource)) + (start-stack #t (destructor resource-value)) #t))) #:unwind? #t))) @@ -662,7 +660,8 @@ destructor) (spawn-fiber-to-destroy-resource resource-id - (hash-ref resources resource-id))) + (resource-details-value + (hash-ref resources resource-id)))) (hash-remove! resources resource-id) @@ -886,7 +885,8 @@ lifetime)) (begin (spawn-fiber-to-destroy-resource resource-id - resource-details) + (resource-details-value + resource-details)) (loop next-resource-id available waiters)) @@ -956,7 +956,8 @@ (hash-ref resources resource-id))) (spawn-fiber-to-destroy-resource resource-id - resource-details) + (resource-details-value + resource-details)) (loop next-resource-id available @@ -1033,7 +1034,8 @@ (lambda (resource-id) (spawn-fiber-to-destroy-resource resource-id - (hash-ref resources resource-id))) + (resource-details-value + (hash-ref resources resource-id)))) resources-to-destroy)) (loop next-resource-id @@ -1072,8 +1074,9 @@ (lambda (resource-id) (spawn-fiber-to-destroy-resource resource-id - (hash-ref resources - resource-id))) + (resource-details-value + (hash-ref resources + resource-id)))) available)) ;; Do this in parallel to avoid deadlocks between the From 8100d36aa5bebb6c6fab114ae5595ace2be43b2e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 25 Nov 2025 09:58:58 +0000 Subject: [PATCH 37/78] Avoid errors about returning no values from a exception handler --- knots/resource-pool.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 739ec4f..f00e05b 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -558,8 +558,9 @@ (lambda (exn) ;; This can happen if the resource pool is destroyed very ;; quickly - (unless (resource-pool-destroyed-error? exn) - (raise-exception exn))) + (if (resource-pool-destroyed-error? exn) + #f + (raise-exception exn))) (lambda () (with-parallelism-limiter return-new-resource/parallelism-limiter From 9c123bbfa937413e759916f91cbc62e3966324c5 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 25 Nov 2025 14:26:39 +0000 Subject: [PATCH 38/78] Fix listing resource pool resources --- knots/resource-pool.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index f00e05b..2d96ed7 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -391,7 +391,7 @@ (('list-resources reply) (spawn-fiber (lambda () - (put-message reply (list-copy resources)))) + (put-message reply (vector->list resources)))) (loop available waiters)) @@ -967,7 +967,9 @@ (('list-resources reply) (spawn-fiber (lambda () - (put-message reply (list-copy resources)))) + (put-message reply (hash-map->list + (lambda (_ value) value) + resources)))) (loop next-resource-id available From 05f7daf0e9b866dd3f8d997b49c6ae14b30d635c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 26 Nov 2025 10:06:09 +0000 Subject: [PATCH 39/78] Add another resource pool test --- tests/resource-pool.scm | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm index 2e30cb9..b3a84d7 100644 --- a/tests/resource-pool.scm +++ b/tests/resource-pool.scm @@ -252,4 +252,34 @@ (destroy-resource-pool resource-pool)))) +;; Test allocating resources to waiters and destroying resources +(run-fibers-for-tests + (lambda () + (let ((resource-pool (make-resource-pool + (lambda () + (sleep 1) + 'res) + 2 + #:idle-seconds 1 + #:add-resources-parallelism 10 + #:destructor + (const #t)))) + (fibers-for-each + (lambda _ + (with-resource-from-pool resource-pool + res + res)) + (iota 20)) + + (sleep 2) + + (fibers-for-each + (lambda _ + (with-resource-from-pool resource-pool + res + res)) + (iota 20)) + + (destroy-resource-pool resource-pool)))) + (display "resource-pool test finished successfully\n") From a8e07b738b558d701c6de1f5ee6452ee4095198e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 26 Nov 2025 10:06:20 +0000 Subject: [PATCH 40/78] Fix a resource pool bug with idle seconds Actually perform the choice operation. --- knots/resource-pool.scm | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 2d96ed7..f957c3d 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -1117,13 +1117,14 @@ (lambda () (let loop () (put-message channel '(check-for-idle-resources)) - (when (choice-operation - (wrap-operation - (sleep-operation idle-seconds) - (const #t)) - (wrap-operation - (wait-operation destroy-condition) - (const #f))) + (when (perform-operation + (choice-operation + (wrap-operation + (sleep-operation idle-seconds) + (const #t)) + (wrap-operation + (wait-operation destroy-condition) + (const #f)))) (loop)))))) (with-exception-handler From f64e435b5710c3602c223c5027e515f0f6aefc02 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 6 Dec 2025 10:02:58 +0000 Subject: [PATCH 41/78] Use start-stack in fibers-force Otherwise the backtraces are more confusing. --- knots/promise.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/knots/promise.scm b/knots/promise.scm index 9df376b..6aa3f0b 100644 --- a/knots/promise.scm +++ b/knots/promise.scm @@ -82,7 +82,10 @@ (make-exception exn (make-knots-exception stack))))) - (fibers-promise-thunk fp))) + (lambda () + (start-stack + #t + ((fibers-promise-thunk fp)))))) #:unwind? #t)) (lambda vals (atomic-box-set! (fibers-promise-values-box fp) From b6746fffdefb0316223d6a8e820c90aa4607a495 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 5 Jan 2026 10:44:04 +0000 Subject: [PATCH 42/78] Add fibers-sort! --- knots/sort.scm | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++ tests/sort.scm | 28 ++++++++++++++++ 2 files changed, 116 insertions(+) create mode 100644 knots/sort.scm create mode 100644 tests/sort.scm diff --git a/knots/sort.scm b/knots/sort.scm new file mode 100644 index 0000000..dcad052 --- /dev/null +++ b/knots/sort.scm @@ -0,0 +1,88 @@ +;;; Guile Knots +;;; Copyright © 2020, 2025 Christopher Baines +;;; +;;; This file is part of Guile Knots. +;;; +;;; The Guile Knots is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; The Guile Knots is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with the guix-data-service. If not, see +;;; . + +(define-module (knots sort) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module (fibers scheduler) + #:use-module (knots promise) + #:export (fibers-sort!)) + +(define (try-split-at! lst i) + (cond ((< i 0) + (error "negitive split size")) + ((= i 0) + (values '() lst)) + (else + (let lp ((l lst) (n (- i 1))) + (if (<= n 0) + (let ((tmp (cdr l))) + (unless (null? tmp) + (set-cdr! l '())) + (values lst tmp)) + (if (or (null? l) + (null? (cdr l))) + (values lst '()) + (lp (cdr l) (- n 1)))))))) + +(define (chunk! lst max-length) + (let loop ((chunks '()) + (lst lst)) + (let ((chunk + rest + (try-split-at! lst max-length))) + (if (null? rest) + (reverse! (cons chunk chunks)) + (loop (cons chunk chunks) + rest))))) + +(define* (fibers-sort! items less #:key parallelism) + (define requested-chunk-count + (or parallelism + (+ 1 (length (scheduler-remote-peers (current-scheduler)))))) + + (define items-length (length items)) + + (if (= 0 items-length) + items + (let* ((chunk-length (ceiling (/ items-length + requested-chunk-count))) + (chunks (chunk! items chunk-length))) + (let loop ((sorted-chunk-promises + (map + (lambda (chunk) + (fibers-delay/eager + (lambda () + (sort! chunk less)))) + chunks))) + (if (null? (cdr sorted-chunk-promises)) + (fibers-force + (first sorted-chunk-promises)) + (loop + (map + (match-lambda + ((items) items) + ((a b) + (fibers-delay/eager + (lambda () + (merge! (fibers-force a) + (fibers-force b) + less))))) + (chunk! sorted-chunk-promises 2)))))))) diff --git a/tests/sort.scm b/tests/sort.scm new file mode 100644 index 0000000..a80b84b --- /dev/null +++ b/tests/sort.scm @@ -0,0 +1,28 @@ +(use-modules (tests) + (fibers) + (unit-test) + (knots sort)) + +(run-fibers-for-tests + (lambda () + (assert-equal + '() + (fibers-sort! '() <)) + + (assert-equal + '(1) + (fibers-sort! (list 1) <)) + + (assert-equal + '(1) + (fibers-sort! (list 1) < #:parallelism 10)) + + (assert-equal + '(1 2) + (fibers-sort! (list 2 1) <)) + + (assert-equal + (sort (reverse! (iota 100)) <) + (fibers-sort! (reverse! (iota 100)) < #:parallelism 10)))) + +(display "sort test finished successfully\n") From f38456b4c60510722ae815a9f09bd5d124da5690 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 5 Jan 2026 10:44:34 +0000 Subject: [PATCH 43/78] Add fibers-delay/eager --- knots/promise.scm | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/knots/promise.scm b/knots/promise.scm index 6aa3f0b..c01d219 100644 --- a/knots/promise.scm +++ b/knots/promise.scm @@ -28,6 +28,7 @@ #:export (fibers-promise? fibers-delay + fibers-delay/eager fibers-force fibers-promise-reset fibers-promise-result-available?)) @@ -105,6 +106,20 @@ (raise-exception res) (apply values res)))))) + +(define (fibers-delay/eager thunk) + (let ((promise (fibers-delay thunk))) + (spawn-fiber + (lambda () + (with-exception-handler + (lambda _ + ;; Silently handle this exception + #f) + (lambda () + (fibers-force promise)) + #:unwind? #t))) + promise)) + (define (fibers-promise-reset fp) (atomic-box-set! (fibers-promise-values-box fp) #f)) From b4342503d52b1efea57c6f80ba3660a2b38d8d20 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 5 Jan 2026 10:50:32 +0000 Subject: [PATCH 44/78] Sort Makefile lines --- Makefile.am | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/Makefile.am b/Makefile.am index 21851ae..4dbede3 100644 --- a/Makefile.am +++ b/Makefile.am @@ -7,20 +7,20 @@ SOURCES = \ knots/promise.scm \ knots/queue.scm \ knots/resource-pool.scm \ + knots/thread-pool.scm \ knots/timeout.scm \ - knots/web-server.scm \ - knots/thread-pool.scm + knots/web-server.scm SCM_TESTS = \ tests/non-blocking.scm \ - tests/promise.scm \ - tests/timeout.scm \ tests/non-blocking.scm \ - tests/queue.scm \ - tests/web-server.scm \ tests/parallelism.scm \ + tests/promise.scm \ + tests/queue.scm \ tests/resource-pool.scm \ - tests/thread-pool.scm + tests/thread-pool.scm \ + tests/timeout.scm \ + tests/web-server.scm TESTS_GOBJECTS = $(SCM_TESTS:%.scm=%.go) From 338d08081e5c90cc23978147394021fa84a4f5cc Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 5 Jan 2026 10:51:24 +0000 Subject: [PATCH 45/78] Add missing Makefile entries for the sort module --- Makefile.am | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Makefile.am b/Makefile.am index 4dbede3..5551fbe 100644 --- a/Makefile.am +++ b/Makefile.am @@ -7,6 +7,7 @@ SOURCES = \ knots/promise.scm \ knots/queue.scm \ knots/resource-pool.scm \ + knots/sort.scm \ knots/thread-pool.scm \ knots/timeout.scm \ knots/web-server.scm @@ -18,6 +19,7 @@ SCM_TESTS = \ tests/promise.scm \ tests/queue.scm \ tests/resource-pool.scm \ + tests/sort.scm \ tests/thread-pool.scm \ tests/timeout.scm \ tests/web-server.scm From 4642f7c7d2f56c19db6de8f9c8c4a85b21db394e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 9 Jan 2026 15:14:47 +0000 Subject: [PATCH 46/78] Fix some issues handling head requests Rather than raising an exception when there's a body provided, use the body as normal to inform the headers, as this is useful, and just don't write the body to the client. --- knots/web-server.scm | 121 ++++++++++++++++++++++--------------------- tests/web-server.scm | 65 +++++++++++++++++++++++ 2 files changed, 127 insertions(+), 59 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index 4d7240b..d0b13ce 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -228,8 +228,6 @@ on the procedure being called at any particular time." (adapt-response-version response (request-version request)) body)) - ((not body) - (values response #vu8())) ((string? body) (let* ((type (response-content-type response '(text/plain))) @@ -243,16 +241,15 @@ on the procedure being called at any particular time." `(,@type (charset . ,charset)))) (string->bytevector body charset)))) ((not (or (bytevector? body) - (procedure? body))) + (procedure? body) + (eq? #f body))) (raise-exception (make-exception-with-irritants (list (make-exception-with-message "unexpected body type") body)))) ((and (response-must-not-include-body? response) - body - ;; FIXME make this stricter: even an empty body should be prohibited. - (not (zero? (bytevector-length body)))) + body) (raise-exception (make-exception-with-irritants (list (make-exception-with-message @@ -262,25 +259,24 @@ on the procedure being called at any particular time." ;; check length; assert type; add other required fields? (values (response-maybe-add-connection-header-value request - (if (procedure? body) - (if (response-content-length response) - response - (extend-response response - 'transfer-encoding - '((chunked)))) - (let ((rlen (response-content-length response)) - (blen (bytevector-length body))) - (cond - (rlen (if (= rlen blen) - response - (error "bad content-length" rlen blen))) - (else (extend-response response 'content-length blen)))))) + (cond + ((procedure? body) + (if (response-content-length response) + response + (extend-response response + 'transfer-encoding + '((chunked))))) + ((bytevector? body) + (let ((rlen (response-content-length response)) + (blen (bytevector-length body))) + (cond + (rlen (if (= rlen blen) + response + (error "bad content-length" rlen blen))) + (else (extend-response response 'content-length blen))))) + (else response))) (if (eq? (request-method request) 'HEAD) - (raise-exception - (make-exception-with-irritants - (list (make-exception-with-message - "unexpected body type") - body))) + #f body))))) (define (with-stack-and-prompt thunk) @@ -405,41 +401,48 @@ on the procedure being called at any particular time." (let ((response-start-time (get-internal-real-time)) (body-written? - (if (procedure? body) - (let* ((type (response-content-type response - '(text/plain))) - (declared-charset (assq-ref (cdr type) 'charset)) - (charset (or declared-charset "ISO-8859-1")) - (body-port - (if (response-content-length response) - client - (make-chunked-output-port/knots - client - #:keep-alive? #t - #:buffering - (- buffer-size - (chunked-output-port-overhead-bytes - buffer-size)))))) - (set-port-encoding! body-port charset) - (let ((body-written? - (with-exception-handler - (lambda (exn) - #f) - (lambda () - (with-exception-handler - (lambda (exn) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (body body-port))) - #t) - #:unwind? #t))) - (unless (response-content-length response) - (close-port body-port)) - body-written?)) - (begin - (put-bytevector client body) - #t)))) + (cond + ((and (procedure? body) + (not + (eq? (request-method request) + 'HEAD))) + (let* ((type (response-content-type response + '(text/plain))) + (declared-charset (assq-ref (cdr type) 'charset)) + (charset (or declared-charset "ISO-8859-1")) + (body-port + (if (response-content-length response) + client + (make-chunked-output-port/knots + client + #:keep-alive? #t + #:buffering + (- buffer-size + (chunked-output-port-overhead-bytes + buffer-size)))))) + (set-port-encoding! body-port charset) + (let ((body-written? + (with-exception-handler + (lambda (exn) + #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (body body-port))) + #t) + #:unwind? #t))) + (unless (response-content-length response) + (close-port body-port)) + body-written?))) + ((bytevector? body) + (put-bytevector client body) + #t) + (else + ;; No body to write + #t)))) (if body-written? (begin (force-output client) diff --git a/tests/web-server.scm b/tests/web-server.scm index e456bf3..67c6423 100644 --- a/tests/web-server.scm +++ b/tests/web-server.scm @@ -1,5 +1,6 @@ (use-modules (srfi srfi-71) (rnrs bytevectors) + (ice-9 match) (ice-9 binary-ports) (ice-9 textual-ports) (tests) @@ -233,4 +234,68 @@ (assert-equal (get-message exception-handled-sucecssfully-channel) #t)))) +(run-fibers-for-tests + (lambda () + (let* ((web-server + (run-knots-web-server + (lambda (request) + (match (split-and-decode-uri-path + (uri-path (request-uri request))) + (("head-no-body") + (values '((content-type . (text/plain))) + #f)) + (("head-empty-body") + (values '((content-type . (text/plain))) + "")) + (("head-no-body-with-content-length") + (values '((content-type . (text/plain)) + (content-length . 10)) + #f)) + (("head-with-body") + (values '((content-type . (text/plain))) + "foo")) + (("head-procedure-body") + (values '((content-type . (text/plain))) + (lambda _ + (error "should not be run")))) + (("head-procedure-body-with-content-length") + (values '((content-type . (text/plain)) + (content-length . 10)) + (lambda _ + (error "should not be run")))))) + #:port 0)) ;; Bind to any port + (port + (web-server-port web-server))) + + (define* (head path) + (let ((uri + (build-uri 'http #:host "127.0.0.1" #:port port + #:path path))) + (http-head + uri + #:port (non-blocking-open-socket-for-uri uri)))) + + (let ((response + (head "/head-no-body"))) + (assert-equal 200 (response-code response))) + (let ((response + (head "/head-empty-body"))) + (assert-equal 200 (response-code response)) + (assert-equal 0 (response-content-length response))) + (let ((response + (head "/head-no-body-with-content-length"))) + (assert-equal 200 (response-code response)) + (assert-equal 10 (response-content-length response))) + (let ((response + (head "/head-with-body"))) + (assert-equal 200 (response-code response)) + (assert-equal 3 (response-content-length response))) + (let ((response + (head "/head-procedure-body"))) + (assert-equal 200 (response-code response))) + (let ((response + (head "/head-procedure-body-with-content-length"))) + (assert-equal 200 (response-code response)) + (assert-equal 10 (response-content-length response)))))) + (display "web-server test finished successfully\n") From 991a5f6961e49537b7a327a493249da3ab6a7bef Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 9 Jan 2026 15:31:54 +0000 Subject: [PATCH 47/78] Make print-backtrace-and-exception/knots more reliable Catch failures in the Guile code for printing backtraces, and print the partial backtrace, plus the backtrace of the exception that happened. --- knots.scm | 119 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 70 insertions(+), 49 deletions(-) diff --git a/knots.scm b/knots.scm index 05b2a1a..01e3738 100644 --- a/knots.scm +++ b/knots.scm @@ -67,6 +67,58 @@ (define* (print-backtrace-and-exception/knots exn #:key (port (current-error-port))) + (define (get-string port stack) + (define stack-len + (stack-length stack)) + + (let ((knots-stacks + (map knots-exception-stack + (filter knots-exception? + (simple-exceptions exn))))) + + (let* ((stack-vec + (stack->vector stack)) + (stack-vec-length + (vector-length stack-vec))) + (print-frames (list->vector + (drop + (vector->list stack-vec) + (if (< stack-vec-length 5) + 0 + 4))) + port + #:count (stack-length stack))) + (for-each + (lambda (stack) + (let* ((stack-vec + (stack->vector stack)) + (stack-vec-length + (vector-length stack-vec))) + (print-frames (list->vector + (drop + (vector->list stack-vec) + (if (< stack-vec-length 4) + 0 + 3))) + port + #:count (stack-length stack)))) + knots-stacks) + (print-exception + port + (if (null? knots-stacks) + (stack-ref stack + (if (< stack-len 4) + stack-len + 4)) + (let* ((stack (last knots-stacks)) + (stack-len (stack-length stack))) + (stack-ref stack + (if (< stack-len 3) + stack-len + 3)))) + '%exception + (list exn)))) + (let* ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) @@ -75,56 +127,25 @@ 0 (and prompt-tag 1))) (_ (make-stack #t)))) - (stack-len - (stack-length stack)) + (string-port + (open-output-string)) (error-string - (call-with-output-string - (lambda (port) - (let ((knots-stacks - (map knots-exception-stack - (filter knots-exception? - (simple-exceptions exn))))) + (with-exception-handler + (lambda (exn) + (display (get-output-string string-port) + port) + (close-output-port string-port) + (display "\n\n" port) - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 5) - 0 - 4))) - port - #:count (stack-length stack))) - (for-each - (lambda (stack) - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 4) - 0 - 3))) - port - #:count (stack-length stack)))) - knots-stacks) - (print-exception + (backtrace port) + (simple-format port - (if (null? knots-stacks) - (stack-ref stack - (if (< stack-len 4) - stack-len - 4)) - (let* ((stack (last knots-stacks)) - (stack-len (stack-length stack))) - (stack-ref stack - (if (< stack-len 3) - stack-len - 3)))) - '%exception - (list exn))))))) + "\nexception in print-backtrace-and-exception/knots: ~A\n" + exn) + (raise-exception exn)) + (lambda () + (get-string string-port stack) + (let ((str (get-output-string string-port))) + (close-output-port string-port) + str))))) (display error-string port))) From 39ae5177f2527169721d7d895e2953021e136bf4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 9 Jan 2026 15:44:04 +0000 Subject: [PATCH 48/78] Add spawn-fiber/knots Which is like spawn-fiber, but uses knots exception handling. --- knots.scm | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/knots.scm b/knots.scm index 01e3738..dee18a5 100644 --- a/knots.scm +++ b/knots.scm @@ -2,6 +2,7 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 suspendable-ports) + #:use-module (fibers) #:use-module (fibers conditions) #:use-module (system repl debug) #:export (call-with-default-io-waiters @@ -15,7 +16,9 @@ knots-exception? knots-exception-stack - print-backtrace-and-exception/knots)) + print-backtrace-and-exception/knots + + spawn-fiber/knots)) (define (call-with-default-io-waiters thunk) (parameterize @@ -149,3 +152,31 @@ (close-output-port string-port) str))))) (display error-string port))) + +(define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) + (spawn-fiber + (lambda () + (with-exception-handler + (lambda (exn) + (display "Uncaught exception in task:\n" + (current-error-port)) + (print-backtrace-and-exception/knots exn)) + (lambda () + (with-exception-handler + (lambda (exn) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) + thunk)) + #:unwind? #t)) + scheduler + #:parallel? parallel?)) From 094259b0494ca5b95b440ba54f253d60ffe10e80 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 12 Jan 2026 10:00:35 +0000 Subject: [PATCH 49/78] Add display, simple-format and format variants Which call put-bytevector for performing output. When used in combination with an unbuffered port, this should be safer than using the normal Guile procedures, as I think it'll avoid writing to the buffers, while still avoiding single character at a time output. More research is needed though in to how to output to stdout/stderr when using fibers with a parallelism greater than 1. --- knots.scm | 56 +++++++++++++++++++++++++++++++++++------ knots/resource-pool.scm | 10 ++++---- knots/web-server.scm | 28 ++++++++++++--------- 3 files changed, 69 insertions(+), 25 deletions(-) diff --git a/knots.scm b/knots.scm index dee18a5..ee38ee4 100644 --- a/knots.scm +++ b/knots.scm @@ -1,7 +1,9 @@ (define-module (knots) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (ice-9 binary-ports) #:use-module (ice-9 suspendable-ports) + #:use-module (rnrs bytevectors) #:use-module (fibers) #:use-module (fibers conditions) #:use-module (system repl debug) @@ -11,6 +13,10 @@ call-with-sigint + display/knots + simple-format/knots + format/knots + &knots-exception make-knots-exception knots-exception? @@ -51,6 +57,34 @@ ;; restore original C handler. (sigaction SIGINT #f)))))) +(define* (display/knots obj #:optional (port (current-output-port))) + (put-bytevector + port + (string->utf8 + (call-with-output-string + (lambda (port) + (display obj port)))))) + +(define (simple-format/knots port s . args) + (let ((str (apply simple-format #f s args))) + (if (eq? #f port) + str + (display/knots + str + (if (eq? #t port) + (current-output-port) + port))))) + +(define (format/knots port s . args) + (let ((str (apply format #f s args))) + (if (eq? #f port) + str + (display/knots + str + (if (eq? #t port) + (current-output-port) + port))))) + (define &knots-exception (make-exception-type '&knots-exception &exception @@ -135,13 +169,19 @@ (error-string (with-exception-handler (lambda (exn) - (display (get-output-string string-port) - port) + (display/knots (get-output-string string-port) + port) (close-output-port string-port) - (display "\n\n" port) + (display/knots "\n\n" port) - (backtrace port) - (simple-format + (let* ((stack (make-stack #t)) + (backtrace + (call-with-output-string + (lambda (port) + (display-backtrace stack port) + (newline port))))) + (display/knots backtrace)) + (simple-format/knots port "\nexception in print-backtrace-and-exception/knots: ~A\n" exn) @@ -151,15 +191,15 @@ (let ((str (get-output-string string-port))) (close-output-port string-port) str))))) - (display error-string port))) + (display/knots error-string port))) (define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) (spawn-fiber (lambda () (with-exception-handler (lambda (exn) - (display "Uncaught exception in task:\n" - (current-error-port)) + (display/knots "Uncaught exception in task:\n" + (current-error-port)) (print-backtrace-and-exception/knots exn)) (lambda () (with-exception-handler diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index f957c3d..d7bdfa3 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -90,7 +90,7 @@ (set-record-type-printer! (lambda (resource-pool port) - (display + (display/knots (simple-format #f "#" (resource-pool-name resource-pool)) port))) @@ -488,8 +488,8 @@ (stack-ref stack 3) '%exception (list exn)))))) - (display error-string - (current-error-port))) + (display/knots error-string + (current-error-port))) (raise-exception exn)) (lambda () (start-stack @@ -1146,8 +1146,8 @@ (stack-ref stack 3) '%exception (list exn)))))) - (display error-string - (current-error-port))) + (display/knots error-string + (current-error-port))) (raise-exception exn)) (lambda () (start-stack diff --git a/knots/web-server.scm b/knots/web-server.scm index d0b13ce..adaba13 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -289,7 +289,7 @@ on the procedure being called at any particular time." (not (memq 'close (response-connection response)))) (define (default-read-request-exception-handler exn) - (display "While reading request:\n" (current-error-port)) + (display/knots "While reading request:\n" (current-error-port)) (print-exception (current-error-port) #f @@ -302,12 +302,12 @@ on the procedure being called at any particular time." (if (and (exception-with-origin? exn) (string=? (exception-origin exn) "fport_write")) - (simple-format + (simple-format/knots (current-error-port) "~A ~A: error replying to client\n" (request-method request) (uri-path (request-uri request))) - (simple-format + (simple-format/knots (current-error-port) "knots web server: ~A ~A: exception replying to client: ~A\n" (request-method request) @@ -329,8 +329,8 @@ on the procedure being called at any particular time." (print-backtrace-and-exception/knots exn #:port port))))) - (display error-string - (current-error-port))) + (display/knots error-string + (current-error-port))) (values (build-response #:code 500) ;; TODO Make this configurable @@ -476,13 +476,17 @@ on the procedure being called at any particular time." (unless (and (exception-with-origin? exn) (string=? (exception-origin exn) "fport_read")) - (display "knots web-server, exception in client loop:\n" - (current-error-port)) - (print-exception - (current-error-port) - #f - '%exception - (list exn))) + (display/knots "knots web-server, exception in client loop:\n" + (current-error-port)) + (display/knots + (call-with-output-string + (lambda (port) + (print-exception + port + #f + '%exception + (list exn)))) + (current-error-port))) #t) (lambda () (or From 5260c38b5ea91f4816b607267b88cf3edaf465c8 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 12 Jan 2026 10:50:11 +0000 Subject: [PATCH 50/78] Address issue with failures when creating resource pool resources Previously failures could lead to no resources in the pool, and waiters which will never get a resource. Retrying here fixes that issue, although maybe another approach is needed that keeps track of new resources being created, as that'll allow keeping track of this when destroying resource pools. --- knots/resource-pool.scm | 62 ++++++++++++++++++++++++----------------- 1 file changed, 37 insertions(+), 25 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index d7bdfa3..bdaad8f 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -562,31 +562,43 @@ #f (raise-exception exn))) (lambda () - (with-parallelism-limiter - return-new-resource/parallelism-limiter - (let ((max-size - (assq-ref (resource-pool-configuration pool) - 'max-size)) - (size (count-resources resources))) - (unless (>= size max-size) - (with-exception-handler - (lambda _ #f) - (lambda () - (with-exception-handler - (lambda (exn) - (simple-format - (current-error-port) - "exception adding resource to pool ~A: ~A\n\n" - name - return-new-resource) - (print-backtrace-and-exception/knots exn) - (raise-exception exn)) - (lambda () - (let ((new-resource - (start-stack #t (return-new-resource)))) - (put-message channel - (list 'add-resource new-resource)))))) - #:unwind? #t))))) + (let loop () + (let ((success? + (with-parallelism-limiter + return-new-resource/parallelism-limiter + (let ((max-size + (assq-ref (resource-pool-configuration pool) + 'max-size)) + (size (count-resources resources))) + (or (>= size max-size) + (with-exception-handler + (lambda _ #f) + (lambda () + (with-exception-handler + (lambda (exn) + (simple-format + (current-error-port) + "exception adding resource to pool ~A: ~A\n\n" + name + return-new-resource) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (let ((new-resource + (start-stack #t (return-new-resource)))) + (put-message channel + (list 'add-resource new-resource))) + #t))) + #:unwind? #t)))))) + (unless success? + ;; TODO Maybe this should be configurable? + (sleep 1) + + ;; Important to retry here and eventually create + ;; a new resource, as there might be waiters + ;; stuck waiting for a resource, especially if + ;; the pool is empty. + (loop))))) #:unwind? #t)))) (define (spawn-fiber-to-destroy-resource resource-id resource-value) From 35f4c16ab0b3846cd10f5209b39a6a3f5bf8a3f1 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sat, 24 Jan 2026 15:21:15 +0000 Subject: [PATCH 51/78] Add call-with-temporary-thread --- knots.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/knots.scm b/knots.scm index ee38ee4..765db5a 100644 --- a/knots.scm +++ b/knots.scm @@ -1,10 +1,12 @@ (define-module (knots) #:use-module (srfi srfi-1) #:use-module (ice-9 match) + #:use-module (ice-9 threads) #:use-module (ice-9 binary-ports) #:use-module (ice-9 suspendable-ports) #:use-module (rnrs bytevectors) #:use-module (fibers) + #:use-module (fibers channels) #:use-module (fibers conditions) #:use-module (system repl debug) #:export (call-with-default-io-waiters @@ -57,6 +59,42 @@ ;; restore original C handler. (sigaction SIGINT #f)))))) +(define (call-with-temporary-thread thunk) + (let ((channel (make-channel))) + (call-with-new-thread + (lambda () + (call-with-default-io-waiters + (lambda () + (with-exception-handler + (lambda (exn) + (put-message channel `(exception . ,exn))) + (lambda () + (with-exception-handler + (lambda (exn) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) + (lambda () + (call-with-values thunk + (lambda values + (put-message channel `(values ,@values))))))) + #:unwind? #t))))) + + (match (get-message channel) + (('values . results) + (apply values results)) + (('exception . exn) + (raise-exception exn))))) + (define* (display/knots obj #:optional (port (current-output-port))) (put-bytevector port From 8b489490e1a1a346ef2398198ac80918fc39c178 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 17 Mar 2026 21:13:03 +0000 Subject: [PATCH 52/78] Fix readable? docstring. --- knots/timeout.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/knots/timeout.scm b/knots/timeout.scm index a65a095..010e1d8 100644 --- a/knots/timeout.scm +++ b/knots/timeout.scm @@ -110,7 +110,7 @@ (exception-predicate &port-write-timeout-error)) (define (readable? port) - "Test if PORT is writable." + "Test if PORT is readable." (= 1 (port-poll port "r" 0))) (define (writable? port) From 8e29587ec158c71cf6a440fbdde19bf3277ec154 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 17 Mar 2026 21:13:30 +0000 Subject: [PATCH 53/78] Change the behind system clock threshold As the Honeycomb LX2 machines start with 2001 as the time. --- knots.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/knots.scm b/knots.scm index 765db5a..0baaf3a 100644 --- a/knots.scm +++ b/knots.scm @@ -37,9 +37,10 @@ (thunk))) (define (wait-when-system-clock-behind) - (let ((start-of-the-year-2000 946684800)) + ;; Jan 02 2001 02:00:00 + (let ((start-of-the-year-2001 978400800)) (while (< (current-time) - start-of-the-year-2000) + start-of-the-year-2001) (simple-format (current-error-port) "warning: system clock potentially behind, waiting\n") (sleep 20)))) From 79d5603416132409d4d4021a440ea9f2217f8a6b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 17 Mar 2026 21:35:45 +0000 Subject: [PATCH 54/78] Add more detail to the README. --- README | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/README b/README index e593a79..693b3a0 100644 --- a/README +++ b/README @@ -1,4 +1,15 @@ -*- mode: org -*- -This Guile library provides useful patterns and functionality to use -Guile Fibers. +* Guile Knots + +Guile Knots is a library providing higher-level patterns and building +blocks for programming with [[https://codeberg.org/guile/fibers][Guile Fibers]]. + +This includes: + +- Parallel map/for-each with configurable concurrency limits +- Resource and thread pools +- Fiber-aware promises for lazy and eager parallel evaluation +- Timeouts for fibers and I/O ports +- A HTTP web server +- Non-blocking socket utilities From 30aa837cf440590b2b94d808b36f2e034dd8a62e Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 17 Mar 2026 21:47:47 +0000 Subject: [PATCH 55/78] Add some resource pool documentation --- knots/resource-pool.scm | 80 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 80 insertions(+) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index bdaad8f..5a1332e 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -154,6 +154,33 @@ (name "unnamed") default-checkout-timeout default-max-waiters) + "Create a resource pool from RESOURCES-LIST-OR-VECTOR, a list or +vector of pre-existing resource values. + +Use @code{with-resource-from-pool} or +@code{call-with-resource-from-pool} to borrow a resource and return it +automatically when done. + +Optional keyword arguments: + +@table @code +@item #:name +A optional string used in log messages. +Defaults to @code{\"unnamed\"}. + +@item #:default-checkout-timeout +Default checkout timeout when requesting a resource from the pool, +unset by default. + +@item #:default-max-waiters +Maximum number of fibers that may queue waiting for a resource. When +this limit is exceeded, @code{&resource-pool-too-many-waiters} is +raised when a resource is requested. Defaults to @code{#f} (no limit). + +@item #:scheduler +The Fibers scheduler to use for the pool's internal fiber. Defaults +to the current scheduler. +@end table" (define channel (make-channel)) (define destroy-condition (make-condition)) @@ -513,6 +540,59 @@ (add-resources-parallelism 1) default-checkout-timeout default-max-waiters) + "Create a dynamic resource pool. RETURN-NEW-RESOURCE is a thunk +called to create each new resource value. MAX-SIZE is the maximum +number of resources the pool will hold simultaneously. + +Resources are created on demand when a checkout is requested and the +pool is not yet at MAX-SIZE. Use @code{with-resource-from-pool} or +@code{call-with-resource-from-pool} to request a resource and return +it automatically when done. + +Optional keyword arguments: + +@table @code +@item #:min-size +Minimum number of resources to keep alive even when idle. Defaults to +@code{0}. + +@item #:idle-seconds +Seconds a resource may remain unused before being destroyed, provided +the pool is above @code{#:min-size}. Defaults to @code{#f} (never +expire idle resources). + +@item #:lifetime +Maximum number of checkouts a single resource will serve before being +destroyed and replaced by a fresh one. Defaults to @code{#f} (no +limit). + +@item #:destructor +A procedure called as @code{(destructor resource)} when a resource is +removed from the pool. Defaults to @code{#f}. + +@item #:add-resources-parallelism +Maximum number of concurrent calls to RETURN-NEW-RESOURCE when the +pool needs to grow. Allowing resources to be created in parallel can +result in more resources being created than can fit inside the pool, +if this happens, the surplus resources are destroyed. Defaults to +@code{1}. + +@item #:name +A string used in log messages. Defaults to @code{\"unnamed\"}. + +@item #:default-checkout-timeout +Default checkout timeout when requesting a resource from the pool, +unset by default. + +@item #:default-max-waiters +Maximum number of fibers that may queue waiting for a resource. When +this limit is exceeded, @code{&resource-pool-too-many-waiters} is +raised when a resource is requested. Defaults to @code{#f} (no limit). + +@item #:scheduler +The Fibers scheduler to use for the pool's internal fiber. Defaults +to the current scheduler. +@end table" (define channel (make-channel)) (define destroy-condition (make-condition)) From 5b84273cbf65a50f2ee7c1e9f49af9a58906b15f Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 17 Mar 2026 21:58:22 +0000 Subject: [PATCH 56/78] Add some documentation for the timeout procedures And tweak how with-fibers-timeout works. --- knots/timeout.scm | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/knots/timeout.scm b/knots/timeout.scm index 010e1d8..2df2ddd 100644 --- a/knots/timeout.scm +++ b/knots/timeout.scm @@ -45,7 +45,16 @@ with-port-timeouts)) -(define* (with-fibers-timeout thunk #:key timeout on-timeout) +(define* (with-fibers-timeout thunk #:key + timeout + (on-timeout + (const *unspecified*))) + "Run THUNK in a new fiber and return its values, waiting TIMEOUT +seconds for it to finish. If THUNK does not complete within TIMEOUT +seconds, the ON-TIMEOUT procedure is called and with-fibers-timeout +returns the result of ON-TIMEOUT instead. + +If THUNK raises an exception it is re-raised in the calling fiber." (let ((channel (make-channel))) (spawn-fiber (lambda () @@ -151,6 +160,21 @@ #:key timeout (read-timeout timeout) (write-timeout timeout)) + "Run THUNK with per-operation I/O timeouts on all ports. If any +read or write blocks for longer than the given number of seconds, an +exception is raised. + +@code{#:timeout} sets both read and write timeouts. +@code{#:read-timeout} and @code{#:write-timeout} specify the timeout +for reads and writes respectively. All three default to @code{#f} (no +timeout). + +This procedure works both with fibers, and without fibers by using the +poll system call with a timeout. + +On read timeout, raises @code{&port-read-timeout-error}. On write +timeout, raises @code{&port-write-timeout-error}. Both carry the +@code{thunk} and @code{port} fields from @code{&port-timeout-error}." (define (no-fibers-wait thunk port mode timeout) (define poll-timeout-ms 200) From d3d4964210f7dad593909189987c6993f3f5f2fb Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 18 Mar 2026 08:44:26 +0000 Subject: [PATCH 57/78] Add more documentation --- knots/parallelism.scm | 9 ++++ knots/promise.scm | 17 +++++++ knots/queue.scm | 6 +++ knots/thread-pool.scm | 106 ++++++++++++++++++++++++++++++++++++++++-- 4 files changed, 134 insertions(+), 4 deletions(-) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index 7631055..e1e1d90 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -318,6 +318,12 @@ invocation of PROC finishes. REPORT is passed the results for each (resource-pool parallelism-limiter-resource-pool)) (define* (make-parallelism-limiter limit #:key (name "unnamed")) + "Return a parallelism limiter that allows at most LIMIT concurrent +fibers to execute within @code{with-parallelism-limiter} at the same +time. Further fibers block until a slot becomes free. + +@code{#:name} is a string used in log messages. Defaults to +@code{\"unnamed\"}." (make-parallelism-limiter-record (make-fixed-size-resource-pool (iota limit) @@ -329,6 +335,9 @@ invocation of PROC finishes. REPORT is passed the results for each parallelism-limiter))) (define* (call-with-parallelism-limiter parallelism-limiter thunk) + "Acquire a slot from PARALLELISM-LIMITER, call THUNK, release the +slot, and return the values from THUNK. Blocks if no slot is +currently available." (call-with-resource-from-pool (parallelism-limiter-resource-pool parallelism-limiter) (lambda _ diff --git a/knots/promise.scm b/knots/promise.scm index c01d219..b85fe64 100644 --- a/knots/promise.scm +++ b/knots/promise.scm @@ -41,12 +41,21 @@ (evaluated-condition fibers-promise-evaluated-condition)) (define (fibers-delay thunk) + "Return a new fiber-aware promise that will evaluate THUNK when +first forced. THUNK is not called until @code{fibers-force} is +called on the promise." (make-fibers-promise thunk (make-atomic-box #f) (make-condition))) (define (fibers-force fp) + "Force the fiber-aware promise FP, returning its values. + +The first call evaluates the promise's thunk. Concurrent callers +block on a condition variable until evaluation finishes, then receive +the same result. If the thunk raises an exception, the exception is +stored and re-raised for all callers." (unless (fibers-promise? fp) (raise-exception (make-exception @@ -108,6 +117,9 @@ (define (fibers-delay/eager thunk) + "Return a new fiber-aware promise and immediately begin evaluating +THUNK in a new fiber. Exceptions during eager evaluation are silently +discarded; they will be re-raised when @code{fibers-force} is called." (let ((promise (fibers-delay thunk))) (spawn-fiber (lambda () @@ -121,10 +133,15 @@ promise)) (define (fibers-promise-reset fp) + "Reset the fiber-aware promise FP so that the next call to +@code{fibers-force} re-evaluates its thunk." (atomic-box-set! (fibers-promise-values-box fp) #f)) (define (fibers-promise-result-available? fp) + "Return @code{#t} if the fiber-aware promise FP has been evaluated +(successfully or with an exception) and @code{#f} if evaluation has +not yet started or is still in progress." (let ((val (atomic-box-ref (fibers-promise-values-box fp)))) (not (or (eq? val #f) (eq? val 'started))))) diff --git a/knots/queue.scm b/knots/queue.scm index ec9f703..2ca9b10 100644 --- a/knots/queue.scm +++ b/knots/queue.scm @@ -25,6 +25,12 @@ #:export (spawn-queueing-fiber)) (define (spawn-queueing-fiber dest-channel) + "Spawn a fiber that serialises items onto DEST-CHANNEL in FIFO order. +Returns a new input channel. + +Multiple producers can put items on the returned channel concurrently. +The fiber buffers them locally and forwards them to DEST-CHANNEL one at +a time, preserving arrival order." (define queue (make-q)) (let ((queue-channel (make-channel))) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index 22c1b5c..3a68a12 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -211,6 +211,52 @@ from there, or #f if that would be an empty string." (name "unnamed") (use-default-io-waiters? #t) default-checkout-timeout) + "Create a pool of SIZE threads started immediately. Use +@code{call-with-thread} to run a procedure in one of the threads. + +Optional keyword arguments: + +@table @code +@item #:thread-initializer +A thunk called once when each thread starts. Its return value is +passed as extra arguments to every procedure run in that thread. +Defaults to @code{#f} (no extra arguments). + +@item #:thread-destructor +A procedure called with the value returned by @code{#:thread-initializer} +when a thread exits. Defaults to @code{#f}. + +@item #:thread-lifetime +Maximum number of procedures a thread will run before restarting (and +re-running @code{#:thread-initializer}). Defaults to @code{#f} (no +limit). + +@item #:expire-on-exception? +When @code{#t}, replace a thread after any unhandled exception. +Defaults to @code{#f}. + +@item #:use-default-io-waiters? +When @code{#t} (the default), each thread uses blocking I/O waiters so +that port reads and writes block the thread rather than trying to +suspend a fiber. + +@item #:name +String used in thread names and log messages. Defaults to +@code{\"unnamed\"}. + +@item #:default-checkout-timeout +Seconds to wait for a free thread slot before raising +@code{&thread-pool-timeout-error}. Defaults to @code{#f} (wait +forever). + +@item #:delay-logger +Called as @code{(delay-logger seconds proc)} with the time spent +waiting for a thread to become available. + +@item #:duration-logger +Called as @code{(duration-logger seconds proc)} after each procedure +completes. +@end table" (define channel (make-channel)) @@ -408,8 +454,34 @@ from there, or #f if that would be an empty string." (use-default-io-waiters? #t) default-checkout-timeout default-max-waiters) - "Return a channel used to offload work to a dedicated thread. ARGS are the -arguments of the thread pool procedure." + "Create a dynamic thread pool with up to MAX-SIZE threads. Use +@code{call-with-thread} to run a procedure in one of the threads. + +Unlike @code{make-fixed-size-thread-pool}, threads are created on +demand and may be reclaimed when idle (controlled by @code{#:min-size} +and the resource pool's idle management). + +Accepts the same @code{#:thread-initializer}, @code{#:thread-destructor}, +@code{#:thread-lifetime}, @code{#:expire-on-exception?}, +@code{#:use-default-io-waiters?}, @code{#:name}, +@code{#:default-checkout-timeout}, @code{#:delay-logger}, and +@code{#:duration-logger} arguments as @code{make-fixed-size-thread-pool}, +plus: + +@table @code +@item #:min-size +Minimum number of threads to keep alive. Defaults to MAX-SIZE (i.e.@: +the pool is pre-filled and never shrinks). + +@item #:scheduler +Fibers scheduler for the pool's internal resource pool fiber. Defaults +to the current scheduler. + +@item #:default-max-waiters +Maximum number of fibers that may queue waiting for a thread. Raises +@code{&thread-pool-timeout-error} when exceeded. Defaults to +@code{#f} (no limit). +@end table" (define param (make-parameter #f)) @@ -444,8 +516,34 @@ arguments of the thread pool procedure." channel destroy-thread-on-exception? (max-waiters 'default)) - "Send PROC to the thread pool through CHANNEL. Return the result of PROC. -If already in the thread pool, call PROC immediately." + "Run PROC in THREAD-POOL and return its values, blocking until +complete. If called from within a thread that already belongs to +THREAD-POOL, PROC is called directly in that thread. + +Optional keyword arguments: + +@table @code +@item #:checkout-timeout +Seconds to wait for a free thread before raising +@code{&thread-pool-timeout-error}. Defaults to the pool's +@code{#:default-checkout-timeout}. + +@item #:max-waiters +Maximum number of fibers that may queue waiting for a thread (for +dynamic pools). Defaults to the pool's @code{#:default-max-waiters}. + +@item #:destroy-thread-on-exception? +When @code{#t}, destroy the thread after PROC raises an exception. +Equivalent to per-call @code{#:expire-on-exception?}. Defaults to +@code{#f}. + +@item #:duration-logger +Called as @code{(duration-logger seconds)} after PROC completes +(whether or not it raised an exception). + +@item #:channel +Override the channel used to communicate with the thread. +@end table" (define (handle-proc fixed-size-thread-pool reply-channel start-time From 09cb805ee28ebfc11d05bd2ed67b34041a76f62c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 18 Mar 2026 08:58:41 +0000 Subject: [PATCH 58/78] Add even more documentation --- knots.scm | 35 +++++++++++++++++++++++++++++++++++ knots/non-blocking.scm | 10 ++++++++++ knots/parallelism.scm | 10 ++++++++++ knots/resource-pool.scm | 21 +++++++++++++++++++++ knots/sort.scm | 9 +++++++++ 5 files changed, 85 insertions(+) diff --git a/knots.scm b/knots.scm index 0baaf3a..304931e 100644 --- a/knots.scm +++ b/knots.scm @@ -29,6 +29,11 @@ spawn-fiber/knots)) (define (call-with-default-io-waiters thunk) + "Run THUNK with Guile's default blocking I/O waiters active. + +This is useful when restoring the default Guile I/O waiters from +within a context (like Fibers) where different I/O waiters are used, +for example when creating a new thread from a fiber." (parameterize ((current-read-waiter (@@ (ice-9 suspendable-ports) default-read-waiter)) @@ -37,6 +42,11 @@ (thunk))) (define (wait-when-system-clock-behind) + "Block until the system clock reads at least 2001-01-02. + +Useful at startup in environments (virtual machines, embedded systems) +where the clock may start at or near the Unix epoch. Prints a warning +to the current error port every 20 seconds while waiting." ;; Jan 02 2001 02:00:00 (let ((start-of-the-year-2001 978400800)) (while (< (current-time) @@ -47,6 +57,18 @@ ;; Copied from (fibers web server) (define (call-with-sigint thunk cvar) + "Run THUNK with a SIGINT handler that signals the Fibers condition +CVAR. Restores the previous handler when THUNK returns. + +Typical usage is to pass a condition variable to this procedure and +wait on CVAR in a fiber to implement clean shutdown on Ctrl-C: + +@example +(let ((quit-cvar (make-condition))) + (call-with-sigint + (lambda () (wait quit-cvar)) + quit-cvar)) +@end example" (let ((handler #f)) (dynamic-wind (lambda () @@ -97,6 +119,11 @@ (raise-exception exn))))) (define* (display/knots obj #:optional (port (current-output-port))) + "Write OBJ to PORT (default: current output port) as a UTF-8 byte +sequence via @code{put-bytevector}. + +When used with ports without buffering, this should be safer than +display." (put-bytevector port (string->utf8 @@ -105,6 +132,8 @@ (display obj port)))))) (define (simple-format/knots port s . args) + "Like @code{simple-format} but should be safer when used with a port +without buffering." (let ((str (apply simple-format #f s args))) (if (eq? #f port) str @@ -115,6 +144,8 @@ port))))) (define (format/knots port s . args) + "Like @code{format} but should be safer when used with a port +without buffering." (let ((str (apply format #f s args))) (if (eq? #f port) str @@ -233,6 +264,10 @@ (display/knots error-string port))) (define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) + "Spawn a fiber to run THUNK, with knots exception handling. + +Accepts the same optional SCHEDULER and @code{#:parallel?} arguments +as @code{spawn-fiber}." (spawn-fiber (lambda () (with-exception-handler diff --git a/knots/non-blocking.scm b/knots/non-blocking.scm index 4473b63..cd029fe 100644 --- a/knots/non-blocking.scm +++ b/knots/non-blocking.scm @@ -32,6 +32,16 @@ (define* (non-blocking-open-socket-for-uri uri #:key (verify-certificate? #t)) + "Open a socket for URI and return it as a non-blocking port. + +For HTTPS URIs the TLS handshake is completed while the socket is +still blocking (required because Guile's TLS wrapper does not support +non-blocking handshakes), then the underlying socket is made +non-blocking. For plain HTTP the socket is made non-blocking +immediately. + +@code{#:verify-certificate?} controls TLS certificate verification +and defaults to @code{#t}." (define tls-wrap (@@ (web client) tls-wrap)) diff --git a/knots/parallelism.scm b/knots/parallelism.scm index e1e1d90..e78e6e2 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -267,6 +267,16 @@ invocation of PROC finishes. REPORT is passed the results for each #:key (parallelism 1) (input-channel (make-channel)) (process-channel input-channel)) + "Convert PROC into a procedure backed by @code{#:parallelism} +(default: 1) background fibers. Returns a wrapper that sends its +arguments to one of the fibers and blocks until the result is +returned. + +@code{#:input-channel} is the channel that callers write requests to; +defaults to a fresh channel. @code{#:process-channel} is the channel +the fibers read from; defaults to @code{#:input-channel}. Setting +them differently allows external parties to bypass the wrapper and +write directly to @code{process-channel}." (for-each (lambda _ (spawn-fiber diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 5a1332e..f06a156 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -1252,6 +1252,10 @@ to the current scheduler. pool) (define (destroy-resource-pool pool) + "Destroy POOL, preventing any new checkouts. Blocks until all +checked-out resources have been returned, running the pool's +@code{#:destructor} on each. Any fibers waiting for a resource +receive @code{&resource-pool-destroyed}." (perform-operation (choice-operation (wrap-operation @@ -1468,6 +1472,23 @@ available. Return the resource once PROC has returned." (lambda (resource) exp ...))) (define* (resource-pool-stats pool #:key (timeout 5)) + "Return an alist of statistics for POOL with the following keys: + +@table @code +@item resources +Total number of resources currently held by the pool. +@item available +Number of resources not currently checked out. +@item waiters +Number of fibers currently queued waiting for a resource. +@item checkout-failure-count +Cumulative number of checkouts where an exception was raised inside +the proc. +@end table + +Blocks waiting for the pool fiber to respond. @code{#:timeout} is +the number of seconds to wait; defaults to @code{5}. Raises +@code{&resource-pool-timeout} if the pool does not respond in time." (define channel (resource-pool-channel pool)) diff --git a/knots/sort.scm b/knots/sort.scm index dcad052..94d49f8 100644 --- a/knots/sort.scm +++ b/knots/sort.scm @@ -54,6 +54,15 @@ rest))))) (define* (fibers-sort! items less #:key parallelism) + "Sort ITEMS destructively using LESS as the comparison procedure, +using a parallel merge sort. Returns the sorted list. + +Splits ITEMS into chunks, sorts each in an eager fiber-promise in +parallel, then merges pairs of sorted chunks in parallel until one +sorted list remains. + +@code{#:parallelism} sets the number of initial chunks. Defaults to +the current fibers parallelism." (define requested-chunk-count (or parallelism (+ 1 (length (scheduler-remote-peers (current-scheduler)))))) From db9b549e59726d287613da92d3d1afd3cdffb391 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 18 Mar 2026 09:34:00 +0000 Subject: [PATCH 59/78] Fix the destroy behaviour for fixed size thread pools destroy-thread-pool should block until the thread pool has been destroyed. --- knots/thread-pool.scm | 34 ++++++++++++++++++++-------------- tests/thread-pool.scm | 30 ++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 14 deletions(-) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index 3a68a12..f8c44b2 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -163,12 +163,13 @@ from there, or #f if that would be an empty string." (define-record-type (fixed-size-thread-pool channel arguments-parameter current-procedures - default-checkout-timeout) + default-checkout-timeout threads) fixed-size-thread-pool? (channel fixed-size-thread-pool-channel) (arguments-parameter fixed-size-thread-pool-arguments-parameter) (current-procedures fixed-size-thread-pool-current-procedures) - (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout)) + (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout) + (threads fixed-size-thread-pool-threads)) ;; Since both thread pool records have this field, use a procedure ;; than handles the appropriate accessor @@ -426,19 +427,20 @@ completes. (initializer/safe) '())))))))) - (for-each - (lambda (i) - (if use-default-io-waiters? - (call-with-default-io-waiters - (lambda () - (start-thread i channel))) - (start-thread i channel))) - (iota size)) + (define threads + (map (lambda (i) + (if use-default-io-waiters? + (call-with-default-io-waiters + (lambda () + (start-thread i channel))) + (start-thread i channel))) + (iota size))) (fixed-size-thread-pool channel param thread-proc-vector - default-checkout-timeout)) + default-checkout-timeout + threads)) (define* (make-thread-pool max-size #:key @@ -627,9 +629,13 @@ Override the channel used to communicate with the thread. destroy-thread-on-exception?)))))))) (define (destroy-thread-pool pool) + "Destroy POOL, stopping all of its threads and calling the destructor +if specified. This procedure will block until the destruction is +complete." (if (fixed-size-thread-pool? pool) - (put-message - (fixed-size-thread-pool-channel pool) - 'destroy) + (let ((channel (fixed-size-thread-pool-channel pool)) + (threads (fixed-size-thread-pool-threads pool))) + (for-each (lambda _ (put-message channel 'destroy)) threads) + (for-each join-thread threads)) (destroy-resource-pool (thread-pool-resource-pool pool)))) diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm index e3a1cdd..dc22119 100644 --- a/tests/thread-pool.scm +++ b/tests/thread-pool.scm @@ -1,5 +1,6 @@ (use-modules (tests) (ice-9 atomic) + (ice-9 threads) (srfi srfi-71) (fibers) (unit-test) @@ -142,4 +143,33 @@ ref-and-decrement)) (error))) +;; Test that the destructor is called when a size 1 fixed-size thread +;; pool is destroyed, and that destroy-thread-pool blocks until it has +;; completed. +(let* ((destructor-called? #f) + (thread-pool + (make-fixed-size-thread-pool + 1 + #:thread-destructor + (lambda () + (set! destructor-called? #t))))) + (destroy-thread-pool thread-pool) + (assert-equal #t destructor-called?)) + +;; Test that the destructor is called for every thread when a +;; multi-thread fixed-size thread pool is destroyed, and that +;; destroy-thread-pool blocks until all destructors have completed. +(let* ((destructor-count 0) + (mutex (make-mutex)) + (pool-size 3) + (thread-pool + (make-fixed-size-thread-pool + pool-size + #:thread-destructor + (lambda () + (with-mutex mutex + (set! destructor-count (+ destructor-count 1))))))) + (destroy-thread-pool thread-pool) + (assert-equal pool-size destructor-count)) + (display "thread-pool test finished successfully\n") From 8cff54ea437881e39729a08cdd3258e07698fcb4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 18 Mar 2026 09:51:54 +0000 Subject: [PATCH 60/78] Add (knots web) --- Makefile.am | 2 + knots/web.scm | 204 +++++++++++++++++++++++++++++++++++++++++++++ tests/web.scm | 223 ++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 429 insertions(+) create mode 100644 knots/web.scm create mode 100644 tests/web.scm diff --git a/Makefile.am b/Makefile.am index 5551fbe..7942955 100644 --- a/Makefile.am +++ b/Makefile.am @@ -5,6 +5,7 @@ SOURCES = \ knots/non-blocking.scm \ knots/parallelism.scm \ knots/promise.scm \ + knots/web.scm \ knots/queue.scm \ knots/resource-pool.scm \ knots/sort.scm \ @@ -18,6 +19,7 @@ SCM_TESTS = \ tests/parallelism.scm \ tests/promise.scm \ tests/queue.scm \ + tests/web.scm \ tests/resource-pool.scm \ tests/sort.scm \ tests/thread-pool.scm \ diff --git a/knots/web.scm b/knots/web.scm new file mode 100644 index 0000000..73edf37 --- /dev/null +++ b/knots/web.scm @@ -0,0 +1,204 @@ +;;; Guile Knots +;;; Copyright © 2026 Christopher Baines +;;; +;;; This file is part of Guile Knots. +;;; +;;; The Guile Knots is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; The Guile Knots is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with the guix-data-service. If not, see +;;; . + +(define-module (knots web) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module (ice-9 exceptions) + #:use-module (web uri) + #:use-module (web request) + #:use-module (web response) + #:use-module (knots) + #:use-module (knots non-blocking) + #:use-module (knots resource-pool) + #:export (make-connection-cache + call-with-connection-cache + call-with-cached-connection + http-fold-requests)) + +(define* (make-connection-cache uri + max-cached-connections + #:key (verify-certificate? #t)) + "Create a resource pool of up to MAX-CACHED-CONNECTIONS +to URI." + (make-resource-pool + (lambda () + ;; Open the socket in a temporary thread so that the blocking + ;; connection attempt does not stall the fiber scheduler. + (call-with-temporary-thread + (lambda () + (non-blocking-open-socket-for-uri + uri + #:verify-certificate? verify-certificate?)))) + max-cached-connections + #:destructor close-port)) + +(define* (call-with-connection-cache uri + max-cached-connections + proc + #:key (verify-certificate? #t)) + "Create a connection cache for URI with up to MAX-CACHED-CONNECTIONS, +call @code{(proc cache)}, then destroy the cache and return +the values returned by PROC." + (let ((cache (make-connection-cache + uri + max-cached-connections + #:verify-certificate? verify-certificate?))) + (call-with-values + (lambda () + (proc cache)) + (lambda vals + (destroy-resource-pool cache) + (apply values vals))))) + +(define* (call-with-cached-connection + cache proc + #:key (close-connection-on-exception? #t)) + "Check out a connection port from CACHE and call @code{(proc port)}, +returning the result. The port is returned to the cache when PROC +returns, or closed on exception if CLOSE-CONNECTION-ON-EXCEPTION? is +true (the default)." + (with-exception-handler + (lambda (exn) + (if (resource-pool-destroy-resource-exception? exn) + (call-with-cached-connection + cache + proc + #:close-connection-on-exception? + close-connection-on-exception?) + (raise-exception exn))) + (lambda () + (with-exception-handler + (lambda (exn) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) + (lambda () + (call-with-resource-from-pool cache + (lambda (port) + (when (port-closed? port) + (raise-exception + (make-resource-pool-destroy-resource-exception))) + (proc port)) + #:destroy-resource-on-exception? close-connection-on-exception?)))) + #:unwind? #t)) + +(define* (http-fold-requests connection-cache proc seed requests + #:key + (batch-size 1000)) + "Fold PROC over HTTP request/response pairs using CONNECTION-CACHE +for connections. PROC is called as +@code{(proc request response body-port accumulator)} and its return +value becomes the new accumulator. Requests are sent in batches of +up to BATCH-SIZE before responses are read (HTTP pipelining). + +When the server closes the connection mid-batch the remaining requests +are retried on a fresh connection from the cache." + + (define &send-error + (make-exception-type '&send-error &exception '())) + (define make-send-error + (record-constructor &send-error)) + (define send-error? + (exception-predicate &send-error)) + + (define (read-responses port batch result) + (let loop ((request (car batch)) + (remaining-requests (cdr batch)) + (result result)) + (let ((response + (with-exception-handler + (lambda (exn) + (close-port port) + #f) + (lambda () + (read-response port)) + #:unwind? #t))) + (if (not response) + (values (cons request remaining-requests) result) + (let* ((body (response-body-port response)) + (new-result (proc request response body result))) + (if (memq 'close (response-connection response)) + (begin + (close-port port) + (values remaining-requests new-result)) + (if (null? remaining-requests) + (values '() new-result) + (loop (car remaining-requests) + (cdr remaining-requests) + new-result)))))))) + + ;; Send up to BATCH-SIZE requests then hand off to read-responses. + ;; If writing fails the connection has dropped; raise &send-error so the + ;; outer loop retries all remaining requests on a fresh connection. + (define (send-batch port batch) + (with-exception-handler + (lambda (exn) + (close-port port) + (raise-exception (make-send-error))) + (lambda () + (for-each (lambda (req) + (write-request req port)) + batch) + (force-output port)) + #:unwind? #t)) + + (let loop ((remaining-requests requests) + (result seed)) + (if (null? remaining-requests) + result + (let ((next-remaining-requests + next-result + (with-exception-handler + (lambda (exn) + (if (or (send-error? exn) + (resource-pool-destroy-resource-exception? exn)) + (values remaining-requests result) + (raise-exception exn))) + (lambda () + (call-with-resource-from-pool connection-cache + (lambda (port) + (if (port-closed? port) + (raise-exception + (make-resource-pool-destroy-resource-exception)) + (let ((batch + pending + (split-at + remaining-requests + (min batch-size (length + remaining-requests))))) + (send-batch port batch) + (let ((remaining-requests + next-result + (read-responses port batch result))) + (values (append remaining-requests pending) + next-result))))) + #:destroy-resource-on-exception? #t)) + #:unwind? #t))) + (loop next-remaining-requests next-result))))) diff --git a/tests/web.scm b/tests/web.scm new file mode 100644 index 0000000..836f4ca --- /dev/null +++ b/tests/web.scm @@ -0,0 +1,223 @@ +(use-modules (tests) + (fibers) + (srfi srfi-71) + (ice-9 rdelim) + (ice-9 exceptions) + (unit-test) + (web uri) + (web client) + (web request) + (web response) + (knots resource-pool) + (knots web-server) + (knots web)) + +;; Test that call-with-cached-connection passes the port to proc and +;; returns its result. +(run-fibers-for-tests + (lambda () + (let* ((port (open-input-string "")) + (cache (make-fixed-size-resource-pool (list port)))) + (assert-equal + 'ok + (call-with-cached-connection cache (lambda (p) 'ok))) + (destroy-resource-pool cache)))) + +;; Test that call-with-cached-connection retries when the checked-out +;; port is already closed, using a fresh connection from the pool. +(run-fibers-for-tests + (lambda () + (let* ((n 0) + (cache (make-resource-pool + (lambda () + (set! n (+ n 1)) + (if (= n 1) + (let ((p (open-input-string ""))) + (close-port p) + p) + (open-input-string ""))) + 1 + ;; Without a destructor, the resource pool calls (#f port) + ;; when destroying the closed-port resource, looping forever. + #:destructor (const #t)))) + (assert-equal + 'ok + (call-with-cached-connection cache (lambda (p) 'ok))) + (destroy-resource-pool cache)))) + +;; Test that call-with-connection-cache provides a working cache and +;; destroys it after the body returns. +(run-fibers-for-tests + (lambda () + (let* ((web-server + (run-knots-web-server + (lambda (request) + (values '((content-type . (text/plain))) "ok")) + #:port 0)) + (server-port (web-server-port web-server)) + (uri (build-uri 'http #:host "127.0.0.1" #:port server-port))) + (assert-equal + 200 + (call-with-connection-cache + uri 1 + (lambda (cache) + (call-with-cached-connection cache + (lambda (p) + (let ((response body + (http-get uri #:port p #:keep-alive? #t))) + (response-code response)))))))))) + +;; Test that http-fold-requests sends requests and folds over responses. +;; The proc must drain the body port between responses so that HTTP +;; pipelining works correctly. +(run-fibers-for-tests + (lambda () + (let* ((web-server + (run-knots-web-server + (lambda (request) + (values '((content-type . (text/plain))) "ok")) + #:port 0)) + (server-port (web-server-port web-server)) + (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) + (cache (make-connection-cache uri 1)) + (requests (list (build-request uri) + (build-request uri)))) + (let ((codes + (http-fold-requests + cache + (lambda (req resp body result) + (read-string body) ; drain body before next pipelined response + (cons (response-code resp) result)) + '() + requests))) + (assert-equal '(200 200) codes)) + (destroy-resource-pool cache)))) + +;; Test that http-fold-requests reconnects and retries remaining requests when +;; the server closes the connection mid-batch via Connection: close. Three +;; requests are sent in one batch; the server closes after the first response, +;; so the remaining two must be retried on a fresh connection. +(run-fibers-for-tests + (lambda () + (let* ((n 0) + (web-server + (run-knots-web-server + (lambda (request) + (set! n (1+ n)) + (if (= n 1) + (values '((content-type . (text/plain)) + (connection . (close))) + "ok") + (values '((content-type . (text/plain))) "ok"))) + #:port 0)) + (server-port (web-server-port web-server)) + (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) + (cache (make-connection-cache uri 1)) + (requests (list (build-request uri) + (build-request uri) + (build-request uri)))) + (let ((codes + (http-fold-requests + cache + (lambda (req resp body result) + (read-string body) + (cons (response-code resp) result)) + '() + requests))) + (assert-equal '(200 200 200) codes)) + (destroy-resource-pool cache)))) + +;; Test that write errors in send-batch are handled gracefully. Each request +;; carries a large header so that the batch data exceeds the TCP send buffer, +;; causing write-request to fail while the server has already closed the +;; connection after the first response. +(run-fibers-for-tests + (lambda () + (let* ((n 0) + (web-server + (run-knots-web-server + (lambda (request) + (set! n (1+ n)) + (if (= n 1) + (values '((content-type . (text/plain)) + (connection . (close))) + "ok") + (values '((content-type . (text/plain))) "ok"))) + #:port 0)) + (server-port (web-server-port web-server)) + (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) + (cache (make-connection-cache uri 1)) + (n-requests 100) + ;; 100 requests x ~100 KB of headers each = ~10 MB, well above + ;; the typical TCP send buffer, so writes fail mid-batch. + (large-request + (build-request uri + #:headers + `((x-padding . ,(make-string 100000 #\a))))) + (requests (make-list n-requests large-request))) + (let ((codes + (http-fold-requests + cache + (lambda (req resp body result) + (read-string body) + (cons (response-code resp) result)) + '() + requests))) + (assert-equal (make-list n-requests 200) codes)) + (destroy-resource-pool cache)))) + +;; Test that http-fold-requests processes multiple batches. With batch-size 2 +;; and 5 requests, three batches are needed; without the pending fix only the +;; first batch would be processed. +(run-fibers-for-tests + (lambda () + (let* ((web-server + (run-knots-web-server + (lambda (request) + (values '((content-type . (text/plain))) "ok")) + #:port 0)) + (server-port (web-server-port web-server)) + (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) + (cache (make-connection-cache uri 1)) + (requests (make-list 5 (build-request uri)))) + (let ((codes + (http-fold-requests + cache + (lambda (req resp body result) + (read-string body) + (cons (response-code resp) result)) + '() + requests + #:batch-size 2))) + (assert-equal (make-list 5 200) codes)) + (destroy-resource-pool cache)))) + +;; Test that an exception raised by proc propagates out of http-fold-requests. +(run-fibers-for-tests + (lambda () + (let* ((web-server + (run-knots-web-server + (lambda (request) + (values '((content-type . (text/plain))) "ok")) + #:port 0)) + (server-port (web-server-port web-server)) + (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) + (cache (make-connection-cache uri 1)) + (requests (list (build-request uri)))) + (assert-equal + 'proc-exception + (exception-message + (with-exception-handler + (lambda (exn) exn) + (lambda () + (http-fold-requests + cache + (lambda (req resp body result) + (raise-exception + (make-exception-with-message 'proc-exception))) + '() + requests)) + #:unwind? #t))) + (destroy-resource-pool cache)))) + +(display "web test finished successfully\n") From 768c2b6a5b7815db247073685c4a35b7193cfc88 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 18 Mar 2026 21:39:55 +0000 Subject: [PATCH 61/78] Export call-with-temporary-thread --- knots.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/knots.scm b/knots.scm index 304931e..ed353f1 100644 --- a/knots.scm +++ b/knots.scm @@ -26,6 +26,8 @@ print-backtrace-and-exception/knots + call-with-temporary-thread + spawn-fiber/knots)) (define (call-with-default-io-waiters thunk) From bb6d9fd89dc29472d659229693a3c033819fc2b7 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 15:04:51 +0000 Subject: [PATCH 62/78] Add exception handling to the server loop This should start to deal with accept failing if there are too many open files. --- knots/web-server.scm | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index adaba13..a99b971 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -576,19 +576,28 @@ before sending back to the client." (spawn-fiber (lambda () - (let loop () - (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC)) - ((client . sockaddr) - (spawn-fiber (lambda () - (client-loop client handler - read-request-exception-handler - write-response-exception-handler - connection-idle-timeout - connection-buffer-size - (post-request-hook/safe - post-request-hook))) - #:parallel? #t) - (loop)))))) + (while #t + (with-exception-handler + (const #t) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn)) + (lambda () + (let loop () + (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC)) + ((client . sockaddr) + (spawn-fiber (lambda () + (client-loop client handler + read-request-exception-handler + write-response-exception-handler + connection-idle-timeout + connection-buffer-size + (post-request-hook/safe + post-request-hook))) + #:parallel? #t) + (loop))))))) + #:unwind? #t)))) (make-web-server socket (vector-ref (getsockname socket) From 677d941cb320aecf4f127e77f041f348d80f6d62 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 15:16:17 +0000 Subject: [PATCH 63/78] Simplify web server exception handling This used to be more complicated as the exception handler was configurable, but now it's not so this can be simplified. --- knots/web-server.scm | 87 ++++++++++++++++++++------------------------ 1 file changed, 39 insertions(+), 48 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index a99b971..99abfdc 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -317,26 +317,6 @@ on the procedure being called at any particular time." ;; Close the client port #f) -(define (exception-handler exn request) - (let* ((error-string - (call-with-output-string - (lambda (port) - (simple-format - port - "exception when processing: ~A ~A\n" - (request-method request) - (uri-path (request-uri request))) - (print-backtrace-and-exception/knots - exn - #:port port))))) - (display/knots error-string - (current-error-port))) - - (values (build-response #:code 500) - ;; TODO Make this configurable - (string->utf8 - "internal server error"))) - (define* (handle-request handler client read-request-exception-handler write-response-exception-handler @@ -362,36 +342,47 @@ on the procedure being called at any particular time." (connection . (close)))) #vu8())) (else - (call-with-escape-continuation - (lambda (return) - (with-exception-handler - (lambda (exn) + (with-exception-handler + (lambda (exn) + (sanitize-response + request + (build-response #:code 500) + (string->utf8 + "internal server error"))) + (lambda () + (with-exception-handler + (lambda (exn) + (let* ((error-string + (call-with-output-string + (lambda (port) + (simple-format + port + "exception when processing: ~A ~A\n" + (request-method request) + (uri-path (request-uri request))) + (print-backtrace-and-exception/knots + exn + #:port port))))) + (display/knots error-string + (current-error-port)))) + (lambda () + (start-stack + #t (call-with-values (lambda () - (exception-handler exn request)) - (lambda (response body) - (call-with-values - (lambda () - (sanitize-response request response body)) - return)))) - (lambda () - (start-stack - #t - (call-with-values - (lambda () - (handler request)) - (match-lambda* - ((response body) - (sanitize-response request response body)) - (other - (raise-exception - (make-exception-with-irritants - (list (make-exception-with-message - (simple-format - #f - "wrong number of values returned from handler, expecting 2, got ~A" - (length other))) - handler))))))))))))))) + (handler request)) + (match-lambda* + ((response body) + (sanitize-response request response body)) + (other + (raise-exception + (make-exception-with-irritants + (list (make-exception-with-message + (simple-format + #f + "wrong number of values returned from handler, expecting 2, got ~A" + (length other))) + handler))))))))))))))) (with-exception-handler (lambda (exn) (write-response-exception-handler exn request)) From c36ddc2214ac872d76814744b720d4177163a59d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 15:19:33 +0000 Subject: [PATCH 64/78] web-server: Expose the sockaddr in the request meta. --- knots/web-server.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index 99abfdc..60b3f06 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -317,16 +317,19 @@ on the procedure being called at any particular time." ;; Close the client port #f) -(define* (handle-request handler client +(define* (handle-request handler client sockaddr read-request-exception-handler write-response-exception-handler buffer-size #:key post-request-hook) + (define meta + `((sockaddr . ,sockaddr))) + (let ((request (with-exception-handler read-request-exception-handler (lambda () - (read-request client)) + (read-request client meta)) #:unwind? #t)) (read-request-time (get-internal-real-time))) @@ -449,7 +452,7 @@ on the procedure being called at any particular time." #f))) #:unwind? #t)))) -(define* (client-loop client handler +(define* (client-loop client handler sockaddr read-request-exception-handler write-response-exception-handler connection-idle-timeout @@ -494,7 +497,7 @@ on the procedure being called at any particular time." #:unwind? #t) (close-port client)) (else - (let ((keep-alive? (handle-request handler client + (let ((keep-alive? (handle-request handler client sockaddr read-request-exception-handler write-response-exception-handler buffer-size @@ -579,7 +582,7 @@ before sending back to the client." (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC)) ((client . sockaddr) (spawn-fiber (lambda () - (client-loop client handler + (client-loop client handler sockaddr read-request-exception-handler write-response-exception-handler connection-idle-timeout From 92c2fe46e751d21f976cbd53df1f3b4ce5997a34 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 15:20:01 +0000 Subject: [PATCH 65/78] Add a copyright header to knots.scm --- knots.scm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/knots.scm b/knots.scm index ed353f1..089f986 100644 --- a/knots.scm +++ b/knots.scm @@ -1,3 +1,22 @@ +;;; Guile Knots +;;; Copyright © 2026 Christopher Baines +;;; +;;; This file is part of Guile Knots. +;;; +;;; The Guile Knots is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; The Guile Knots is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with the guix-data-service. If not, see +;;; . + (define-module (knots) #:use-module (srfi srfi-1) #:use-module (ice-9 match) From b3fa4d069b06e3fe9948386f37349838ef173a71 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Fri, 20 Mar 2026 19:11:03 +0000 Subject: [PATCH 66/78] Rework the backtrace handling Try and improve the print-backtrace-and-exception/knots output, be selective about the stack frames which are shown to try and produce some useful output which reflects user code and hide the &knots-exceptions. This commit also introduces a bunch of tests scripts that produce output from print-backtrace-and-exception/knots, to help test this code in different situations. --- Makefile.am | 6 +- knots.scm | 125 +------ knots/backtraces.scm | 318 +++++++++++++++++ tests/backtraces.scm | 319 ++++++++++++++++++ .../call-with-cached-connection.scm | 18 + .../call-with-resource-from-pool.scm | 16 + tests/backtraces/call-with-thread.scm | 14 + tests/backtraces/fibers-force.scm | 15 + tests/backtraces/fibers-map.scm | 20 ++ .../backtraces/guile-error-deep-in-thread.scm | 19 ++ tests/backtraces/guile-error-in-thread.scm | 11 + tests/backtraces/nested-parallelism.scm | 40 +++ tests/backtraces/plain-exception.scm | 10 + tests/backtraces/stack-situation-fibers.scm | 19 ++ tests/backtraces/stack-situation-script.scm | 15 + tests/backtraces/stack-situation-unknown.scm | 17 + tests/backtraces/temporary-thread.scm | 11 + .../triple-with-exception-handler.scm | 16 + tests/backtraces/vhash-fold-in-thread.scm | 26 ++ tests/backtraces/vhash-fold.scm | 24 ++ tests/backtraces/wrapped-exception.scm | 16 + 21 files changed, 957 insertions(+), 118 deletions(-) create mode 100644 knots/backtraces.scm create mode 100644 tests/backtraces.scm create mode 100644 tests/backtraces/call-with-cached-connection.scm create mode 100644 tests/backtraces/call-with-resource-from-pool.scm create mode 100644 tests/backtraces/call-with-thread.scm create mode 100644 tests/backtraces/fibers-force.scm create mode 100644 tests/backtraces/fibers-map.scm create mode 100644 tests/backtraces/guile-error-deep-in-thread.scm create mode 100644 tests/backtraces/guile-error-in-thread.scm create mode 100644 tests/backtraces/nested-parallelism.scm create mode 100644 tests/backtraces/plain-exception.scm create mode 100644 tests/backtraces/stack-situation-fibers.scm create mode 100644 tests/backtraces/stack-situation-script.scm create mode 100644 tests/backtraces/stack-situation-unknown.scm create mode 100644 tests/backtraces/temporary-thread.scm create mode 100644 tests/backtraces/triple-with-exception-handler.scm create mode 100644 tests/backtraces/vhash-fold-in-thread.scm create mode 100644 tests/backtraces/vhash-fold.scm create mode 100644 tests/backtraces/wrapped-exception.scm diff --git a/Makefile.am b/Makefile.am index 7942955..3429a15 100644 --- a/Makefile.am +++ b/Makefile.am @@ -2,18 +2,20 @@ include guile.am SOURCES = \ knots.scm \ + knots/backtraces.scm \ knots/non-blocking.scm \ knots/parallelism.scm \ knots/promise.scm \ - knots/web.scm \ knots/queue.scm \ knots/resource-pool.scm \ knots/sort.scm \ knots/thread-pool.scm \ knots/timeout.scm \ - knots/web-server.scm + knots/web-server.scm \ + knots/web.scm SCM_TESTS = \ + tests/backtraces.scm \ tests/non-blocking.scm \ tests/non-blocking.scm \ tests/parallelism.scm \ diff --git a/knots.scm b/knots.scm index 089f986..e8e9690 100644 --- a/knots.scm +++ b/knots.scm @@ -19,6 +19,7 @@ (define-module (knots) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (ice-9 binary-ports) @@ -27,7 +28,14 @@ #:use-module (fibers) #:use-module (fibers channels) #:use-module (fibers conditions) - #:use-module (system repl debug) + #:use-module (ice-9 format) + #:use-module (knots backtraces) + #:re-export (&knots-exception + make-knots-exception + knots-exception? + knots-exception-stack + + print-backtrace-and-exception/knots) #:export (call-with-default-io-waiters wait-when-system-clock-behind @@ -38,13 +46,6 @@ simple-format/knots format/knots - &knots-exception - make-knots-exception - knots-exception? - knots-exception-stack - - print-backtrace-and-exception/knots - call-with-temporary-thread spawn-fiber/knots)) @@ -176,114 +177,6 @@ without buffering." (current-output-port) port))))) -(define &knots-exception - (make-exception-type '&knots-exception - &exception - '(stack))) - -(define make-knots-exception - (record-constructor &knots-exception)) - -(define knots-exception? - (exception-predicate &knots-exception)) - -(define knots-exception-stack - (exception-accessor - &knots-exception - (record-accessor &knots-exception 'stack))) - -(define* (print-backtrace-and-exception/knots - exn - #:key (port (current-error-port))) - (define (get-string port stack) - (define stack-len - (stack-length stack)) - - (let ((knots-stacks - (map knots-exception-stack - (filter knots-exception? - (simple-exceptions exn))))) - - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 5) - 0 - 4))) - port - #:count (stack-length stack))) - (for-each - (lambda (stack) - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 4) - 0 - 3))) - port - #:count (stack-length stack)))) - knots-stacks) - (print-exception - port - (if (null? knots-stacks) - (stack-ref stack - (if (< stack-len 4) - stack-len - 4)) - (let* ((stack (last knots-stacks)) - (stack-len (stack-length stack))) - (stack-ref stack - (if (< stack-len 3) - stack-len - 3)))) - '%exception - (list exn)))) - - (let* ((stack - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1))) - (_ - (make-stack #t)))) - (string-port - (open-output-string)) - (error-string - (with-exception-handler - (lambda (exn) - (display/knots (get-output-string string-port) - port) - (close-output-port string-port) - (display/knots "\n\n" port) - - (let* ((stack (make-stack #t)) - (backtrace - (call-with-output-string - (lambda (port) - (display-backtrace stack port) - (newline port))))) - (display/knots backtrace)) - (simple-format/knots - port - "\nexception in print-backtrace-and-exception/knots: ~A\n" - exn) - (raise-exception exn)) - (lambda () - (get-string string-port stack) - (let ((str (get-output-string string-port))) - (close-output-port string-port) - str))))) - (display/knots error-string port))) - (define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) "Spawn a fiber to run THUNK, with knots exception handling. diff --git a/knots/backtraces.scm b/knots/backtraces.scm new file mode 100644 index 0000000..a12ecb6 --- /dev/null +++ b/knots/backtraces.scm @@ -0,0 +1,318 @@ +;;; Guile Knots +;;; Copyright © 2026 Christopher Baines +;;; +;;; This file is part of Guile Knots. +;;; +;;; The Guile Knots is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; The Guile Knots is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with the guix-data-service. If not, see +;;; . + +(define-module (knots backtraces) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-43) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (system repl debug) + #:use-module (system vm frame) + #:use-module ((knots) #:select (display/knots + simple-format/knots + format/knots)) + #:export (&knots-exception + make-knots-exception + knots-exception? + knots-exception-stack + + print-backtrace-and-exception/knots + + classify-stack-situation)) + +(define &knots-exception + (make-exception-type '&knots-exception + &exception + '(stack))) + +(define make-knots-exception + (record-constructor &knots-exception)) + +(define knots-exception? + (exception-predicate &knots-exception)) + +(define knots-exception-stack + (exception-accessor + &knots-exception + (record-accessor &knots-exception 'stack))) + +(define (backtrace-debug-mode?) + (let ((val (getenv "KNOTS_BACKTRACE_DEBUG"))) + (and val + (not (string=? val "")) + (not (string=? val "0"))))) + +(define (debug-print-stack port label full-vec included-vec) + (simple-format/knots port "[KNOTS DEBUG] ~A\n" label) + (if (vector-empty? full-vec) + (simple-format/knots port " (empty)\n") + (vector-fold-right + (lambda (i _ frame) + (let ((marker + (if (vector-index + (lambda (f) (eq? f frame)) + included-vec) + ">" " ")) + (name + (symbol->string + (or (frame-procedure-name frame) + '_)))) + (match (frame-source frame) + (#f + (format/knots port " ~a ~3d unknown ~a~%" + marker i name)) + ((_ file line . col) + (format/knots port " ~a ~3d ~a:~a:~a ~a~%" + marker i file (1+ line) col name))))) + #f + full-vec)) + (force-output port)) + +(define (internal-file? file) + (or (string-prefix? "ice-9/" file) + (string-prefix? "system/" file) + (string-prefix? "srfi/" file) + (string=? file "knots.scm") + (string-prefix? "knots/" file) + (string=? file "fibers.scm") + (string-prefix? "fibers/" file))) + +(define (frame-file frame) + (let ((src (frame-source frame))) + (and src (cadr src)))) + +(define (user-frame? frame) + (let ((file (frame-file frame))) + (and (string? file) + (not (internal-file? file))))) + +(define (raise-machinery-frame? frame) + ;; Return #t for frames that are part of the raise/unwind machinery + ;; and should be skipped when looking for the raise site. + ;; Specifically: C/unknown frames (no source file) and + ;; ice-9/boot-9.scm frames. Other internal frames such as + ;; ice-9/vlist.scm are part of the actual call path and should be + ;; preserved. + (let ((file (frame-file frame))) + (or (not file) + (string=? file "ice-9/boot-9.scm")))) + +(define (fibers-frame? frame) + ;; Return #t if FRAME belongs to the fibers library. + (let ((file (frame-file frame))) + (and (string? file) + (or (string=? file "fibers.scm") + (string-prefix? "fibers/" file))))) + +;; The number of frames in Guile's eval-machinery tail appended to every +;; top-level script stack: +;; +;; [n-6] ice-9/boot-9.scm _ +;; [n-5] ice-9/boot-9.scm save-module-excursion +;; [n-4] ice-9/eval.scm _ +;; [n-3] ice-9/boot-9.scm call-with-prompt +;; [n-2] C/unknown apply-smob/0 +;; [n-1] ice-9/boot-9.scm with-exception-handler +(define script-eval-tail-length 6) + +(define (classify-stack-situation stack-vector) + (cond + ((vector-any fibers-frame? stack-vector) + 'run-fibers) + ((let ((len (vector-length stack-vector))) + (and (>= len script-eval-tail-length) + (equal? (frame-file (vector-ref stack-vector (- len 1))) + "ice-9/boot-9.scm") + (eq? (frame-procedure-name (vector-ref stack-vector (- len 3))) + 'call-with-prompt) + (not (vector-any (lambda (frame) + (eq? (frame-procedure-name frame) + '%start-stack)) + stack-vector)))) + 'script) + (else + 'unknown))) + +(define (filter-knots-stack-vector vector) + ;; Extract user frames from a pre-captured knots stack. The bottom 3 frames + ;; are always fixed overhead: make-stack (C), the handler body frame at the + ;; make-stack call site (exactly 1 Scheme frame), and raise-exception + ;; (boot-9). User frames start at index 3. + (let ((last-user (vector-index-right user-frame? vector))) + (if (or (not last-user) (< last-user 3)) + #() + (vector-copy vector 3 (+ last-user 1))))) + +(define (filter-stack-vector vector) + ;; Return the slice of VECTOR containing the frames relevant for + ;; display. Skips the fixed 2-frame overhead (make-stack + call + ;; site) and any raise machinery to find after-raise, then bounds at + ;; the eval-machinery tail (script) or the first fibers scheduler + ;; frame (run-fibers/unknown). + + (define (skip-handler-and-raise vector start) + ;; Scan forward from START in VECTOR, first past any user frames + ;; (the handler body), then past raise-machinery frames (C/unknown + ;; and ice-9/boot-9.scm). Returns the index of the first + ;; remaining frame — the raise site or context. Other internal + ;; frames such as ice-9/vlist.scm are preserved because they are + ;; part of the actual call path. + (let* ((len (vector-length vector)) + (after-handler + (let loop ((i start)) + (if (or (>= i len) (not (user-frame? (vector-ref vector i)))) + i + (loop (+ i 1)))))) + (let loop ((i after-handler)) + (cond + ((>= i len) i) + ((raise-machinery-frame? (vector-ref vector i)) (loop (+ i 1))) + (else i))))) + + (let* ((len (vector-length vector)) + (situation (classify-stack-situation vector)) + (after-raise (skip-handler-and-raise vector (min 2 len))) + (end (if (and (eq? situation 'script) + (> (- len script-eval-tail-length) after-raise)) + (- len script-eval-tail-length) + (let loop ((i after-raise)) + (cond ((>= i len) i) + ((fibers-frame? (vector-ref vector i)) i) + (else (loop (+ i 1)))))))) + (if (>= after-raise end) + #() + (vector-copy vector after-raise end)))) + +;; Based on print-frame from (system repl debug), but without the +;; frame indexes +(define* (print-frame/no-index frame + #:optional (port (current-output-port)) + #:key (width (terminal-width)) + (last-source #f) (innermost? #f)) + (define (source-file src) + (match src + (#f "unknown file") + ((_ #f . _) "current input") + ((_ file . _) file))) + (let* ((source (frame-source frame)) + (file (source-file source))) + (when (not (equal? file (source-file last-source))) + (format port "~&In ~a:~&" file)) + (format port "~9@a ~v:@y~%" + (match source + (#f "") + ((_ _ line . col) (simple-format #f "~A:~A" (1+ line) col))) + width + (frame-call-representation frame #:top-frame? innermost?)))) + +(define* (print-backtrace-and-exception/knots + exn + #:key (port (current-error-port))) + (define (get-string out stack) + (let* ((stack-vector (stack->vector stack)) + (knots-stack-vectors + (map (lambda (exn) + (stack->vector + (knots-exception-stack exn))) + (reverse + (filter knots-exception? + (simple-exceptions exn))))) + (filtered-stack-vector + (filter-stack-vector stack-vector)) + (filtered-knots-stack-vectors + (map filter-knots-stack-vector knots-stack-vectors))) + (when (backtrace-debug-mode?) + (let ((debug-port (current-error-port)) + (situation (classify-stack-situation stack-vector))) + (simple-format/knots + debug-port + "[KNOTS DEBUG] situation: ~A\n" situation) + (debug-print-stack debug-port "stack" + stack-vector filtered-stack-vector) + (let ((stack-count (length knots-stack-vectors))) + (for-each + (lambda (knots-vec user-vec index) + (debug-print-stack + debug-port + (format #f "knots stack ~a/~a" index stack-count) + knots-vec user-vec)) + knots-stack-vectors + filtered-knots-stack-vectors + (iota stack-count 1))) + (display/knots "\n" debug-port) + (force-output debug-port))) + + (for-each (lambda (vec) + (vector-fold-right + (lambda (i last-source frame) + (print-frame/no-index frame out + #:innermost? (= i 0) + #:last-source last-source) + (frame-source frame)) + #f + vec)) + (cons filtered-stack-vector + filtered-knots-stack-vectors)) + + (print-exception + out + #f + '%exception + (list (if (backtrace-debug-mode?) + exn + (apply make-exception + (remove knots-exception? + (simple-exceptions exn)))))))) + + (let* ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t)))) + (string-port + (open-output-string)) + (output + (with-exception-handler + (lambda (output-exn) + (display/knots (get-output-string string-port) + port) + (close-output-port string-port) + (display/knots "\n\n" port) + + (let* ((stack (make-stack #t)) + (backtrace + (call-with-output-string + (lambda (port) + (display-backtrace stack port) + (newline port))))) + (display/knots backtrace port)) + (simple-format/knots + port + "\nexception in print-backtrace-and-exception/knots: ~A\n" + output-exn) + (raise-exception output-exn)) + (lambda () + (get-string string-port stack) + (let ((str (get-output-string string-port))) + (close-output-port string-port) + str))))) + (display/knots output port))) diff --git a/tests/backtraces.scm b/tests/backtraces.scm new file mode 100644 index 0000000..c5f8e0e --- /dev/null +++ b/tests/backtraces.scm @@ -0,0 +1,319 @@ +(use-modules (srfi srfi-1) + (srfi srfi-13) + (ice-9 popen) + (ice-9 rdelim) + (ice-9 match)) + +(define (run-backtrace-script file) + (let* ((pipe (open-pipe* OPEN_READ + "/bin/sh" "-c" + (string-append "./test-env guile " file " 2>&1"))) + (output (read-string pipe))) + (close-pipe pipe) + output)) + +(define (read-backtrace-entry-annotation script keyword) + ;; Scan SCRIPT line by line and return the annotation for the expected + ;; backtrace entry matching KEYWORD (e.g. "FIRST" or "LAST"), or #f if + ;; none is found. + ;; + ;; Two forms are recognised: + ;; + ;; ; KEYWORD BACKTRACE ENTRY HERE + ;; — placed inline on a code line. Returns ('here LINE COL) where LINE + ;; is the 1-based line number and COL is the 0-based column of the + ;; first non-space character on that line. + ;; + ;; ; KEYWORD BACKTRACE ENTRY: STRING + ;; — STRING is a literal substring expected to appear in the output. + ;; Returns ('string STRING). + (let ((here-marker (string-append keyword " BACKTRACE ENTRY HERE")) + (string-marker (string-append keyword " BACKTRACE ENTRY: "))) + (call-with-input-file script + (lambda (port) + (let loop ((line (read-line port)) (line-num 1)) + (cond + ((eof-object? line) #f) + ((string-contains line here-marker) + (let ((col (string-index line (lambda (c) (not (char=? c #\space)))))) + (list 'here line-num col))) + ((string-contains line string-marker) + (let* ((idx (+ (string-contains line string-marker) + (string-length string-marker))) + (content (string-trim-right (substring line idx)))) + (list 'string content))) + (else (loop (read-line port) (+ line-num 1))))))))) + +(define (frame-line? line) + ;; Return #t if LINE looks like a backtrace frame line: leading whitespace + ;; followed by digits:digits (LINE:COL). + (and (> (string-length line) 0) + (let* ((stripped (string-trim line)) + (colon (string-index stripped #\:))) + (and colon + (> colon 0) + (string-every char-set:digit stripped 0 colon))))) + +(define (extract-frame-lines output) + ;; Return all backtrace frame lines before "ERROR:" in OUTPUT. + (let* ((error-pos (string-contains output "\nERROR:")) + (before-error (if error-pos + (substring output 0 error-pos) + output))) + (filter frame-line? (string-split before-error #\newline)))) + +(define (innermost-frame-line output) + ;; Return the last backtrace frame line before "ERROR:" in OUTPUT, or #f. + (let ((frame-lines (extract-frame-lines output))) + (if (null? frame-lines) #f (last frame-lines)))) + +(define (outermost-frame-line output) + ;; Return the first backtrace frame line before "ERROR:" in OUTPUT, or #f. + (let ((frame-lines (extract-frame-lines output))) + (if (null? frame-lines) #f (car frame-lines)))) + +;;; Assertions + +(define current-test-fail-count 0) + +(define (expect! label ok? detail) + ;; Print one expectation line; record a failure if not ok. + (if ok? + (format #t " PASS ~a~%" label) + (begin + (set! current-test-fail-count (+ current-test-fail-count 1)) + (format #t " FAIL ~a~% ~a~%" label detail)))) + +(define (assert-output-contains output expected) + (expect! (format #f "output contains ~s" expected) + (string-contains output expected) + "not found in output")) + +(define (assert-output-excludes output unexpected) + (expect! (format #f "output excludes ~s" unexpected) + (not (string-contains output unexpected)) + "unexpectedly found in output")) + +(define (assert-backtrace-entry output script keyword frame-line-proc) + (let ((annotation (read-backtrace-entry-annotation script keyword)) + (frame (frame-line-proc output))) + (when annotation + (match annotation + (('here line col) + (let ((expected (string-append (number->string line) ":" + (number->string col)))) + (expect! (format #f "~a backtrace entry ~a" keyword expected) + (and frame (string-contains frame expected)) + (format #f "got ~s" (or frame "(none)"))))) + (('string content) + (expect! (format #f "~a backtrace entry ~s" keyword content) + (string-contains output content) + "not found in output")))))) + +(define (assert-first-backtrace-entry output script) + (assert-backtrace-entry output script "FIRST" outermost-frame-line)) + +(define (assert-last-backtrace-entry output script) + (assert-backtrace-entry output script "LAST" innermost-frame-line)) + +;;; Test runner + +(define pass-count 0) +(define fail-count 0) + +(define (run-test name thunk) + (set! current-test-fail-count 0) + (format #t "~%~a~%" name) + (catch #t + thunk + (lambda (key . args) + (set! current-test-fail-count (+ current-test-fail-count 1)) + (format #t " ERROR unexpected exception: ~s~%" (cons key args)))) + (if (zero? current-test-fail-count) + (set! pass-count (+ pass-count 1)) + (set! fail-count (+ fail-count 1)))) + +;;; Tests + +(run-test "plain-exception" + (lambda () + (let* ((script "tests/backtraces/plain-exception.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"plain error message\"")))) + +(run-test "triple-with-exception-handler" + (lambda () + (let* ((script "tests/backtraces/triple-with-exception-handler.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"plain error message\"")))) + +(run-test "wrapped-exception" + (lambda () + (let* ((script "tests/backtraces/wrapped-exception.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"wrapped error message\"")))) + +(run-test "temporary-thread" + (lambda () + (let* ((script "tests/backtraces/temporary-thread.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from temporary thread\"")))) + +(run-test "fibers-map" + (lambda () + (let* ((script "tests/backtraces/fibers-map.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from fibers-map\"")))) + +(run-test "call-with-resource-from-pool" + (lambda () + (let* ((script "tests/backtraces/call-with-resource-from-pool.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-resource-from-pool\"")))) + +;; Two knots stacks are printed (one per fiber boundary); ERROR: appears +;; once at the end after both frame blocks. +(run-test "call-with-cached-connection" + (lambda () + (let* ((script "tests/backtraces/call-with-cached-connection.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-cached-connection\"")))) + +(run-test "fibers-force" + (lambda () + (let* ((script "tests/backtraces/fibers-force.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from fibers-force\"")))) + +(run-test "call-with-thread" + (lambda () + (let* ((script "tests/backtraces/call-with-thread.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-thread\"")))) + +;; Nested fibers-map: user frames that survive fiber boundaries appear; +;; intermediate functions (one-deep, two-deep, three-deep) are lost at +;; their respective boundaries because fibers-map yields before the +;; exception propagates back. knots/parallelism.scm and srfi frames +;; appear as call-path context between the surviving user frames. +(run-test "nested-parallelism" + (lambda () + (let* ((script "tests/backtraces/nested-parallelism.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"deeply nested error ~S\"") + (assert-output-contains output "(run-work)") + (assert-output-contains output "(process-batch _)") + (assert-output-contains output "(deeply-nested _)") + (assert-output-excludes output "In fibers")))) + +(run-test "guile-error-in-thread" + (lambda () + (let* ((script "tests/backtraces/guile-error-in-thread.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &assertion-failure\n 2. &origin: \"+\"\n 3. &message: \"Wrong type argument in position ~A: ~S\"\n 4. &irritants: (1 a)")))) + +;; sort is a C function and appears as "In unknown file:" between the user frames. +(run-test "guile-error-deep-in-thread" + (lambda () + (let* ((script "tests/backtraces/guile-error-deep-in-thread.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &assertion-failure\n 2. &origin: \"+\"") + (assert-output-contains output "(do-sort)") + (assert-output-contains output "In unknown file:") + (assert-output-contains output "(sort (1 2 3)") + (assert-output-excludes output "In knots/") + (assert-output-excludes output "In srfi/")))) + +;; The error fires inside ice-9/vlist.scm (vlist-fold passed a non-vlist), +;; so vlist-fold appears as the innermost frame and ice-9/vlist.scm frames +;; appear between the user frames. +(run-test "vhash-fold" + (lambda () + (let* ((script "tests/backtraces/vhash-fold.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &assertion-failure\n 2. &origin: #f") + (assert-output-contains output "(do-fold)") + (assert-output-contains output "In ice-9/vlist.scm:") + (assert-output-contains output "(vlist-fold")))) + +;; do-fold calls vhash-fold in non-tail position so its frame is preserved. +;; ice-9/vlist.scm frames appear between the user frames, as in vhash-fold. +(run-test "vhash-fold-in-thread" + (lambda () + (let* ((script "tests/backtraces/vhash-fold-in-thread.scm") + (output (run-backtrace-script script))) + (assert-first-backtrace-entry output script) + (assert-last-backtrace-entry output script) + (assert-output-contains output + "ERROR:\n 1. &assertion-failure\n 2. &origin: #f") + (assert-output-contains output "(do-fold)") + (assert-output-contains output "In ice-9/vlist.scm:") + (assert-output-contains output "(vlist-fold") + (assert-output-excludes output "In knots/")))) + +(run-test "stack-situation-script" + (lambda () + (let* ((script "tests/backtraces/stack-situation-script.scm") + (output (run-backtrace-script script))) + (assert-output-contains output "situation: script")))) + +(run-test "stack-situation-fibers" + (lambda () + (let* ((script "tests/backtraces/stack-situation-fibers.scm") + (output (run-backtrace-script script))) + (assert-output-contains output "situation: run-fibers")))) + +(run-test "stack-situation-unknown" + (lambda () + (let* ((script "tests/backtraces/stack-situation-unknown.scm") + (output (run-backtrace-script script))) + (assert-output-contains output "situation: unknown")))) + +;;; Summary + +(newline) +(if (zero? fail-count) + (format #t "All ~a scripts passed.~%" pass-count) + (format #t "~a of ~a scripts had failures.~%" fail-count (+ pass-count fail-count))) + +(when (> fail-count 0) + (primitive-exit 1)) diff --git a/tests/backtraces/call-with-cached-connection.scm b/tests/backtraces/call-with-cached-connection.scm new file mode 100644 index 0000000..2e641a2 --- /dev/null +++ b/tests/backtraces/call-with-cached-connection.scm @@ -0,0 +1,18 @@ +(use-modules (knots) (fibers) (knots resource-pool) (knots web)) + +(run-fibers + (lambda () + (let ((cache (make-fixed-size-resource-pool + (list (open-input-string "fake"))))) + ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + (with-exception-handler + (lambda (e) + (print-backtrace-and-exception/knots e) + (primitive-exit 1)) + (lambda () + (call-with-cached-connection cache + (lambda (port) + (error "error from call-with-cached-connection")) ; LAST BACKTRACE ENTRY HERE + #:close-connection-on-exception? #f))))) + #:hz 0 #:parallelism 1) + diff --git a/tests/backtraces/call-with-resource-from-pool.scm b/tests/backtraces/call-with-resource-from-pool.scm new file mode 100644 index 0000000..cdbce9e --- /dev/null +++ b/tests/backtraces/call-with-resource-from-pool.scm @@ -0,0 +1,16 @@ +(use-modules (knots) (fibers) (knots resource-pool)) + +(run-fibers + (lambda () + (let ((pool (make-resource-pool (const 'resource) 1))) + ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + (with-exception-handler + (lambda (e) + (print-backtrace-and-exception/knots e) + (primitive-exit 1)) + (lambda () + (call-with-resource-from-pool pool + (lambda (resource) + (error "error from call-with-resource-from-pool"))))))) ; LAST BACKTRACE ENTRY HERE + #:hz 0 #:parallelism 1) + diff --git a/tests/backtraces/call-with-thread.scm b/tests/backtraces/call-with-thread.scm new file mode 100644 index 0000000..0921a31 --- /dev/null +++ b/tests/backtraces/call-with-thread.scm @@ -0,0 +1,14 @@ +(use-modules (knots) (knots thread-pool)) + +(define thread-pool (make-fixed-size-thread-pool 1)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (call-with-thread + thread-pool + (lambda () + (error "error from call-with-thread"))))) ; LAST BACKTRACE ENTRY HERE diff --git a/tests/backtraces/fibers-force.scm b/tests/backtraces/fibers-force.scm new file mode 100644 index 0000000..7abef0c --- /dev/null +++ b/tests/backtraces/fibers-force.scm @@ -0,0 +1,15 @@ +(use-modules (knots) (fibers) (knots promise)) + +(run-fibers + (lambda () + ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + (with-exception-handler + (lambda (e) + (print-backtrace-and-exception/knots e) + (primitive-exit 1)) + (lambda () + (fibers-force + (fibers-delay + (lambda () + (error "error from fibers-force"))))))) ; LAST BACKTRACE ENTRY HERE + #:hz 0 #:parallelism 1) diff --git a/tests/backtraces/fibers-map.scm b/tests/backtraces/fibers-map.scm new file mode 100644 index 0000000..24ef36c --- /dev/null +++ b/tests/backtraces/fibers-map.scm @@ -0,0 +1,20 @@ +(use-modules (knots) (fibers) (knots parallelism)) + +(run-fibers + (lambda () + (with-exception-handler + (lambda _ + ;; To avoid the test hanging if there's an exception + (primitive-exit 1)) + (lambda () + ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + (with-exception-handler + (lambda (e) + (print-backtrace-and-exception/knots e) + (primitive-exit 1)) + (lambda () + (fibers-map + (lambda (x) + (error "error from fibers-map")) ; LAST BACKTRACE ENTRY HERE + '(1))))))) + #:hz 0 #:parallelism 1) diff --git a/tests/backtraces/guile-error-deep-in-thread.scm b/tests/backtraces/guile-error-deep-in-thread.scm new file mode 100644 index 0000000..405e2b9 --- /dev/null +++ b/tests/backtraces/guile-error-deep-in-thread.scm @@ -0,0 +1,19 @@ +(use-modules (knots)) + +(define (do-sort) + (begin + (sort '(1 2 3) + (lambda _ + (+ 1 'a))) ; LAST BACKTRACE ENTRY HERE + 'unreachable)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (call-with-temporary-thread + (lambda () + (do-sort) + 'done)))) diff --git a/tests/backtraces/guile-error-in-thread.scm b/tests/backtraces/guile-error-in-thread.scm new file mode 100644 index 0000000..3063dec --- /dev/null +++ b/tests/backtraces/guile-error-in-thread.scm @@ -0,0 +1,11 @@ +(use-modules (knots)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (call-with-temporary-thread + (lambda () + (+ 1 'a))))) ; LAST BACKTRACE ENTRY HERE diff --git a/tests/backtraces/nested-parallelism.scm b/tests/backtraces/nested-parallelism.scm new file mode 100644 index 0000000..ceb53b9 --- /dev/null +++ b/tests/backtraces/nested-parallelism.scm @@ -0,0 +1,40 @@ +(use-modules (knots) (fibers) (knots parallelism)) + +;; Deep call chain within the innermost fiber. Each function calls the next +;; via `begin', placing the call in non-tail position so Guile's TCO does not +;; collapse the frames; all four frames survive and appear in the backtrace. +(define (deeply-nested x) + (error "deeply nested error" x)) ; LAST BACKTRACE ENTRY HERE + +(define (three-deep x) + (fibers-map deeply-nested (list x))) + +(define (two-deep x) + (fibers-map three-deep (list x))) + +(define (one-deep x) + (fibers-map two-deep (list x))) + +;; process-batch runs inside one fiber and dispatches the deep call chain into +;; a nested fiber via a second fibers-map, creating two fiber boundaries. +(define (process-batch items) + (begin + (fibers-map one-deep (list items)) + 'unreachable)) + +(define (run-work) + (begin + (fibers-map process-batch '(1)) + 'unreachable)) + +(define result + (run-fibers + (lambda () + ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + (with-exception-handler + (lambda (e) + (print-backtrace-and-exception/knots e) + (primitive-exit 1)) + run-work)) + #:hz 0 #:parallelism 1)) + diff --git a/tests/backtraces/plain-exception.scm b/tests/backtraces/plain-exception.scm new file mode 100644 index 0000000..f2ab1a2 --- /dev/null +++ b/tests/backtraces/plain-exception.scm @@ -0,0 +1,10 @@ +(use-modules (knots)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (error "plain error message"))) ; LAST BACKTRACE ENTRY HERE diff --git a/tests/backtraces/stack-situation-fibers.scm b/tests/backtraces/stack-situation-fibers.scm new file mode 100644 index 0000000..c1e9ec8 --- /dev/null +++ b/tests/backtraces/stack-situation-fibers.scm @@ -0,0 +1,19 @@ +(use-modules (knots) + (knots backtraces) + (fibers) + (system repl debug)) + +(run-fibers + (lambda () + (with-exception-handler + (lambda (exn) + (let ((stack (make-stack #t))) + (print-backtrace-and-exception/knots exn) + (simple-format/knots #t + "situation: ~A\n" + (classify-stack-situation + (stack->vector stack)))) + (primitive-exit 0)) + (lambda () + (error "test")))) + #:hz 0 #:parallelism 1) diff --git a/tests/backtraces/stack-situation-script.scm b/tests/backtraces/stack-situation-script.scm new file mode 100644 index 0000000..a21a8bd --- /dev/null +++ b/tests/backtraces/stack-situation-script.scm @@ -0,0 +1,15 @@ +(use-modules (knots) + (knots backtraces) + (system repl debug)) + +(with-exception-handler + (lambda (exn) + (let ((stack (make-stack #t))) + (print-backtrace-and-exception/knots exn) + (simple-format/knots #t + "situation: ~A\n" + (classify-stack-situation + (stack->vector stack)))) + (primitive-exit 0)) + (lambda () + (error "test"))) diff --git a/tests/backtraces/stack-situation-unknown.scm b/tests/backtraces/stack-situation-unknown.scm new file mode 100644 index 0000000..e95c263 --- /dev/null +++ b/tests/backtraces/stack-situation-unknown.scm @@ -0,0 +1,17 @@ +(use-modules (knots) + (knots backtraces) + (fibers) + (system repl debug)) + +(start-stack + #t + (with-exception-handler + (lambda (exn) + (let* ((stack (make-stack #t)) + (stack-classification + (classify-stack-situation (stack->vector stack)))) + (print-backtrace-and-exception/knots exn) + (simple-format/knots #t "situation: ~A\n" stack-classification) + (primitive-exit 0))) + (lambda () + (error "test")))) diff --git a/tests/backtraces/temporary-thread.scm b/tests/backtraces/temporary-thread.scm new file mode 100644 index 0000000..a962a7b --- /dev/null +++ b/tests/backtraces/temporary-thread.scm @@ -0,0 +1,11 @@ +(use-modules (knots)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (call-with-temporary-thread + (lambda () + (error "error from temporary thread"))))) ; LAST BACKTRACE ENTRY HERE diff --git a/tests/backtraces/triple-with-exception-handler.scm b/tests/backtraces/triple-with-exception-handler.scm new file mode 100644 index 0000000..421f88e --- /dev/null +++ b/tests/backtraces/triple-with-exception-handler.scm @@ -0,0 +1,16 @@ +(use-modules (knots)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + +(with-exception-handler + (lambda _ #f) + (lambda () + (with-exception-handler + (lambda _ #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (error "plain error message"))))))) ; LAST BACKTRACE ENTRY HERE diff --git a/tests/backtraces/vhash-fold-in-thread.scm b/tests/backtraces/vhash-fold-in-thread.scm new file mode 100644 index 0000000..e0a37c3 --- /dev/null +++ b/tests/backtraces/vhash-fold-in-thread.scm @@ -0,0 +1,26 @@ +(use-modules (knots) (ice-9 vlist)) + +;; LAST BACKTRACE ENTRY: 257:2 + +(define (do-fold) + (begin + (vhash-fold + (lambda (key value result) + ;; Shouldn't be reached + #f) + 0 + ;; The aim here is to pass in #f for the vlist, and cause an + ;; exception within the (ice-9 vlist) module + #f) + 'done)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (call-with-temporary-thread + (lambda () + (do-fold) + 'done)))) diff --git a/tests/backtraces/vhash-fold.scm b/tests/backtraces/vhash-fold.scm new file mode 100644 index 0000000..56da6f6 --- /dev/null +++ b/tests/backtraces/vhash-fold.scm @@ -0,0 +1,24 @@ +(use-modules (knots) (ice-9 vlist)) + +;; LAST BACKTRACE ENTRY: 257:2 + +(define (do-fold) + (begin + (vhash-fold + (lambda (key value result) + ;; Shouldn't be reached + #f) + 0 + ;; The aim here is to pass in #f for the vlist, and cause an + ;; exception within the (ice-9 vlist) module + #f) + 'done)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (do-fold) + 'done)) diff --git a/tests/backtraces/wrapped-exception.scm b/tests/backtraces/wrapped-exception.scm new file mode 100644 index 0000000..79d3843 --- /dev/null +++ b/tests/backtraces/wrapped-exception.scm @@ -0,0 +1,16 @@ +(use-modules (knots)) + +;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +(with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (primitive-exit 1)) + (lambda () + (with-exception-handler + (lambda (exn) + (raise-exception + (make-exception + exn + (make-knots-exception (make-stack #t))))) + (lambda () + (error "wrapped error message"))))) ; LAST BACKTRACE ENTRY HERE From b451e04169589c12fdf0471b8216c1bcb01a6168 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 18:54:22 +0000 Subject: [PATCH 67/78] Add missing #:unwind? #t --- knots/web-server.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/knots/web-server.scm b/knots/web-server.scm index 60b3f06..b51ca00 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -385,7 +385,8 @@ on the procedure being called at any particular time." #f "wrong number of values returned from handler, expecting 2, got ~A" (length other))) - handler))))))))))))))) + handler)))))))))) + #:unwind? #t))))) (with-exception-handler (lambda (exn) (write-response-exception-handler exn request)) From cfc40069fbef715855cb4aac019d5b6d0ecae3be Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 18:54:28 +0000 Subject: [PATCH 68/78] Fix running the tests --- Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.am b/Makefile.am index 3429a15..bdcf044 100644 --- a/Makefile.am +++ b/Makefile.am @@ -36,4 +36,4 @@ EXTRA_DIST = \ pre-inst-env.in check: $(GOBJECTS) $(TESTS_GOBJECTS) - find tests -name "*.scm" | xargs -t -L1 ./test-env guile + find tests -maxdepth 1 -name "*.scm" | xargs -t -L1 ./test-env guile From 33db002464e0933ae09292314eaa8bd3f37cb3b1 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 19:03:10 +0000 Subject: [PATCH 69/78] Remove direct use of /bin/sh in backtrace tests --- tests/backtraces.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/tests/backtraces.scm b/tests/backtraces.scm index c5f8e0e..590ab3e 100644 --- a/tests/backtraces.scm +++ b/tests/backtraces.scm @@ -5,9 +5,8 @@ (ice-9 match)) (define (run-backtrace-script file) - (let* ((pipe (open-pipe* OPEN_READ - "/bin/sh" "-c" - (string-append "./test-env guile " file " 2>&1"))) + (let* ((pipe (open-pipe (string-append "./test-env guile " file " 2>&1") + OPEN_READ)) (output (read-string pipe))) (close-pipe pipe) output)) From f203a8933a86fed35d23bf9627cd53a91ac1c1b3 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 22 Mar 2026 19:12:59 +0000 Subject: [PATCH 70/78] Remove Guile line numbers from backtrace tests As these differ between 3.0.10 and 3.0.11. --- tests/backtraces/call-with-cached-connection.scm | 2 +- tests/backtraces/call-with-resource-from-pool.scm | 2 +- tests/backtraces/call-with-thread.scm | 2 +- tests/backtraces/fibers-force.scm | 2 +- tests/backtraces/fibers-map.scm | 2 +- tests/backtraces/guile-error-deep-in-thread.scm | 2 +- tests/backtraces/guile-error-in-thread.scm | 2 +- tests/backtraces/nested-parallelism.scm | 2 +- tests/backtraces/plain-exception.scm | 2 +- tests/backtraces/temporary-thread.scm | 2 +- tests/backtraces/triple-with-exception-handler.scm | 2 +- tests/backtraces/vhash-fold-in-thread.scm | 2 +- tests/backtraces/vhash-fold.scm | 2 +- tests/backtraces/wrapped-exception.scm | 2 +- 14 files changed, 14 insertions(+), 14 deletions(-) diff --git a/tests/backtraces/call-with-cached-connection.scm b/tests/backtraces/call-with-cached-connection.scm index 2e641a2..6f91f12 100644 --- a/tests/backtraces/call-with-cached-connection.scm +++ b/tests/backtraces/call-with-cached-connection.scm @@ -4,7 +4,7 @@ (lambda () (let ((cache (make-fixed-size-resource-pool (list (open-input-string "fake"))))) - ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) diff --git a/tests/backtraces/call-with-resource-from-pool.scm b/tests/backtraces/call-with-resource-from-pool.scm index cdbce9e..04dfb66 100644 --- a/tests/backtraces/call-with-resource-from-pool.scm +++ b/tests/backtraces/call-with-resource-from-pool.scm @@ -3,7 +3,7 @@ (run-fibers (lambda () (let ((pool (make-resource-pool (const 'resource) 1))) - ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) diff --git a/tests/backtraces/call-with-thread.scm b/tests/backtraces/call-with-thread.scm index 0921a31..964f96c 100644 --- a/tests/backtraces/call-with-thread.scm +++ b/tests/backtraces/call-with-thread.scm @@ -2,7 +2,7 @@ (define thread-pool (make-fixed-size-thread-pool 1)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) diff --git a/tests/backtraces/fibers-force.scm b/tests/backtraces/fibers-force.scm index 7abef0c..c0cf025 100644 --- a/tests/backtraces/fibers-force.scm +++ b/tests/backtraces/fibers-force.scm @@ -2,7 +2,7 @@ (run-fibers (lambda () - ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) diff --git a/tests/backtraces/fibers-map.scm b/tests/backtraces/fibers-map.scm index 24ef36c..02b9394 100644 --- a/tests/backtraces/fibers-map.scm +++ b/tests/backtraces/fibers-map.scm @@ -7,7 +7,7 @@ ;; To avoid the test hanging if there's an exception (primitive-exit 1)) (lambda () - ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) diff --git a/tests/backtraces/guile-error-deep-in-thread.scm b/tests/backtraces/guile-error-deep-in-thread.scm index 405e2b9..5333b30 100644 --- a/tests/backtraces/guile-error-deep-in-thread.scm +++ b/tests/backtraces/guile-error-deep-in-thread.scm @@ -7,7 +7,7 @@ (+ 1 'a))) ; LAST BACKTRACE ENTRY HERE 'unreachable)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) diff --git a/tests/backtraces/guile-error-in-thread.scm b/tests/backtraces/guile-error-in-thread.scm index 3063dec..b0b216a 100644 --- a/tests/backtraces/guile-error-in-thread.scm +++ b/tests/backtraces/guile-error-in-thread.scm @@ -1,6 +1,6 @@ (use-modules (knots)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) diff --git a/tests/backtraces/nested-parallelism.scm b/tests/backtraces/nested-parallelism.scm index ceb53b9..97fe9c3 100644 --- a/tests/backtraces/nested-parallelism.scm +++ b/tests/backtraces/nested-parallelism.scm @@ -30,7 +30,7 @@ (define result (run-fibers (lambda () - ;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler + ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) diff --git a/tests/backtraces/plain-exception.scm b/tests/backtraces/plain-exception.scm index f2ab1a2..165e4e5 100644 --- a/tests/backtraces/plain-exception.scm +++ b/tests/backtraces/plain-exception.scm @@ -1,6 +1,6 @@ (use-modules (knots)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) diff --git a/tests/backtraces/temporary-thread.scm b/tests/backtraces/temporary-thread.scm index a962a7b..2b78275 100644 --- a/tests/backtraces/temporary-thread.scm +++ b/tests/backtraces/temporary-thread.scm @@ -1,6 +1,6 @@ (use-modules (knots)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) diff --git a/tests/backtraces/triple-with-exception-handler.scm b/tests/backtraces/triple-with-exception-handler.scm index 421f88e..299beed 100644 --- a/tests/backtraces/triple-with-exception-handler.scm +++ b/tests/backtraces/triple-with-exception-handler.scm @@ -1,6 +1,6 @@ (use-modules (knots)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda _ #f) diff --git a/tests/backtraces/vhash-fold-in-thread.scm b/tests/backtraces/vhash-fold-in-thread.scm index e0a37c3..ac116f1 100644 --- a/tests/backtraces/vhash-fold-in-thread.scm +++ b/tests/backtraces/vhash-fold-in-thread.scm @@ -14,7 +14,7 @@ #f) 'done)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) diff --git a/tests/backtraces/vhash-fold.scm b/tests/backtraces/vhash-fold.scm index 56da6f6..559d116 100644 --- a/tests/backtraces/vhash-fold.scm +++ b/tests/backtraces/vhash-fold.scm @@ -14,7 +14,7 @@ #f) 'done)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) diff --git a/tests/backtraces/wrapped-exception.scm b/tests/backtraces/wrapped-exception.scm index 79d3843..e10f638 100644 --- a/tests/backtraces/wrapped-exception.scm +++ b/tests/backtraces/wrapped-exception.scm @@ -1,6 +1,6 @@ (use-modules (knots)) -;; FIRST BACKTRACE ENTRY: 1762:12 (with-exception-handler +;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) From d282841a7805ebe51b12769de04d377b41524eb3 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 11:43:25 +0000 Subject: [PATCH 71/78] Don't export classify-stack-situation As it's not intended for general use. --- knots/backtraces.scm | 4 +--- tests/backtraces/stack-situation-fibers.scm | 3 ++- tests/backtraces/stack-situation-script.scm | 3 ++- tests/backtraces/stack-situation-unknown.scm | 4 +++- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/knots/backtraces.scm b/knots/backtraces.scm index a12ecb6..306a469 100644 --- a/knots/backtraces.scm +++ b/knots/backtraces.scm @@ -32,9 +32,7 @@ knots-exception? knots-exception-stack - print-backtrace-and-exception/knots - - classify-stack-situation)) + print-backtrace-and-exception/knots)) (define &knots-exception (make-exception-type '&knots-exception diff --git a/tests/backtraces/stack-situation-fibers.scm b/tests/backtraces/stack-situation-fibers.scm index c1e9ec8..0aef4c7 100644 --- a/tests/backtraces/stack-situation-fibers.scm +++ b/tests/backtraces/stack-situation-fibers.scm @@ -11,7 +11,8 @@ (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" - (classify-stack-situation + ((@@ (knots backtraces) + classify-stack-situation) (stack->vector stack)))) (primitive-exit 0)) (lambda () diff --git a/tests/backtraces/stack-situation-script.scm b/tests/backtraces/stack-situation-script.scm index a21a8bd..6fc944d 100644 --- a/tests/backtraces/stack-situation-script.scm +++ b/tests/backtraces/stack-situation-script.scm @@ -8,7 +8,8 @@ (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" - (classify-stack-situation + ((@@ (knots backtraces) + classify-stack-situation) (stack->vector stack)))) (primitive-exit 0)) (lambda () diff --git a/tests/backtraces/stack-situation-unknown.scm b/tests/backtraces/stack-situation-unknown.scm index e95c263..920457b 100644 --- a/tests/backtraces/stack-situation-unknown.scm +++ b/tests/backtraces/stack-situation-unknown.scm @@ -9,7 +9,9 @@ (lambda (exn) (let* ((stack (make-stack #t)) (stack-classification - (classify-stack-situation (stack->vector stack)))) + ((@@ (knots backtraces) + classify-stack-situation) + (stack->vector stack)))) (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" stack-classification) (primitive-exit 0))) From d0ff89023b9fb0ff2617b95b45af90128fe6c8c7 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 11:56:53 +0000 Subject: [PATCH 72/78] Add documentation for lots of the "undocumented" bits In the Guile Documenta generated documentation. --- knots.scm | 2 ++ knots/backtraces.scm | 34 ++++++++++++++++++++++++++++++++++ knots/parallelism.scm | 7 +++++++ knots/promise.scm | 4 ++++ knots/resource-pool.scm | 36 ++++++++++++++++++++++++++++++++++++ knots/thread-pool.scm | 26 ++++++++++++++++++++++++++ knots/timeout.scm | 6 ++++++ knots/web-server.scm | 30 +++++++++++++++++++++++++----- 8 files changed, 140 insertions(+), 5 deletions(-) diff --git a/knots.scm b/knots.scm index e8e9690..2144596 100644 --- a/knots.scm +++ b/knots.scm @@ -105,6 +105,8 @@ wait on CVAR in a fiber to implement clean shutdown on Ctrl-C: (sigaction SIGINT #f)))))) (define (call-with-temporary-thread thunk) + "Run THUNK in a temporary thread and return its result to the +calling fiber." (let ((channel (make-channel))) (call-with-new-thread (lambda () diff --git a/knots/backtraces.scm b/knots/backtraces.scm index 306a469..7268311 100644 --- a/knots/backtraces.scm +++ b/knots/backtraces.scm @@ -41,14 +41,20 @@ (define make-knots-exception (record-constructor &knots-exception)) +(set-procedure-property! make-knots-exception 'documentation + "Construct a @code{&knots-exception} with the given stack.") (define knots-exception? (exception-predicate &knots-exception)) +(set-procedure-property! knots-exception? 'documentation + "Return @code{#t} if OBJ is a @code{&knots-exception}.") (define knots-exception-stack (exception-accessor &knots-exception (record-accessor &knots-exception 'stack))) +(set-procedure-property! knots-exception-stack 'documentation + "Return the stack from a @code{&knots-exception}.") (define (backtrace-debug-mode?) (let ((val (getenv "KNOTS_BACKTRACE_DEBUG"))) @@ -222,6 +228,34 @@ (define* (print-backtrace-and-exception/knots exn #:key (port (current-error-port))) + "Print the backtrace and exception information from EXN to PORT. This +procedure captures the stack, so should be run before the stack is +unwound, so using @code{with-exception-handler} without +@code{#:unwind? #t}, the exception may need to then be re-raised and +handled in an outer exception handler. + +@example +(with-exception-handler + (lambda (exn) + ;; Recover from the exception + #f) + (lambda () + (with-exception-handler + (lambda (exn) + (print-backtrace-and-exception/knots exn) + (raise-exception exn)) + (lambda () + (do-things)))) + #:unwind? #t) +@end example + +It's important to use @code{print-backtrace-and-exception/knots} for +displaying backtraces involving functionality from Guile Knots, since +the stack involved is potentially split across several fibers. The +stacks involved are attached to the exception, and this procedure +extracts this information out and assembles a backtrace including all +the code involved. +" (define (get-string out stack) (let* ((stack-vector (stack->vector stack)) (knots-stack-vectors diff --git a/knots/parallelism.scm b/knots/parallelism.scm index e78e6e2..393d78c 100644 --- a/knots/parallelism.scm +++ b/knots/parallelism.scm @@ -326,6 +326,10 @@ write directly to @code{process-channel}." (make-parallelism-limiter-record resource-pool) parallelism-limiter? (resource-pool parallelism-limiter-resource-pool)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'parallelism-limiter?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") (define* (make-parallelism-limiter limit #:key (name "unnamed")) "Return a parallelism limiter that allows at most LIMIT concurrent @@ -340,6 +344,7 @@ time. Further fibers block until a slot becomes free. #:name name))) (define (destroy-parallelism-limiter parallelism-limiter) + "Destroy PARALLELISM-LIMITER, releasing its underlying resource pool." (destroy-resource-pool (parallelism-limiter-resource-pool parallelism-limiter))) @@ -354,6 +359,8 @@ currently available." (thunk)))) (define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...) + "Evaluate EXP ... while holding a slot from PARALLELISM-LIMITER. +Syntactic sugar around @code{call-with-parallelism-limiter}." (call-with-parallelism-limiter parallelism-limiter (lambda () exp ...))) diff --git a/knots/promise.scm b/knots/promise.scm index b85fe64..8d21441 100644 --- a/knots/promise.scm +++ b/knots/promise.scm @@ -39,6 +39,10 @@ (thunk fibers-promise-thunk) (values-box fibers-promise-values-box) (evaluated-condition fibers-promise-evaluated-condition)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fibers-promise?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") (define (fibers-delay thunk) "Return a new fiber-aware promise that will evaluate THUNK when diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index f06a156..5a8e2e0 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -86,6 +86,22 @@ set-resource-pool-channel!) (destroy-condition resource-pool-destroy-condition) (configuration resource-pool-configuration)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool-name)) + 'documentation + "Return the name of the resource pool.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool-channel)) + 'documentation + "Return the channel used by the resource pool.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'resource-pool-configuration)) + 'documentation + "Return the configuration alist of the resource pool.") (set-record-type-printer! @@ -1277,12 +1293,16 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-timeout (record-accessor &resource-pool-timeout 'pool))) +(set-procedure-property! resource-pool-timeout-error-pool 'documentation + "Return the pool from a @code{&resource-pool-timeout} exception.") (define make-resource-pool-timeout-error (record-constructor &resource-pool-timeout)) (define resource-pool-timeout-error? (exception-predicate &resource-pool-timeout)) +(set-procedure-property! resource-pool-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-timeout} exception.") (define &resource-pool-too-many-waiters (make-exception-type '&recource-pool-too-many-waiters @@ -1293,17 +1313,23 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'pool))) +(set-procedure-property! resource-pool-too-many-waiters-error-pool 'documentation + "Return the pool from a @code{&resource-pool-too-many-waiters} exception.") (define resource-pool-too-many-waiters-error-waiters-count (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'waiters-count))) +(set-procedure-property! resource-pool-too-many-waiters-error-waiters-count 'documentation + "Return the waiters count from a @code{&resource-pool-too-many-waiters} exception.") (define make-resource-pool-too-many-waiters-error (record-constructor &resource-pool-too-many-waiters)) (define resource-pool-too-many-waiters-error? (exception-predicate &resource-pool-too-many-waiters)) +(set-procedure-property! resource-pool-too-many-waiters-error? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-too-many-waiters} exception.") (define &resource-pool-destroyed (make-exception-type '&recource-pool-destroyed @@ -1314,12 +1340,16 @@ receive @code{&resource-pool-destroyed}." (exception-accessor &resource-pool-destroyed (record-accessor &resource-pool-destroyed 'pool))) +(set-procedure-property! resource-pool-destroyed-error-pool 'documentation + "Return the pool from a @code{&resource-pool-destroyed} exception.") (define make-resource-pool-destroyed-error (record-constructor &resource-pool-destroyed)) (define resource-pool-destroyed-error? (exception-predicate &resource-pool-destroyed)) +(set-procedure-property! resource-pool-destroyed-error? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-destroyed} exception.") (define &resource-pool-destroy-resource (make-exception-type '&recource-pool-destroy-resource @@ -1328,9 +1358,13 @@ receive @code{&resource-pool-destroyed}." (define make-resource-pool-destroy-resource-exception (record-constructor &resource-pool-destroy-resource)) +(set-procedure-property! make-resource-pool-destroy-resource-exception 'documentation + "Construct a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-destroy-resource-exception? (exception-predicate &resource-pool-destroy-resource)) +(set-procedure-property! resource-pool-destroy-resource-exception? 'documentation + "Return @code{#t} if OBJ is a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-default-timeout-handler (make-parameter #f)) @@ -1467,6 +1501,8 @@ available. Return the resource once PROC has returned." (apply values vals))))))) (define-syntax-rule (with-resource-from-pool pool resource exp ...) + "Evaluate EXP ... with RESOURCE bound to a resource checked out from +POOL. Syntactic sugar around @code{call-with-resource-from-pool}." (call-with-resource-from-pool pool (lambda (resource) exp ...))) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index f8c44b2..aa460de 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -160,6 +160,14 @@ from there, or #f if that would be an empty string." thread-pool? (resource-pool thread-pool-resource-pool) (arguments-parameter thread-pool-arguments-parameter-accessor)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'thread-pool?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'thread-pool-resource-pool)) + 'documentation + "Return the underlying resource pool of the thread pool.") (define-record-type (fixed-size-thread-pool channel arguments-parameter current-procedures @@ -170,15 +178,29 @@ from there, or #f if that would be an empty string." (current-procedures fixed-size-thread-pool-current-procedures) (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout) (threads fixed-size-thread-pool-threads)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-channel)) + 'documentation + "Return the channel of the fixed-size thread pool.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-current-procedures)) + 'documentation + "Return the current procedures vector of the fixed-size thread pool.") ;; Since both thread pool records have this field, use a procedure ;; than handles the appropriate accessor (define (thread-pool-arguments-parameter pool) + "Return the arguments parameter for POOL, dispatching on pool type." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-arguments-parameter pool) (thread-pool-arguments-parameter-accessor pool))) (define (thread-pool-default-checkout-timeout pool) + "Return the default checkout timeout for POOL." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-default-checkout-timeout pool) (assq-ref (resource-pool-configuration @@ -197,9 +219,13 @@ from there, or #f if that would be an empty string." (exception-accessor &thread-pool-timeout-error (record-accessor &thread-pool-timeout-error 'pool))) +(set-procedure-property! thread-pool-timeout-error-pool 'documentation + "Return the pool from a @code{&thread-pool-timeout-error} exception.") (define thread-pool-timeout-error? (exception-predicate &thread-pool-timeout-error)) +(set-procedure-property! thread-pool-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&thread-pool-timeout-error} exception.") (define* (make-fixed-size-thread-pool size #:key diff --git a/knots/timeout.scm b/knots/timeout.scm index 2df2ddd..37da65e 100644 --- a/knots/timeout.scm +++ b/knots/timeout.scm @@ -95,6 +95,8 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-timeout-error? (exception-predicate &port-timeout-error)) +(set-procedure-property! port-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&port-timeout-error}.") (define &port-read-timeout-error (make-exception-type '&port-read-timeout-error @@ -106,6 +108,8 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-read-timeout-error? (exception-predicate &port-read-timeout-error)) +(set-procedure-property! port-read-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&port-read-timeout-error}.") (define &port-write-timeout-error (make-exception-type '&port-write-timeout-error @@ -117,6 +121,8 @@ If THUNK raises an exception it is re-raised in the calling fiber." (define port-write-timeout-error? (exception-predicate &port-write-timeout-error)) +(set-procedure-property! port-write-timeout-error? 'documentation + "Return @code{#t} if OBJ is a @code{&port-write-timeout-error}.") (define (readable? port) "Test if PORT is readable." diff --git a/knots/web-server.scm b/knots/web-server.scm index b51ca00..8b328e3 100644 --- a/knots/web-server.scm +++ b/knots/web-server.scm @@ -141,23 +141,29 @@ closes PORT, unless KEEP-ALIVE? is true." (define request-body-ended-prematurely-error? (exception-predicate &request-body-ended-prematurely)) +(set-procedure-property! request-body-ended-prematurely-error? 'documentation + "Return @code{#t} if OBJ is a @code{&request-body-ended-prematurely} exception.") -(define (request-body-port/knots r) +(define (request-body-port/knots request) + "Return an input port for reading the body of request REQUEST. +Handles chunked transfer encoding." (cond - ((member '(chunked) (request-transfer-encoding r)) - (make-chunked-input-port (request-port r) + ((member '(chunked) (request-transfer-encoding request)) + (make-chunked-input-port (request-port request) #:keep-alive? #t)) (else (let ((content-length - (request-content-length r))) + (request-content-length request))) (make-delimited-input-port - (request-port r) + (request-port request) content-length (lambda (bytes-read) (raise-exception (make-request-body-ended-prematurely-error bytes-read)))))))) (define (read-request-body/knots r) + "Read and return the full body of request R as a bytevector. +Handles chunked transfer encoding." (cond ((member '(chunked) (request-transfer-encoding r)) (get-bytevector-all @@ -299,6 +305,8 @@ on the procedure being called at any particular time." #f) (define (default-write-response-exception-handler exn request) + "Default handler for exceptions raised while writing an HTTP response. +Logs the error for REQUEST to the current error port." (if (and (exception-with-origin? exn) (string=? (exception-origin exn) "fport_write")) @@ -528,6 +536,18 @@ on the procedure being called at any particular time." web-server? (socket web-server-socket) (port web-server-port)) +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'web-server?)) + 'documentation + "Return @code{#t} if OBJ is a @code{}.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'web-server-socket)) + 'documentation + "Return the socket of the web server.") +(set-procedure-property! + (macro-transformer (module-ref (current-module) 'web-server-port)) + 'documentation + "Return the port number of the web server.") (define* (run-knots-web-server handler #:key (host #f) From 781c8cf9db654c82cabd385217eee2f659d5f7ad Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 12:20:22 +0000 Subject: [PATCH 73/78] Fix a copy/paste error in decrement-resource-checkout-count! --- knots/resource-pool.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 5a8e2e0..8092a3a 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -138,7 +138,7 @@ (define-inlinable (decrement-resource-checkout-count! resource) (set-resource-details-checkout-count! resource - (1+ (resource-details-checkout-count resource)))) + (1- (resource-details-checkout-count resource)))) (define (spawn-fiber-for-checkout channel reply-channel From a44cc014a4ffa580611476628b6ca6916a79b482 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 13:12:13 +0000 Subject: [PATCH 74/78] Sort out resource pool delay and duration logging --- knots/resource-pool.scm | 165 +++++++++++++++++++++++++++++----------- tests/resource-pool.scm | 46 +++++++++++ 2 files changed, 168 insertions(+), 43 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 8092a3a..88c102c 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -103,6 +103,14 @@ 'documentation "Return the configuration alist of the resource pool.") +(define (resource-pool-delay-logger resource-pool) + (assq-ref (resource-pool-configuration resource-pool) + 'delay-logger)) + +(define (resource-pool-duration-logger resource-pool) + (assq-ref (resource-pool-configuration resource-pool) + 'duration-logger)) + (set-record-type-printer! (lambda (resource-pool port) @@ -164,8 +172,8 @@ (define* (make-fixed-size-resource-pool resources-list-or-vector #:key - (delay-logger (const #f)) - (duration-logger (const #f)) + (delay-logger #f) + (duration-logger #f) scheduler (name "unnamed") default-checkout-timeout @@ -193,6 +201,19 @@ Maximum number of fibers that may queue waiting for a resource. When this limit is exceeded, @code{&resource-pool-too-many-waiters} is raised when a resource is requested. Defaults to @code{#f} (no limit). +@item #:delay-logger +Called as @code{(delay-logger seconds)} with the time spent waiting +for a resource to become available. Defaults to @code{#f} (no +logging). + +@item #:duration-logger +Called as @code{(duration-logger seconds)} after the proc passed to +@code{call-with-resource-from-pool} completes, whether it returned +normally or raised an exception. Can be overridden per-call via the +@code{#:duration-logger} keyword argument to +@code{call-with-resource-from-pool}. Defaults to @code{#f} (no +logging). + @item #:scheduler The Fibers scheduler to use for the pool's internal fiber. Defaults to the current scheduler. @@ -547,8 +568,8 @@ to the current scheduler. (define* (make-resource-pool return-new-resource max-size #:key (min-size 0) (idle-seconds #f) - (delay-logger (const #f)) - (duration-logger (const #f)) + (delay-logger #f) + (duration-logger #f) destructor lifetime scheduler @@ -605,6 +626,19 @@ Maximum number of fibers that may queue waiting for a resource. When this limit is exceeded, @code{&resource-pool-too-many-waiters} is raised when a resource is requested. Defaults to @code{#f} (no limit). +@item #:delay-logger +Called as @code{(delay-logger seconds)} with the time spent waiting +for a resource to become available. Defaults to @code{#f} (no +logging). + +@item #:duration-logger +Called as @code{(duration-logger seconds)} after the proc passed to +@code{call-with-resource-from-pool} completes, whether it returned +normally or raised an exception. Can be overridden per-call via the +@code{#:duration-logger} keyword argument to +@code{call-with-resource-from-pool}. Defaults to @code{#f} (no +logging). + @item #:scheduler The Fibers scheduler to use for the pool's internal fiber. Defaults to the current scheduler. @@ -1374,9 +1408,20 @@ receive @code{&resource-pool-destroyed}." (timeout-handler (resource-pool-default-timeout-handler)) (max-waiters 'default) (channel (resource-pool-channel pool)) - (destroy-resource-on-exception? #f)) + (destroy-resource-on-exception? #f) + (delay-logger (resource-pool-delay-logger pool)) + (duration-logger (resource-pool-duration-logger pool))) "Call PROC with a resource from POOL, blocking until a resource becomes -available. Return the resource once PROC has returned." +available. Return the resource once PROC has returned. + +@code{#:delay-logger} is called as @code{(delay-logger seconds)} with +the time spent waiting for a resource to become available. Defaults +to the pool's @code{#:delay-logger} if not specified. + +@code{#:duration-logger} is called as @code{(duration-logger seconds)} +after PROC completes, whether it returned normally or raised an +exception. Defaults to the pool's @code{#:duration-logger} if not +specified." (define timeout-or-default (if (eq? timeout 'default) @@ -1390,6 +1435,26 @@ available. Return the resource once PROC has returned." 'default-max-waiters) max-waiters)) + (define (delay-logger/safe seconds) + (with-exception-handler + ;; Ignore exceptions, since this would break returning the + ;; resource + (lambda (exn) #f) + (lambda () + (delay-logger seconds)) + #:unwind? #t)) + + (define (duration-logger/safe seconds) + (with-exception-handler + ;; Ignore exceptions, since this would break returning the + ;; resource + (lambda (exn) #f) + (lambda () + (duration-logger seconds)) + #:unwind? #t)) + + (define checkout-start-time (get-internal-real-time)) + (unless channel (raise-exception (make-resource-pool-destroyed-error pool))) @@ -1462,43 +1527,57 @@ available. Return the resource once PROC has returned." (raise-exception (make-resource-pool-destroyed-error pool))) (('success resource-id resource-value) - (call-with-values - (lambda () - (with-exception-handler - (lambda (exn) - ;; Unwind the stack before calling put-message, as - ;; this avoids inconsistent behaviour with - ;; continuation barriers - (put-message - channel - (list (if (or destroy-resource-on-exception? - (resource-pool-destroy-resource-exception? exn)) - 'destroy - 'return) - resource-id)) - (raise-exception exn)) - (lambda () - (with-exception-handler - (lambda (exn) - (let ((stack - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1))) - (_ - (make-stack #t))))) - (raise-exception - (make-exception - exn - (make-knots-exception stack))))) - (lambda () - (proc resource-value)))) - #:unwind? #t)) - (lambda vals - (put-message channel - `(return ,resource-id)) - (apply values vals))))))) + (when delay-logger + (delay-logger/safe + (/ (- (get-internal-real-time) checkout-start-time) + internal-time-units-per-second))) + + (let ((proc-start-time (get-internal-real-time))) + (call-with-values + (lambda () + (with-exception-handler + (lambda (exn) + ;; Unwind the stack before calling put-message, as + ;; this avoids inconsistent behaviour with + ;; continuation barriers + (when duration-logger + (duration-logger/safe + (/ (- (get-internal-real-time) proc-start-time) + internal-time-units-per-second))) + (put-message + channel + (list (if (or destroy-resource-on-exception? + (resource-pool-destroy-resource-exception? exn)) + 'destroy + 'return) + resource-id)) + (raise-exception exn)) + (lambda () + (with-exception-handler + (lambda (exn) + (let ((stack + (match (fluid-ref %stacks) + ((stack-tag . prompt-tag) + (make-stack #t + 0 prompt-tag + 0 (and prompt-tag 1))) + (_ + (make-stack #t))))) + (raise-exception + (make-exception + exn + (make-knots-exception stack))))) + (lambda () + (proc resource-value)))) + #:unwind? #t)) + (lambda vals + (when duration-logger + (duration-logger/safe + (/ (- (get-internal-real-time) proc-start-time) + internal-time-units-per-second))) + (put-message channel + `(return ,resource-id)) + (apply values vals)))))))) (define-syntax-rule (with-resource-from-pool pool resource exp ...) "Evaluate EXP ... with RESOURCE bound to a resource checked out from diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm index b3a84d7..5726ad3 100644 --- a/tests/resource-pool.scm +++ b/tests/resource-pool.scm @@ -282,4 +282,50 @@ (destroy-resource-pool resource-pool)))) +;; Test delay-logger and duration-logger +(run-fibers-for-tests + (lambda () + (let* ((logged-delay #f) + (logged-duration #f) + (resource-pool (make-fixed-size-resource-pool + (list 1) + #:delay-logger + (lambda (seconds) + (set! logged-delay seconds)) + #:duration-logger + (lambda (seconds) + (set! logged-duration seconds))))) + + (call-with-resource-from-pool resource-pool + (lambda (res) + (sleep 0.2))) + + (assert-true (number? logged-delay)) + (assert-true (number? logged-duration)) + (assert-true (>= logged-duration 0.1)) + + (destroy-resource-pool resource-pool)))) + +;; Test per-call duration-logger overrides pool default +(run-fibers-for-tests + (lambda () + (let* ((pool-logged #f) + (call-logged #f) + (resource-pool (make-fixed-size-resource-pool + (list 1) + #:duration-logger + (lambda (seconds) + (set! pool-logged seconds))))) + + (call-with-resource-from-pool resource-pool + (lambda (res) #t) + #:duration-logger + (lambda (seconds) + (set! call-logged seconds))) + + (assert-true (not pool-logged)) + (assert-true (number? call-logged)) + + (destroy-resource-pool resource-pool)))) + (display "resource-pool test finished successfully\n") From b411faf27908eae5747b74d42ca6b248d8fd38c5 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 13:25:29 +0000 Subject: [PATCH 75/78] Tweak the thread pool delay and duration loggers Bringing the functionality in line with the resource pool loggers. --- knots/thread-pool.scm | 19 ++++++++-------- tests/thread-pool.scm | 50 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 59 insertions(+), 10 deletions(-) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index aa460de..3844d8f 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -277,12 +277,12 @@ Seconds to wait for a free thread slot before raising forever). @item #:delay-logger -Called as @code{(delay-logger seconds proc)} with the time spent -waiting for a thread to become available. +Called as @code{(delay-logger seconds)} with the time spent waiting +for a thread to become available. @item #:duration-logger -Called as @code{(duration-logger seconds proc)} after each procedure -completes. +Called as @code{(duration-logger seconds)} after each procedure +completes, whether it returned normally or raised an exception. @end table" (define channel (make-channel)) @@ -352,8 +352,7 @@ completes. (- (get-internal-real-time) sent-time))) (delay-logger (/ time-delay - internal-time-units-per-second) - proc))) + internal-time-units-per-second)))) (let* ((start-time (get-internal-real-time)) (response @@ -406,11 +405,11 @@ completes. (match response (('thread-pool-error duration _) (when duration-logger - (duration-logger duration proc)) + (duration-logger duration)) #t) ((duration . _) (when duration-logger - (duration-logger duration proc)) + (duration-logger duration)) #f)))) (if (and exception? expire-on-exception?) @@ -474,8 +473,8 @@ completes. scheduler thread-initializer thread-destructor - (delay-logger (lambda _ #f)) - (duration-logger (const #f)) + delay-logger + duration-logger thread-lifetime (expire-on-exception? #f) (name "unnamed") diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm index dc22119..a086640 100644 --- a/tests/thread-pool.scm +++ b/tests/thread-pool.scm @@ -172,4 +172,54 @@ (destroy-thread-pool thread-pool) (assert-equal pool-size destructor-count)) +;; Test delay-logger and duration-logger for fixed-size thread pool +(let* ((logged-delay #f) + (logged-duration #f) + (thread-pool + (make-fixed-size-thread-pool + 1 + #:delay-logger + (lambda (seconds) + (set! logged-delay seconds)) + #:duration-logger + (lambda (seconds) + (set! logged-duration seconds))))) + + (call-with-thread + thread-pool + (lambda () + (usleep 100000))) + + (assert-true (number? logged-delay)) + (assert-true (number? logged-duration)) + (assert-true (>= logged-duration 0.1)) + + (destroy-thread-pool thread-pool)) + +;; Test delay-logger and duration-logger for dynamic thread pool +(run-fibers-for-tests + (lambda () + (let* ((logged-delay #f) + (logged-duration #f) + (thread-pool + (make-thread-pool + 1 + #:delay-logger + (lambda (seconds) + (set! logged-delay seconds)) + #:duration-logger + (lambda (seconds) + (set! logged-duration seconds))))) + + (call-with-thread + thread-pool + (lambda () + (usleep 100000))) + + (assert-true (number? logged-delay)) + (assert-true (number? logged-duration)) + (assert-true (>= logged-duration 0.1)) + + (destroy-thread-pool thread-pool)))) + (display "thread-pool test finished successfully\n") From c2e1cd94d7a8c7cb64d90fd15a29738905cb8295 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 13:54:25 +0000 Subject: [PATCH 76/78] Adjust the delay and duration loggers for thread pools Based on the changes in resource pools. --- knots/resource-pool.scm | 3 ++ knots/thread-pool.scm | 63 +++++++++++++++++++++++++++++++---------- 2 files changed, 51 insertions(+), 15 deletions(-) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm index 88c102c..8dcf46b 100644 --- a/knots/resource-pool.scm +++ b/knots/resource-pool.scm @@ -60,6 +60,9 @@ make-resource-pool-destroy-resource-exception resource-pool-destroy-resource-exception? + resource-pool-delay-logger + resource-pool-duration-logger + resource-pool-default-timeout-handler call-with-resource-from-pool diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm index 3844d8f..825a24a 100644 --- a/knots/thread-pool.scm +++ b/knots/thread-pool.scm @@ -55,6 +55,8 @@ ;; thread pools thread-pool-arguments-parameter thread-pool-default-checkout-timeout + thread-pool-delay-logger + thread-pool-duration-logger destroy-thread-pool @@ -171,12 +173,15 @@ from there, or #f if that would be an empty string." (define-record-type (fixed-size-thread-pool channel arguments-parameter current-procedures - default-checkout-timeout threads) + default-checkout-timeout delay-logger + duration-logger threads) fixed-size-thread-pool? (channel fixed-size-thread-pool-channel) (arguments-parameter fixed-size-thread-pool-arguments-parameter) (current-procedures fixed-size-thread-pool-current-procedures) (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout) + (delay-logger fixed-size-thread-pool-delay-logger) + (duration-logger fixed-size-thread-pool-duration-logger) (threads fixed-size-thread-pool-threads)) (set-procedure-property! (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?)) @@ -207,6 +212,20 @@ from there, or #f if that would be an empty string." (thread-pool-resource-pool pool)) 'default-checkout-timeout))) +(define (thread-pool-delay-logger pool) + "Return the delay logger for POOL, dispatching on pool type." + (if (fixed-size-thread-pool? pool) + (fixed-size-thread-pool-delay-logger pool) + (resource-pool-delay-logger + (thread-pool-resource-pool pool)))) + +(define (thread-pool-duration-logger pool) + "Return the duration logger for POOL, dispatching on pool type." + (if (fixed-size-thread-pool? pool) + (fixed-size-thread-pool-duration-logger pool) + (resource-pool-duration-logger + (thread-pool-resource-pool pool)))) + (define &thread-pool-timeout-error (make-exception-type '&thread-pool-timeout-error &error @@ -346,14 +365,7 @@ completes, whether it returned normally or raised an exception. (let loop ((lifetime thread-lifetime)) (match (get-message channel) ('destroy #f) - ((reply sent-time proc) - (when delay-logger - (let ((time-delay - (- (get-internal-real-time) - sent-time))) - (delay-logger (/ time-delay - internal-time-units-per-second)))) - + ((reply proc) (let* ((start-time (get-internal-real-time)) (response (with-exception-handler @@ -465,6 +477,8 @@ completes, whether it returned normally or raised an exception. param thread-proc-vector default-checkout-timeout + delay-logger + duration-logger threads)) (define* (make-thread-pool max-size @@ -538,7 +552,10 @@ Maximum number of fibers that may queue waiting for a thread. Raises (define* (call-with-thread thread-pool proc #:key - duration-logger + (delay-logger + (thread-pool-delay-logger thread-pool)) + (duration-logger + (thread-pool-duration-logger thread-pool)) checkout-timeout channel destroy-thread-on-exception? @@ -564,9 +581,15 @@ When @code{#t}, destroy the thread after PROC raises an exception. Equivalent to per-call @code{#:expire-on-exception?}. Defaults to @code{#f}. +@item #:delay-logger +Called as @code{(delay-logger seconds)} with the time spent waiting +for a thread to become available. Defaults to the pool's +@code{#:delay-logger} if not specified. + @item #:duration-logger Called as @code{(duration-logger seconds)} after PROC completes -(whether or not it raised an exception). +(whether or not it raised an exception). Defaults to the pool's +@code{#:duration-logger} if not specified. @item #:channel Override the channel used to communicate with the thread. @@ -574,7 +597,8 @@ Override the channel used to communicate with the thread. (define (handle-proc fixed-size-thread-pool reply-channel start-time - timeout) + timeout + delay-logger) (let* ((request-channel (or channel (fixed-size-thread-pool-channel @@ -585,7 +609,6 @@ Override the channel used to communicate with the thread. (wrap-operation (put-operation request-channel (list reply-channel - start-time proc)) (const #t)))) @@ -600,6 +623,11 @@ Override the channel used to communicate with the thread. (raise-exception (make-thread-pool-timeout-error))) + (when delay-logger + (delay-logger + (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second))) + (let ((reply (get-message reply-channel))) (match reply (('thread-pool-error duration exn) @@ -620,7 +648,8 @@ Override the channel used to communicate with the thread. (handle-proc thread-pool reply-channel start-time - checkout-timeout) + checkout-timeout + delay-logger) (with-exception-handler (lambda (exn) (if (and (resource-pool-timeout-error? exn) @@ -641,13 +670,17 @@ Override the channel used to communicate with the thread. (handle-proc fixed-size-thread-pool reply-channel start-time - remaining-time) + remaining-time + #f) (raise-exception (make-thread-pool-timeout-error thread-pool)))) (handle-proc fixed-size-thread-pool reply-channel start-time + #f #f))) + #:delay-logger delay-logger + #:duration-logger #f #:max-waiters max-waiters #:timeout checkout-timeout #:destroy-resource-on-exception? From cb5ec50b341f603e9d129152b45e47cf008ea126 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 15:15:26 +0000 Subject: [PATCH 77/78] Rename README --- README => README.org | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename README => README.org (100%) diff --git a/README b/README.org similarity index 100% rename from README rename to README.org From 86dca4e08241668b5ce2805b7ca2b9a2eaed245a Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 23 Mar 2026 17:16:26 +0000 Subject: [PATCH 78/78] Update fibers link --- doc/index.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/index.texi b/doc/index.texi index 925cf43..19380a4 100644 --- a/doc/index.texi +++ b/doc/index.texi @@ -16,10 +16,10 @@ @top Overview Guile Knots is a library providing tools and patterns for programming -with @url{https://github.com/wingo/fibers, Guile Fibers}. Guile Knots -provides higher level building blocks for writing programs using Guile -Fibers, including managing code that can't run in a thread used by -fibers. Also included is a web server implementation using Fibers, +with @url{https://codeberg.org/guile/fibers, Guile Fibers}. Guile +Knots provides higher level building blocks for writing programs using +Guile Fibers, including managing code that can't run in a thread used +by fibers. Also included is a web server implementation using Fibers, which while being similar to the web server provided by Fibers, can provide some benefits in specific circumstances.