[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
07/08: store: Add a functional object cache and use it in 'lower-object'
From: |
David Craven |
Subject: |
07/08: store: Add a functional object cache and use it in 'lower-object'. |
Date: |
Fri, 6 Jan 2017 11:16:03 +0000 (UTC) |
dvc pushed a commit to branch wip-build-systems-gexp
in repository guix.
commit a648d74417c535bccfcd577c4aa81a49c4f7ffa1
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 | 8 ++++++--
guix/grafts.scm | 8 +++++++-
guix/store.scm | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++-----
3 files changed, 67 insertions(+), 8 deletions(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 8e4581c..6b3cbc0 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -176,8 +176,12 @@ procedure to expand it; otherwise return #f."
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true.
OBJ must be an object that has an associated gexp compiler, such as a
<package>."
- (let ((lower (lookup-compiler obj)))
- (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 dda7c1d..444ea09 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?
@@ -333,4 +334,9 @@ 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)))
+
;;; grafts.scm ends here
diff --git a/guix/store.scm b/guix/store.scm
index 49549d0..cc67aee 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -22,6 +22,7 @@
#:use-module (guix combinators)
#:use-module (guix serialization)
#:use-module (guix monads)
+ #:use-module (guix records)
#:autoload (guix base32) (bytevector->base32-string)
#:autoload (guix build syscalls) (terminal-columns)
#:use-module (rnrs bytevectors)
@@ -46,6 +47,7 @@
nix-server-major-version
nix-server-minor-version
nix-server-socket
+ mcached
&nix-error nix-error?
&nix-connection-error nix-connection-error?
@@ -310,9 +312,7 @@
;; remote-store.cc
-(define-record-type <nix-server>
- (%make-nix-server socket major minor
- 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)
@@ -322,7 +322,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)
@@ -400,7 +402,8 @@ for this connection will be pinned. Return a server
object."
(protocol-major v)
(protocol-minor v)
(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)))))))))
@@ -1128,6 +1131,52 @@ be used internally by the daemon's build hook."
(define-alias store-return state-return)
(define-alias store-bind state-bind)
+(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 58fee7f), David Craven, 2017/01/06
- 03/08: gexp: Micro-optimize sexp serialization., David Craven, 2017/01/06
- 05/08: tests: Add 'test-assertm' to (guix tests)., David Craven, 2017/01/06
- 01/08: gnu: bootstrap: Move 'use-modules' forms to the beginning of build expressions., David Craven, 2017/01/06
- 04/08: monads: Micro-optimize 'foldm'., David Craven, 2017/01/06
- 06/08: packages: Turn 'bag->derivation' into a monadic procedure., David Craven, 2017/01/06
- 08/08: DRAFT gexp: Handle list conversion to <gexp-input> in the expanded code., David Craven, 2017/01/06
- 07/08: store: Add a functional object cache and use it in 'lower-object'.,
David Craven <=
- 02/08: build-system: Rewrite using gexps., David Craven, 2017/01/06