Am Montag, den 29.11.2010, 10:34 -0300 schrieb Stephen Eilert:
So it is not only "memoization", but a caching system. I was going to
> write something similar, to cache webservice responses.
>
That it is.
I've got several caches working with the attached code.
The API is kind of patterned after SRFI-69.
It tried however to hide that we're using hash tables, since that I
might want to experiment with.
If that fits approximately your needs I'd love to share the code. --
and get your comments (API suggestions anyone?).
(It's not yet available as an egg, though.)
Here's an example which hopefully explains how to use it.
(define *resync-cache*
(make-cache "*resync-cache*"
eq?
#f ;; state
;; miss:
(lambda (cs k) (cons k #f))
;; hit
#f ;; (lambda (c es) #t)
;; fulfil
(lambda (c es results)
(set-cdr! es (if (and (pair? results) (aggregate? (car
results)))
#f
(add-duration
*system-time*
(make-time
'time-duration 0
(or (respond-timeout-interval) 20)))))
(values))
;; valid?
(lambda (es)
(or (not (cdr es))
(srfi19:time<=? *system-time* (cdr es))))
;; delete
#f ;; (lambda (cs es) #f)
))
(cache-ref *resync-cache* oid
(lambda () (%find-frame-sync! oid #f context)))
(define-record-type <cache>
(%make-cache name mailbox t index state miss hit fulfil valid? delete)
cache?
(name cache-name)
(mailbox cache-mailbox)
(t cache-thread set-cache-thread!)
(index cache-index)
(state cache-state)
(miss cache-miss)
(hit cache-hit)
(fulfil cache-fulfil)
(valid? cache-valid?)
(delete cache-delete))
(define (default-hit-handler cache value-state) #f)
(define (default-fulfil-handler cache value-state values-or-false) #f)
(define (default-delete-handler cache-state value-state) #f)
(define (make-cache name eq state miss hit fulfil valid? delete)
(assert (procedure? miss))
(assert (procedure? valid?))
(%make-cache
name
(make-mailbox name) #f (make-hash-table eq)
state miss
(or hit default-hit-handler)
(or fulfil default-fulfil-handler)
valid?
(or delete default-delete-handler)))
(define-inline (check-cache! cache)
(or (cache-thread cache)
(set-cache-thread!
cache
(thread-start!
(make-thread
(lambda ()
(let loop ()
(guard
(ex (else (log-condition (cache-name cache) ex)
(loop)))
(let loop ((request (receive-message! (cache-mailbox cache))))
(send-message! (car request) (call-with-values (cdr request) list))
(loop (receive-message! (cache-mailbox cache)))))))
(dbgname (cache-name cache) "~a-table"))))))
(define (cache-size cache) (hash-table-size (cache-index cache)))
(define-inline (cache-lookup cache key)
(hash-table-ref/default (cache-index cache) key #f))
(define-inline (cache-lookup/default cache key default)
(hash-table-ref/default (cache-index cache) key default))
(define-record-type <cache-entry>
(make-cache-entry mutex avail value)
cache-entry?
(mutex cache-entry-mutex)
(avail cache-entry-avail)
(value cache-entry-value %set-entry-value!))
(define (set-entry-value! entry old new)
(with-mutex
(cache-entry-mutex entry)
(if (eq? old (cache-entry-value entry))
(begin
(%set-entry-value! entry new)
(condition-variable-broadcast! (cache-entry-avail entry))))))
(define-record-type <cache-value>
(make-cache-value state avail values thunk)
cache-value?
(state cache-value-state)
(avail cache-value-avail)
(values cache-value-values)
(thunk cache-value-thunk))
(define (with-cache-index cache thunk)
(check-cache! cache)
(let ((m (make-mailbox (cache-name cache))))
(send-message! (cache-mailbox cache) (cons m thunk))
(apply values (receive-message! m))))
(define (cache-find! cache key thunk)
(hash-table-ref
(cache-index cache) key
(lambda ()
(define entry (make-cache-entry
(make-mutex (dbgname key "~a-entry"))
(make-condition-variable key)
(make-cache-value
((cache-miss cache) (cache-state cache) key)
(make-mutex (dbgname key "~a-value"))
'() thunk)))
(hash-table-set! (cache-index cache) key entry)
entry)))
(define-inline (cache-find cache key thunk)
(hash-table-ref
(cache-index cache) key
(lambda ()
(with-cache-index cache (lambda () (cache-find! cache key thunk))))))
(define-inline (cache-value-fulfiled! cache entry values)
((cache-fulfil cache) cache (cache-value-state (cache-entry-value entry)) values))
;; Compute the value, run trigger and signal completion.
(define (cache-entry-force! cache key entry old)
(guard
(exception
(else (let ((new (make-cache-value
(cache-value-state old)
raise
(list (if (condition? exception) exception
(make-condition
&message 'message
(format "~a ~a ~a" key (cache-value-thunk old) exception))))
(cache-value-thunk old))))
(cache-value-fulfiled! cache entry #f)
(set-entry-value! entry old new)
new)))
(let ((new (call-with-values (cache-value-thunk old)
(lambda result
(make-cache-value
(cache-value-state old)
values result
(cache-value-thunk old))))))
(cache-value-fulfiled! cache entry (cache-value-values new))
(set-entry-value! entry old new)
new)))
;; Arrange to compute if needed the value and return it.
(define-inline (!cache-entry-force cache key entry)
(thread-start!
(make-thread
(lambda ()
(let* ((value (cache-entry-value entry))
(avail (cache-value-avail value)))
(if (and (mutex? avail) (not (mutex-owner avail)))
(with-mutex
avail
(if (mutex? (cache-value-avail value))
(cache-entry-force! cache key entry value))))))
(dbgname key "~a-ref"))))
;; Wait for computed value and return it.
(define (cache-entry-wait cache key entry)
(guard
(ex (else (if (eq? (mutex-state (cache-entry-mutex entry)) (current-thread))
(mutex-unlock! (cache-entry-mutex entry)))
(raise ex)))
(let loop ()
(mutex-lock! (cache-entry-mutex entry))
(let* ((value (cache-entry-value entry))
(avail (cache-value-avail value)))
(if (procedure? avail)
(begin
(mutex-unlock! (cache-entry-mutex entry))
(apply avail (cache-value-values value)))
(begin
(if (not (mutex-owner avail))
(!cache-entry-force cache key entry))
(mutex-unlock! (cache-entry-mutex entry) (cache-entry-avail entry))
(let* ((value (cache-entry-value entry))
(avail (cache-value-avail value)))
(if (procedure? avail)
(apply avail (cache-value-values value))
(loop)))))))))
(define-inline (cache-entry-ref cache key entry)
(let* ((value (cache-entry-value entry))
(avail (cache-value-avail value)))
(if (procedure? avail)
(if ((cache-valid? cache) (cache-value-state value))
(begin
((cache-hit cache) cache (cache-value-state value))
(apply avail (cache-value-values value)))
(begin
(with-mutex
(cache-entry-mutex entry)
(let* ((value (cache-entry-value entry))
(avail (cache-value-avail value)))
(if (and (procedure? avail)
((cache-valid? cache) (cache-value-state value)))
((cache-hit cache) cache (cache-value-state value))
(begin
((cache-delete cache) (cache-state cache) (cache-value-state value))
(%set-entry-value!
entry
(make-cache-value
((cache-miss cache) (cache-state cache) key)
(make-mutex (dbgname key "~a-value")) #f
(cache-value-thunk value)))))))
(cache-entry-wait cache key entry)))
(cache-entry-wait cache key entry))))
(define-inline (cache-entry-ref/default cache key entry default)
(let* ((value (cache-entry-value entry))
(avail (cache-value-avail value)))
(if (procedure? avail)
(if ((cache-valid? cache) (cache-value-state value))
(begin
((cache-hit cache) cache (cache-value-state value))
(apply avail (cache-value-values value)))
(with-mutex
(cache-entry-mutex entry)
(let* ((value (cache-entry-value entry))
(avail (cache-value-avail value)))
(if (and (procedure? avail)
((cache-valid? cache) (cache-value-state value)))
(begin
((cache-hit cache) cache (cache-value-state value))
(apply avail (cache-value-values value)))
(begin
((cache-delete cache) (cache-state cache) (cache-value-state value))
(%set-entry-value!
entry
(make-cache-value
((cache-miss cache) (cache-state cache) key)
(make-mutex (dbgname key "~a-value")) #f
(cache-value-thunk value)))
(!cache-entry-force cache key entry)
default)))))
(begin
(if (not (mutex-owner avail))
(!cache-entry-force cache key entry))
default))))
(define (cache-state-update! cache state proc)
(with-cache-index cache (lambda () (proc (cache-state cache) state))))
(define (raise-deleted-condition message)
(raise (make-condition &message 'message message)))
(define (cache-entry-delete! cache key entry0)
(receive
(entry old)
(with-cache-index
cache
(lambda ()
(let ((entry (hash-table-ref/default (cache-index cache) key #f)))
(if entry
(let ((value (cache-entry-value entry0)))
(if (eq? entry entry0)
(hash-table-delete! (cache-index cache) key))
((cache-delete cache) (cache-state cache) (cache-value-state value))
(values entry0 value))
(values #f #f)))))
(if entry (set-entry-value!
entry old
(make-cache-value
(cache-value-state old)
raise
(list (make-condition &message 'message
(format "~a[~a] deleted" (cache-name cache) key)))
(cache-value-thunk old))))))
(define (%cache-set! cache key job . res)
(let ((entry (cache-lookup cache key)))
(if entry
(let* ((value (cache-entry-value entry))
(new (make-cache-value
(cache-value-state value)
job res
(cache-value-thunk value))))
(with-mutex
(cache-entry-mutex entry)
(if (eq? value (cache-entry-value entry))
(begin
((cache-delete cache) (cache-state cache) (cache-value-state value))
(cache-value-fulfiled! cache entry
(and (eq? job values) (cache-value-values new)))
(%set-entry-value! entry new)
(condition-variable-broadcast! (cache-entry-avail entry))))))
(cache-find! cache key (lambda () (apply job res))))))
;; (cache-set! cache key . job+res)
;;
;; if (null? job+res): remove entry
;; if (null? (cdr job+res)):
;; (eq? (car job+res) #t): reset to last valid, unfulfiled last thunk
;; (procedure? (car job+res)): reset to valid, unfilfiled (car job+res)
;; else: set to (apply (car job+res) (cdr job+res))
(define (cache-set! cache key . job+res)
(cond
((null? job+res)
(and-let* ((entry (hash-table-ref/default (cache-index cache) key #f)))
;; (!apply cache-entry-delete! (list cache key entry))
(cache-entry-delete! cache key entry)))
((eq? (car job+res) #t) (cache-invalid! cache key))
((null? (cdr job+res)) (cache-invalid! cache key (car job+res)))
(else (!apply %cache-set! `(,cache ,key . ,job+res)))))
(define (cache-invalid/check! check cache key . thunk)
(let ((entry (cache-lookup cache key)))
(if (and entry (check entry))
(receive
(entry old new)
(with-cache-index
cache
(lambda ()
(let ((entry (cache-lookup cache key)))
(if (and entry (check entry))
(let ((old (cache-entry-value entry)))
((cache-delete cache) (cache-state cache) (cache-value-state old))
(values
entry old
(make-cache-value
((cache-miss cache) (cache-state cache) key)
(make-mutex (dbgname key "~a-value")) #f
(if (pair? thunk) (car thunk) (cache-value-thunk old)))))
(values #f #f #f)))))
(if entry (set-entry-value! entry old new))
entry)
(begin
(if (and (not entry) (pair? thunk))
(let ((entry (cache-find cache key (car thunk))))
(cache-entry-ref/default cache key entry #f)
entry)
entry)))))
;; (cache-invalid! cache key . thunk)
;;
;; Invalidate the cached values. If there's a running computation,
;; leave it running. If thunk is given, it's arranged to be called,
;; otherwise default is returned.
(define (cache-invalid! cache key . thunk)
(define (check entry)
(and-let* ((val (cache-entry-value entry))
(avail (cache-value-avail val))
((not (mutex? avail))))
((cache-valid? cache) (cache-value-state val))))
(apply cache-invalid/check! check cache key thunk))
;; (cache-invalid/abort! cache key . thunk)
;;
;; Invalidate the cached values and abort any running computation. If
;; thunk is given, it's arranged to be called, otherwise default is
;; returned.
(define (cache-invalid/abort! cache key . thunk)
(define (check entry)
(and-let* ((val (cache-entry-value entry))
(avail (cache-value-avail val)))
(or (mutex? avail)
((cache-valid? cache) (cache-value-state val)))))
(apply cache-invalid/check! check cache key thunk))
;; (cache-ref/default cache key thunk default)
;;
;; Returns current cached value or default. Does never wait. If
;; thunk is given, it's arranged to be called, otherwise default is
;; returned.
(define (cache-ref/default cache key thunk default)
(if thunk
(cache-entry-ref/default cache key (cache-find cache key thunk) default)
(let ((entry (cache-lookup cache key)))
(if entry (cache-entry-ref/default cache key entry default) default))))
;; (cache-ref cache key thunk . default)
;;
;; If default is given falls back to cache-ref/default. Otherwise
;; returns the last valid cached values. Always waits for valid
;; values, possibly arranging thunk to produce them.
(define (cache-ref cache key thunk . default)
(if (pair? default)
(cache-ref/default cache key thunk (car default))
(cache-entry-ref cache key (cache-find cache key thunk))))
(define (cache-reref cache key thunk)
(cache-entry-ref cache key (cache-invalid! cache key thunk)))
;; (cache-fold cache f nil)
;;
;; fold f(key value nil) over cache content
(define (cache-fold cache f nil)
(hash-table-fold (cache-index cache)
(lambda (k v nil)
(if (eq? (cache-value-avail (cache-entry-value v)) values)
(f k (car (cache-value-values (cache-entry-value v))) nil)
nil))
nil))
;; (cache-cleanup! cache [valid?] [used?])
;;
;; valid? : default: (cache-valid cache)
;; used? : no default; of cache result values arity.
;;
;; Remove all entries, which are not "valid?" and "used?" (if given).
;; Used is applied to the cached values.
(define (cache-cleanup! cache . predicates)
(let ((valid? (if (and (pair? predicates) (procedure? (car predicates)))
(car predicates) (cache-valid? cache)))
(used? (if (and (pair? predicates) (pair? (cdr predicates)))
(cadr predicates) #t))
(del (cache-delete cache)))
(for-each
(lambda (key+entry)
(define key (car key+entry))
(define entry (cdr key+entry))
;; This appears to be questionable. We first signal
;; the evaluation of an uncached thunk, maybe for no good reason -??-
;; then we remove the entry.
;; Questionable: there where pending references when forcing entries.
;; and no good explanation...
(define value (cache-entry-value entry))
(if (not (procedure? (cache-value-avail value)))
(set-entry-value!
entry value
(make-cache-value
(cache-value-state value)
raise
(list (make-condition
&message 'message
(format "~a[~a] deleted in cleanup" (cache-name cache) key)))
(cache-value-thunk value)))))
(with-cache-index
cache
(lambda ()
(let* ((index (cache-index cache))
(removable (hash-table-fold
index
(lambda (key entry init)
(if (let ((value (cache-entry-value entry)))
(or (mutex? (cache-value-avail value))
(and (valid? (cache-value-state value))
(or (eq? used? #t)
(apply used? (cache-value-values value))))))
init
(begin
(guard
(ex (else (log-condition (cache-name cache) ex)))
(del (cache-state cache) (cache-value-state (cache-entry-value entry))))
(cons (cons key entry) init))))
'())))
(for-each
(lambda (key+entry)
(hash-table-delete! (cache-index cache) (car key+entry)))
removable)
removable))))))
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
