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) | |
20 | #:export (memoize | |
21 | mlambda | |
22 | mlambdaq)) | |
23 | ||
24 | (define-syntax-rule (call/mv thunk) | |
25 | (call-with-values thunk list)) | |
26 | (define-syntax-rule (return/mv lst) | |
27 | (apply values lst)) | |
28 | ||
29 | (define-syntax-rule (call/1 thunk) | |
30 | (thunk)) | |
31 | (define-syntax-rule (return/1 value) | |
32 | value) | |
33 | ||
f9704f17 LC |
34 | (define-syntax define-cache-procedure |
35 | (syntax-rules () | |
36 | "Define a procedure NAME that implements a cache using HASH-REF and | |
37 | HASH-SET!. Use CALL to invoke the thunk and RETURN to return its value; CALL | |
38 | and RETURN are used to distinguish between multiple-value and single-value | |
39 | returns." | |
40 | ((_ name hash-ref hash-set! call return) | |
146db52a LC |
41 | (define name |
42 | (let ((%nothing '(this is nothing))) | |
43 | (lambda (cache key thunk) | |
44 | "Cache the result of THUNK under KEY in CACHE, or return the | |
f9704f17 | 45 | already-cached result." |
146db52a LC |
46 | (let ((results (hash-ref cache key %nothing))) |
47 | (if (eq? results %nothing) | |
48 | (let ((results (call thunk))) | |
49 | (hash-set! cache key results) | |
50 | (return results)) | |
51 | (return results))))))) | |
f9704f17 LC |
52 | ((_ name hash-ref hash-set!) |
53 | (define-cache-procedure name hash-ref hash-set! | |
54 | call/mv return/mv)))) | |
55 | ||
56 | (define-cache-procedure cached/mv hash-ref hash-set!) | |
57 | (define-cache-procedure cachedq/mv hashq-ref hashq-set!) | |
58 | (define-cache-procedure cached hash-ref hash-set! call/1 return/1) | |
59 | (define-cache-procedure cachedq hashq-ref hashq-set! call/1 return/1) | |
60 | ||
61 | (define (memoize proc) | |
62 | "Return a memoizing version of PROC. | |
63 | ||
64 | This is a generic version of 'mlambda' what works regardless of the arity of | |
65 | 'proc'. It is more expensive since the argument list is always allocated, and | |
66 | the result is returned via (apply values results)." | |
67 | (let ((cache (make-hash-table))) | |
68 | (lambda args | |
69 | (cached/mv cache args | |
70 | (lambda () | |
71 | (apply proc args)))))) | |
72 | ||
73 | (define-syntax %mlambda | |
74 | (syntax-rules () | |
75 | "Return a memoizing lambda. This is restricted to procedures that return | |
76 | exactly one value." | |
77 | ((_ cached () body ...) | |
78 | ;; The zero-argument case is equivalent to a promise. | |
e3c83a7c LC |
79 | (let ((result #f) (cached? #f) |
80 | (compute (lambda () body ...))) | |
f9704f17 LC |
81 | (lambda () |
82 | (unless cached? | |
e3c83a7c | 83 | (set! result (compute)) |
f9704f17 LC |
84 | (set! cached? #t)) |
85 | result))) | |
86 | ||
87 | ;; Optimize the fixed-arity case such that there's no argument list | |
88 | ;; allocated. XXX: We can't really avoid the closure allocation since | |
89 | ;; Guile 2.0's compiler will always keep it. | |
90 | ((_ cached (arg) body ...) ;one argument | |
91 | (let ((cache (make-hash-table)) | |
92 | (proc (lambda (arg) body ...))) | |
93 | (lambda (arg) | |
94 | (cached cache arg (lambda () (proc arg)))))) | |
95 | ((_ _ (args ...) body ...) ;two or more arguments | |
96 | (let ((cache (make-hash-table)) | |
97 | (proc (lambda (args ...) body ...))) | |
98 | (lambda (args ...) | |
99 | ;; XXX: Always use 'cached', which uses 'equal?', to compare the | |
100 | ;; argument lists. | |
101 | (cached cache (list args ...) | |
102 | (lambda () | |
103 | (proc args ...)))))))) | |
104 | ||
105 | (define-syntax-rule (mlambda formals body ...) | |
106 | "Define a memoizing lambda. The lambda's arguments are compared with | |
107 | 'equal?', and BODY is expected to yield a single return value." | |
108 | (%mlambda cached formals body ...)) | |
109 | ||
110 | (define-syntax-rule (mlambdaq formals body ...) | |
111 | "Define a memoizing lambda. If FORMALS lists a single argument, it is | |
112 | compared using 'eq?'; otherwise, the argument list is compared using 'equal?'. | |
113 | BODY is expected to yield a single return value." | |
114 | (%mlambda cachedq formals body ...)) |