diff options
author | Christopher Baines <mail@cbaines.net> | 2021-05-29 23:59:08 +0100 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2021-05-30 00:01:40 +0100 |
commit | de775db48ed16aecb6cb934fcfec367f4b76733f (patch) | |
tree | eb5c03c66754bf67793fb507427fe0b7e4a713dc | |
parent | 8258e9c8d9f729b2670a602c523c59847b676b1a (diff) | |
download | build-coordinator-de775db48ed16aecb6cb934fcfec367f4b76733f.tar build-coordinator-de775db48ed16aecb6cb934fcfec367f4b76733f.tar.gz |
Fix the make-chunked-output-port* implementation
A broken one was committed previously.
-rw-r--r-- | guix-build-coordinator/utils.scm | 36 |
1 files changed, 24 insertions, 12 deletions
diff --git a/guix-build-coordinator/utils.scm b/guix-build-coordinator/utils.scm index 9887d05..0150257 100644 --- a/guix-build-coordinator/utils.scm +++ b/guix-build-coordinator/utils.scm @@ -262,32 +262,44 @@ upcoming chunk." (define* (make-chunked-output-port* port #:key (keep-alive? #f) (buffering 1200)) + (define initial-heap-size + (assq-ref (gc-stats) 'heap-size)) + (define (%put-string s) - (let ((length (string-length s))) - (unless (eq? length 0) + (unless (string-null? s) + (let* ((bv (string->bytevector s "ISO-8859-1")) + (length (bytevector-length bv))) (with-gc-protection (lambda () (put-string port (number->string length 16)) (put-string port "\r\n") - (write s port) - (put-string port "\r\n")))))) + (put-bytevector port bv) + (put-string port "\r\n"))) + + (let* ((stats (gc-stats)) + (initial-gc-times + (assq-ref stats 'gc-times))) + (while (let ((updated-stats (gc-stats))) + (and (> (assq-ref updated-stats 'heap-allocated-since-gc) + initial-heap-size) + (= initial-gc-times + (assq-ref updated-stats 'gc-times)))) + (gc) + (usleep 10)))))) + (define (%put-char c) (%put-string (list->string (list c)))) - (define (flush) - (force-output port)) - (define (safe-flush) - (with-gc-protection flush)) + (define (flush) #t) (define (close) (with-gc-protection (lambda () - (flush) - (put-string port "0\r\n\r\n") - (force-output port) + (put-string port "0\r\n") (unless keep-alive? + (force-output port) (close-port port))))) (let ((ret (make-soft-port - (vector %put-char %put-string safe-flush #f close) "w"))) + (vector %put-char %put-string flush #f close) "w"))) (setvbuf ret 'block buffering) ret)) |