store: Support dynamic allocation of per-connection caches.

* guix/store.scm (<store-connection>)[object-cache]: Remove.
[caches]: New field.
(open-connection, port->connection): Adjust '%make-store-connection'
calls accordingly.
(%store-connection-caches, %object-cache-id): New variables.
(allocate-store-connection-cache, vector-set)
(store-connection-cache, set-store-connection-cache)
(set-store-connection-caches!, set-store-connection-cache!): New
procedures.
(cache-object-mapping): Add #:cache parameter.
(set-store-connection-object-cache!): Remove.
(lookup-cached-object): Use 'store-connection-cache'.
(run-with-store): Use 'store-connection-caches' and
'set-store-connection-caches!'.

1 files changed, 78 insertions, 16 deletions

diff --git a/guix/store.scm b/guix/store.scm
index cf5d5eeccc..897062efff 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -36,6 +36,7 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 binary-ports)
   #:use-module ((ice-9 control) #:select (let/ec))
+  #:use-module (ice-9 atomic)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
@@ -47,7 +48,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 popen)
-  #:use-module (ice-9 threads)
+  #:autoload   (ice-9 threads) (current-processor-count)
   #:use-module (ice-9 format)
   #:use-module (web uri)
   #:export (%daemon-socket-uri
@@ -87,6 +88,11 @@
             nix-protocol-error-message
             nix-protocol-error-status
 
+            allocate-store-connection-cache
+            store-connection-cache
+            set-store-connection-cache
+            set-store-connection-cache!
+
             hash-algo
             build-mode
 
@@ -383,8 +389,8 @@
   ;; the session.
   (ats-cache    store-connection-add-to-store-cache)
   (atts-cache   store-connection-add-text-to-store-cache)
-  (object-cache store-connection-object-cache
-                (default vlist-null))             ;vhash
+  (caches       store-connection-caches
+                (default '#()))                   ;vector
   (built-in-builders store-connection-built-in-builders
                      (default (delay '()))))      ;promise
 
@@ -586,6 +592,10 @@ for this connection will be pinned.  Return a server object."
             (write-int (if reserve-space? 1 0) port))
           (letrec* ((built-in-builders
                      (delay (%built-in-builders conn)))
+                    (caches
+                     (make-vector
+                      (atomic-box-ref %store-connection-caches)
+                      vlist-null))
                     (conn
                      (%make-store-connection port
                                              (protocol-major v)
@@ -593,7 +603,7 @@ for this connection will be pinned.  Return a server object."
                                              output flush
                                              (make-hash-table 100)
                                              (make-hash-table 100)
-                                             vlist-null
+                                             caches
                                              built-in-builders)))
             (let loop ((done? (process-stderr conn)))
               (or done? (process-stderr conn)))
@@ -616,7 +626,9 @@ connection.  Use with care."
                               output flush
                               (make-hash-table 100)
                               (make-hash-table 100)
-                              vlist-null
+                              (make-vector
+                               (atomic-box-ref %store-connection-caches)
+                               vlist-null)
                               (delay (%built-in-builders connection))))
 
     connection))
@@ -1801,6 +1813,57 @@ This makes sense only when the daemon was started with '--cache-failures'."
 
 
 ;;;
+;;; Per-connection caches.
+;;;
+
+;; Number of currently allocated store connection caches--things that go in
+;; the 'caches' vector of <store-connection>.
+(define %store-connection-caches (make-atomic-box 0))
+
+(define (allocate-store-connection-cache name)
+  "Allocate a new cache for store connections and return its identifier.  Said
+identifier can be passed as an argument to "
+  (let loop ((current (atomic-box-ref %store-connection-caches)))
+    (let ((previous (atomic-box-compare-and-swap! %store-connection-caches
+                                                  current (+ current 1))))
+      (if (= previous current)
+          current
+          (loop current)))))
+
+(define %object-cache-id
+  ;; The "object cache", mapping lowerable objects such as <package> records
+  ;; to derivations.
+  (allocate-store-connection-cache 'object-cache))
+
+(define (vector-set vector index value)
+  (let ((new (vector-copy vector)))
+    (vector-set! new index value)
+    new))
+
+(define (store-connection-cache store cache)
+  "Return the cache of STORE identified by CACHE, an identifier as returned by
+'allocate-store-connection-cache'."
+  (vector-ref (store-connection-caches store) cache))
+
+(define (set-store-connection-cache store cache value)
+  "Return a copy of STORE where CACHE has the given VALUE.  CACHE must be a
+value returned by 'allocate-store-connection-cache'."
+  (store-connection
+   (inherit store)
+   (caches (vector-set (store-connection-caches store) cache value))))
+
+(define set-store-connection-caches!              ;private
+  (record-modifier <store-connection> 'caches))
+
+(define (set-store-connection-cache! store cache value)
+  "Set STORE's CACHE to VALUE.
+
+This is a mutating version that should be avoided.  Prefer the functional
+'set-store-connection-cache' instead, together with using %STORE-MONAD."
+  (vector-set! (store-connection-caches store) cache value))
+
+
+;;;
 ;;; Store monad.
 ;;;
 
@@ -1819,7 +1882,9 @@ This makes sense only when the daemon was started with '--cache-failures'."
 (template-directory instantiations %store-monad)
 
 (define* (cache-object-mapping object keys result
-                               #:key (vhash-cons vhash-consq))
+                               #:key
+                               (cache %object-cache-id)
+                               (vhash-cons vhash-consq))
   "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.  Use VHASH-CONS to insert OBJECT into the cache.
@@ -1828,10 +1893,10 @@ OBJECT is typically a high-level object such as a <package> or an <origin>,
 and RESULT is typically its derivation."
   (lambda (store)
     (values result
-            (store-connection
-             (inherit store)
-             (object-cache (vhash-cons object (cons result keys)
-                                       (store-connection-object-cache store)))))))
+            (set-store-connection-cache
+             store cache
+             (vhash-cons object (cons result keys)
+                         (store-connection-cache store cache))))))
 
 (define record-cache-lookup!
   (if (profiled? "object-cache")
@@ -1871,7 +1936,7 @@ and KEYS; use VHASH-FOLD* to look for OBJECT in the cache.  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)
-    (let* ((cache (store-connection-object-cache store))
+    (let* ((cache (store-connection-cache store %object-cache-id))
 
            ;; Escape as soon as we find the result.  This avoids traversing
            ;; the whole vlist chain and significantly reduces the number of
@@ -2048,9 +2113,6 @@ the store."
   ;; when using 'gexp->derivation' and co.
   (make-parameter #f))
 
-(define set-store-connection-object-cache!
-  (record-modifier <store-connection> 'object-cache))
-
 (define* (run-with-store store mval
                          #:key
                          (guile-for-build (%guile-for-build))
@@ -2070,8 +2132,8 @@ connection, and return the result."
         (when (and store new-store)
           ;; Copy the object cache from NEW-STORE so we don't fully discard
           ;; the state.
-          (let ((cache (store-connection-object-cache new-store)))
-            (set-store-connection-object-cache! store cache)))
+          (let ((caches (store-connection-caches new-store)))
+            (set-store-connection-caches! store caches)))
         result))))