futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

store: Add a functional object cache and use it in 'lower-object'.

Browse Source 
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:
Ludovic Courtès 2015-11-20 18:44:29 +01:00
parent 9ed86fe175
commit c6080c3249
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 74 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
guix/gexp.scm
View File

@ -211,7 +211,12 @@ OBJ must be an object that has an associated gexp compiler, such as a
(#f
(raise (condition (&gexp-input-error (input obj)))))
(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
(syntax-rules (=> compiler expander)

8
guix/grafts.scm
View File

@ -40,7 +40,8 @@
graft-derivation/shallow
%graft?
set-grafting))
set-grafting
grafting?))
(define-record-type* <graft> graft make-graft
graft?
@ -328,6 +329,11 @@ it otherwise. It returns the previous setting."
(lambda (store)
(values (%graft? enable?) store)))
(define (grafting?)
"Return a Boolean indicating whether grafting is enabled."
(lambda (store)
(values (%graft?) store)))
;; Local Variables:
;; eval: (put 'with-cache 'scheme-indent-function 1)
;; End:

68
guix/store.scm
View File

@ -23,6 +23,7 @@
#:use-module (guix memoization)
#:use-module (guix serialization)
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix base16)
#:use-module (guix base32)
#:use-module (gcrypt hash)
@ -30,6 +31,7 @@
#:autoload (guix build syscalls) (terminal-columns)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
#:use-module ((ice-9 control) #:select (let/ec))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
@ -55,6 +57,7 @@
nix-server-minor-version
nix-server-socket
current-store-protocol-version ;for internal use
mcached
&nix-error nix-error?
&nix-connection-error nix-connection-error?
@ -332,10 +335,7 @@
;; remote-store.cc
(define-record-type <nix-server>
(%make-nix-server socket major minor
buffer flush
ats-cache atts-cache)
(define-record-type* <nix-server> nix-server %make-nix-server
nix-server?
(socket nix-server-socket)
(major nix-server-major-version)
@ -348,7 +348,9 @@
;; during the session are temporary GC roots kept for the duration of
;; the session.
(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>
(lambda (obj port)
@ -523,7 +525,8 @@ for this connection will be pinned. Return a server object."
(protocol-minor v)
output flush
(make-hash-table 100)
(make-hash-table 100))))
(make-hash-table 100)
vlist-null)))
(let loop ((done? (process-stderr conn)))
(or done? (process-stderr conn)))
conn)))))))))
@ -543,7 +546,8 @@ connection. Use with care."
(protocol-minor version)
output flush
(make-hash-table 100)
(make-hash-table 100))))
(make-hash-table 100)
vlist-null)))
(define (nix-server-version store)
"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.
(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)
"Return PROC with documentation taken from ORIGINAL."
(set-object-property! proc 'documentation