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 2017-06-12 17:11:22 +02:00 committed by Ludovic Courtès
parent b46712159c
commit 015f17e8b9
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
7 changed files with 32 additions and 44 deletions

View File

@ -82,6 +82,7 @@
derivation-hash derivation-hash
read-derivation read-derivation
read-derivation-from-file
write-derivation write-derivation
derivation->output-path derivation->output-path
derivation->output-paths derivation->output-paths
@ -241,8 +242,7 @@ result is the set of prerequisites of DRV not already in valid."
(append inputs result) (append inputs result)
(fold set-insert input-set inputs) (fold set-insert input-set inputs)
(map (lambda (i) (map (lambda (i)
(call-with-input-file (derivation-input-path i) (read-derivation-from-file (derivation-input-path i)))
read-derivation))
inputs))))) inputs)))))
(define (offloadable-derivation? drv) (define (offloadable-derivation? drv)
@ -295,9 +295,8 @@ substituter many times."
;; info is not already in cache. ;; info is not already in cache.
;; Also, skip derivations marked as non-substitutable. ;; Also, skip derivations marked as non-substitutable.
(append-map (lambda (input) (append-map (lambda (input)
(let ((drv (call-with-input-file (let ((drv (read-derivation-from-file
(derivation-input-path input) (derivation-input-path input))))
read-derivation)))
(if (substitutable-derivation? drv) (if (substitutable-derivation? drv)
(derivation-input-output-paths input) (derivation-input-output-paths input)
'()))) '())))
@ -400,13 +399,15 @@ one-argument procedure similar to that returned by 'substitution-oracle'."
(derivation-inputs drv)) (derivation-inputs drv))
substitute) substitute)
(map (lambda (i) (map (lambda (i)
(call-with-input-file (derivation-input-path i) (read-derivation-from-file
read-derivation)) (derivation-input-path i)))
inputs) inputs)
(map derivation-input-sub-derivations inputs))))))) (map derivation-input-sub-derivations inputs)))))))
(define (%read-derivation drv-port) (define (read-derivation drv-port)
;; Actually read derivation from 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 ",")) (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. ;; XXX: This is redundant with 'atts-cache' in the store.
(make-weak-value-hash-table 200)) (make-weak-value-hash-table 200))
(define (read-derivation drv-port) (define (read-derivation-from-file file)
"Read the derivation from DRV-PORT and return the corresponding "Read the derivation in FILE, a '.drv' file, and return the corresponding
<derivation> object." <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 ;; and because the same argument is read more than 15 times on average
;; during something like (package-derivation s gdb). ;; during something like (package-derivation s gdb).
(let ((file (port-filename drv-port))) (or (and file (hash-ref %derivation-cache file))
(or (and file (hash-ref %derivation-cache file)) (let ((drv (call-with-input-file file read-derivation)))
(let ((drv (%read-derivation drv-port))) (hash-set! %derivation-cache file drv)
(hash-set! %derivation-cache file drv) drv)))
drv))))
(define-inlinable (write-sequence lst write-item port) (define-inlinable (write-sequence lst write-item port)
;; Write each element of LST with WRITE-ITEM to PORT, separating them with a ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
@ -608,8 +608,7 @@ DRV."
(define derivation-path->output-path (define derivation-path->output-path
;; This procedure is called frequently, so memoize it. ;; This procedure is called frequently, so memoize it.
(let ((memoized (mlambda (path output) (let ((memoized (mlambda (path output)
(derivation->output-path (call-with-input-file path (derivation->output-path (read-derivation-from-file path)
read-derivation)
output)))) output))))
(lambda* (path #:optional (output "out")) (lambda* (path #:optional (output "out"))
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store "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) (define (derivation-path->output-paths path)
"Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
list of name/path pairs of its outputs." 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) (mlambda (file)
"Return a string containing the base16 representation of the hash of the "Return a string containing the base16 representation of the hash of the
derivation at FILE." derivation at FILE."
(call-with-input-file file (bytevector->base16-string
(compose bytevector->base16-string (derivation-hash (read-derivation-from-file file)))))
derivation-hash
read-derivation))))
(define derivation-hash ; `hashDerivationModulo' in derivations.cc (define derivation-hash ; `hashDerivationModulo' in derivations.cc
(mlambda (drv) (mlambda (drv)
@ -896,7 +893,7 @@ recursively."
((_ . replacement) ((_ . replacement)
(list replacement)) (list replacement))
(#f (#f
(let* ((drv (loop (call-with-input-file path read-derivation)))) (let* ((drv (loop (read-derivation-from-file path))))
(cons drv sub-drvs)))))))) (cons drv sub-drvs))))))))
(let loop ((drv drv)) (let loop ((drv drv))

View File

@ -156,7 +156,7 @@ name of the output of that derivation ITEM corresponds to (for example
(() ;ITEM is a plain file (() ;ITEM is a plain file
(values #f #f)) (values #f #f))
((drv-file _ ...) ((drv-file _ ...)
(let ((drv (call-with-input-file drv-file read-derivation))) (let ((drv (read-derivation-from-file drv-file)))
(values drv (values drv
(any (match-lambda (any (match-lambda
((name . path) ((name . path)

View File

@ -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 ;; Usually we'll have more luck with the output file name since
;; the deriver that was used by the server could be different, so ;; the deriver that was used by the server could be different, so
;; try one of the output file names. ;; 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)) (or (find-url (derivation->output-path drv))
(find-url file)))) (find-url file))))
(lambda args (lambda args
@ -599,7 +599,7 @@ build---packages, gexps, derivations, and so on."
(append-map (match-lambda (append-map (match-lambda
(('argument . (? string? spec)) (('argument . (? string? spec))
(cond ((derivation-path? spec) (cond ((derivation-path? spec)
(list (call-with-input-file spec read-derivation))) (list (read-derivation-from-file spec)))
((store-path? spec) ((store-path? spec)
;; Nothing to do; maybe for --log-file. ;; Nothing to do; maybe for --log-file.
'()) '())

View File

@ -221,15 +221,11 @@ GNU-BUILD-SYSTEM have zero dependencies."
;;; Derivation DAG. ;;; 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) (define (derivation-dependencies obj)
"Return the <derivation> objects and store items corresponding to the "Return the <derivation> objects and store items corresponding to the
dependencies of OBJ, a <derivation> or store item." dependencies of OBJ, a <derivation> or store item."
(if (derivation? obj) (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-inputs obj))
(derivation-sources obj)) (derivation-sources obj))
'())) '()))
@ -263,7 +259,7 @@ a plain store file."
((? derivation-path? item) ((? derivation-path? item)
(mbegin %store-monad (mbegin %store-monad
((store-lift add-temp-root) item) ((store-lift add-temp-root) item)
(return (list (file->derivation item))))) (return (list (read-derivation-from-file item)))))
(x (x
(raise (raise
(condition (&message (message "unsupported argument for \ (condition (&message (message "unsupported argument for \

View File

@ -652,9 +652,8 @@ machine."
(with-error-handling (with-error-handling
(process-request (equal? (match:substring match 1) "1") (process-request (equal? (match:substring match 1) "1")
(match:substring match 2) ; system (match:substring match 2) ; system
(call-with-input-file (read-derivation-from-file
(match:substring match 3) (match:substring match 3))
read-derivation)
(string-tokenize (string-tokenize
(match:substring match 4) not-coma) (match:substring match 4) not-coma)
#:print-build-trace? print-build-trace? #:print-build-trace? print-build-trace?

View File

@ -106,11 +106,11 @@ of GnuTLS over HTTPS, before we have built GnuTLS. See
(match args (match args
(((? derivation-path? drv) (? store-path? output)) (((? derivation-path? drv) (? store-path? output))
(assert-low-privileges) (assert-low-privileges)
(perform-download (call-with-input-file drv read-derivation) (perform-download (read-derivation-from-file drv)
output)) output))
(((? derivation-path? drv)) ;backward compatibility (((? derivation-path? drv)) ;backward compatibility
(assert-low-privileges) (assert-low-privileges)
(perform-download (call-with-input-file drv read-derivation))) (perform-download (read-derivation-from-file drv)))
(("--version") (("--version")
(show-version-and-exit)) (show-version-and-exit))
(x (x

View File

@ -225,10 +225,6 @@ compression disabled~%"))
("WantMassQuery" . 0) ("WantMassQuery" . 0)
("Priority" . 100))) ("Priority" . 100)))
(define (load-derivation file)
"Read the derivation from FILE."
(call-with-input-file file read-derivation))
(define (signed-string s) (define (signed-string s)
"Sign the hash of the string S with the daemon's key." "Sign the hash of the string S with the daemon's key."
(let* ((public-key (%public-key)) (let* ((public-key (%public-key))
@ -286,7 +282,7 @@ References: ~a~%~a"
base-info base-info
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(let ((drv (load-derivation deriver))) (let ((drv (read-derivation-from-file deriver)))
(format #f "~aSystem: ~a~%Deriver: ~a~%" (format #f "~aSystem: ~a~%Deriver: ~a~%"
base-info (derivation-system drv) base-info (derivation-system drv)
(basename deriver)))) (basename deriver))))