;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
+;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (gcrypt hash)
#:use-module (guix profiling)
#:autoload (guix build syscalls) (terminal-columns)
+ #:autoload (guix build utils) (dump-port)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module ((ice-9 control) #:select (let/ec))
+ #:use-module (ice-9 atomic)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 popen)
- #:use-module (ice-9 threads)
+ #:autoload (ice-9 threads) (current-processor-count)
#:use-module (ice-9 format)
#:use-module (web uri)
#:export (%daemon-socket-uri
nix-server-socket
current-store-protocol-version ;for internal use
+ cache-lookup-recorder ;for internal use
mcached
&store-error store-error?
nix-protocol-error-message
nix-protocol-error-status
+ allocate-store-connection-cache
+ store-connection-cache
+ set-store-connection-cache
+ set-store-connection-cache!
+
hash-algo
build-mode
+ connect-to-daemon
open-connection
port->connection
close-connection
add-text-to-store
add-to-store
add-file-tree-to-store
+ file-mapping->tree
binary-file
with-build-handler
map/accumulate-builds
build
query-failed-paths
clear-failed-paths
+ ensure-path
+ find-roots
add-temp-root
add-indirect-root
add-permanent-root
built-in-builders
references
references/cached
- references/substitutes
references*
query-path-info*
requisites
interned-file
interned-file-tree
+ %graft?
+ without-grafting
+ set-grafting
+ grafting?
+
%store-prefix
store-path
output-path
(write-string (bytevector->base16-string arg) p))))
(define-syntax read-arg
- (syntax-rules (integer boolean string store-path store-path-list string-list
+ (syntax-rules (integer boolean string store-path
+ store-path-list string-list string-pairs
substitutable-path-list path-info base16)
((_ integer p)
(read-int p))
(read-store-path-list p))
((_ string-list p)
(read-string-list p))
+ ((_ string-pairs p)
+ (read-string-pairs p))
((_ substitutable-path-list p)
(read-substitutable-path-list p))
((_ path-info p)
;; the session.
(ats-cache store-connection-add-to-store-cache)
(atts-cache store-connection-add-text-to-store-cache)
- (object-cache store-connection-object-cache
- (default vlist-null)) ;vhash
+ (caches store-connection-caches
+ (default '#())) ;vector
(built-in-builders store-connection-built-in-builders
(default (delay '())))) ;promise
'&store-connection-error' upon error."
(let ((s (with-fluids ((%default-port-encoding #f))
;; This trick allows use of the `scm_c_read' optimization.
- (socket PF_UNIX SOCK_STREAM 0)))
+ (socket PF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0)))
(a (make-socket-address PF_UNIX file)))
(system-error-to-connection-error file
(define (open-inet-socket host port)
"Connect to the Unix-domain socket at HOST:PORT and return it. Raise a
'&store-connection-error' upon error."
- (let ((sock (with-fluids ((%default-port-encoding #f))
- ;; This trick allows use of the `scm_c_read' optimization.
- (socket PF_UNIX SOCK_STREAM 0))))
- (define addresses
- (getaddrinfo host
- (if (number? port) (number->string port) port)
- (if (number? port)
- (logior AI_ADDRCONFIG AI_NUMERICSERV)
- AI_ADDRCONFIG)
- 0 ;any address family
- SOCK_STREAM)) ;TCP only
-
- (let loop ((addresses addresses))
- (match addresses
- ((ai rest ...)
- (let ((s (socket (addrinfo:fam ai)
- ;; TCP/IP only
- SOCK_STREAM IPPROTO_IP)))
-
- (catch 'system-error
- (lambda ()
- (connect s (addrinfo:addr ai))
-
- ;; Setting this option makes a dramatic difference because it
- ;; avoids the "ACK delay" on our RPC messages.
- (setsockopt s IPPROTO_TCP TCP_NODELAY 1)
- s)
- (lambda args
- ;; Connection failed, so try one of the other addresses.
- (close s)
- (if (null? rest)
- (raise (condition (&store-connection-error
- (file host)
- (errno (system-error-errno args)))))
- (loop rest))))))))))
+ (define addresses
+ (getaddrinfo host
+ (if (number? port) (number->string port) port)
+ (if (number? port)
+ (logior AI_ADDRCONFIG AI_NUMERICSERV)
+ AI_ADDRCONFIG)
+ 0 ;any address family
+ SOCK_STREAM)) ;TCP only
+
+ (let loop ((addresses addresses))
+ (match addresses
+ ((ai rest ...)
+ (let ((s (socket (addrinfo:fam ai)
+ ;; TCP/IP only
+ (logior SOCK_STREAM SOCK_CLOEXEC) IPPROTO_IP)))
+
+ (catch 'system-error
+ (lambda ()
+ (connect s (addrinfo:addr ai))
+
+ ;; Setting this option makes a dramatic difference because it
+ ;; avoids the "ACK delay" on our RPC messages.
+ (setsockopt s IPPROTO_TCP TCP_NODELAY 1)
+ s)
+ (lambda args
+ ;; Connection failed, so try one of the other addresses.
+ (close s)
+ (if (null? rest)
+ (raise (condition (&store-connection-error
+ (file host)
+ (errno (system-error-errno args)))))
+ (loop rest)))))))))
(define (connect-to-daemon uri)
"Connect to the daemon at URI, a string that may be an actual URI or a file
-name."
+name, and return an input/output port.
+
+This is a low-level procedure that does not perform the initial handshake with
+the daemon. Use 'open-connection' for that."
(define (not-supported)
(raise (condition (&store-connection-error
(file uri)
should the disk become full. When CPU-AFFINITY is true, it must be an integer
corresponding to an OS-level CPU number to which the daemon's worker process
for this connection will be pinned. Return a server object."
+ (define (handshake-error)
+ (raise (condition
+ (&store-connection-error (file (or port uri))
+ (errno EPROTO))
+ (&message (message "build daemon handshake failed")))))
+
(guard (c ((nar-error? c)
;; One of the 'write-' or 'read-' calls below failed, but this is
;; really a connection error.
- (raise (condition
- (&store-connection-error (file (or port uri))
- (errno EPROTO))
- (&message (message "build daemon handshake failed"))))))
+ (handshake-error)))
(let*-values (((port)
(or port (connect-to-daemon uri)))
((output flush)
(make-bytevector 8192))))
(write-int %worker-magic-1 port)
(let ((r (read-int port)))
- (and (eqv? r %worker-magic-2)
- (let ((v (read-int port)))
- (and (eqv? (protocol-major %protocol-version)
- (protocol-major v))
- (begin
- (write-int %protocol-version port)
- (when (>= (protocol-minor v) 14)
- (write-int (if cpu-affinity 1 0) port)
- (when cpu-affinity
- (write-int cpu-affinity port)))
- (when (>= (protocol-minor v) 11)
- (write-int (if reserve-space? 1 0) port))
- (letrec* ((built-in-builders
- (delay (%built-in-builders conn)))
- (conn
- (%make-store-connection port
- (protocol-major v)
- (protocol-minor v)
- output flush
- (make-hash-table 100)
- (make-hash-table 100)
- vlist-null
- built-in-builders)))
- (let loop ((done? (process-stderr conn)))
- (or done? (process-stderr conn)))
- conn)))))))))
+ (unless (= r %worker-magic-2)
+ (handshake-error))
+
+ (let ((v (read-int port)))
+ (unless (= (protocol-major %protocol-version)
+ (protocol-major v))
+ (handshake-error))
+
+ (write-int %protocol-version port)
+ (when (>= (protocol-minor v) 14)
+ (write-int (if cpu-affinity 1 0) port)
+ (when cpu-affinity
+ (write-int cpu-affinity port)))
+ (when (>= (protocol-minor v) 11)
+ (write-int (if reserve-space? 1 0) port))
+ (letrec* ((built-in-builders
+ (delay (%built-in-builders conn)))
+ (caches
+ (make-vector
+ (atomic-box-ref %store-connection-caches)
+ vlist-null))
+ (conn
+ (%make-store-connection port
+ (protocol-major v)
+ (protocol-minor v)
+ output flush
+ (make-hash-table 100)
+ (make-hash-table 100)
+ caches
+ built-in-builders)))
+ (let loop ((done? (process-stderr conn)))
+ (or done? (process-stderr conn)))
+ conn))))))
(define* (port->connection port
#:key (version %protocol-version))
output flush
(make-hash-table 100)
(make-hash-table 100)
- vlist-null
+ (make-vector
+ (atomic-box-ref %store-connection-caches)
+ vlist-null)
(delay (%built-in-builders connection))))
connection))
(define (call-with-store proc)
"Call PROC with an open store connection."
(let ((store (open-connection)))
- (catch #t
- (lambda ()
- (parameterize ((current-store-protocol-version
- (store-connection-version store)))
- (let ((result (proc store)))
+ (define (thunk)
+ (parameterize ((current-store-protocol-version
+ (store-connection-version store)))
+ (call-with-values (lambda () (proc store))
+ (lambda results
(close-connection store)
- result)))
- (lambda (key . args)
- (close-connection store)
- (apply throw key args)))))
+ (apply values results)))))
+
+ (with-exception-handler (lambda (exception)
+ (close-connection store)
+ (raise-exception exception))
+ thunk)))
(define-syntax-rule (with-store store exp ...)
"Bind STORE to an open connection to the store and evaluate EXPs;
;; The port where build output is sent.
(make-parameter (current-error-port)))
-(define* (dump-port in out
- #:optional len
- #:key (buffer-size 16384))
- "Read LEN bytes from IN (or as much as possible if LEN is #f) and write it
-to OUT, using chunks of BUFFER-SIZE bytes."
- (define buffer
- (make-bytevector buffer-size))
-
- (let loop ((total 0)
- (bytes (get-bytevector-n! in buffer 0
- (if len
- (min len buffer-size)
- buffer-size))))
- (or (eof-object? bytes)
- (and len (= total len))
- (let ((total (+ total bytes)))
- (put-bytevector out buffer 0 bytes)
- (loop total
- (get-bytevector-n! in buffer 0
- (if len
- (min (- len total) buffer-size)
- buffer-size)))))))
-
(define %newlines
;; Newline characters triggering a flush of 'current-build-output-port'.
;; Unlike Guile's 'line, we flush upon #\return so that progress reports
(map (if (false-if-exception (resolve-interface '(gnutls)))
(cut string-append "https://" <>)
(cut string-append "http://" <>))
- '("ci.guix.gnu.org")))
+ '("ci.guix.gnu.org"
+ "bordeaux.guix.gnu.org")))
(define (current-user-name)
"Return the name of the calling user."
(terminal-columns (terminal-columns))
;; Locale of the client.
- (locale (false-if-exception (setlocale LC_ALL))))
+ (locale (false-if-exception (setlocale LC_MESSAGES))))
;; Must be called after `open-connection'.
- (define socket
- (store-connection-socket server))
+ (define buffered
+ (store-connection-output-port server))
(unless (unspecified? use-build-hook?)
(warn-about-deprecation #:use-build-hook? #f
(let-syntax ((send (syntax-rules ()
((_ (type option) ...)
(begin
- (write-arg type option socket)
+ (write-arg type option buffered)
...)))))
- (write-int (operation-id set-options) socket)
+ (write-int (operation-id set-options) buffered)
(send (boolean keep-failed?) (boolean keep-going?)
(boolean fallback?) (integer verbosity))
(when (< (store-connection-minor-version server) #x61)
`(("locale" . ,locale))
'()))))
(send (string-pairs pairs))))
+ (write-buffered-output server)
(let loop ((done? (process-stderr server)))
(or done? (process-stderr server)))))
;; We don't use the 'operation' macro so we can pass SELECT? to
;; 'write-file'.
(record-operation 'add-to-store)
- (let ((port (store-connection-socket server)))
- (write-int (operation-id add-to-store) port)
- (write-string basename port)
- (write-int 1 port) ;obsolete, must be #t
- (write-int (if recursive? 1 0) port)
- (write-string hash-algo port)
- (write-file file-name port #:select? select?)
+ (let ((port (store-connection-socket server))
+ (buffered (store-connection-output-port server)))
+ (write-int (operation-id add-to-store) buffered)
+ (write-string basename buffered)
+ (write-int 1 buffered) ;obsolete, must be #t
+ (write-int (if recursive? 1 0) buffered)
+ (write-string hash-algo buffered)
+ (write-file file-name buffered #:select? select?)
(write-buffered-output server)
(let loop ((done? (process-stderr server)))
(or done? (loop (process-stderr server))))
;; We don't use the 'operation' macro so we can use 'write-file-tree'
;; instead of 'write-file'.
(record-operation 'add-to-store/tree)
- (let ((port (store-connection-socket server)))
- (write-int (operation-id add-to-store) port)
- (write-string basename port)
- (write-int 1 port) ;obsolete, must be #t
- (write-int (if recursive? 1 0) port)
- (write-string hash-algo port)
- (write-file-tree basename port
+ (let ((port (store-connection-socket server))
+ (buffered (store-connection-output-port server)))
+ (write-int (operation-id add-to-store) buffered)
+ (write-string basename buffered)
+ (write-int 1 buffered) ;obsolete, must be #t
+ (write-int (if recursive? 1 0) buffered)
+ (write-string hash-algo buffered)
+ (write-file-tree basename buffered
#:file-type+size file-type+size
#:file-port file-port
#:symlink-target symlink-target
(hash-set! cache tree result)
result)))))
+(define (file-mapping->tree mapping)
+ "Convert MAPPING, an alist like:
+
+ ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
+
+to a tree suitable for 'add-file-tree-to-store' and 'interned-file-tree'."
+ (let ((mapping (map (match-lambda
+ ((destination . source)
+ (cons (string-tokenize destination %not-slash)
+ source)))
+ mapping)))
+ (fold (lambda (pair result)
+ (match pair
+ ((destination . source)
+ (let loop ((destination destination)
+ (result result))
+ (match destination
+ ((file)
+ (let* ((mode (stat:mode (stat source)))
+ (type (if (zero? (logand mode #o100))
+ 'regular
+ 'executable)))
+ (alist-cons file
+ `(,type (file ,source))
+ result)))
+ ((file rest ...)
+ (let ((directory (assoc-ref result file)))
+ (alist-cons file
+ `(directory
+ ,@(loop rest
+ (match directory
+ (('directory . entries) entries)
+ (#f '()))))
+ (if directory
+ (alist-delete file result)
+ result)))))))))
+ '()
+ mapping)))
+
(define current-build-prompt
;; When true, this is the prompt to abort to when 'build-things' is called.
(make-parameter #f))
(things unresolved-things)
(continuation unresolved-continuation))
-(define (build-accumulator continue store things mode)
- "This build handler accumulates THINGS and returns an <unresolved> object."
- (if (= mode (build-mode normal))
- (unresolved things continue)
- (continue #t)))
-
-(define (map/accumulate-builds store proc lst)
+(define (build-accumulator expected-store)
+ "Return a build handler that accumulates THINGS and returns an <unresolved>
+object, only for build requests on EXPECTED-STORE."
+ (lambda (continue store things mode)
+ ;; Note: Do not compare STORE and EXPECTED-STORE with 'eq?' because
+ ;; 'cache-object-mapping' and similar functional "setters" change the
+ ;; store's object identity.
+ (if (and (eq? (store-connection-socket store)
+ (store-connection-socket expected-store))
+ (= mode (build-mode normal)))
+ (begin
+ ;; Preserve caches accumulated up to this handler invocation.
+ (set-store-connection-caches! expected-store
+ (store-connection-caches store))
+
+ (unresolved things
+ (lambda (new-store value)
+ ;; Borrow caches from NEW-STORE.
+ (set-store-connection-caches!
+ store (store-connection-caches new-store))
+ (continue value))))
+ (continue #t))))
+
+(define default-cutoff
+ ;; Default cutoff parameter for 'map/accumulate-builds'.
+ (make-parameter 32))
+
+(define* (map/accumulate-builds store proc lst
+ #:key (cutoff (default-cutoff)))
"Apply PROC over each element of LST, accumulating 'build-things' calls and
-coalescing them into a single call."
- (define result
- (map (lambda (obj)
- (with-build-handler build-accumulator
- (proc obj)))
- lst))
+coalescing them into a single call.
+
+CUTOFF is the threshold above which we stop accumulating unresolved nodes."
+
+ ;; The CUTOFF parameter helps avoid pessimal behavior where we keep
+ ;; stumbling upon the same .drv build requests with many incoming edges.
+ ;; See <https://bugs.gnu.org/49439>.
+
+ (define accumulator
+ (build-accumulator store))
+
+ (define-values (result rest)
+ ;; Have the default cutoff decay as we go deeper in the call stack to
+ ;; avoid pessimal behavior.
+ (parameterize ((default-cutoff (quotient cutoff 2)))
+ (let loop ((lst lst)
+ (result '())
+ (unresolved 0))
+ (match lst
+ ((head . tail)
+ (match (with-build-handler accumulator
+ (proc head))
+ ((? unresolved? obj)
+ (if (>= unresolved cutoff)
+ (values (reverse (cons obj result)) tail)
+ (loop tail (cons obj result) (+ 1 unresolved))))
+ (obj
+ (loop tail (cons obj result) unresolved))))
+ (()
+ (values (reverse result) lst))))))
(match (append-map (lambda (obj)
(if (unresolved? obj)
'()))
result)
(()
+ ;; REST is necessarily empty.
result)
(to-build
- ;; We've accumulated things TO-BUILD. Actually build them and resume the
- ;; corresponding continuations.
+ ;; We've accumulated things TO-BUILD; build them.
(build-things store (delete-duplicates to-build))
- (map/accumulate-builds store
- (lambda (obj)
- (if (unresolved? obj)
- ;; Pass #f because 'build-things' is now
- ;; unnecessary.
- ((unresolved-continuation obj) #f)
- obj))
- result))))
+
+ ;; Resume the continuations corresponding to TO-BUILD, and then process
+ ;; REST.
+ (append (map/accumulate-builds store
+ (lambda (obj)
+ (if (unresolved? obj)
+ ;; Pass #f because 'build-things' is now
+ ;; unnecessary.
+ ((unresolved-continuation obj)
+ store #f)
+ obj))
+ result #:cutoff cutoff)
+ (map/accumulate-builds store proc rest #:cutoff cutoff)))))
(define build-things
(let ((build (operation (build-things (string-list things)
things)))
(parameterize ((current-store-protocol-version
(store-connection-version store)))
+ (when (< (current-store-protocol-version) #x163)
+ ;; This corresponds to the first version bump of the daemon
+ ;; since the introduction of lzip compression support. The
+ ;; version change happened with commit 6ef61cc4c30 on the
+ ;; 2018/10/15).
+ (warn-about-old-daemon))
(if (>= (store-connection-minor-version store) 15)
(build store things mode)
(if (= mode (build-mode normal))
(message "unsupported build mode")
(status 1))))))))))))
+(define-operation (ensure-path (store-path path))
+ "Ensure that a path is valid. If it is not valid, it may be made valid by
+running a substitute. As a GC root is not created by the daemon, you may want
+to call ADD-TEMP-ROOT on that store path."
+ boolean)
+
+(define-operation (find-roots)
+ "Return a list of root/target pairs: for each pair, the first element is the
+GC root file name and the second element is its target in the store.
+
+When talking to a local daemon, this operation is equivalent to the 'gc-roots'
+procedure in (guix store roots), except that the 'find-roots' excludes
+potential roots that do not point to store items."
+ string-pairs)
+
(define-operation (add-temp-root (store-path path))
"Make PATH a temporary root for the duration of the current session.
Return #t."
"Return the list of references of PATH."
store-path-list))
-(define %reference-cache
- ;; Brute-force cache mapping store items to their list of references.
- ;; Caching matters because when building a profile in the presence of
- ;; grafts, we keep calling 'graft-derivation', which in turn calls
- ;; 'references/substitutes' many times with the same arguments. Ideally we
- ;; would use a cache associated with the daemon connection instead (XXX).
- (make-hash-table 100))
-
-(define (references/cached store item)
- "Like 'references', but cache results."
- (or (hash-ref %reference-cache item)
- (let ((references (references store item)))
- (hash-set! %reference-cache item references)
- references)))
-
-(define (references/substitutes store items)
- "Return the list of list of references of ITEMS; the result has the same
-length as ITEMS. Query substitute information for any item missing from the
-store at once. Raise a '&store-protocol-error' exception if reference
-information for one of ITEMS is missing."
- (let* ((requested items)
- (local-refs (map (lambda (item)
- (or (hash-ref %reference-cache item)
- (guard (c ((store-protocol-error? c) #f))
- (references store item))))
- items))
- (missing (fold-right (lambda (item local-ref result)
- (if local-ref
- result
- (cons item result)))
- '()
- items local-refs))
-
- ;; Query all the substitutes at once to minimize the cost of
- ;; launching 'guix substitute' and making HTTP requests.
- (substs (if (null? missing)
- '()
- (substitutable-path-info store missing))))
- (when (< (length substs) (length missing))
- (raise (condition (&store-protocol-error
- (message "cannot determine \
-the list of references")
- (status 1)))))
-
- ;; Intersperse SUBSTS and LOCAL-REFS.
- (let loop ((items items)
- (local-refs local-refs)
- (result '()))
- (match items
- (()
- (let ((result (reverse result)))
- (for-each (cut hash-set! %reference-cache <> <>)
- requested result)
- result))
- ((item items ...)
- (match local-refs
- ((#f tail ...)
- (loop items tail
- (cons (any (lambda (subst)
- (and (string=? (substitutable-path subst) item)
- (substitutable-references subst)))
- substs)
- result)))
- ((head tail ...)
- (loop items tail
- (cons head result)))))))))
-
(define* (fold-path store proc seed paths
#:optional (relatives (cut references store <>)))
"Call PROC for each of the RELATIVES of PATHS, exactly once, and return the
#f. MIN-FREED is the minimum amount of disk space to be freed, in
bytes, before the GC can stop. Return the list of store paths delete,
and the number of bytes freed."
- (let ((s (store-connection-socket server)))
- (write-int (operation-id collect-garbage) s)
- (write-int action s)
- (write-store-path-list to-delete s)
- (write-arg boolean #f s) ; ignore-liveness?
- (write-long-long min-freed s)
- (write-int 0 s) ; obsolete
+ (let ((s (store-connection-socket server))
+ (buffered (store-connection-output-port server)))
+ (write-int (operation-id collect-garbage) buffered)
+ (write-int action buffered)
+ (write-store-path-list to-delete buffered)
+ (write-arg boolean #f buffered) ; ignore-liveness?
+ (write-long-long min-freed buffered)
+ (write-int 0 buffered) ; obsolete
(when (>= (store-connection-minor-version server) 5)
;; Obsolete `use-atime' and `max-atime' parameters.
- (write-int 0 s)
- (write-int 0 s))
+ (write-int 0 buffered)
+ (write-int 0 buffered))
+ (write-buffered-output server)
;; Loop until the server is done sending error output.
(let loop ((done? (process-stderr server)))
(define* (export-path server path port #:key (sign? #t))
"Export PATH to PORT. When SIGN? is true, sign it."
- (let ((s (store-connection-socket server)))
- (write-int (operation-id export-path) s)
- (write-store-path path s)
- (write-arg boolean sign? s)
+ (let ((s (store-connection-socket server))
+ (buffered (store-connection-output-port server)))
+ (write-int (operation-id export-path) buffered)
+ (write-store-path path buffered)
+ (write-arg boolean sign? buffered)
+ (write-buffered-output server)
(let loop ((done? (process-stderr server port)))
(or done? (loop (process-stderr server port))))
(= 1 (read-int s))))
-(define* (export-paths server paths port #:key (sign? #t) recursive?)
+(define* (export-paths server paths port #:key (sign? #t) recursive?
+ (start (const #f))
+ (progress (const #f))
+ (finish (const #f)))
"Export the store paths listed in PATHS to PORT, in topological order,
signing them if SIGN? is true. When RECURSIVE? is true, export the closure of
-PATHS---i.e., PATHS and all their dependencies."
+PATHS---i.e., PATHS and all their dependencies.
+
+START, PROGRESS, and FINISH are used to track progress of the data transfer.
+START is a one-argument that is passed the list of store items that will be
+transferred; it returns values that are then used as the initial state
+threaded through PROGRESS calls. PROGRESS is passed the store item about to
+be sent, along with the values previously return by START or by PROGRESS
+itself. FINISH is called when the last store item has been called."
(define ordered
(let ((sorted (topologically-sorted server paths)))
;; When RECURSIVE? is #f, filter out the references of PATHS.
sorted
(filter (cut member <> paths) sorted))))
- (let loop ((paths ordered))
+ (let loop ((paths ordered)
+ (state (call-with-values (lambda () (start ordered))
+ list)))
(match paths
(()
+ (apply finish state)
(write-int 0 port))
((head tail ...)
(write-int 1 port)
(and (export-path server head port #:sign? sign?)
- (loop tail))))))
+ (loop tail
+ (call-with-values
+ (lambda () (apply progress head state))
+ list)))))))
(define-operation (query-failed-paths)
"Return the list of store items for which a build failure is cached.
boolean)
\f
+;;;
+;;; Per-connection caches.
+;;;
+
+;; Number of currently allocated store connection caches--things that go in
+;; the 'caches' vector of <store-connection>.
+(define %store-connection-caches (make-atomic-box 0))
+
+(define %max-store-connection-caches
+ ;; Maximum number of caches returned by 'allocate-store-connection-cache'.
+ 32)
+
+(define %store-connection-cache-names
+ ;; Mapping of cache ID to symbol.
+ (make-vector %max-store-connection-caches))
+
+(define (allocate-store-connection-cache name)
+ "Allocate a new cache for store connections and return its identifier. Said
+identifier can be passed as an argument to "
+ (let loop ((current (atomic-box-ref %store-connection-caches)))
+ (let ((previous (atomic-box-compare-and-swap! %store-connection-caches
+ current (+ current 1))))
+ (if (= previous current)
+ (begin
+ (vector-set! %store-connection-cache-names current name)
+ current)
+ (loop current)))))
+
+(define %object-cache-id
+ ;; The "object cache", mapping lowerable objects such as <package> records
+ ;; to derivations.
+ (allocate-store-connection-cache 'object-cache))
+
+(define (vector-set vector index value)
+ (let ((new (vector-copy vector)))
+ (vector-set! new index value)
+ new))
+
+(define (store-connection-cache store cache)
+ "Return the cache of STORE identified by CACHE, an identifier as returned by
+'allocate-store-connection-cache'."
+ (vector-ref (store-connection-caches store) cache))
+
+(define (set-store-connection-cache store cache value)
+ "Return a copy of STORE where CACHE has the given VALUE. CACHE must be a
+value returned by 'allocate-store-connection-cache'."
+ (store-connection
+ (inherit store)
+ (caches (vector-set (store-connection-caches store) cache value))))
+
+(define set-store-connection-caches! ;private
+ (record-modifier <store-connection> 'caches))
+
+(define (set-store-connection-cache! store cache value)
+ "Set STORE's CACHE to VALUE.
+
+This is a mutating version that should be avoided. Prefer the functional
+'set-store-connection-cache' instead, together with using %STORE-MONAD."
+ (vector-set! (store-connection-caches store) cache value))
+
+
+(define %reference-cache-id
+ ;; Cache mapping store items to their list of references. Caching matters
+ ;; because when building a profile in the presence of grafts, we keep
+ ;; calling 'graft-derivation', which in turn calls 'references/cached' many
+ ;; times with the same arguments.
+ (allocate-store-connection-cache 'reference-cache))
+
+(define (references/cached store item)
+ "Like 'references', but cache results."
+ (let* ((cache (store-connection-cache store %reference-cache-id))
+ (value (vhash-assoc item cache)))
+ (record-cache-lookup! %reference-cache-id value cache)
+ (match value
+ ((_ . references)
+ references)
+ (#f
+ (let* ((references (references store item))
+ (cache (vhash-cons item references cache)))
+ (set-store-connection-cache! store %reference-cache-id cache)
+ references)))))
+
+\f
;;;
;;; Store monad.
;;;
(template-directory instantiations %store-monad)
(define* (cache-object-mapping object keys result
- #:key (vhash-cons vhash-consq))
+ #:key
+ (cache %object-cache-id)
+ (vhash-cons vhash-consq))
"Augment the store's object cache with a mapping from OBJECT/KEYS to RESULT.
KEYS is a list of additional keys to match against, for instance a (SYSTEM
TARGET) tuple. Use VHASH-CONS to insert OBJECT into the cache.
and RESULT is typically its derivation."
(lambda (store)
(values result
- (store-connection
- (inherit store)
- (object-cache (vhash-cons object (cons result keys)
- (store-connection-object-cache store)))))))
-
-(define record-cache-lookup!
- (if (profiled? "object-cache")
+ (set-store-connection-cache
+ store cache
+ (vhash-cons object (cons result keys)
+ (store-connection-cache store cache))))))
+
+(define (cache-lookup-recorder component title)
+ "Return a procedure of two arguments to record cache lookups, hits, and
+misses for COMPONENT. The procedure must be passed a Boolean indicating
+whether the cache lookup was a hit, and the actual cache (a vhash)."
+ (if (profiled? component)
(let ((fresh 0)
(lookups 0)
- (hits 0))
+ (hits 0)
+ (size 0))
(register-profiling-hook!
- "object-cache"
+ component
(lambda ()
- (format (current-error-port) "Store object cache:
+ (format (current-error-port) "~a:
fresh caches: ~5@a
lookups: ~5@a
- hits: ~5@a (~,1f%)~%"
- fresh lookups hits
+ hits: ~5@a (~,1f%)
+ cache size: ~5@a entries~%"
+ title fresh lookups hits
(if (zero? lookups)
100.
- (* 100. (/ hits lookups))))))
+ (* 100. (/ hits lookups)))
+ size)))
(lambda (hit? cache)
(set! fresh
- (if (eq? cache vlist-null)
- (+ 1 fresh)
- fresh))
+ (if (eq? cache vlist-null)
+ (+ 1 fresh)
+ fresh))
(set! lookups (+ 1 lookups))
- (set! hits (if hit? (+ hits 1) hits))))
+ (set! hits (if hit? (+ hits 1) hits))
+ (set! size (+ (if hit? 0 1)
+ (vlist-length cache)))))
(lambda (x y)
#t)))
-(define* (lookup-cached-object object #:optional (keys '())
- #:key (vhash-fold* vhash-foldq*))
- "Return the cached object in the store connection corresponding to OBJECT
+(define recorder-for-cache
+ (let ((recorders (make-vector %max-store-connection-caches)))
+ (lambda (cache-id)
+ "Return a procedure to record lookup stats for CACHE-ID."
+ (match (vector-ref recorders cache-id)
+ ((? unspecified?)
+ (let* ((name (symbol->string
+ (vector-ref %store-connection-cache-names cache-id)))
+ (description
+ (string-titlecase
+ (string-map (match-lambda
+ (#\- #\space)
+ (chr chr))
+ name))))
+ (let ((proc (cache-lookup-recorder name description)))
+ (vector-set! recorders cache-id proc)
+ proc)))
+ (proc proc)))))
+
+(define (record-cache-lookup! cache-id value cache)
+ "Record the lookup of VALUE in CACHE-ID, whose current value is CACHE."
+ (let ((record! (recorder-for-cache cache-id)))
+ (record! value cache)))
+
+(define-inlinable (lookup-cached-object cache-id object keys vhash-fold*)
+ "Return the object in store cache CACHE-ID corresponding to OBJECT
and KEYS; use VHASH-FOLD* to look for OBJECT in the cache. KEYS is a list of
additional keys to match against, and which are compared with 'equal?'.
Return #f on failure and the cached result otherwise."
(lambda (store)
- (let* ((cache (store-connection-object-cache store))
+ (let* ((cache (store-connection-cache store cache-id))
;; Escape as soon as we find the result. This avoids traversing
;; the whole vlist chain and significantly reduces the number of
result))))
#f object
cache))))
- (record-cache-lookup! value cache)
+ (record-cache-lookup! cache-id value cache)
(values value store))))
(define* (%mcached mthunk object #:optional (keys '())
#:key
+ (cache %object-cache-id)
(vhash-cons vhash-consq)
(vhash-fold* vhash-foldq*))
"Bind the monadic value returned by MTHUNK, which supposedly corresponds to
OBJECT/KEYS, or return its cached value. Use VHASH-CONS to insert OBJECT into
the cache, and VHASH-FOLD* to look it up."
- (mlet %store-monad ((cached (lookup-cached-object object keys
- #:vhash-fold* vhash-fold*)))
+ (mlet %store-monad ((cached (lookup-cached-object cache object keys
+ vhash-fold*)))
(if cached
(return cached)
(>>= (mthunk)
(lambda (result)
(cache-object-mapping object keys result
+ #:cache cache
#:vhash-cons vhash-cons))))))
(define-syntax mcached
- (syntax-rules (eq? equal?)
+ (syntax-rules (eq? equal? =>)
"Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the
value associated with OBJECT/KEYS in the store's object cache if there is
one."
- ((_ eq? mvalue object keys ...)
+ ((_ eq? (=> cache) mvalue object keys ...)
(%mcached (lambda () mvalue)
object (list keys ...)
+ #:cache cache
#:vhash-cons vhash-consq
#:vhash-fold* vhash-foldq*))
- ((_ equal? mvalue object keys ...)
+ ((_ equal? (=> cache) mvalue object keys ...)
(%mcached (lambda () mvalue)
object (list keys ...)
+ #:cache cache
#:vhash-cons vhash-cons
#:vhash-fold* vhash-fold*))
+ ((_ eq? mvalue object keys ...)
+ (mcached eq? (=> %object-cache-id)
+ mvalue object keys ...))
+ ((_ equal? mvalue object keys ...)
+ (mcached equal? (=> %object-cache-id)
+ mvalue object keys ...))
((_ mvalue object keys ...)
(mcached eq? mvalue object keys ...))))
(values (map/accumulate-builds store
(lambda (obj)
(run-with-store store
- (mproc obj)))
+ (mproc obj)
+ #:system (%current-system)
+ #:target (%current-target-system)))
lst)
store)))
;; when using 'gexp->derivation' and co.
(make-parameter #f))
-(define set-store-connection-object-cache!
- (record-modifier <store-connection> 'object-cache))
-
(define* (run-with-store store mval
#:key
(guile-for-build (%guile-for-build))
(when (and store new-store)
;; Copy the object cache from NEW-STORE so we don't fully discard
;; the state.
- (let ((cache (store-connection-object-cache new-store)))
- (set-store-connection-object-cache! store cache)))
+ (let ((caches (store-connection-caches new-store)))
+ (set-store-connection-caches! store caches)))
result))))
\f
+;;;
+;;; Whether to enable grafts.
+;;;
+
+(define %graft?
+ ;; Whether to honor package grafts by default.
+ (make-parameter #t))
+
+(define (call-without-grafting thunk)
+ (lambda (store)
+ (values (parameterize ((%graft? #f))
+ (run-with-store store (thunk)))
+ store)))
+
+(define-syntax-rule (without-grafting mexp ...)
+ "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is
+false."
+ (call-without-grafting (lambda () (mbegin %store-monad mexp ...))))
+
+(define-inlinable (set-grafting enable?)
+ ;; This monadic procedure enables grafting when ENABLE? is true, and
+ ;; disables it otherwise. It returns the previous setting.
+ (lambda (store)
+ (values (%graft? enable?) store)))
+
+(define-inlinable (grafting?)
+ ;; Return a Boolean indicating whether grafting is enabled.
+ (lambda (store)
+ (values (%graft?) store)))
+
+\f
;;;
;;; Store paths.
;;;
(define (store-path-hash-part path)
"Return the hash part of PATH as a base32 string, or #f if PATH is not a
syntactically valid store path."
- (let* ((base (store-path-base path))
- (hash (string-take base 32)))
- (and (string-every %nix-base32-charset hash)
- hash)))
+ (match (store-path-base path)
+ (#f #f)
+ (base
+ (let ((hash (string-take base 32)))
+ (and (string-every %nix-base32-charset hash)
+ hash)))))
(define (derivation-log-file drv)
"Return the build log file for DRV, a derivation file name, or #f if it
HCoop / jackhill / guix / guix.git / blobdiff