diff options
author | Ludovic Courtès <ludo@gnu.org> | 2022-01-27 09:20:40 +0100 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2022-01-27 14:13:24 +0100 |
commit | e778910bdfc68c60a5be59aac93049d32feae904 (patch) | |
tree | 066b75261ab0b3fbe66dd10c35724216d1111325 /guix | |
parent | c71910a095f7e1ef0ab4c1fbea85348373e5a264 (diff) |
inferior: Move initialization bits away from 'inferior-eval-with-store'.
* guix/inferior.scm (port->inferior): In the inferior, define
'cached-store-connection', 'store-protocol-error?', and
'store-protocol-error-message'.
(inferior-eval-with-store): Use them.
Diffstat (limited to 'guix')
-rw-r--r-- | guix/inferior.scm | 76 |
1 files changed, 42 insertions, 34 deletions
diff --git a/guix/inferior.scm b/guix/inferior.scm index 9681064429..6949bb3687 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -225,7 +225,39 @@ 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)) + (inferior-eval '(begin + (define %store-table (make-hash-table)) + (define (cached-store-connection store-id version) + ;; 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. + (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 + version) + (open-connection)))) + (hashv-set! %store-table store-id store) + store)))) + result) + (inferior-eval '(begin + (define store-protocol-error? + (if (defined? 'store-protocol-error?) + store-protocol-error? + nix-protocol-error?)) + (define store-protocol-error-message + (if (defined? 'store-protocol-error-message) + store-protocol-error-message + nix-protocol-error-message))) result) result)) (_ @@ -627,39 +659,15 @@ thus be the code of a one-argument procedure that accepts a store." (store-id (object-address (store-connection-socket store)))) (ensure-store-bridge! inferior) (send-inferior-request - `(let ((proc ,code) - (error? (if (defined? 'store-protocol-error?) - store-protocol-error? - nix-protocol-error?)) - (error-message (if (defined? 'store-protocol-error-message) - store-protocol-error-message - nix-protocol-error-message))) - - ;; 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))))) + `(let ((proc ,code) + (store (cached-store-connection ,store-id ,proto))) + ;; 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 ((store-protocol-error? c) + `(store-protocol-error + ,(store-protocol-error-message c)))) + `(result ,(proc store)))) inferior) (proxy inferior store) |