derivations: Introduce 'read-derivation-from-file'.
This avoids the open/fstat/close syscalls upon a cache hit that we had with the previous idiom: (call-with-input-file file read-derivation) where caching happened in 'read-derivation' itself. * guix/derivations.scm (%read-derivation): Rename to... (read-derivation): ... this. (read-derivation-from-file): New procedure. (derivation-prerequisites, substitution-oracle) (derivation-prerequisites-to-build): (derivation-path->output-path, derivation-path->output-paths): (derivation-path->base16-hash, map-derivation): Use 'read-derivation-from-file' instead of (call-with-input-file … read-derivation). * guix/grafts.scm (item->deriver): Likewise. * guix/scripts/build.scm (log-url, options->things-to-build): Likewise. * guix/scripts/graph.scm (file->derivation): Remove. (derivation-dependencies, %derivation-node-type): Use 'read-derivation-from-file' instead. * guix/scripts/offload.scm (guix-offload): Likewise. * guix/scripts/perform-download.scm (guix-perform-download): Likewise. * guix/scripts/publish.scm (load-derivation): Remove. (narinfo-string): Use 'read-derivation-from-file'.
This commit is contained in:
Ludovic Courtès
Ludovic Courtès
parent
b46712159c
commit
015f17e8b9
@ -82,6 +82,7 @@
|
||||
derivation-hash
|
||||
|
||||
read-derivation
|
||||
read-derivation-from-file
|
||||
write-derivation
|
||||
derivation->output-path
|
||||
derivation->output-paths
|
||||
@ -241,8 +242,7 @@ result is the set of prerequisites of DRV not already in valid."
|
||||
(append inputs result)
|
||||
(fold set-insert input-set inputs)
|
||||
(map (lambda (i)
|
||||
(call-with-input-file (derivation-input-path i)
|
||||
read-derivation))
|
||||
(read-derivation-from-file (derivation-input-path i)))
|
||||
inputs)))))
|
||||
|
||||
(define (offloadable-derivation? drv)
|
||||
@ -295,9 +295,8 @@ substituter many times."
|
||||
;; info is not already in cache.
|
||||
;; Also, skip derivations marked as non-substitutable.
|
||||
(append-map (lambda (input)
|
||||
(let ((drv (call-with-input-file
|
||||
(derivation-input-path input)
|
||||
read-derivation)))
|
||||
(let ((drv (read-derivation-from-file
|
||||
(derivation-input-path input))))
|
||||
(if (substitutable-derivation? drv)
|
||||
(derivation-input-output-paths input)
|
||||
'())))
|
||||
@ -400,13 +399,15 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
|
||||
(derivation-inputs drv))
|
||||
substitute)
|
||||
(map (lambda (i)
|
||||
(call-with-input-file (derivation-input-path i)
|
||||
read-derivation))
|
||||
(read-derivation-from-file
|
||||
(derivation-input-path i)))
|
||||
inputs)
|
||||
(map derivation-input-sub-derivations inputs)))))))
|
||||
|
||||
(define (%read-derivation drv-port)
|
||||
;; Actually read derivation from DRV-PORT.
|
||||
(define (read-derivation drv-port)
|
||||
"Read the derivation from DRV-PORT and return the corresponding <derivation>
|
||||
object. Most of the time you'll want to use 'read-derivation-from-file',
|
||||
which caches things as appropriate and is thus more efficient."
|
||||
|
||||
(define comma (string->symbol ","))
|
||||
|
||||
@ -482,17 +483,16 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
|
||||
;; XXX: This is redundant with 'atts-cache' in the store.
|
||||
(make-weak-value-hash-table 200))
|
||||
|
||||
(define (read-derivation drv-port)
|
||||
"Read the derivation from DRV-PORT and return the corresponding
|
||||
(define (read-derivation-from-file file)
|
||||
"Read the derivation in FILE, a '.drv' file, and return the corresponding
|
||||
<derivation> object."
|
||||
;; Memoize that operation because `%read-derivation' is quite expensive,
|
||||
;; Memoize that operation because 'read-derivation' is quite expensive,
|
||||
;; and because the same argument is read more than 15 times on average
|
||||
;; during something like (package-derivation s gdb).
|
||||
(let ((file (port-filename drv-port)))
|
||||
(or (and file (hash-ref %derivation-cache file))
|
||||
(let ((drv (%read-derivation drv-port)))
|
||||
(hash-set! %derivation-cache file drv)
|
||||
drv))))
|
||||
(or (and file (hash-ref %derivation-cache file))
|
||||
(let ((drv (call-with-input-file file read-derivation)))
|
||||
(hash-set! %derivation-cache file drv)
|
||||
drv)))
|
||||
|
||||
(define-inlinable (write-sequence lst write-item port)
|
||||
;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
|
||||
@ -608,8 +608,7 @@ DRV."
|
||||
(define derivation-path->output-path
|
||||
;; This procedure is called frequently, so memoize it.
|
||||
(let ((memoized (mlambda (path output)
|
||||
(derivation->output-path (call-with-input-file path
|
||||
read-derivation)
|
||||
(derivation->output-path (read-derivation-from-file path)
|
||||
output))))
|
||||
(lambda* (path #:optional (output "out"))
|
||||
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
|
||||
@ -619,7 +618,7 @@ path of its output OUTPUT."
|
||||
(define (derivation-path->output-paths path)
|
||||
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
|
||||
list of name/path pairs of its outputs."
|
||||
(derivation->output-paths (call-with-input-file path read-derivation)))
|
||||
(derivation->output-paths (read-derivation-from-file path)))
|
||||
|
||||
|
||||
;;;
|
||||
@ -630,10 +629,8 @@ list of name/path pairs of its outputs."
|
||||
(mlambda (file)
|
||||
"Return a string containing the base16 representation of the hash of the
|
||||
derivation at FILE."
|
||||
(call-with-input-file file
|
||||
(compose bytevector->base16-string
|
||||
derivation-hash
|
||||
read-derivation))))
|
||||
(bytevector->base16-string
|
||||
(derivation-hash (read-derivation-from-file file)))))
|
||||
|
||||
(define derivation-hash ; `hashDerivationModulo' in derivations.cc
|
||||
(mlambda (drv)
|
||||
@ -896,7 +893,7 @@ recursively."
|
||||
((_ . replacement)
|
||||
(list replacement))
|
||||
(#f
|
||||
(let* ((drv (loop (call-with-input-file path read-derivation))))
|
||||
(let* ((drv (loop (read-derivation-from-file path))))
|
||||
(cons drv sub-drvs))))))))
|
||||
|
||||
(let loop ((drv drv))
|
||||
|
||||
@ -156,7 +156,7 @@ name of the output of that derivation ITEM corresponds to (for example
|
||||
(() ;ITEM is a plain file
|
||||
(values #f #f))
|
||||
((drv-file _ ...)
|
||||
(let ((drv (call-with-input-file drv-file read-derivation)))
|
||||
(let ((drv (read-derivation-from-file drv-file)))
|
||||
(values drv
|
||||
(any (match-lambda
|
||||
((name . path)
|
||||
|
||||
@ -87,7 +87,7 @@ found. Return #f if no build log was found."
|
||||
;; Usually we'll have more luck with the output file name since
|
||||
;; the deriver that was used by the server could be different, so
|
||||
;; try one of the output file names.
|
||||
(let ((drv (call-with-input-file file read-derivation)))
|
||||
(let ((drv (read-derivation-from-file file)))
|
||||
(or (find-url (derivation->output-path drv))
|
||||
(find-url file))))
|
||||
(lambda args
|
||||
@ -599,7 +599,7 @@ build---packages, gexps, derivations, and so on."
|
||||
(append-map (match-lambda
|
||||
(('argument . (? string? spec))
|
||||
(cond ((derivation-path? spec)
|
||||
(list (call-with-input-file spec read-derivation)))
|
||||
(list (read-derivation-from-file spec)))
|
||||
((store-path? spec)
|
||||
;; Nothing to do; maybe for --log-file.
|
||||
'())
|
||||
|
||||
@ -221,15 +221,11 @@ GNU-BUILD-SYSTEM have zero dependencies."
|
||||
;;; Derivation DAG.
|
||||
;;;
|
||||
|
||||
(define (file->derivation file)
|
||||
"Read the derivation from FILE and return it."
|
||||
(call-with-input-file file read-derivation))
|
||||
|
||||
(define (derivation-dependencies obj)
|
||||
"Return the <derivation> objects and store items corresponding to the
|
||||
dependencies of OBJ, a <derivation> or store item."
|
||||
(if (derivation? obj)
|
||||
(append (map (compose file->derivation derivation-input-path)
|
||||
(append (map (compose read-derivation-from-file derivation-input-path)
|
||||
(derivation-inputs obj))
|
||||
(derivation-sources obj))
|
||||
'()))
|
||||
@ -263,7 +259,7 @@ a plain store file."
|
||||
((? derivation-path? item)
|
||||
(mbegin %store-monad
|
||||
((store-lift add-temp-root) item)
|
||||
(return (list (file->derivation item)))))
|
||||
(return (list (read-derivation-from-file item)))))
|
||||
(x
|
||||
(raise
|
||||
(condition (&message (message "unsupported argument for \
|
||||
|
||||
@ -652,9 +652,8 @@ machine."
|
||||
(with-error-handling
|
||||
(process-request (equal? (match:substring match 1) "1")
|
||||
(match:substring match 2) ; system
|
||||
(call-with-input-file
|
||||
(match:substring match 3)
|
||||
read-derivation)
|
||||
(read-derivation-from-file
|
||||
(match:substring match 3))
|
||||
(string-tokenize
|
||||
(match:substring match 4) not-coma)
|
||||
#:print-build-trace? print-build-trace?
|
||||
|
||||
@ -106,11 +106,11 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See
|
||||
(match args
|
||||
(((? derivation-path? drv) (? store-path? output))
|
||||
(assert-low-privileges)
|
||||
(perform-download (call-with-input-file drv read-derivation)
|
||||
(perform-download (read-derivation-from-file drv)
|
||||
output))
|
||||
(((? derivation-path? drv)) ;backward compatibility
|
||||
(assert-low-privileges)
|
||||
(perform-download (call-with-input-file drv read-derivation)))
|
||||
(perform-download (read-derivation-from-file drv)))
|
||||
(("--version")
|
||||
(show-version-and-exit))
|
||||
(x
|
||||
|
||||
@ -225,10 +225,6 @@ compression disabled~%"))
|
||||
("WantMassQuery" . 0)
|
||||
("Priority" . 100)))
|
||||
|
||||
(define (load-derivation file)
|
||||
"Read the derivation from FILE."
|
||||
(call-with-input-file file read-derivation))
|
||||
|
||||
(define (signed-string s)
|
||||
"Sign the hash of the string S with the daemon's key."
|
||||
(let* ((public-key (%public-key))
|
||||
@ -286,7 +282,7 @@ References: ~a~%~a"
|
||||
base-info
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(let ((drv (load-derivation deriver)))
|
||||
(let ((drv (read-derivation-from-file deriver)))
|
||||
(format #f "~aSystem: ~a~%Deriver: ~a~%"
|
||||
base-info (derivation-system drv)
|
||||
(basename deriver))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user