diff options
| -rw-r--r-- | guix/store.scm | 67 |
1 files changed, 54 insertions, 13 deletions
diff --git a/guix/store.scm b/guix/store.scm index 1d176fb99d..220901f6ce 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de> @@ -1793,6 +1793,14 @@ This makes sense only when the daemon was started with '--cache-failures'." ;; the 'caches' vector of <store-connection>. (define %store-connection-caches (make-atomic-box 0)) +(define %max-store-connection-caches + ;; Maximum number of caches returned by 'allocate-store-connection-cache'. + 32) + +(define %store-connection-cache-names + ;; Mapping of cache ID to symbol. + (make-vector %max-store-connection-caches)) + (define (allocate-store-connection-cache name) "Allocate a new cache for store connections and return its identifier. Said identifier can be passed as an argument to " @@ -1800,7 +1808,9 @@ identifier can be passed as an argument to " (let ((previous (atomic-box-compare-and-swap! %store-connection-caches current (+ current 1)))) (if (= previous current) - current + (begin + (vector-set! %store-connection-cache-names current name) + current) (loop current))))) (define %object-cache-id @@ -1926,16 +1936,37 @@ whether the cache lookup was a hit, and the actual cache (a vhash)." (lambda (x y) #t))) -(define record-cache-lookup! - (cache-lookup-recorder "object-cache" "Store object cache")) - -(define-inlinable (lookup-cached-object object keys vhash-fold*) - "Return the cached object in the store connection corresponding to OBJECT +(define recorder-for-cache + (let ((recorders (make-vector %max-store-connection-caches))) + (lambda (cache-id) + "Return a procedure to record lookup stats for CACHE-ID." + (match (vector-ref recorders cache-id) + ((? unspecified?) + (let* ((name (symbol->string + (vector-ref %store-connection-cache-names cache-id))) + (description + (string-titlecase + (string-map (match-lambda + (#\- #\space) + (chr chr)) + name)))) + (let ((proc (cache-lookup-recorder name description))) + (vector-set! recorders cache-id proc) + proc))) + (proc proc))))) + +(define (record-cache-lookup! cache-id value cache) + "Record the lookup of VALUE in CACHE-ID, whose current value is CACHE." + (let ((record! (recorder-for-cache cache-id))) + (record! value cache))) + +(define-inlinable (lookup-cached-object cache-id object keys vhash-fold*) + "Return the object in store cache CACHE-ID corresponding to OBJECT and KEYS; use VHASH-FOLD* to look for OBJECT in the cache. KEYS is a list of additional keys to match against, and which are compared with 'equal?'. Return #f on failure and the cached result otherwise." (lambda (store) - (let* ((cache (store-connection-cache store %object-cache-id)) + (let* ((cache (store-connection-cache store cache-id)) ;; Escape as soon as we find the result. This avoids traversing ;; the whole vlist chain and significantly reduces the number of @@ -1949,40 +1980,50 @@ Return #f on failure and the cached result otherwise." result)))) #f object cache)))) - (record-cache-lookup! value cache) + (record-cache-lookup! cache-id value cache) (values value store)))) (define* (%mcached mthunk object #:optional (keys '()) #:key + (cache %object-cache-id) (vhash-cons vhash-consq) (vhash-fold* vhash-foldq*)) "Bind the monadic value returned by MTHUNK, which supposedly corresponds to OBJECT/KEYS, or return its cached value. Use VHASH-CONS to insert OBJECT into the cache, and VHASH-FOLD* to look it up." - (mlet %store-monad ((cached (lookup-cached-object object keys + (mlet %store-monad ((cached (lookup-cached-object cache object keys vhash-fold*))) (if cached (return cached) (>>= (mthunk) (lambda (result) (cache-object-mapping object keys result + #:cache cache #:vhash-cons vhash-cons)))))) (define-syntax mcached - (syntax-rules (eq? equal?) + (syntax-rules (eq? equal? =>) "Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the value associated with OBJECT/KEYS in the store's object cache if there is one." - ((_ eq? mvalue object keys ...) + ((_ eq? (=> cache) mvalue object keys ...) (%mcached (lambda () mvalue) object (list keys ...) + #:cache cache #:vhash-cons vhash-consq #:vhash-fold* vhash-foldq*)) - ((_ equal? mvalue object keys ...) + ((_ equal? (=> cache) mvalue object keys ...) (%mcached (lambda () mvalue) object (list keys ...) + #:cache cache #:vhash-cons vhash-cons #:vhash-fold* vhash-fold*)) + ((_ eq? mvalue object keys ...) + (mcached eq? (=> %object-cache-id) + mvalue object keys ...)) + ((_ equal? mvalue object keys ...) + (mcached equal? (=> %object-cache-id) + mvalue object keys ...)) ((_ mvalue object keys ...) (mcached eq? mvalue object keys ...)))) |