Commit | Line | Data |
---|---|---|
f9704f17 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix memoization) | |
252c4083 LC |
20 | #:use-module (guix profiling) |
21 | #:use-module (ice-9 match) | |
22 | #:autoload (srfi srfi-1) (count) | |
6c80641d | 23 | #:use-module (srfi srfi-9) |
d1f01e48 LC |
24 | #:export (invalidate-memoization! |
25 | memoize | |
f9704f17 LC |
26 | mlambda |
27 | mlambdaq)) | |
28 | ||
6c80641d LC |
29 | ;; Data type representation a memoization cache when profiling is on. |
30 | (define-record-type <cache> | |
31 | (make-cache table lookups hits) | |
32 | cache? | |
33 | (table cache-table) | |
34 | (lookups cache-lookups set-cache-lookups!) | |
35 | (hits cache-hits set-cache-hits!)) | |
36 | ||
37 | (define-syntax-rule (define-lookup-procedure proc get) | |
38 | "Define a lookup procedure PROC. When profiling is turned off, PROC is set | |
39 | to GET; when profiling is on, PROC is a wrapper around GET that keeps tracks | |
40 | of lookups and cache hits." | |
41 | (define proc | |
42 | (if (profiled? "memoization") | |
43 | (lambda (cache key default) | |
44 | (let ((result (get (cache-table cache) key default))) | |
45 | (set-cache-lookups! cache (+ 1 (cache-lookups cache))) | |
46 | (unless (eq? result default) | |
47 | (set-cache-hits! cache (+ 1 (cache-hits cache)))) | |
48 | result)) | |
49 | get))) | |
50 | ||
51 | (define-syntax-rule (define-update-procedure proc put!) | |
52 | "Define an update procedure PROC. When profiling is turned off, PROC is | |
53 | equal to PUT!; when profiling is on, PROC is a wrapper around PUT and unboxes | |
54 | the underlying hash table." | |
55 | (define proc | |
56 | (if (profiled? "memoization") | |
57 | (lambda (cache key value) | |
58 | (put! (cache-table cache) key value)) | |
59 | put!))) | |
60 | ||
61 | (define-lookup-procedure cache-ref hash-ref) | |
62 | (define-lookup-procedure cacheq-ref hashq-ref) | |
63 | (define-update-procedure cache-set! hash-set!) | |
64 | (define-update-procedure cacheq-set! hashq-set!) | |
65 | ||
f9704f17 LC |
66 | (define-syntax-rule (call/mv thunk) |
67 | (call-with-values thunk list)) | |
68 | (define-syntax-rule (return/mv lst) | |
69 | (apply values lst)) | |
70 | ||
71 | (define-syntax-rule (call/1 thunk) | |
72 | (thunk)) | |
73 | (define-syntax-rule (return/1 value) | |
74 | value) | |
75 | ||
f9704f17 LC |
76 | (define-syntax define-cache-procedure |
77 | (syntax-rules () | |
78 | "Define a procedure NAME that implements a cache using HASH-REF and | |
79 | HASH-SET!. Use CALL to invoke the thunk and RETURN to return its value; CALL | |
80 | and RETURN are used to distinguish between multiple-value and single-value | |
81 | returns." | |
82 | ((_ name hash-ref hash-set! call return) | |
146db52a LC |
83 | (define name |
84 | (let ((%nothing '(this is nothing))) | |
85 | (lambda (cache key thunk) | |
86 | "Cache the result of THUNK under KEY in CACHE, or return the | |
f9704f17 | 87 | already-cached result." |
146db52a LC |
88 | (let ((results (hash-ref cache key %nothing))) |
89 | (if (eq? results %nothing) | |
90 | (let ((results (call thunk))) | |
91 | (hash-set! cache key results) | |
92 | (return results)) | |
93 | (return results))))))) | |
f9704f17 LC |
94 | ((_ name hash-ref hash-set!) |
95 | (define-cache-procedure name hash-ref hash-set! | |
96 | call/mv return/mv)))) | |
97 | ||
6c80641d LC |
98 | (define-cache-procedure cached/mv cache-ref cache-set!) |
99 | (define-cache-procedure cachedq/mv cacheq-ref cacheq-set!) | |
100 | (define-cache-procedure cached cache-ref cache-set! call/1 return/1) | |
101 | (define-cache-procedure cachedq cacheq-ref cacheq-set! call/1 return/1) | |
f9704f17 | 102 | |
252c4083 LC |
103 | (define %memoization-tables |
104 | ;; Map procedures to the underlying hash table. | |
105 | (make-weak-key-hash-table)) | |
106 | ||
107 | (define %make-hash-table* | |
6c80641d LC |
108 | ;; When profiling is off, this is equivalent to 'make-hash-table'. When |
109 | ;; profiling is on, return a hash table wrapped in a <cache> object. | |
252c4083 LC |
110 | (if (profiled? "memoization") |
111 | (lambda (proc location) | |
6c80641d | 112 | (let ((cache (make-cache (make-hash-table) 0 0))) |
252c4083 | 113 | (hashq-set! %memoization-tables proc |
6c80641d LC |
114 | (cons cache location)) |
115 | cache)) | |
252c4083 | 116 | (lambda (proc location) |
d1f01e48 LC |
117 | (let ((table (make-hash-table))) |
118 | (hashq-set! %memoization-tables proc table) | |
119 | table)))) | |
252c4083 LC |
120 | |
121 | (define-syntax-rule (make-hash-table* proc) | |
122 | (%make-hash-table* proc (current-source-location))) | |
123 | ||
d1f01e48 LC |
124 | (define (invalidate-memoization! proc) |
125 | "Invalidate the memoization cache of PROC." | |
126 | (match (hashq-ref %memoization-tables proc) | |
127 | ((? hash-table? table) | |
128 | (hash-clear! table)) | |
129 | (((? cache? cache) . _) | |
130 | (hash-clear! (cache-table cache))))) | |
131 | ||
252c4083 LC |
132 | (define* (show-memoization-tables #:optional (port (current-error-port))) |
133 | "Display to PORT statistics about the memoization tables." | |
6c80641d | 134 | (define (cache<? p1 p2) |
252c4083 | 135 | (match p1 |
6c80641d | 136 | ((cache1 . _) |
252c4083 | 137 | (match p2 |
6c80641d LC |
138 | ((cache2 . _) |
139 | (< (hash-count (const #t) (cache-table cache1)) | |
140 | (hash-count (const #t) (cache-table cache2)))))))) | |
252c4083 | 141 | |
6c80641d | 142 | (define caches |
252c4083 LC |
143 | (hash-map->list (lambda (key value) |
144 | value) | |
145 | %memoization-tables)) | |
146 | ||
6c80641d LC |
147 | (match (sort caches (negate cache<?)) |
148 | (((caches . locations) ...) | |
252c4083 | 149 | (format port "Memoization: ~a tables, ~a non-empty~%" |
6c80641d LC |
150 | (length caches) |
151 | (count (lambda (cache) | |
152 | (> (hash-count (const #t) (cache-table cache)) 0)) | |
153 | caches)) | |
154 | (for-each (lambda (cache location) | |
155 | (let ((size (hash-count (const #t) (cache-table cache)))) | |
252c4083 | 156 | (unless (zero? size) |
6c80641d | 157 | (format port " ~a:~a:~a: \t~a entries, ~a lookups, ~a% hits~%" |
252c4083 LC |
158 | (assq-ref location 'filename) |
159 | (and=> (assq-ref location 'line) 1+) | |
160 | (assq-ref location 'column) | |
6c80641d LC |
161 | size |
162 | (cache-lookups cache) | |
163 | (inexact->exact | |
164 | (round | |
165 | (* 100. (/ (cache-hits cache) | |
166 | (cache-lookups cache) 1.)))))))) | |
167 | caches locations)))) | |
252c4083 LC |
168 | |
169 | (register-profiling-hook! "memoization" show-memoization-tables) | |
170 | ||
f9704f17 LC |
171 | (define (memoize proc) |
172 | "Return a memoizing version of PROC. | |
173 | ||
174 | This is a generic version of 'mlambda' what works regardless of the arity of | |
175 | 'proc'. It is more expensive since the argument list is always allocated, and | |
176 | the result is returned via (apply values results)." | |
252c4083 LC |
177 | (letrec* ((mproc (lambda args |
178 | (cached/mv cache args | |
179 | (lambda () | |
180 | (apply proc args))))) | |
181 | (cache (make-hash-table* mproc))) | |
182 | mproc)) | |
f9704f17 LC |
183 | |
184 | (define-syntax %mlambda | |
185 | (syntax-rules () | |
186 | "Return a memoizing lambda. This is restricted to procedures that return | |
187 | exactly one value." | |
188 | ((_ cached () body ...) | |
189 | ;; The zero-argument case is equivalent to a promise. | |
e3c83a7c LC |
190 | (let ((result #f) (cached? #f) |
191 | (compute (lambda () body ...))) | |
f9704f17 LC |
192 | (lambda () |
193 | (unless cached? | |
e3c83a7c | 194 | (set! result (compute)) |
f9704f17 LC |
195 | (set! cached? #t)) |
196 | result))) | |
197 | ||
198 | ;; Optimize the fixed-arity case such that there's no argument list | |
199 | ;; allocated. XXX: We can't really avoid the closure allocation since | |
200 | ;; Guile 2.0's compiler will always keep it. | |
201 | ((_ cached (arg) body ...) ;one argument | |
252c4083 LC |
202 | (letrec* ((proc (lambda (arg) body ...)) |
203 | (mproc (lambda (arg) | |
204 | (cached cache arg (lambda () (proc arg))))) | |
205 | (cache (make-hash-table* mproc))) | |
206 | mproc)) | |
f9704f17 | 207 | ((_ _ (args ...) body ...) ;two or more arguments |
252c4083 LC |
208 | (letrec* ((proc (lambda (args ...) body ...)) |
209 | (mproc (lambda (args ...) | |
210 | ;; XXX: Always use 'cached', which uses 'equal?', to | |
211 | ;; compare the argument lists. | |
212 | (cached cache (list args ...) | |
213 | (lambda () | |
214 | (proc args ...))))) | |
215 | (cache (make-hash-table* mproc))) | |
216 | mproc)))) | |
f9704f17 LC |
217 | |
218 | (define-syntax-rule (mlambda formals body ...) | |
219 | "Define a memoizing lambda. The lambda's arguments are compared with | |
220 | 'equal?', and BODY is expected to yield a single return value." | |
221 | (%mlambda cached formals body ...)) | |
222 | ||
223 | (define-syntax-rule (mlambdaq formals body ...) | |
224 | "Define a memoizing lambda. If FORMALS lists a single argument, it is | |
225 | compared using 'eq?'; otherwise, the argument list is compared using 'equal?'. | |
226 | BODY is expected to yield a single return value." | |
227 | (%mlambda cachedq formals body ...)) |