summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/store.scm32
-rw-r--r--guix/ui.scm9
2 files changed, 40 insertions, 1 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)
...
diff --git a/guix/ui.scm b/guix/ui.scm
index 56fcc00300..889c9d0228 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.