diff options
| -rw-r--r-- | guix/store.scm | 32 | ||||
| -rw-r--r-- | guix/ui.scm | 9 |
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. |