amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

inferior: Move initialization bits away from 'inferior-eval-with-store'.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2022-01-27 09:20:40 +01:00
parent c71910a095
commit e778910bdf
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 42 additions and 34 deletions
Download patch file Download diff file Expand all files Collapse all files

76
guix/inferior.scm
View file

@ -225,7 +225,39 @@ inferior."
(inferior-eval '(use-modules (srfi srfi-34)) result) (inferior-eval '(use-modules (srfi srfi-34)) result)
(inferior-eval '(define %package-table (make-hash-table)) (inferior-eval '(define %package-table (make-hash-table))
result) 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)
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)))) (store-id (object-address (store-connection-socket store))))
(ensure-store-bridge! inferior) (ensure-store-bridge! inferior)
(send-inferior-request (send-inferior-request
`(let ((proc ,code) `(let ((proc ,code)
(error? (if (defined? 'store-protocol-error?) (store (cached-store-connection ,store-id ,proto)))
store-protocol-error? ;; Serialize '&store-protocol-error' conditions. The exception
nix-protocol-error?)) ;; serialization mechanism that 'read-repl-response' expects is
(error-message (if (defined? 'store-protocol-error-message) ;; unsuitable for SRFI-35 error conditions, hence this special case.
store-protocol-error-message (guard (c ((store-protocol-error? c)
nix-protocol-error-message))) `(store-protocol-error
,(store-protocol-error-message c))))
;; Cache connections to STORE-ID. This ensures that the caches within `(result ,(proc store))))
;; <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) inferior)
(proxy inferior store) (proxy inferior store)