15/16: store: Add 'GUIX_PROFILING' support for the object cache.

[Ludovic Courtès]

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

commit a61fb010dfb50961ccc8300dcb6993158a976f40
Author: Ludovic Courtès <address@hidden>
Date:   Wed Jun 28 10:13:45 2017 +0200

    store: Add 'GUIX_PROFILING' support for the object cache.
    
    * guix/store.scm (profiled?): New procedure.
    (record-operation): Use it.
    (record-cache-lookup!): New procedure.
    (lookup-cached-object): Use it.
---
 guix/store.scm | 77 +++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 55 insertions(+), 22 deletions(-)

diff --git a/guix/store.scm b/guix/store.scm
index e9ea906..1016cb5 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -773,6 +773,14 @@ bytevector) as its internal buffer, and a thunk to flush 
this output port."
                                           write #f #f flush)
           flush))
 
+(define profiled?
+  (let ((profiled
+         (or (and=> (getenv "GUIX_PROFILING") string-tokenize)
+             '())))
+    (lambda (component)
+      "Return true if COMPONENT profiling is active."
+      (member component profiled))))
+
 (define %rpc-calls
   ;; Mapping from RPC names (symbols) to invocation counts.
   (make-hash-table))
@@ -793,16 +801,14 @@ bytevector) as its internal buffer, and a thunk to flush 
this output port."
 
 (define record-operation
   ;; Optionally, increment the number of calls of the given RPC.
-  (let ((profiled (or (and=> (getenv "GUIX_PROFILING") string-tokenize)
-                      '())))
-    (if (member "rpc" profiled)
-        (begin
-          (add-hook! exit-hook show-rpc-profile)
-          (lambda (name)
-            (let ((count (or (hashq-ref %rpc-calls name) 0)))
-              (hashq-set! %rpc-calls name (+ count 1)))))
-        (lambda (_)
-          #t))))
+  (if (profiled? "rpc")
+      (begin
+        (add-hook! exit-hook show-rpc-profile)
+        (lambda (name)
+          (let ((count (or (hashq-ref %rpc-calls name) 0)))
+            (hashq-set! %rpc-calls name (+ count 1)))))
+      (lambda (_)
+        #t)))
 
 (define-syntax operation
   (syntax-rules ()
@@ -1357,24 +1363,51 @@ and RESULT is typically its derivation."
              (object-cache (vhash-consq object (cons result keys)
                                         (nix-server-object-cache store)))))))
 
+(define record-cache-lookup!
+  (if (profiled? "object-cache")
+      (let ((fresh    0)
+            (lookups  0)
+            (hits     0))
+        (add-hook! exit-hook
+                   (lambda ()
+                     (format (current-error-port) "Store object cache:
+  fresh caches: address@hidden
+  lookups:      address@hidden
+  hits:         address@hidden (~,1f%)~%"
+                             fresh lookups hits
+                             (* 100. (/ hits lookups)))))
+        (lambda (hit? cache)
+          (set! fresh
+            (if (eq? cache vlist-null)
+                (+ 1 fresh)
+                fresh))
+          (set! lookups (+ 1 lookups))
+          (set! hits (if hit? (+ hits 1) hits))))
+      (lambda (x y)
+        #t)))
+
 (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)))
+    (let* ((cache (nix-server-object-cache store))
+
+           ;; Escape as soon as we find the result.  This avoids traversing
+           ;; the whole vlist chain and significantly reduces the number of
+           ;; 'hashq' calls.
+           (value (let/ec return
+                    (vhash-foldq* (lambda (item result)
+                                    (match item
+                                      ((value . keys*)
+                                       (if (equal? keys keys*)
+                                           (return value)
+                                           result))))
+                                  #f object
+                                  cache))))
+      (record-cache-lookup! value cache)
+      (values value store))))
 
 (define* (%mcached mthunk object #:optional (keys '()))
   "Bind the monadic value returned by MTHUNK, which supposedly corresponds to