[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
06/11: store: Add a functional object cache and use it in 'lower-object'
From: |
Ludovic Courtès |
Subject: |
06/11: store: Add a functional object cache and use it in 'lower-object'. |
Date: |
Sun, 25 Jun 2017 16:12:15 -0400 (EDT) |
civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit 383d2e4ea053251519089ca854bf6b417a02db91
Author: Ludovic Courtès <address@hidden>
Date: Fri Nov 20 18:44:29 2015 +0100
store: Add a functional object cache and use it in 'lower-object'.
* 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.
---
guix/gexp.scm | 7 ++++++-
guix/grafts.scm | 8 +++++++-
guix/store.scm | 60 +++++++++++++++++++++++++++++++++++++++++++++++++++------
3 files changed, 67 insertions(+), 8 deletions(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index b22d7fb..c91c81d 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -199,7 +199,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)
diff --git a/guix/grafts.scm b/guix/grafts.scm
index d6b0e93..eac2368 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -40,7 +40,8 @@
graft-derivation/shallow
%graft?
- set-grafting))
+ set-grafting
+ grafting?))
(define-record-type* <graft> graft make-graft
graft?
@@ -335,6 +336,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:
diff --git a/guix/store.scm b/guix/store.scm
index b584caa..978ba5c 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -22,6 +22,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 (guix hash)
@@ -49,6 +50,7 @@
nix-server-major-version
nix-server-minor-version
nix-server-socket
+ mcached
&nix-error nix-error?
&nix-connection-error nix-connection-error?
@@ -320,10 +322,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)
@@ -336,7 +335,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)
@@ -509,7 +510,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)))))))))
@@ -1340,6 +1342,52 @@ be used internally by the daemon's build hook."
;; 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)
+ (values (vhash-foldq* (lambda (item result)
+ (match item
+ ((value . keys*)
+ (or result
+ (and (equal? keys keys*) value)))))
+ #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
- branch wip-build-systems-gexp created (now 0b64b8c), Ludovic Courtès, 2017/06/25
- 03/11: gexp: Micro-optimize sexp serialization., Ludovic Courtès, 2017/06/25
- 08/11: packages: Simplify patch instantiation., Ludovic Courtès, 2017/06/25
- 05/11: packages: Turn 'bag->derivation' into a monadic procedure., Ludovic Courtès, 2017/06/25
- 01/11: gnu: bootstrap: Move 'use-modules' forms to the beginning of build expressions., Ludovic Courtès, 2017/06/25
- 04/11: tests: Add 'test-assertm' to (guix tests)., Ludovic Courtès, 2017/06/25
- 09/11: Use 'mapm' instead of 'sequence' + 'map'., Ludovic Courtès, 2017/06/25
- 06/11: store: Add a functional object cache and use it in 'lower-object'.,
Ludovic Courtès <=
- 11/11: packages: Turn 'cache!' into a single-value-return cache., Ludovic Courtès, 2017/06/25
- 10/11: gexp: 'imported-files' takes file-like objects., Ludovic Courtès, 2017/06/25
- 07/11: DRAFT gexp: Handle list conversion to <gexp-input> in the expanded code., Ludovic Courtès, 2017/06/25
- 02/11: build-system: Rewrite using gexps., Ludovic Courtès, 2017/06/25