store: Add a functional object cache and use it in 'lower-object'.
This leads to ~25% improvements on things like: guix system build desktop.tmpl --no-grafts -d * guix/store.scm (<nix-server>)[object-cache]: New field. * guix/store.scm (open-connection): Initialize it. (cache-object-mapping, lookup-cached-object, %mcached): New procedures. (mcached): New macro. * guix/gexp.scm (lower-object): Use it. * guix/grafts.scm (grafting?): New procedure.
This commit is contained in:
parent
9ed86fe175
commit
c6080c3249
@ -211,7 +211,12 @@ OBJ must be an object that has an associated gexp compiler, such as a
|
|||||||
(#f
|
(#f
|
||||||
(raise (condition (&gexp-input-error (input obj)))))
|
(raise (condition (&gexp-input-error (input obj)))))
|
||||||
(lower
|
(lower
|
||||||
(lower obj system target))))
|
;; Cache in STORE the result of lowering OBJ.
|
||||||
|
(mlet %store-monad ((graft? (grafting?)))
|
||||||
|
(mcached (let ((lower (lookup-compiler obj)))
|
||||||
|
(lower obj system target))
|
||||||
|
obj
|
||||||
|
system target graft?)))))
|
||||||
|
|
||||||
(define-syntax define-gexp-compiler
|
(define-syntax define-gexp-compiler
|
||||||
(syntax-rules (=> compiler expander)
|
(syntax-rules (=> compiler expander)
|
||||||
|
@ -40,7 +40,8 @@
|
|||||||
graft-derivation/shallow
|
graft-derivation/shallow
|
||||||
|
|
||||||
%graft?
|
%graft?
|
||||||
set-grafting))
|
set-grafting
|
||||||
|
grafting?))
|
||||||
|
|
||||||
(define-record-type* <graft> graft make-graft
|
(define-record-type* <graft> graft make-graft
|
||||||
graft?
|
graft?
|
||||||
@ -328,6 +329,11 @@ it otherwise. It returns the previous setting."
|
|||||||
(lambda (store)
|
(lambda (store)
|
||||||
(values (%graft? enable?) store)))
|
(values (%graft? enable?) store)))
|
||||||
|
|
||||||
|
(define (grafting?)
|
||||||
|
"Return a Boolean indicating whether grafting is enabled."
|
||||||
|
(lambda (store)
|
||||||
|
(values (%graft?) store)))
|
||||||
|
|
||||||
;; Local Variables:
|
;; Local Variables:
|
||||||
;; eval: (put 'with-cache 'scheme-indent-function 1)
|
;; eval: (put 'with-cache 'scheme-indent-function 1)
|
||||||
;; End:
|
;; End:
|
||||||
|
@ -23,6 +23,7 @@
|
|||||||
#:use-module (guix memoization)
|
#:use-module (guix memoization)
|
||||||
#:use-module (guix serialization)
|
#:use-module (guix serialization)
|
||||||
#:use-module (guix monads)
|
#:use-module (guix monads)
|
||||||
|
#:use-module (guix records)
|
||||||
#:use-module (guix base16)
|
#:use-module (guix base16)
|
||||||
#:use-module (guix base32)
|
#:use-module (guix base32)
|
||||||
#:use-module (gcrypt hash)
|
#:use-module (gcrypt hash)
|
||||||
@ -30,6 +31,7 @@
|
|||||||
#:autoload (guix build syscalls) (terminal-columns)
|
#:autoload (guix build syscalls) (terminal-columns)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (ice-9 binary-ports)
|
#:use-module (ice-9 binary-ports)
|
||||||
|
#:use-module ((ice-9 control) #:select (let/ec))
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (srfi srfi-9 gnu)
|
#:use-module (srfi srfi-9 gnu)
|
||||||
@ -55,6 +57,7 @@
|
|||||||
nix-server-minor-version
|
nix-server-minor-version
|
||||||
nix-server-socket
|
nix-server-socket
|
||||||
current-store-protocol-version ;for internal use
|
current-store-protocol-version ;for internal use
|
||||||
|
mcached
|
||||||
|
|
||||||
&nix-error nix-error?
|
&nix-error nix-error?
|
||||||
&nix-connection-error nix-connection-error?
|
&nix-connection-error nix-connection-error?
|
||||||
@ -332,10 +335,7 @@
|
|||||||
|
|
||||||
;; remote-store.cc
|
;; remote-store.cc
|
||||||
|
|
||||||
(define-record-type <nix-server>
|
(define-record-type* <nix-server> nix-server %make-nix-server
|
||||||
(%make-nix-server socket major minor
|
|
||||||
buffer flush
|
|
||||||
ats-cache atts-cache)
|
|
||||||
nix-server?
|
nix-server?
|
||||||
(socket nix-server-socket)
|
(socket nix-server-socket)
|
||||||
(major nix-server-major-version)
|
(major nix-server-major-version)
|
||||||
@ -348,7 +348,9 @@
|
|||||||
;; during the session are temporary GC roots kept for the duration of
|
;; during the session are temporary GC roots kept for the duration of
|
||||||
;; the session.
|
;; the session.
|
||||||
(ats-cache nix-server-add-to-store-cache)
|
(ats-cache nix-server-add-to-store-cache)
|
||||||
(atts-cache nix-server-add-text-to-store-cache))
|
(atts-cache nix-server-add-text-to-store-cache)
|
||||||
|
(object-cache nix-server-object-cache
|
||||||
|
(default vlist-null))) ;vhash
|
||||||
|
|
||||||
(set-record-type-printer! <nix-server>
|
(set-record-type-printer! <nix-server>
|
||||||
(lambda (obj port)
|
(lambda (obj port)
|
||||||
@ -523,7 +525,8 @@ for this connection will be pinned. Return a server object."
|
|||||||
(protocol-minor v)
|
(protocol-minor v)
|
||||||
output flush
|
output flush
|
||||||
(make-hash-table 100)
|
(make-hash-table 100)
|
||||||
(make-hash-table 100))))
|
(make-hash-table 100)
|
||||||
|
vlist-null)))
|
||||||
(let loop ((done? (process-stderr conn)))
|
(let loop ((done? (process-stderr conn)))
|
||||||
(or done? (process-stderr conn)))
|
(or done? (process-stderr conn)))
|
||||||
conn)))))))))
|
conn)))))))))
|
||||||
@ -543,7 +546,8 @@ connection. Use with care."
|
|||||||
(protocol-minor version)
|
(protocol-minor version)
|
||||||
output flush
|
output flush
|
||||||
(make-hash-table 100)
|
(make-hash-table 100)
|
||||||
(make-hash-table 100))))
|
(make-hash-table 100)
|
||||||
|
vlist-null)))
|
||||||
|
|
||||||
(define (nix-server-version store)
|
(define (nix-server-version store)
|
||||||
"Return the protocol version of STORE as an integer."
|
"Return the protocol version of STORE as an integer."
|
||||||
@ -1486,6 +1490,56 @@ This makes sense only when the daemon was started with '--cache-failures'."
|
|||||||
;; from %STATE-MONAD.
|
;; from %STATE-MONAD.
|
||||||
(template-directory instantiations %store-monad)
|
(template-directory instantiations %store-monad)
|
||||||
|
|
||||||
|
(define* (cache-object-mapping object keys result)
|
||||||
|
"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.
|
||||||
|
|
||||||
|
OBJECT is typically a high-level object such as a <package> or an <origin>,
|
||||||
|
and RESULT is typically its derivation."
|
||||||
|
(lambda (store)
|
||||||
|
(values result
|
||||||
|
(nix-server
|
||||||
|
(inherit store)
|
||||||
|
(object-cache (vhash-consq object (cons result keys)
|
||||||
|
(nix-server-object-cache store)))))))
|
||||||
|
|
||||||
|
(define* (lookup-cached-object object #:optional (keys '()))
|
||||||
|
"Return the cached object in the store connection corresponding to OBJECT
|
||||||
|
and KEYS. 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)
|
||||||
|
;; Escape as soon as we find the result. This avoids traversing the whole
|
||||||
|
;; vlist chain and significantly reduces the number of 'hashq' calls.
|
||||||
|
(values (let/ec return
|
||||||
|
(vhash-foldq* (lambda (item result)
|
||||||
|
(match item
|
||||||
|
((value . keys*)
|
||||||
|
(if (equal? keys keys*)
|
||||||
|
(return value)
|
||||||
|
result))))
|
||||||
|
#f object
|
||||||
|
(nix-server-object-cache store)))
|
||||||
|
store)))
|
||||||
|
|
||||||
|
(define* (%mcached mthunk object #:optional (keys '()))
|
||||||
|
"Bind the monadic value returned by MTHUNK, which supposedly corresponds to
|
||||||
|
OBJECT/KEYS, or return its cached value."
|
||||||
|
(mlet %store-monad ((cached (lookup-cached-object object keys)))
|
||||||
|
(if cached
|
||||||
|
(return cached)
|
||||||
|
(>>= (mthunk)
|
||||||
|
(lambda (result)
|
||||||
|
(cache-object-mapping object keys result))))))
|
||||||
|
|
||||||
|
(define-syntax-rule (mcached mvalue object keys ...)
|
||||||
|
"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."
|
||||||
|
(%mcached (lambda () mvalue)
|
||||||
|
object (list keys ...)))
|
||||||
|
|
||||||
(define (preserve-documentation original proc)
|
(define (preserve-documentation original proc)
|
||||||
"Return PROC with documentation taken from ORIGINAL."
|
"Return PROC with documentation taken from ORIGINAL."
|
||||||
(set-object-property! proc 'documentation
|
(set-object-property! proc 'documentation
|
||||||
|
Loading…
Reference in New Issue
Block a user