store: Add an RPC counter.

* guix/store.scm (%rpc-calls): New variable.
(show-rpc-profile, record-operation): New procedures.
(operation): Add call to 'record-operation'.
* guix/ui.scm (run-guix-command): Wrap COMMAND-MAIN in 'dynamic-wind'.
Run EXIT-HOOK.

1 files changed, 32 insertions, 0 deletions

diff --git a/guix/store.scm b/guix/store.scm
index ed588aae47..2acab6b1a3 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -718,6 +718,37 @@ encoding conversion errors."
     (let loop ((done? (process-stderr server)))
       (or done? (process-stderr server)))))
 
+(define %rpc-calls
+  ;; Mapping from RPC names (symbols) to invocation counts.
+  (make-hash-table))
+
+(define* (show-rpc-profile #:optional (port (current-error-port)))
+  "Write to PORT a summary of the RPCs that have been made."
+  (let ((profile (sort (hash-fold alist-cons '() %rpc-calls)
+                       (lambda (rpc1 rpc2)
+                         (< (cdr rpc1) (cdr rpc2))))))
+    (format port "Remote procedure call summary: ~a RPCs~%"
+            (match profile
+              (((names . counts) ...)
+               (reduce + 0 counts))))
+    (for-each (match-lambda
+                ((rpc . count)
+                 (format port "  ~30a ... ~5@a~%" rpc count)))
+              profile)))
+
+(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))))
+
 (define-syntax operation
   (syntax-rules ()
     "Define a client-side RPC stub for the given operation."
@@ -725,6 +756,7 @@ encoding conversion errors."
      (lambda (server arg ...)
        docstring
        (let ((s (nix-server-socket server)))
+         (record-operation 'name)
          (write-int (operation-id name) s)
          (write-arg type arg s)
          ...