[Top][All Lists]

[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: Ludovic Courtès
Subject: 07/08: store: Add a functional object cache and use it in 'lower-object'.
Date: Fri, 13 May 2016 21:49:50 +0000 (UTC)

civodul pushed a commit to branch wip-build-systems-gexp
in repository guix.

commit 186417e04df40edd5fcfbb26af1a0b928bfb7381
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 520bb26..396c38f 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -158,8 +158,12 @@ procedure to lower 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
-  (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-rule (define-gexp-compiler (name (param predicate)
                                                 system target)
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 6bec999..89ec1a6 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -40,7 +40,8 @@
-            set-grafting))
+            set-grafting
+            grafting?))
 (define-record-type* <graft> graft make-graft
@@ -301,4 +302,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 8d1099d..87181bf 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -21,6 +21,7 @@
   #:use-module (guix config)
   #: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)
@@ -45,6 +46,7 @@
+            mcached
             &nix-error nix-error?
             &nix-connection-error nix-connection-error?
@@ -306,9 +308,7 @@
-(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
   (socket nix-server-socket)
   (major  nix-server-major-version)
@@ -318,7 +318,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)
@@ -381,7 +383,8 @@ for this connection will be pinned.  Return a server 
                                                (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 s)))
                         (or done? (process-stderr s)))
@@ -1075,6 +1078,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
+  (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
+  (%mcached (lambda () mvalue)
+            object (list keys ...)))
 (define (preserve-documentation original proc)
   "Return PROC with documentation taken from ORIGINAL."
   (set-object-property! proc 'documentation

reply via email to

[Prev in Thread] Current Thread [Next in Thread]