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.

3 files changed, 74 insertions, 9 deletions

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 537875b6b7..f33fb198e4 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -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)
diff --git a/guix/grafts.scm b/guix/grafts.scm
index f303e925f1..01e245d8eb 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?
@@ -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:
diff --git a/guix/store.scm b/guix/store.scm
index b1bdbf3813..9dc651b26c 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -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