From e037e9dbec1ab5a8cfaf65d73aa3afb2eeb98d71 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludovic.courtes@inria.fr>
Date: Mon, 19 Jun 2017 21:47:22 +0200
Subject: store: Buffer RPC writes.

For a command like:

  guix build python2-numpy -n

this reduces the number of 'write' syscalls from 9.5K to 2.0K.

* guix/store.scm (<nix-server>)[buffer, flush]: New fields.
(open-connection): Adjust accordingly.  Call 'buffering-output-port' to
compute the two new fields.
(write-buffered-output, buffering-output-port): New procedures.
(operation): Write to (nix-server-output-port server).  Call
'write-buffered-output'.
---
 guix/store.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 59 insertions(+), 4 deletions(-)

(limited to 'guix/store.scm')

diff --git a/guix/store.scm b/guix/store.scm
index 2acab6b1a3..b584caa073 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -322,12 +322,16 @@
 
 (define-record-type <nix-server>
   (%make-nix-server socket major minor
+                    buffer flush
                     ats-cache atts-cache)
   nix-server?
   (socket nix-server-socket)
   (major  nix-server-major-version)
   (minor  nix-server-minor-version)
 
+  (buffer nix-server-output-port)                 ;output port
+  (flush  nix-server-flush-output)                ;thunk
+
   ;; Caches.  We keep them per-connection, because store paths build
   ;; during the session are temporary GC roots kept for the duration of
   ;; the session.
@@ -481,7 +485,11 @@ for this connection will be pinned.  Return a server object."
                      (&nix-connection-error (file (or port uri))
                                             (errno EPROTO))
                      (&message (message "build daemon handshake failed"))))))
-    (let ((port (or port (connect-to-daemon uri))))
+    (let*-values (((port)
+                   (or port (connect-to-daemon uri)))
+                  ((output flush)
+                   (buffering-output-port port
+                                          (make-bytevector 8192))))
       (write-int %worker-magic-1 port)
       (let ((r (read-int port)))
         (and (eqv? r %worker-magic-2)
@@ -499,12 +507,18 @@ for this connection will be pinned.  Return a server object."
                       (let ((conn (%make-nix-server port
                                                     (protocol-major v)
                                                     (protocol-minor v)
+                                                    output flush
                                                     (make-hash-table 100)
                                                     (make-hash-table 100))))
                         (let loop ((done? (process-stderr conn)))
                           (or done? (process-stderr conn)))
                         conn)))))))))
 
+(define (write-buffered-output server)
+  "Flush SERVER's output port."
+  (force-output (nix-server-output-port server))
+  ((nix-server-flush-output server)))
+
 (define (close-connection server)
   "Close the connection to SERVER."
   (close (nix-server-socket server)))
@@ -718,6 +732,44 @@ encoding conversion errors."
     (let loop ((done? (process-stderr server)))
       (or done? (process-stderr server)))))
 
+(define (buffering-output-port port buffer)
+  "Return two value: an output port wrapped around PORT that uses BUFFER (a
+bytevector) as its internal buffer, and a thunk to flush this output port."
+  ;; Note: In Guile 2.2.2, custom binary output ports already have their own
+  ;; 4K internal buffer.
+  (define size
+    (bytevector-length buffer))
+
+  (define total 0)
+
+  (define (flush)
+    (put-bytevector port buffer 0 total)
+    (set! total 0))
+
+  (define (write bv offset count)
+    (if (zero? count)                             ;end of file
+        (flush)
+        (let loop ((offset offset)
+                   (count count)
+                   (written 0))
+          (cond ((= total size)
+                 (flush)
+                 (loop offset count written))
+                ((zero? count)
+                 written)
+                (else
+                 (let ((to-copy (min count (- size total))))
+                   (bytevector-copy! bv offset buffer total to-copy)
+                   (set! total (+ total to-copy))
+                   (loop (+ offset to-copy) (- count to-copy)
+                         (+ written to-copy))))))))
+
+  ;; Note: We need to return FLUSH because the custom binary port has no way
+  ;; to be notified of a 'force-output' call on itself.
+  (values (make-custom-binary-output-port "buffering-output-port"
+                                          write #f #f flush)
+          flush))
+
 (define %rpc-calls
   ;; Mapping from RPC names (symbols) to invocation counts.
   (make-hash-table))
@@ -755,11 +807,14 @@ encoding conversion errors."
     ((_ (name (type arg) ...) docstring return ...)
      (lambda (server arg ...)
        docstring
-       (let ((s (nix-server-socket server)))
+       (let* ((s (nix-server-socket server))
+              (buffered (nix-server-output-port server)))
          (record-operation 'name)
-         (write-int (operation-id name) s)
-         (write-arg type arg s)
+         (write-int (operation-id name) buffered)
+         (write-arg type arg buffered)
          ...
+         (write-buffered-output server)
+
          ;; Loop until the server is done sending error output.
          (let loop ((done? (process-stderr server)))
            (or done? (loop (process-stderr server))))
-- 
cgit v1.2.3