diff options
| -rw-r--r-- | guix/inferior.scm | 54 |
1 files changed, 33 insertions, 21 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm index 1c19527b8f..9681064429 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -225,6 +225,8 @@ inferior." (inferior-eval '(use-modules (srfi srfi-34)) result) (inferior-eval '(define %package-table (make-hash-table)) result) + (inferior-eval '(define %store-table (make-hash-table)) + result) result)) (_ #f))) @@ -617,7 +619,12 @@ process." thus be the code of a one-argument procedure that accepts a store." (let* ((major (store-connection-major-version store)) (minor (store-connection-minor-version store)) - (proto (logior major minor))) + (proto (logior major minor)) + + ;; The address of STORE itself is not a good identifier because it + ;; keeps changing through the use of "functional caches". The + ;; address of its socket port makes more sense. + (store-id (object-address (store-connection-socket store)))) (ensure-store-bridge! inferior) (send-inferior-request `(let ((proc ,code) @@ -628,26 +635,31 @@ thus be the code of a one-argument procedure that accepts a store." store-protocol-error-message nix-protocol-error-message))) - ;; 'port->connection' appeared in June 2018 and we can hardly - ;; emulate it on older versions. Thus fall back to - ;; 'open-connection', at the risk of talking to the wrong daemon or - ;; having our build result reclaimed (XXX). - (let ((store (if (defined? 'port->connection) - (port->connection %bridge-socket #:version ,proto) - (open-connection)))) - (dynamic-wind - (const #t) - (lambda () - ;; Serialize '&store-protocol-error' conditions. The - ;; exception serialization mechanism that - ;; 'read-repl-response' expects is unsuitable for SRFI-35 - ;; error conditions, hence this special case. - (guard (c ((error? c) - `(store-protocol-error ,(error-message c)))) - `(result ,(proc store)))) - (lambda () - (unless (defined? 'port->connection) - (close-port store)))))) + ;; Cache connections to STORE-ID. This ensures that the caches within + ;; <store-connection> (in particular the object cache) are reused + ;; across calls to 'inferior-eval-with-store', which makes a + ;; significant difference when it is called repeatedly. + (let ((store (or (hashv-ref %store-table ,store-id) + + ;; 'port->connection' appeared in June 2018 and we + ;; can hardly emulate it on older versions. Thus + ;; fall back to 'open-connection', at the risk of + ;; talking to the wrong daemon or having our build + ;; result reclaimed (XXX). + (let ((store (if (defined? 'port->connection) + (port->connection %bridge-socket + #:version ,proto) + (open-connection)))) + (hashv-set! %store-table ,store-id store) + store)))) + + ;; Serialize '&store-protocol-error' conditions. The + ;; exception serialization mechanism that + ;; 'read-repl-response' expects is unsuitable for SRFI-35 + ;; error conditions, hence this special case. + (guard (c ((error? c) + `(store-protocol-error ,(error-message c)))) + `(result ,(proc store))))) inferior) (proxy inferior store) |