Commit | Line | Data |
---|---|---|
583a23bf | 1 | ;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012, 2015 Free Software Foundation, Inc. |
327d4dd3 | 2 | ;;;; |
73be1d9e MV |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 6 | ;;;; version 3 of the License, or (at your option) any later version. |
73be1d9e MV |
7 | ;;;; |
8 | ;;;; This library is distributed in the hope that it will be useful, | |
14f1d9fe | 9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | ;;;; Lesser General Public License for more details. | |
12 | ;;;; | |
13 | ;;;; You should have received a copy of the GNU Lesser General Public | |
14 | ;;;; License along with this library; if not, write to the Free Software | |
92205699 | 15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
327d4dd3 | 16 | ;;;; |
14f1d9fe MD |
17 | \f |
18 | ||
4631414e AW |
19 | ;; There are circularities here; you can't import (oop goops compile) |
20 | ;; before (oop goops). So when compiling, make sure that things are | |
21 | ;; kosher. | |
f6ddf827 | 22 | (eval-when (expand) (resolve-module '(oop goops))) |
4631414e | 23 | |
14f1d9fe | 24 | (define-module (oop goops dispatch) |
5bdea5bd AW |
25 | #:use-module (oop goops) |
26 | #:use-module (oop goops util) | |
f3b312a1 | 27 | #:use-module (system base target) |
5bdea5bd AW |
28 | #:export (memoize-method!) |
29 | #:no-backtrace) | |
30 | ||
14f1d9fe | 31 | |
cfe55d3e AW |
32 | (define *dispatch-module* (current-module)) |
33 | ||
34 | ;;; | |
35 | ;;; Generic functions have an applicable-methods cache associated with | |
36 | ;;; them. Every distinct set of types that is dispatched through a | |
37 | ;;; generic adds an entry to the cache. This cache gets compiled out to | |
38 | ;;; a dispatch procedure. In steady-state, this dispatch procedure is | |
39 | ;;; never recompiled; but during warm-up there is some churn, both to | |
40 | ;;; the cache and to the dispatch procedure. | |
41 | ;;; | |
42 | ;;; So what is the deal if warm-up happens in a multithreaded context? | |
43 | ;;; There is indeed a window between missing the cache for a certain set | |
44 | ;;; of arguments, and then updating the cache with the newly computed | |
45 | ;;; applicable methods. One of the updaters is liable to lose their new | |
46 | ;;; entry. | |
47 | ;;; | |
48 | ;;; This is actually OK though, because a subsequent cache miss for the | |
49 | ;;; race loser will just cause memoization to try again. The cache will | |
50 | ;;; eventually be consistent. We're not mutating the old part of the | |
51 | ;;; cache, just consing on the new entry. | |
52 | ;;; | |
53 | ;;; It doesn't even matter if the dispatch procedure and the cache are | |
54 | ;;; inconsistent -- most likely the type-set that lost the dispatch | |
55 | ;;; procedure race will simply re-trigger a memoization, but since the | |
56 | ;;; winner isn't in the effective-methods cache, it will likely also | |
57 | ;;; re-trigger a memoization, and the cache will finally be consistent. | |
58 | ;;; As you can see there is a possibility for ping-pong effects, but | |
59 | ;;; it's unlikely given the shortness of the window between slot-set! | |
60 | ;;; invocations. We could add a mutex, but it is strictly unnecessary, | |
61 | ;;; and would add runtime cost and complexity. | |
62 | ;;; | |
63 | ||
64 | (define (emit-linear-dispatch gf-sym nargs methods free rest?) | |
65 | (define (gen-syms n stem) | |
66 | (let lp ((n (1- n)) (syms '())) | |
67 | (if (< n 0) | |
68 | syms | |
69 | (lp (1- n) (cons (gensym stem) syms))))) | |
70 | (let* ((args (gen-syms nargs "a")) | |
71 | (types (gen-syms nargs "t"))) | |
72 | (let lp ((methods methods) | |
73 | (free free) | |
74 | (exp `(cache-miss ,gf-sym | |
2f652c68 AW |
75 | ,(if rest? |
76 | `(cons* ,@args rest) | |
77 | `(list ,@args))))) | |
cfe55d3e AW |
78 | (cond |
79 | ((null? methods) | |
80 | (values `(,(if rest? `(,@args . rest) args) | |
81 | (let ,(map (lambda (t a) | |
82 | `(,t (class-of ,a))) | |
83 | types args) | |
84 | ,exp)) | |
85 | free)) | |
86 | (else | |
87 | ;; jeez | |
88 | (let preddy ((free free) | |
89 | (types types) | |
90 | (specs (vector-ref (car methods) 1)) | |
91 | (checks '())) | |
92 | (if (null? types) | |
93 | (let ((m-sym (gensym "p"))) | |
94 | (lp (cdr methods) | |
95 | (acons (vector-ref (car methods) 3) | |
96 | m-sym | |
97 | free) | |
98 | `(if (and . ,checks) | |
99 | ,(if rest? | |
100 | `(apply ,m-sym ,@args rest) | |
101 | `(,m-sym . ,args)) | |
102 | ,exp))) | |
103 | (let ((var (assq-ref free (car specs)))) | |
104 | (if var | |
105 | (preddy free | |
106 | (cdr types) | |
107 | (cdr specs) | |
108 | (cons `(eq? ,(car types) ,var) | |
109 | checks)) | |
110 | (let ((var (gensym "c"))) | |
111 | (preddy (acons (car specs) var free) | |
112 | (cdr types) | |
113 | (cdr specs) | |
114 | (cons `(eq? ,(car types) ,var) | |
115 | checks)))))))))))) | |
116 | ||
117 | (define (compute-dispatch-procedure gf cache) | |
118 | (define (scan) | |
119 | (let lp ((ls cache) (nreq -1) (nrest -1)) | |
120 | (cond | |
121 | ((null? ls) | |
122 | (collate (make-vector (1+ nreq) '()) | |
123 | (make-vector (1+ nrest) '()))) | |
124 | ((vector-ref (car ls) 2) ; rest | |
125 | (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0)))) | |
126 | (else ; req | |
127 | (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest))))) | |
128 | (define (collate req rest) | |
129 | (let lp ((ls cache)) | |
130 | (cond | |
131 | ((null? ls) | |
132 | (emit req rest)) | |
133 | ((vector-ref (car ls) 2) ; rest | |
134 | (let ((n (vector-ref (car ls) 0))) | |
135 | (vector-set! rest n (cons (car ls) (vector-ref rest n))) | |
136 | (lp (cdr ls)))) | |
137 | (else ; req | |
138 | (let ((n (vector-ref (car ls) 0))) | |
139 | (vector-set! req n (cons (car ls) (vector-ref req n))) | |
140 | (lp (cdr ls))))))) | |
141 | (define (emit req rest) | |
142 | (let ((gf-sym (gensym "g"))) | |
143 | (define (emit-rest n clauses free) | |
144 | (if (< n (vector-length rest)) | |
145 | (let ((methods (vector-ref rest n))) | |
146 | (cond | |
147 | ((null? methods) | |
148 | (emit-rest (1+ n) clauses free)) | |
149 | ;; FIXME: hash dispatch | |
150 | (else | |
151 | (call-with-values | |
152 | (lambda () | |
153 | (emit-linear-dispatch gf-sym n methods free #t)) | |
154 | (lambda (clause free) | |
155 | (emit-rest (1+ n) (cons clause clauses) free)))))) | |
156 | (emit-req (1- (vector-length req)) clauses free))) | |
157 | (define (emit-req n clauses free) | |
158 | (if (< n 0) | |
159 | (comp `(lambda ,(map cdr free) | |
160 | (case-lambda ,@clauses)) | |
161 | (map car free)) | |
162 | (let ((methods (vector-ref req n))) | |
163 | (cond | |
164 | ((null? methods) | |
165 | (emit-req (1- n) clauses free)) | |
166 | ;; FIXME: hash dispatch | |
167 | (else | |
168 | (call-with-values | |
169 | (lambda () | |
170 | (emit-linear-dispatch gf-sym n methods free #f)) | |
171 | (lambda (clause free) | |
172 | (emit-req (1- n) (cons clause clauses) free)))))))) | |
173 | ||
174 | (emit-rest 0 | |
175 | (if (or (zero? (vector-length rest)) | |
176 | (null? (vector-ref rest 0))) | |
177 | (list `(args (cache-miss ,gf-sym args))) | |
178 | '()) | |
179 | (acons gf gf-sym '())))) | |
180 | (define (comp exp vals) | |
f3b312a1 LC |
181 | ;; When cross-compiling Guile itself, the native Guile must generate |
182 | ;; code for the host. | |
183 | (with-target %host-type | |
184 | (lambda () | |
185 | (let ((p ((@ (system base compile) compile) exp | |
186 | #:env *dispatch-module* | |
21b83fb7 | 187 | #:from 'scheme |
f3b312a1 LC |
188 | #:opts '(#:partial-eval? #f #:cse? #f)))) |
189 | (apply p vals))))) | |
190 | ||
cfe55d3e AW |
191 | ;; kick it. |
192 | (scan)) | |
193 | ||
194 | ;; o/~ ten, nine, eight | |
195 | ;; sometimes that's just how it goes | |
196 | ;; three, two, one | |
197 | ;; | |
198 | ;; get out before it blows o/~ | |
199 | ;; | |
eb721b3b | 200 | (define timer-init 30) |
cfe55d3e AW |
201 | (define (delayed-compile gf) |
202 | (let ((timer timer-init)) | |
203 | (lambda args | |
2f652c68 | 204 | (set! timer (1- timer)) |
cfe55d3e | 205 | (cond |
2f652c68 AW |
206 | ((zero? timer) |
207 | (let ((dispatch (compute-dispatch-procedure | |
208 | gf (slot-ref gf 'effective-methods)))) | |
209 | (slot-set! gf 'procedure dispatch) | |
210 | (apply dispatch args))) | |
cfe55d3e | 211 | (else |
2f652c68 AW |
212 | ;; interestingly, this catches recursive compilation attempts as |
213 | ;; well; in that case, timer is negative | |
214 | (cache-dispatch gf args)))))) | |
cfe55d3e AW |
215 | |
216 | (define (cache-dispatch gf args) | |
217 | (define (map-until n f ls) | |
218 | (if (or (zero? n) (null? ls)) | |
219 | '() | |
220 | (cons (f (car ls)) (map-until (1- n) f (cdr ls))))) | |
2f652c68 AW |
221 | (define (equal? x y) ; can't use the stock equal? because it's a generic... |
222 | (cond ((pair? x) (and (pair? y) | |
223 | (eq? (car x) (car y)) | |
224 | (equal? (cdr x) (cdr y)))) | |
225 | ((null? x) (null? y)) | |
226 | (else #f))) | |
227 | (if (slot-ref gf 'n-specialized) | |
228 | (let ((types (map-until (slot-ref gf 'n-specialized) class-of args))) | |
229 | (let lp ((cache (slot-ref gf 'effective-methods))) | |
230 | (cond ((null? cache) | |
231 | (cache-miss gf args)) | |
232 | ((equal? (vector-ref (car cache) 1) types) | |
233 | (apply (vector-ref (car cache) 3) args)) | |
234 | (else (lp (cdr cache)))))) | |
235 | (cache-miss gf args))) | |
cfe55d3e AW |
236 | |
237 | (define (cache-miss gf args) | |
9022ff18 | 238 | (apply (memoize-method! gf args) args)) |
cfe55d3e AW |
239 | |
240 | (define (memoize-effective-method! gf args applicable) | |
241 | (define (first-n ls n) | |
242 | (if (or (zero? n) (null? ls)) | |
243 | '() | |
244 | (cons (car ls) (first-n (cdr ls) (- n 1))))) | |
245 | (define (parse n ls) | |
246 | (cond ((null? ls) | |
247 | (memoize n #f (map class-of args))) | |
248 | ((= n (slot-ref gf 'n-specialized)) | |
249 | (memoize n #t (map class-of (first-n args n)))) | |
250 | (else | |
251 | (parse (1+ n) (cdr ls))))) | |
252 | (define (memoize len rest? types) | |
583a23bf | 253 | (let* ((cmethod ((@@ (oop goops) compute-cmethod) applicable types)) |
cfe55d3e AW |
254 | (cache (cons (vector len types rest? cmethod) |
255 | (slot-ref gf 'effective-methods)))) | |
256 | (slot-set! gf 'effective-methods cache) | |
51f66c91 | 257 | (slot-set! gf 'procedure (delayed-compile gf)) |
cfe55d3e AW |
258 | cmethod)) |
259 | (parse 0 args)) | |
260 | ||
261 | ||
14f1d9fe MD |
262 | ;;; |
263 | ;;; Memoization | |
264 | ;;; | |
265 | ||
9022ff18 | 266 | (define (memoize-method! gf args) |
14f1d9fe MD |
267 | (let ((applicable ((if (eq? gf compute-applicable-methods) |
268 | %compute-applicable-methods | |
269 | compute-applicable-methods) | |
270 | gf args))) | |
271 | (cond (applicable | |
5bdea5bd | 272 | (memoize-effective-method! gf args applicable)) |
14f1d9fe | 273 | (else |
2aecf4cf | 274 | (no-applicable-method gf args))))) |
14f1d9fe MD |
275 | |
276 | (set-procedure-property! memoize-method! 'system-procedure #t) |