#:use-module (guix profiling)
#:use-module (ice-9 match)
#:autoload (srfi srfi-1) (count)
- #:export (memoize
+ #:use-module (srfi srfi-9)
+ #:export (invalidate-memoization!
+ memoize
mlambda
mlambdaq))
+;; Data type representation a memoization cache when profiling is on.
+(define-record-type <cache>
+ (make-cache table lookups hits)
+ cache?
+ (table cache-table)
+ (lookups cache-lookups set-cache-lookups!)
+ (hits cache-hits set-cache-hits!))
+
+(define-syntax-rule (define-lookup-procedure proc get)
+ "Define a lookup procedure PROC. When profiling is turned off, PROC is set
+to GET; when profiling is on, PROC is a wrapper around GET that keeps tracks
+of lookups and cache hits."
+ (define proc
+ (if (profiled? "memoization")
+ (lambda (cache key default)
+ (let ((result (get (cache-table cache) key default)))
+ (set-cache-lookups! cache (+ 1 (cache-lookups cache)))
+ (unless (eq? result default)
+ (set-cache-hits! cache (+ 1 (cache-hits cache))))
+ result))
+ get)))
+
+(define-syntax-rule (define-update-procedure proc put!)
+ "Define an update procedure PROC. When profiling is turned off, PROC is
+equal to PUT!; when profiling is on, PROC is a wrapper around PUT and unboxes
+the underlying hash table."
+ (define proc
+ (if (profiled? "memoization")
+ (lambda (cache key value)
+ (put! (cache-table cache) key value))
+ put!)))
+
+(define-lookup-procedure cache-ref hash-ref)
+(define-lookup-procedure cacheq-ref hashq-ref)
+(define-update-procedure cache-set! hash-set!)
+(define-update-procedure cacheq-set! hashq-set!)
+
(define-syntax-rule (call/mv thunk)
(call-with-values thunk list))
(define-syntax-rule (return/mv lst)
(define-cache-procedure name hash-ref hash-set!
call/mv return/mv))))
-(define-cache-procedure cached/mv hash-ref hash-set!)
-(define-cache-procedure cachedq/mv hashq-ref hashq-set!)
-(define-cache-procedure cached hash-ref hash-set! call/1 return/1)
-(define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1)
+(define-cache-procedure cached/mv cache-ref cache-set!)
+(define-cache-procedure cachedq/mv cacheq-ref cacheq-set!)
+(define-cache-procedure cached cache-ref cache-set! call/1 return/1)
+(define-cache-procedure cachedq cacheq-ref cacheq-set! call/1 return/1)
(define %memoization-tables
;; Map procedures to the underlying hash table.
(make-weak-key-hash-table))
(define %make-hash-table*
+ ;; When profiling is off, this is equivalent to 'make-hash-table'. When
+ ;; profiling is on, return a hash table wrapped in a <cache> object.
(if (profiled? "memoization")
(lambda (proc location)
- (let ((table (make-hash-table)))
+ (let ((cache (make-cache (make-hash-table) 0 0)))
(hashq-set! %memoization-tables proc
- (cons table location))
- table))
+ (cons cache location))
+ cache))
(lambda (proc location)
- (make-hash-table))))
+ (let ((table (make-hash-table)))
+ (hashq-set! %memoization-tables proc table)
+ table))))
(define-syntax-rule (make-hash-table* proc)
(%make-hash-table* proc (current-source-location)))
+(define (invalidate-memoization! proc)
+ "Invalidate the memoization cache of PROC."
+ (match (hashq-ref %memoization-tables proc)
+ ((? hash-table? table)
+ (hash-clear! table))
+ (((? cache? cache) . _)
+ (hash-clear! (cache-table cache)))))
+
(define* (show-memoization-tables #:optional (port (current-error-port)))
"Display to PORT statistics about the memoization tables."
- (define (table<? p1 p2)
+ (define (cache<? p1 p2)
(match p1
- ((table1 . _)
+ ((cache1 . _)
(match p2
- ((table2 . _)
- (< (hash-count (const #t) table1)
- (hash-count (const #t) table2)))))))
+ ((cache2 . _)
+ (< (hash-count (const #t) (cache-table cache1))
+ (hash-count (const #t) (cache-table cache2))))))))
- (define tables
+ (define caches
(hash-map->list (lambda (key value)
value)
%memoization-tables))
- (match (sort tables (negate table<?))
- (((tables . locations) ...)
+ (match (sort caches (negate cache<?))
+ (((caches . locations) ...)
(format port "Memoization: ~a tables, ~a non-empty~%"
- (length tables)
- (count (lambda (table)
- (> (hash-count (const #t) table) 0))
- tables))
- (for-each (lambda (table location)
- (let ((size (hash-count (const #t) table)))
+ (length caches)
+ (count (lambda (cache)
+ (> (hash-count (const #t) (cache-table cache)) 0))
+ caches))
+ (for-each (lambda (cache location)
+ (let ((size (hash-count (const #t) (cache-table cache))))
(unless (zero? size)
- (format port " ~a:~a:~a: \t~a entries~%"
+ (format port " ~a:~a:~a: \t~a entries, ~a lookups, ~a% hits~%"
(assq-ref location 'filename)
(and=> (assq-ref location 'line) 1+)
(assq-ref location 'column)
- size))))
- tables locations))))
+ size
+ (cache-lookups cache)
+ (inexact->exact
+ (round
+ (* 100. (/ (cache-hits cache)
+ (cache-lookups cache) 1.))))))))
+ caches locations))))
(register-profiling-hook! "memoization" show-memoization-tables)
HCoop / jackhill / guix / guix.git / blobdiff