From 094259b0494ca5b95b440ba54f253d60ffe10e80 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 12 Jan 2026 10:00:35 +0000 Subject: [PATCH] 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