futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

store: Allow objects in the cache to be inserted and search for with 'equal?'.

Browse Source 
* guix/store.scm (cache-object-mapping): Add #:vhash-cons parameter and
honor it.
(lookup-cached-object): Add #:vhash-fold* parameter and honor it.
(%mcached): Add #:vhash-fold* and #:vhash-cons and honor them.
(mcached): Add clauses with 'eq?' and 'equal?' as the first argument.
This commit is contained in:
Ludovic Courtès 2019-10-27 19:08:15 +01:00
parent f58b45350b
commit c57e417eff
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 43 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
guix/store.scm
View File

@ -1612,10 +1612,11 @@ This makes sense only when the daemon was started with '--cache-failures'."
;; from %STATE-MONAD.
(template-directory instantiations %store-monad)
(define* (cache-object-mapping object keys result)
(define* (cache-object-mapping object keys result
#:key (vhash-cons vhash-consq))
"Augment the store's object cache with a mapping from OBJECT/KEYS to RESULT.
KEYS is a list of additional keys to match against, for instance a (SYSTEM
TARGET) tuple.
TARGET) tuple. Use VHASH-CONS to insert OBJECT into the cache.
OBJECT is typically a high-level object such as a <package> or an <origin>,
and RESULT is typically its derivation."
@ -1623,8 +1624,8 @@ and RESULT is typically its derivation."
(values result
(store-connection
(inherit store)
(object-cache (vhash-consq object (cons result keys)
(store-connection-object-cache store)))))))
(object-cache (vhash-cons object (cons result keys)
(store-connection-object-cache store)))))))
(define record-cache-lookup!
(if (profiled? "object-cache")
@ -1653,11 +1654,12 @@ and RESULT is typically its derivation."
(lambda (x y)
#t)))
(define* (lookup-cached-object object #:optional (keys '()))
(define* (lookup-cached-object object #:optional (keys '())
#:key (vhash-fold* vhash-foldq*))
"Return the cached object in the store connection corresponding to OBJECT
and KEYS. 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."
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-object-cache store))
@ -1665,33 +1667,50 @@ otherwise."
;; the whole vlist chain and significantly reduces the number of
;; 'hashq' calls.
(value (let/ec return
(vhash-foldq* (lambda (item result)
(match item
((value . keys*)
(if (equal? keys keys*)
(return value)
result))))
#f object
cache))))
(vhash-fold* (lambda (item result)
(match item
((value . keys*)
(if (equal? keys keys*)
(return value)
result))))
#f object
cache))))
(record-cache-lookup! value cache)
(values value store))))
(define* (%mcached mthunk object #:optional (keys '()))
(define* (%mcached mthunk object #:optional (keys '())
#:key
(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."
(mlet %store-monad ((cached (lookup-cached-object object keys)))
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
#:vhash-fold* vhash-fold*)))
(if cached
(return cached)
(>>= (mthunk)
(lambda (result)
(cache-object-mapping object keys result))))))
(cache-object-mapping object keys result
#:vhash-cons vhash-cons))))))
(define-syntax-rule (mcached mvalue object keys ...)
"Run MVALUE, which corresponds to OBJECT/KEYS, and cache it; or return the
(define-syntax mcached
(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."
(%mcached (lambda () mvalue)
object (list keys ...)))
((_ eq? mvalue object keys ...)
(%mcached (lambda () mvalue)
object (list keys ...)
#:vhash-cons vhash-consq
#:vhash-fold* vhash-foldq*))
((_ equal? mvalue object keys ...)
(%mcached (lambda () mvalue)
object (list keys ...)
#:vhash-cons vhash-cons
#:vhash-fold* vhash-fold*))
((_ mvalue object keys ...)
(mcached eq? mvalue object keys ...))))
(define (preserve-documentation original proc)
"Return PROC with documentation taken from ORIGINAL."