03/03: store: Add an RPC counter.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit f4453df9a5742ef47cad79254b33bfaa1ff15d24
Author: Ludovic Courtès <address@hidden>
Date:   Fri Jun 16 14:23:51 2017 +0200

    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.
---
 guix/store.scm | 32 ++++++++++++++++++++++++++++++++
 guix/ui.scm    |  9 ++++++++-
 2 files changed, 40 insertions(+), 1 deletion(-)

diff --git a/guix/store.scm b/guix/store.scm
index ed588aa..2acab6b 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 ... address@hidden" 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)
          ...
diff --git a/guix/ui.scm b/guix/ui.scm
index 56fcc00..889c9d0 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1318,7 +1318,14 @@ found."
     (parameterize ((program-name command))
       ;; Disable canonicalization so we don't don't stat unreasonably.
       (with-fluids ((%file-port-name-canonicalization #f))
-        (apply command-main args)))))
+        (dynamic-wind
+          (const #f)
+          (lambda ()
+            (apply command-main args))
+          (lambda ()
+            ;; Abuse 'exit-hook' (which is normally meant to be used by the
+            ;; REPL) to run things like profiling hooks upon completion.
+            (run-hook exit-hook)))))))
 
 (define (run-guix . args)
   "Run the 'guix' command defined by command line ARGS.