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) | |
f9704f17 LC |
23 | #:export (memoize |
24 | mlambda | |
25 | mlambdaq)) | |
26 | ||
27 | (define-syntax-rule (call/mv thunk) | |
28 | (call-with-values thunk list)) | |
29 | (define-syntax-rule (return/mv lst) | |
30 | (apply values lst)) | |
31 | ||
32 | (define-syntax-rule (call/1 thunk) | |
33 | (thunk)) | |
34 | (define-syntax-rule (return/1 value) | |
35 | value) | |
36 | ||
f9704f17 LC |
37 | (define-syntax define-cache-procedure |
38 | (syntax-rules () | |
39 | "Define a procedure NAME that implements a cache using HASH-REF and | |
40 | HASH-SET!. Use CALL to invoke the thunk and RETURN to return its value; CALL | |
41 | and RETURN are used to distinguish between multiple-value and single-value | |
42 | returns." | |
43 | ((_ name hash-ref hash-set! call return) | |
146db52a LC |
44 | (define name |
45 | (let ((%nothing '(this is nothing))) | |
46 | (lambda (cache key thunk) | |
47 | "Cache the result of THUNK under KEY in CACHE, or return the | |
f9704f17 | 48 | already-cached result." |
146db52a LC |
49 | (let ((results (hash-ref cache key %nothing))) |
50 | (if (eq? results %nothing) | |
51 | (let ((results (call thunk))) | |
52 | (hash-set! cache key results) | |
53 | (return results)) | |
54 | (return results))))))) | |
f9704f17 LC |
55 | ((_ name hash-ref hash-set!) |
56 | (define-cache-procedure name hash-ref hash-set! | |
57 | call/mv return/mv)))) | |
58 | ||
59 | (define-cache-procedure cached/mv hash-ref hash-set!) | |
60 | (define-cache-procedure cachedq/mv hashq-ref hashq-set!) | |
61 | (define-cache-procedure cached hash-ref hash-set! call/1 return/1) | |
62 | (define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1) | |
63 | ||
252c4083 LC |
64 | (define %memoization-tables |
65 | ;; Map procedures to the underlying hash table. | |
66 | (make-weak-key-hash-table)) | |
67 | ||
68 | (define %make-hash-table* | |
69 | (if (profiled? "memoization") | |
70 | (lambda (proc location) | |
71 | (let ((table (make-hash-table))) | |
72 | (hashq-set! %memoization-tables proc | |
73 | (cons table location)) | |
74 | table)) | |
75 | (lambda (proc location) | |
76 | (make-hash-table)))) | |
77 | ||
78 | (define-syntax-rule (make-hash-table* proc) | |
79 | (%make-hash-table* proc (current-source-location))) | |
80 | ||
81 | (define* (show-memoization-tables #:optional (port (current-error-port))) | |
82 | "Display to PORT statistics about the memoization tables." | |
83 | (define (table<? p1 p2) | |
84 | (match p1 | |
85 | ((table1 . _) | |
86 | (match p2 | |
87 | ((table2 . _) | |
88 | (< (hash-count (const #t) table1) | |
89 | (hash-count (const #t) table2))))))) | |
90 | ||
91 | (define tables | |
92 | (hash-map->list (lambda (key value) | |
93 | value) | |
94 | %memoization-tables)) | |
95 | ||
96 | (match (sort tables (negate table<?)) | |
97 | (((tables . locations) ...) | |
98 | (format port "Memoization: ~a tables, ~a non-empty~%" | |
99 | (length tables) | |
100 | (count (lambda (table) | |
101 | (> (hash-count (const #t) table) 0)) | |
102 | tables)) | |
103 | (for-each (lambda (table location) | |
104 | (let ((size (hash-count (const #t) table))) | |
105 | (unless (zero? size) | |
106 | (format port " ~a:~a:~a: \t~a entries~%" | |
107 | (assq-ref location 'filename) | |
108 | (and=> (assq-ref location 'line) 1+) | |
109 | (assq-ref location 'column) | |
110 | size)))) | |
111 | tables locations)))) | |
112 | ||
113 | (register-profiling-hook! "memoization" show-memoization-tables) | |
114 | ||
f9704f17 LC |
115 | (define (memoize proc) |
116 | "Return a memoizing version of PROC. | |
117 | ||
118 | This is a generic version of 'mlambda' what works regardless of the arity of | |
119 | 'proc'. It is more expensive since the argument list is always allocated, and | |
120 | the result is returned via (apply values results)." | |
252c4083 LC |
121 | (letrec* ((mproc (lambda args |
122 | (cached/mv cache args | |
123 | (lambda () | |
124 | (apply proc args))))) | |
125 | (cache (make-hash-table* mproc))) | |
126 | mproc)) | |
f9704f17 LC |
127 | |
128 | (define-syntax %mlambda | |
129 | (syntax-rules () | |
130 | "Return a memoizing lambda. This is restricted to procedures that return | |
131 | exactly one value." | |
132 | ((_ cached () body ...) | |
133 | ;; The zero-argument case is equivalent to a promise. | |
e3c83a7c LC |
134 | (let ((result #f) (cached? #f) |
135 | (compute (lambda () body ...))) | |
f9704f17 LC |
136 | (lambda () |
137 | (unless cached? | |
e3c83a7c | 138 | (set! result (compute)) |
f9704f17 LC |
139 | (set! cached? #t)) |
140 | result))) | |
141 | ||
142 | ;; Optimize the fixed-arity case such that there's no argument list | |
143 | ;; allocated. XXX: We can't really avoid the closure allocation since | |
144 | ;; Guile 2.0's compiler will always keep it. | |
145 | ((_ cached (arg) body ...) ;one argument | |
252c4083 LC |
146 | (letrec* ((proc (lambda (arg) body ...)) |
147 | (mproc (lambda (arg) | |
148 | (cached cache arg (lambda () (proc arg))))) | |
149 | (cache (make-hash-table* mproc))) | |
150 | mproc)) | |
f9704f17 | 151 | ((_ _ (args ...) body ...) ;two or more arguments |
252c4083 LC |
152 | (letrec* ((proc (lambda (args ...) body ...)) |
153 | (mproc (lambda (args ...) | |
154 | ;; XXX: Always use 'cached', which uses 'equal?', to | |
155 | ;; compare the argument lists. | |
156 | (cached cache (list args ...) | |
157 | (lambda () | |
158 | (proc args ...))))) | |
159 | (cache (make-hash-table* mproc))) | |
160 | mproc)))) | |
f9704f17 LC |
161 | |
162 | (define-syntax-rule (mlambda formals body ...) | |
163 | "Define a memoizing lambda. The lambda's arguments are compared with | |
164 | 'equal?', and BODY is expected to yield a single return value." | |
165 | (%mlambda cached formals body ...)) | |
166 | ||
167 | (define-syntax-rule (mlambdaq formals body ...) | |
168 | "Define a memoizing lambda. If FORMALS lists a single argument, it is | |
169 | compared using 'eq?'; otherwise, the argument list is compared using 'equal?'. | |
170 | BODY is expected to yield a single return value." | |
171 | (%mlambda cachedq formals body ...)) |