From d1f7748a2e41f2ca320eca56b366933b8aa1123c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 16 Apr 2019 11:46:17 +0200
Subject: [PATCH] store: Add "add-data-to-store-cache" profiling component.
* guix/store.scm (add-data-to-store): Define 'lookup' and use it instead
of 'hash-ref'.
---
guix/store.scm | 42 ++++++++++++++++++++++++++++++++++++++++--
1 file changed, 40 insertions(+), 2 deletions(-)
diff --git a/guix/store.scm b/guix/store.scm
index 9c195c335cd..1b485ab5faa 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -996,14 +996,52 @@ (define add-data-to-store
(operation (add-text-to-store (string name) (bytevector text)
(string-list references))
#f
- store-path)))
+ store-path))
+ (lookup (if (profiled? "add-data-to-store-cache")
+ (let ((lookups 0)
+ (hits 0)
+ (drv 0)
+ (scheme 0))
+ (define (show-stats)
+ (define (% n)
+ (if (zero? lookups)
+ 100.
+ (* 100. (/ n lookups))))
+
+ (format (current-error-port) "
+'add-data-to-store' cache:
+ lookups: ~5@a
+ hits: ~5@a (~,1f%)
+ .drv files: ~5@a (~,1f%)
+ Scheme files: ~5@a (~,1f%)~%"
+ lookups hits (% hits)
+ drv (% drv)
+ scheme (% scheme)))
+
+ (register-profiling-hook! "add-data-to-store-cache"
+ show-stats)
+ (lambda (cache args)
+ (let ((result (hash-ref cache args)))
+ (set! lookups (+ 1 lookups))
+ (when result
+ (set! hits (+ 1 hits)))
+ (match args
+ ((_ name _)
+ (cond ((string-suffix? ".drv" name)
+ (set! drv (+ drv 1)))
+ ((string-suffix? "-builder" name)
+ (set! scheme (+ scheme 1)))
+ ((string-suffix? ".scm" name)
+ (set! scheme (+ scheme 1))))))
+ result)))
+ hash-ref)))
(lambda* (server name bytes #:optional (references '()))
"Add BYTES under file NAME in the store, and return its store path.
REFERENCES is the list of store paths referred to by the resulting store
path."
(let* ((args `(,bytes ,name ,references))
(cache (store-connection-add-text-to-store-cache server)))
- (or (hash-ref cache args)
+ (or (lookup cache args)
(let ((path (add-text-to-store server name bytes references)))
(hash-set! cache args path)
path))))))
--
GitLab