1 |
|
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
;;; Permutation vectors. |
28 |
|
;;; |
29 |
|
|
30 |
|
(in-package :pcl) |
31 |
|
|
32 |
|
(defmacro instance-slot-index (wrapper slot-name) |
33 |
|
`(let ((pos 0)) |
34 |
|
(declare (fixnum pos)) |
35 |
|
(block loop |
36 |
|
(dolist (sn (wrapper-instance-slots-layout ,wrapper)) |
37 |
|
(when (eq ,slot-name sn) (return-from loop pos)) |
38 |
|
(incf pos))))) |
39 |
|
|
40 |
|
|
41 |
|
;;; |
42 |
|
;;; |
43 |
|
;;; |
44 |
|
(defun pv-cache-limit-fn (nlines) |
45 |
|
(default-limit-fn nlines)) |
46 |
|
|
47 |
|
(defstruct (pv-table |
48 |
|
(:predicate pv-tablep) |
49 |
|
(:constructor make-pv-table-internal |
50 |
|
(slot-name-lists call-list))) |
51 |
|
(cache nil :type (or cache null)) |
52 |
|
(pv-size 0 :type fixnum) |
53 |
|
(slot-name-lists nil :type list) |
54 |
|
(call-list nil :type list)) |
55 |
|
|
56 |
|
#+cmu |
57 |
|
(declaim (ext:freeze-type pv-table)) |
58 |
|
|
59 |
|
(defvar *initial-pv-table* (make-pv-table-internal nil nil)) |
60 |
|
|
61 |
|
; help new slot-value-using-class methods affect fast iv access |
62 |
|
(defvar *all-pv-table-list* nil) |
63 |
|
|
64 |
|
(defun make-pv-table (&key slot-name-lists call-list) |
65 |
|
(let ((pv-table (make-pv-table-internal slot-name-lists call-list))) |
66 |
|
(push pv-table *all-pv-table-list*) |
67 |
|
pv-table)) |
68 |
|
|
69 |
|
(defun make-pv-table-type-declaration (var) |
70 |
|
`(type pv-table ,var)) |
71 |
|
|
72 |
|
(defvar *slot-name-lists-inner* (make-hash-table :test #'equal)) |
73 |
|
(defvar *slot-name-lists-outer* (make-hash-table :test #'equal)) |
74 |
|
|
75 |
|
;entries in this are lists of (table . pv-offset-list) |
76 |
|
(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) |
77 |
|
|
78 |
|
(defun intern-pv-table (&key slot-name-lists call-list) |
79 |
|
(let ((new-p nil)) |
80 |
|
(flet ((inner (x) |
81 |
|
(or (gethash x *slot-name-lists-inner*) |
82 |
|
(setf (gethash x *slot-name-lists-inner*) (copy-list x)))) |
83 |
|
(outer (x) |
84 |
|
(or (gethash x *slot-name-lists-outer*) |
85 |
|
(setf (gethash x *slot-name-lists-outer*) |
86 |
|
(let ((snl (copy-list (cdr x))) |
87 |
|
(cl (car x))) |
88 |
|
(setq new-p t) |
89 |
|
(make-pv-table :slot-name-lists snl |
90 |
|
:call-list cl)))))) |
91 |
|
(let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) |
92 |
|
(when new-p |
93 |
|
(let ((pv-index 1)) |
94 |
|
(declare (fixnum pv-index)) |
95 |
|
(dolist (slot-name-list slot-name-lists) |
96 |
|
(dolist (slot-name (cdr slot-name-list)) |
97 |
|
(note-pv-table-reference slot-name pv-index pv-table) |
98 |
|
(incf pv-index))) |
99 |
|
(dolist (gf-call call-list) |
100 |
|
(note-pv-table-reference gf-call pv-index pv-table) |
101 |
|
(incf pv-index)) |
102 |
|
(setf (pv-table-pv-size pv-table) pv-index))) |
103 |
|
pv-table)))) |
104 |
|
|
105 |
|
(defun note-pv-table-reference (ref pv-offset pv-table) |
106 |
|
(let ((entry (gethash ref *pv-key-to-pv-table-table*))) |
107 |
|
(when (listp entry) |
108 |
|
(let ((table-entry (assq pv-table entry))) |
109 |
|
(when (and (null table-entry) |
110 |
|
(> (length entry) 8)) |
111 |
|
(let ((new-table-table (make-hash-table :size 16 :test 'eq))) |
112 |
|
(dolist (table-entry entry) |
113 |
|
(setf (gethash (car table-entry) new-table-table) |
114 |
|
(cdr table-entry))) |
115 |
|
(setf (gethash ref *pv-key-to-pv-table-table*) new-table-table))) |
116 |
|
(when (listp entry) |
117 |
|
(if (null table-entry) |
118 |
|
(let ((new (cons pv-table pv-offset))) |
119 |
|
(if (consp entry) |
120 |
|
(push new (cdr entry)) |
121 |
|
(setf (gethash ref *pv-key-to-pv-table-table*) (list new)))) |
122 |
|
(push pv-offset (cdr table-entry))) |
123 |
|
(return-from note-pv-table-reference nil)))) |
124 |
|
(let ((list (gethash pv-table entry))) |
125 |
|
(if (consp list) |
126 |
|
(push pv-offset (cdr list)) |
127 |
|
(setf (gethash pv-table entry) (list pv-offset))))) |
128 |
|
nil) |
129 |
|
|
130 |
|
(defun map-pv-table-references-of (ref function) |
131 |
|
(let ((entry (gethash ref *pv-key-to-pv-table-table*))) |
132 |
|
(if (listp entry) |
133 |
|
(dolist (table+pv-offset-list entry) |
134 |
|
(funcall function |
135 |
|
(car table+pv-offset-list) (cdr table+pv-offset-list))) |
136 |
|
(maphash function entry))) |
137 |
|
ref) |
138 |
|
|
139 |
|
|
140 |
|
(defvar *pvs* (make-hash-table :test #'equal)) |
141 |
|
|
142 |
|
(defun optimize-slot-value-by-class-p (class slot-name type) |
143 |
|
(or (not (eq *boot-state* 'complete)) |
144 |
|
(let ((slotd (find-slot-definition class slot-name))) |
145 |
|
(and slotd |
146 |
|
(slot-accessor-std-p slotd type))))) |
147 |
|
|
148 |
|
(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell) |
149 |
|
(if (symbolp slot-name) |
150 |
|
(when (optimize-slot-value-by-class-p class slot-name 'all) |
151 |
|
(or (instance-slot-index wrapper slot-name) |
152 |
|
(let ((cell (assq slot-name class-slots))) |
153 |
|
(when cell |
154 |
|
(setf (car class-slot-p-cell) t) |
155 |
|
cell)))) |
156 |
|
(when (consp slot-name) |
157 |
|
(dolist (type '(reader writer) nil) |
158 |
|
(when (eq (car slot-name) type) |
159 |
|
(return |
160 |
|
(let* ((gf-name (cadr slot-name)) |
161 |
|
(gf (gdefinition gf-name)) |
162 |
|
(location |
163 |
|
(when (eq *boot-state* 'complete) |
164 |
|
(accessor-values1 gf type class)))) |
165 |
|
(when (consp location) |
166 |
|
(setf (car class-slot-p-cell) t)) |
167 |
|
location))))))) |
168 |
|
|
169 |
|
(defun compute-pv (slot-name-lists wrappers) |
170 |
|
(unless (listp wrappers) (setq wrappers (list wrappers))) |
171 |
|
(let* ((not-simple-p-cell (list nil)) |
172 |
|
(elements |
173 |
|
(gathering1 (collecting) |
174 |
|
(iterate ((slot-names (list-elements slot-name-lists))) |
175 |
|
(when slot-names |
176 |
|
(let* ((wrapper (pop wrappers)) |
177 |
|
(std-p #+cmu17 (typep wrapper 'wrapper) |
178 |
|
#-cmu17 t) |
179 |
|
(class (wrapper-class* wrapper)) |
180 |
|
(class-slots (and std-p (wrapper-class-slots wrapper)))) |
181 |
|
(dolist (slot-name (cdr slot-names)) |
182 |
|
(gather1 |
183 |
|
(when std-p |
184 |
|
(compute-pv-slot slot-name wrapper class |
185 |
|
class-slots not-simple-p-cell)))))))))) |
186 |
|
(if (car not-simple-p-cell) |
187 |
|
(make-permutation-vector (cons t elements)) |
188 |
|
(or (gethash elements *pvs*) |
189 |
|
(setf (gethash elements *pvs*) |
190 |
|
(make-permutation-vector (cons nil elements))))))) |
191 |
|
|
192 |
|
(defun compute-calls (call-list wrappers) |
193 |
|
(declare (ignore call-list wrappers)) |
194 |
|
#|| |
195 |
|
(map 'vector |
196 |
|
#'(lambda (call) |
197 |
|
(compute-emf-from-wrappers call wrappers)) |
198 |
|
call-list) |
199 |
|
||# |
200 |
|
'#()) |
201 |
|
|
202 |
|
#|| ; Need to finish this, then write the maintenance functions. |
203 |
|
(defun compute-emf-from-wrappers (call wrappers) |
204 |
|
(when call |
205 |
|
; FIXME use regular destructuring-bind |
206 |
|
(pcl-destructuring-bind (gf-name nreq restp arg-info) call |
207 |
|
(if (eq gf-name 'make-instance) |
208 |
|
(error "should not get here") ; there is another mechanism for this. |
209 |
|
#'(lambda (&rest args) |
210 |
|
(if (not (eq *boot-state* 'complete)) |
211 |
|
(apply (gdefinition gf-name) args) |
212 |
|
(let* ((gf (gdefinition gf-name)) |
213 |
|
(arg-info (arg-info-reader gf)) |
214 |
|
(classes '?) |
215 |
|
(types '?) |
216 |
|
(emf (cache-miss-values-internal gf arg-info |
217 |
|
wrappers classes types |
218 |
|
'caching))) |
219 |
|
(update-all-pv-tables call wrappers emf) |
220 |
|
#+copy-&rest-arg (setq args (copy-list args)) |
221 |
|
(invoke-emf emf args)))))))) |
222 |
|
||# |
223 |
|
|
224 |
|
(defun make-permutation-vector (indexes) |
225 |
|
(make-array (length indexes) :initial-contents indexes)) |
226 |
|
|
227 |
|
(defun pv-table-lookup (pv-table pv-wrappers) |
228 |
|
(let* ((slot-name-lists (pv-table-slot-name-lists pv-table)) |
229 |
|
(call-list (pv-table-call-list pv-table)) |
230 |
|
(cache (or (pv-table-cache pv-table) |
231 |
|
(setf (pv-table-cache pv-table) |
232 |
|
(get-cache (- (length slot-name-lists) |
233 |
|
(count nil slot-name-lists)) |
234 |
|
t |
235 |
|
#'pv-cache-limit-fn |
236 |
|
2))))) |
237 |
|
(or (probe-cache cache pv-wrappers) |
238 |
|
(let* ((pv (compute-pv slot-name-lists pv-wrappers)) |
239 |
|
(calls (compute-calls call-list pv-wrappers)) |
240 |
|
(pv-cell (cons pv calls)) |
241 |
|
(new-cache (fill-cache cache pv-wrappers pv-cell))) |
242 |
|
(unless (eq new-cache cache) |
243 |
|
(setf (pv-table-cache pv-table) new-cache) |
244 |
|
(free-cache cache)) |
245 |
|
pv-cell)))) |
246 |
|
|
247 |
|
(defun make-pv-type-declaration (var) |
248 |
|
`(type simple-vector ,var)) |
249 |
|
|
250 |
|
(defvar *empty-pv* #()) |
251 |
|
|
252 |
|
(defmacro pvref (pv index) |
253 |
|
`(svref ,pv ,index)) |
254 |
|
|
255 |
|
(defmacro copy-pv (pv) |
256 |
|
`(copy-seq ,pv)) |
257 |
|
|
258 |
|
(defun make-calls-type-declaration (var) |
259 |
|
`(type simple-vector ,var)) |
260 |
|
|
261 |
|
(defmacro callsref (calls index) |
262 |
|
`(svref ,calls ,index)) |
263 |
|
|
264 |
|
(defvar *pv-table-cache-update-info* nil) |
265 |
|
|
266 |
|
;called by: |
267 |
|
;(method shared-initialize :after (structure-class t)) |
268 |
|
;update-slots |
269 |
|
(defun update-pv-table-cache-info (class) |
270 |
|
(let ((slot-names-for-pv-table-update nil) |
271 |
|
(new-icui nil)) |
272 |
|
(dolist (icu *pv-table-cache-update-info*) |
273 |
|
(if (eq (car icu) class) |
274 |
|
(pushnew (cdr icu) slot-names-for-pv-table-update) |
275 |
|
(push icu new-icui))) |
276 |
|
(setq *pv-table-cache-update-info* new-icui) |
277 |
|
(when slot-names-for-pv-table-update |
278 |
|
(update-all-pv-table-caches class slot-names-for-pv-table-update)))) |
279 |
|
|
280 |
|
(defun update-all-pv-table-caches (class slot-names) |
281 |
|
(let* ((cwrapper (class-wrapper class)) |
282 |
|
(std-p #+cmu17 (typep cwrapper 'wrapper) #-cmu17 t) |
283 |
|
(class-slots (and std-p (wrapper-class-slots cwrapper))) |
284 |
|
(class-slot-p-cell (list nil)) |
285 |
|
(new-values (mapcar #'(lambda (slot-name) |
286 |
|
(cons slot-name |
287 |
|
(when std-p |
288 |
|
(compute-pv-slot |
289 |
|
slot-name cwrapper class |
290 |
|
class-slots class-slot-p-cell)))) |
291 |
|
slot-names)) |
292 |
|
(pv-tables nil)) |
293 |
|
(dolist (slot-name slot-names) |
294 |
|
(map-pv-table-references-of |
295 |
|
slot-name |
296 |
|
#'(lambda (pv-table pv-offset-list) |
297 |
|
(declare (ignore pv-offset-list)) |
298 |
|
(pushnew pv-table pv-tables)))) |
299 |
|
(dolist (pv-table pv-tables) |
300 |
|
(let* ((cache (pv-table-cache pv-table)) |
301 |
|
(slot-name-lists (pv-table-slot-name-lists pv-table)) |
302 |
|
(pv-size (pv-table-pv-size pv-table)) |
303 |
|
(pv-map (make-array pv-size :initial-element nil))) |
304 |
|
(let ((map-index 1)(param-index 0)) |
305 |
|
(declare (fixnum map-index param-index)) |
306 |
|
(dolist (slot-name-list slot-name-lists) |
307 |
|
(dolist (slot-name (cdr slot-name-list)) |
308 |
|
(let ((a (assoc slot-name new-values))) |
309 |
|
(setf (svref pv-map map-index) |
310 |
|
(and a (cons param-index (cdr a))))) |
311 |
|
(incf map-index)) |
312 |
|
(incf param-index))) |
313 |
|
(when cache |
314 |
|
(map-cache #'(lambda (wrappers pv-cell) |
315 |
|
(setf (car pv-cell) |
316 |
|
(update-slots-in-pv wrappers (car pv-cell) |
317 |
|
cwrapper pv-size pv-map))) |
318 |
|
cache)))))) |
319 |
|
|
320 |
|
(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) |
321 |
|
(if (not (if (atom wrappers) |
322 |
|
(eq cwrapper wrappers) |
323 |
|
(dolist (wrapper wrappers nil) |
324 |
|
(when (eq wrapper cwrapper) |
325 |
|
(return t))))) |
326 |
|
pv |
327 |
|
(let* ((old-intern-p (listp (pvref pv 0))) |
328 |
|
(new-pv (if old-intern-p |
329 |
|
(copy-pv pv) |
330 |
|
pv)) |
331 |
|
(new-intern-p t)) |
332 |
|
(if (atom wrappers) |
333 |
|
(dotimes (i pv-size) |
334 |
|
(when (consp (let ((map (svref pv-map i))) |
335 |
|
(if map |
336 |
|
(setf (pvref new-pv i) (cdr map)) |
337 |
|
(pvref new-pv i)))) |
338 |
|
(setq new-intern-p nil))) |
339 |
|
(let ((param 0)) |
340 |
|
(declare (fixnum param)) |
341 |
|
(dolist (wrapper wrappers) |
342 |
|
(when (eq wrapper cwrapper) |
343 |
|
(dotimes (i pv-size) |
344 |
|
(when (consp (let ((map (svref pv-map i))) |
345 |
|
(if (and map (= (car map) param)) |
346 |
|
(setf (pvref new-pv i) (cdr map)) |
347 |
|
(pvref new-pv i)))) |
348 |
|
(setq new-intern-p nil)))) |
349 |
|
(incf param)))) |
350 |
|
(when new-intern-p |
351 |
|
(setq new-pv (let ((list-pv (coerce pv 'list))) |
352 |
|
(or (gethash (cdr list-pv) *pvs*) |
353 |
|
(setf (gethash (cdr list-pv) *pvs*) |
354 |
|
(if old-intern-p |
355 |
|
new-pv |
356 |
|
(make-permutation-vector list-pv))))))) |
357 |
|
new-pv))) |
358 |
|
|
359 |
|
|
360 |
|
(defun maybe-expand-accessor-form (form required-parameters slots env) |
361 |
|
(let* ((fname (car form)) |
362 |
|
#||(len (length form))||# |
363 |
|
(gf (if (symbolp fname) |
364 |
|
(unencapsulated-fdefinition fname) |
365 |
|
(gdefinition fname)))) |
366 |
|
(macrolet ((maybe-optimize-reader () |
367 |
|
`(let ((parameter |
368 |
|
(can-optimize-access1 (cadr form) |
369 |
|
required-parameters env))) |
370 |
|
(when parameter |
371 |
|
(optimize-reader slots parameter gf-name form)))) |
372 |
|
(maybe-optimize-writer () |
373 |
|
`(let ((parameter |
374 |
|
(can-optimize-access1 (caddr form) |
375 |
|
required-parameters env))) |
376 |
|
(when parameter |
377 |
|
(optimize-writer slots parameter gf-name form))))) |
378 |
|
(unless (and (consp (cadr form)) |
379 |
|
(eq 'instance-accessor-parameter (caadr form))) |
380 |
|
(or #|| |
381 |
|
(cond ((and (= len 2) (symbolp fname)) |
382 |
|
(let ((gf-name (gethash fname *gf-declared-reader-table*))) |
383 |
|
(when gf-name |
384 |
|
(maybe-optimize-reader)))) |
385 |
|
((= len 3) |
386 |
|
(let ((gf-name (gethash fname *gf-declared-writer-table*))) |
387 |
|
(when gf-name |
388 |
|
(maybe-optimize-writer))))) |
389 |
|
||# |
390 |
|
(when (and (eq *boot-state* 'complete) |
391 |
|
(generic-function-p gf)) |
392 |
|
(let ((methods (generic-function-methods gf))) |
393 |
|
(when methods |
394 |
|
(let* ((gf-name (generic-function-name gf)) |
395 |
|
(arg-info (gf-arg-info gf)) |
396 |
|
(metatypes (arg-info-metatypes arg-info)) |
397 |
|
(nreq (length metatypes)) |
398 |
|
(applyp (arg-info-applyp arg-info))) |
399 |
|
(when (null applyp) |
400 |
|
(cond ((= nreq 1) |
401 |
|
(when (some #'standard-reader-method-p methods) |
402 |
|
(maybe-optimize-reader))) |
403 |
|
((and (= nreq 2) |
404 |
|
(consp gf-name) |
405 |
|
(eq (car gf-name) 'setf)) |
406 |
|
(when (some #'standard-writer-method-p methods) |
407 |
|
(maybe-optimize-writer)))))))))))))) |
408 |
|
|
409 |
|
(defun optimize-generic-function-call (form required-parameters env slots calls) |
410 |
|
(declare (ignore required-parameters env slots calls)) |
411 |
|
(or (and (eq (car form) 'make-instance) |
412 |
|
(expand-make-instance-form form)) |
413 |
|
#|| |
414 |
|
(maybe-expand-accessor-form form required-parameters slots env) |
415 |
|
(let* ((fname (car form)) |
416 |
|
(len (length form)) |
417 |
|
(gf (if (symbolp fname) |
418 |
|
(and (fboundp fname) |
419 |
|
(unencapsulated-fdefinition fname)) |
420 |
|
(and (gboundp fname) |
421 |
|
(gdefinition fname)))) |
422 |
|
(gf-name (and (fsc-instance-p gf) |
423 |
|
(if (early-gf-p gf) |
424 |
|
(early-gf-name gf) |
425 |
|
(generic-function-name gf))))) |
426 |
|
(when gf-name |
427 |
|
(multiple-value-bind (nreq restp) |
428 |
|
(get-generic-function-info gf) |
429 |
|
(optimize-gf-call slots calls form nreq restp env)))) |
430 |
|
||# |
431 |
|
form)) |
432 |
|
|
433 |
|
|
434 |
|
|
435 |
|
(defun can-optimize-access (form required-parameters env) |
436 |
|
(let ((type (ecase (car form) |
437 |
|
(slot-value 'reader) |
438 |
|
(set-slot-value 'writer) |
439 |
|
(slot-boundp 'boundp))) |
440 |
|
(var (cadr form)) |
441 |
|
(slot-name (eval (caddr form)))) ; known to be constant |
442 |
|
(can-optimize-access1 var required-parameters env type slot-name))) |
443 |
|
|
444 |
|
(defun can-optimize-access1 (var required-parameters env &optional type slot-name) |
445 |
|
(when (and (consp var) (eq 'the (car var))) |
446 |
|
(setq var (caddr var))) |
447 |
|
(when (symbolp var) |
448 |
|
(let* ((rebound? (caddr (variable-declaration 'variable-rebinding var env))) |
449 |
|
(parameter-or-nil (car (memq (or rebound? var) required-parameters)))) |
450 |
|
(when parameter-or-nil |
451 |
|
(let* ((class-name (caddr (variable-declaration |
452 |
|
'class parameter-or-nil env))) |
453 |
|
(class (find-class class-name nil))) |
454 |
|
(when (or (not (eq *boot-state* 'complete)) |
455 |
|
(and class (not (class-finalized-p class)))) |
456 |
|
(setq class nil)) |
457 |
|
(when (and class-name (not (eq class-name 't))) |
458 |
|
(when (or (null type) |
459 |
|
(not (and class |
460 |
|
(memq *the-class-structure-object* |
461 |
|
(class-precedence-list class)))) |
462 |
|
(optimize-slot-value-by-class-p class slot-name type)) |
463 |
|
(cons parameter-or-nil (or class class-name))))))))) |
464 |
|
|
465 |
|
(defun optimize-slot-value (slots sparameter form) |
466 |
|
(if sparameter |
467 |
|
; FIXME use regular destructuring-bind |
468 |
|
(pcl-destructuring-bind (ignore ignore slot-name-form) form |
469 |
|
(let ((slot-name (eval slot-name-form))) |
470 |
|
(optimize-instance-access slots :read sparameter slot-name nil))) |
471 |
|
`(accessor-slot-value ,@(cdr form)))) |
472 |
|
|
473 |
|
(defun optimize-set-slot-value (slots sparameter form) |
474 |
|
(if sparameter |
475 |
|
; FIXME use regular destructuring-bind |
476 |
|
(pcl-destructuring-bind (ignore ignore slot-name-form new-value) form |
477 |
|
(let ((slot-name (eval slot-name-form))) |
478 |
|
(optimize-instance-access slots :write sparameter slot-name new-value))) |
479 |
|
`(accessor-set-slot-value ,@(cdr form)))) |
480 |
|
|
481 |
|
(defun optimize-slot-boundp (slots sparameter form) |
482 |
|
(if sparameter |
483 |
|
; FIXME use regular destructuring-bind |
484 |
|
(pcl-destructuring-bind (ignore ignore slot-name-form new-value) form |
485 |
|
(let ((slot-name (eval slot-name-form))) |
486 |
|
(optimize-instance-access slots :boundp sparameter slot-name new-value))) |
487 |
|
`(accessor-slot-boundp ,@(cdr form)))) |
488 |
|
|
489 |
|
(defun optimize-reader (slots sparameter gf-name form) |
490 |
|
(if sparameter |
491 |
|
(optimize-accessor-call slots :read sparameter gf-name nil) |
492 |
|
form)) |
493 |
|
|
494 |
|
(defun optimize-writer (slots sparameter gf-name form) |
495 |
|
(if sparameter |
496 |
|
; FIXME use regular destructuring-bind |
497 |
|
(pcl-destructuring-bind (ignore ignore new-value) form |
498 |
|
(optimize-accessor-call slots :write sparameter gf-name new-value)) |
499 |
|
form)) |
500 |
|
;;; |
501 |
|
;;; The <slots> argument is an alist, the CAR of each entry is the name of |
502 |
|
;;; a required parameter to the function. The alist is in order, so the |
503 |
|
;;; position of an entry in the alist corresponds to the argument's position |
504 |
|
;;; in the lambda list. |
505 |
|
;;; |
506 |
|
(defun optimize-instance-access (slots read/write sparameter slot-name new-value) |
507 |
|
(let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) |
508 |
|
(parameter (if (consp sparameter) (car sparameter) sparameter))) |
509 |
|
(if (and (eq *boot-state* 'complete) |
510 |
|
(classp class) |
511 |
|
(memq *the-class-structure-object* (class-precedence-list class))) |
512 |
|
(let ((slotd (find-slot-definition class slot-name))) |
513 |
|
(ecase read/write |
514 |
|
(:read |
515 |
|
`(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) |
516 |
|
(:write |
517 |
|
`(setf (,(slot-definition-defstruct-accessor-symbol slotd) ,parameter) |
518 |
|
,new-value)) |
519 |
|
(:boundp |
520 |
|
'T))) |
521 |
|
(let* ((parameter-entry (assq parameter slots)) |
522 |
|
(slot-entry (assq slot-name (cdr parameter-entry))) |
523 |
|
(position (posq parameter-entry slots)) |
524 |
|
(pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) |
525 |
|
(unless parameter-entry |
526 |
|
(error "Internal error in slot optimization.")) |
527 |
|
(unless slot-entry |
528 |
|
(setq slot-entry (list slot-name)) |
529 |
|
(push slot-entry (cdr parameter-entry))) |
530 |
|
(push pv-offset-form (cdr slot-entry)) |
531 |
|
(ecase read/write |
532 |
|
(:read |
533 |
|
`(instance-read ,pv-offset-form ,parameter ,position |
534 |
|
',slot-name ',class)) |
535 |
|
(:write |
536 |
|
`(let ((.new-value. ,new-value)) |
537 |
|
(instance-write ,pv-offset-form ,parameter ,position |
538 |
|
',slot-name ',class .new-value.))) |
539 |
|
(:boundp |
540 |
|
`(instance-boundp ,pv-offset-form ,parameter ,position |
541 |
|
',slot-name ',class))))))) |
542 |
|
|
543 |
|
(defun optimize-accessor-call (slots read/write sparameter gf-name new-value) |
544 |
|
(let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) |
545 |
|
(parameter (if (consp sparameter) (car sparameter) sparameter)) |
546 |
|
(parameter-entry (assq parameter slots)) |
547 |
|
(name (case read/write |
548 |
|
(:read `(reader ,gf-name)) |
549 |
|
(:write `(writer ,gf-name)))) |
550 |
|
(slot-entry (assoc name (cdr parameter-entry) :test #'equal)) |
551 |
|
(position (posq parameter-entry slots)) |
552 |
|
(pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) |
553 |
|
(unless parameter-entry |
554 |
|
(error "Internal error in slot optimization.")) |
555 |
|
(unless slot-entry |
556 |
|
(setq slot-entry (list name)) |
557 |
|
(push slot-entry (cdr parameter-entry))) |
558 |
|
(push pv-offset-form (cdr slot-entry)) |
559 |
|
(ecase read/write |
560 |
|
(:read |
561 |
|
`(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) |
562 |
|
(:write |
563 |
|
`(let ((.new-value. ,new-value)) |
564 |
|
(instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class |
565 |
|
.new-value.)))))) |
566 |
|
|
567 |
|
(defvar *unspecific-arg* '..unspecific-arg..) |
568 |
|
|
569 |
|
(defun optimize-gf-call-internal (form slots env) |
570 |
|
(when (and (consp form) |
571 |
|
(eq (car form) 'the)) |
572 |
|
(setq form (caddr form))) |
573 |
|
(or (and (symbolp form) |
574 |
|
(let* ((rebound? (caddr (variable-declaration 'variable-rebinding |
575 |
|
form env))) |
576 |
|
(parameter-or-nil (car (assq (or rebound? form) slots)))) |
577 |
|
(when parameter-or-nil |
578 |
|
(let* ((class-name (caddr (variable-declaration |
579 |
|
'class parameter-or-nil env)))) |
580 |
|
(when (and class-name (not (eq class-name 't))) |
581 |
|
(position parameter-or-nil slots :key #'car)))))) |
582 |
|
(if (constantp form) |
583 |
|
(let ((form (eval form))) |
584 |
|
(if (symbolp form) |
585 |
|
form |
586 |
|
*unspecific-arg*)) |
587 |
|
*unspecific-arg*))) |
588 |
|
|
589 |
|
(defun optimize-gf-call (slots calls gf-call-form nreq restp env) |
590 |
|
(unless (eq (car gf-call-form) 'make-instance) ; needs more work |
591 |
|
(let* ((args (cdr gf-call-form)) |
592 |
|
(all-args-p (eq (car gf-call-form) 'make-instance)) |
593 |
|
(non-required-args (nthcdr nreq args)) |
594 |
|
(required-args (ldiff args non-required-args)) |
595 |
|
(call-spec (list (car gf-call-form) nreq restp |
596 |
|
(mapcar #'(lambda (form) |
597 |
|
(optimize-gf-call-internal form slots env)) |
598 |
|
(if all-args-p |
599 |
|
args |
600 |
|
required-args)))) |
601 |
|
(call-entry (assoc call-spec calls :test #'equal)) |
602 |
|
(pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) |
603 |
|
(unless (some #'integerp |
604 |
|
(let ((spec-args (cdr call-spec))) |
605 |
|
(if all-args-p |
606 |
|
(ldiff spec-args (nthcdr nreq spec-args)) |
607 |
|
spec-args))) |
608 |
|
(return-from optimize-gf-call nil)) |
609 |
|
(unless call-entry |
610 |
|
(setq call-entry (list call-spec)) |
611 |
|
(push call-entry (cdr calls))) |
612 |
|
(push pv-offset-form (cdr call-entry)) |
613 |
|
(if (eq (car call-spec) 'make-instance) |
614 |
|
`(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form)) |
615 |
|
`(let ((.emf. (pv-ref .pv. ,pv-offset-form))) |
616 |
|
(invoke-effective-method-function .emf. ,restp |
617 |
|
,@required-args ,@(when restp `((list ,@non-required-args))))))))) |
618 |
|
|
619 |
|
|
620 |
|
(define-walker-template pv-offset) ; These forms get munged by mutate slots. |
621 |
|
(defmacro pv-offset (arg) arg) |
622 |
|
(define-walker-template instance-accessor-parameter) |
623 |
|
(defmacro instance-accessor-parameter (x) x) |
624 |
|
|
625 |
|
;; It is safe for these two functions to be wrong. |
626 |
|
;; They just try to guess what the most likely case will be. |
627 |
|
(defun generate-fast-class-slot-access-p (class-form slot-name-form) |
628 |
|
(let ((class (and (constantp class-form) (eval class-form))) |
629 |
|
(slot-name (and (constantp slot-name-form) (eval slot-name-form)))) |
630 |
|
(and (eq *boot-state* 'complete) |
631 |
|
(standard-class-p class) |
632 |
|
(not (eq class *the-class-t*)) ; shouldn't happen, though. |
633 |
|
(let ((slotd (find-slot-definition class slot-name))) |
634 |
|
(and slotd (classp (slot-definition-allocation slotd))))))) |
635 |
|
|
636 |
|
(defun skip-fast-slot-access-p (class-form slot-name-form type) |
637 |
|
(let ((class (and (constantp class-form) (eval class-form))) |
638 |
|
(slot-name (and (constantp slot-name-form) (eval slot-name-form)))) |
639 |
|
(and (eq *boot-state* 'complete) |
640 |
|
(standard-class-p class) |
641 |
|
(not (eq class *the-class-t*)) ; shouldn't happen, though. |
642 |
|
(let ((slotd (find-slot-definition class slot-name))) |
643 |
|
(and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))) |
644 |
|
|
645 |
|
(defun skip-optimize-slot-value-by-class-p (class slot-name type) |
646 |
|
(let ((slotd (find-slot-definition class slot-name))) |
647 |
|
(and slotd |
648 |
|
(eq *boot-state* 'complete) |
649 |
|
(not (slot-accessor-std-p slotd type))))) |
650 |
|
|
651 |
|
(defmacro instance-read-internal (pv slots pv-offset default &optional type) |
652 |
|
(unless (member type '(nil :instance :class :default)) |
653 |
|
(error "Illegal type argument to ~S: ~S" 'instance-read-internal type)) |
654 |
|
(if (eq type ':default) |
655 |
|
default |
656 |
|
(let* ((index (gensym)) |
657 |
|
(value index)) |
658 |
|
`(locally (declare #.*optimize-speed*) |
659 |
|
(let ((,index (pvref ,pv ,pv-offset))) |
660 |
|
(setq ,value (typecase ,index |
661 |
|
,@(when (or (null type) (eq type ':instance)) |
662 |
|
`((fixnum (%instance-ref ,slots ,index)))) |
663 |
|
,@(when (or (null type) (eq type ':class)) |
664 |
|
`((cons (cdr ,index)))) |
665 |
|
(t ',*slot-unbound*))) |
666 |
|
(if (eq ,value ',*slot-unbound*) |
667 |
|
,default |
668 |
|
,value)))))) |
669 |
|
|
670 |
|
(defmacro instance-read (pv-offset parameter position slot-name class) |
671 |
|
(if (skip-fast-slot-access-p class slot-name 'reader) |
672 |
|
`(accessor-slot-value ,parameter ,slot-name) |
673 |
|
`(instance-read-internal .pv. ,(slot-vector-symbol position) |
674 |
|
,pv-offset (accessor-slot-value ,parameter ,slot-name) |
675 |
|
,(if (generate-fast-class-slot-access-p class slot-name) |
676 |
|
':class ':instance)))) |
677 |
|
|
678 |
|
(defmacro instance-reader (pv-offset parameter position gf-name class) |
679 |
|
(declare (ignore class)) |
680 |
|
`(instance-read-internal .pv. ,(slot-vector-symbol position) |
681 |
|
,pv-offset |
682 |
|
(,gf-name (instance-accessor-parameter ,parameter)) |
683 |
|
:instance)) |
684 |
|
|
685 |
|
(defmacro instance-write-internal (pv slots pv-offset new-value default |
686 |
|
&optional type) |
687 |
|
(unless (member type '(nil :instance :class :default)) |
688 |
|
(error "Illegal type argument to ~S: ~S" 'instance-write-internal type)) |
689 |
|
(if (eq type ':default) |
690 |
|
default |
691 |
|
(let* ((index (gensym))) |
692 |
|
`(locally (declare #.*optimize-speed*) |
693 |
|
(let ((,index (pvref ,pv ,pv-offset))) |
694 |
|
(typecase ,index |
695 |
|
,@(when (or (null type) (eq type ':instance)) |
696 |
|
`((fixnum (setf (%instance-ref ,slots ,index) ,new-value)))) |
697 |
|
,@(when (or (null type) (eq type ':class)) |
698 |
|
`((cons (setf (cdr ,index) ,new-value)))) |
699 |
|
(t ,default))))))) |
700 |
|
|
701 |
|
(defmacro instance-write (pv-offset parameter position slot-name class new-value) |
702 |
|
(if (skip-fast-slot-access-p class slot-name 'writer) |
703 |
|
`(accessor-set-slot-value ,parameter ,slot-name ,new-value) |
704 |
|
`(instance-write-internal .pv. ,(slot-vector-symbol position) |
705 |
|
,pv-offset ,new-value |
706 |
|
(accessor-set-slot-value ,parameter ,slot-name ,new-value) |
707 |
|
,(if (generate-fast-class-slot-access-p class slot-name) |
708 |
|
':class ':instance)))) |
709 |
|
|
710 |
|
(defmacro instance-writer (pv-offset parameter position gf-name class new-value) |
711 |
|
(declare (ignore class)) |
712 |
|
`(instance-write-internal .pv. ,(slot-vector-symbol position) |
713 |
|
,pv-offset ,new-value |
714 |
|
(,(if (consp gf-name) |
715 |
|
(get-setf-function-name gf-name) |
716 |
|
gf-name) |
717 |
|
(instance-accessor-parameter ,parameter) |
718 |
|
,new-value) |
719 |
|
:instance)) |
720 |
|
|
721 |
|
(defmacro instance-boundp-internal (pv slots pv-offset default |
722 |
|
&optional type) |
723 |
|
(unless (member type '(nil :instance :class :default)) |
724 |
|
(error "Illegal type argument to ~S: ~S" 'instance-boundp-internal type)) |
725 |
|
(if (eq type ':default) |
726 |
|
default |
727 |
|
(let* ((index (gensym))) |
728 |
|
`(locally (declare #.*optimize-speed*) |
729 |
|
(let ((,index (pvref ,pv ,pv-offset))) |
730 |
|
(typecase ,index |
731 |
|
,@(when (or (null type) (eq type ':instance)) |
732 |
|
`((fixnum (not (eq (%instance-ref ,slots ,index) ',*slot-unbound*))))) |
733 |
|
,@(when (or (null type) (eq type ':class)) |
734 |
|
`((cons (not (eq (cdr ,index) ',*slot-unbound*))))) |
735 |
|
(t ,default))))))) |
736 |
|
|
737 |
|
(defmacro instance-boundp (pv-offset parameter position slot-name class) |
738 |
|
(if (skip-fast-slot-access-p class slot-name 'boundp) |
739 |
|
`(accessor-slot-boundp ,parameter ,slot-name) |
740 |
|
`(instance-boundp-internal .pv. ,(slot-vector-symbol position) |
741 |
|
,pv-offset (accessor-slot-boundp ,parameter ,slot-name) |
742 |
|
,(if (generate-fast-class-slot-access-p class slot-name) |
743 |
|
':class ':instance)))) |
744 |
|
|
745 |
|
;;; |
746 |
|
;;; This magic function has quite a job to do indeed. |
747 |
|
;;; |
748 |
|
;;; The careful reader will recall that <slots> contains all of the optimized |
749 |
|
;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is |
750 |
|
;;; a call to either INSTANCE-READ or INSTANCE-WRITE. |
751 |
|
;;; |
752 |
|
;;; At the time these calls were produced, the first argument was specified as |
753 |
|
;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset |
754 |
|
;;; arguments into the actual number that is the correct offset into the pv. |
755 |
|
;;; |
756 |
|
;;; But first, oh but first, we sort <slots> a bit so that for each argument |
757 |
|
;;; we have the slots in alphabetical order. This canonicalizes the PV-TABLE's a |
758 |
|
;;; bit and will hopefully lead to having fewer PV's floating around. Even |
759 |
|
;;; if the gain is only modest, it costs nothing. |
760 |
|
;;; |
761 |
|
(defun slot-name-lists-from-slots (slots calls) |
762 |
|
(multiple-value-bind (slots calls) |
763 |
|
(mutate-slots-and-calls slots calls) |
764 |
|
(let* ((slot-name-lists |
765 |
|
(mapcar #'(lambda (parameter-entry) |
766 |
|
(cons nil (mapcar #'car (cdr parameter-entry)))) |
767 |
|
slots)) |
768 |
|
(call-list |
769 |
|
(mapcar #'car calls))) |
770 |
|
(dolist (call call-list) |
771 |
|
(dolist (arg (cdr call)) |
772 |
|
(when (integerp arg) |
773 |
|
(setf (car (nth arg slot-name-lists)) t)))) |
774 |
|
(setq slot-name-lists (mapcar #'(lambda (r+snl) |
775 |
|
(when (or (car r+snl) (cdr r+snl)) |
776 |
|
r+snl)) |
777 |
|
slot-name-lists)) |
778 |
|
(let ((cvt (apply #'vector |
779 |
|
(let ((i -1)) |
780 |
|
(declare (fixnum i)) |
781 |
|
(mapcar #'(lambda (r+snl) |
782 |
|
(when r+snl (incf i))) |
783 |
|
slot-name-lists))))) |
784 |
|
(setq call-list (mapcar #'(lambda (call) |
785 |
|
(cons (car call) |
786 |
|
(mapcar #'(lambda (arg) |
787 |
|
(if (integerp arg) |
788 |
|
(svref cvt arg) |
789 |
|
arg)) |
790 |
|
(cdr call)))) |
791 |
|
call-list))) |
792 |
|
(values slot-name-lists call-list)))) |
793 |
|
|
794 |
|
(defun mutate-slots-and-calls (slots calls) |
795 |
|
(let ((sorted-slots (sort-slots slots)) |
796 |
|
(sorted-calls (sort-calls (cdr calls))) |
797 |
|
(pv-offset 0)) ; index 0 is for info |
798 |
|
(declare (fixnum pv-offset)) |
799 |
|
(dolist (parameter-entry sorted-slots) |
800 |
|
(dolist (slot-entry (cdr parameter-entry)) |
801 |
|
(incf pv-offset) |
802 |
|
(dolist (form (cdr slot-entry)) |
803 |
|
(setf (cadr form) pv-offset)))) |
804 |
|
(dolist (call-entry sorted-calls) |
805 |
|
(incf pv-offset) |
806 |
|
(dolist (form (cdr call-entry)) |
807 |
|
(setf (cadr form) pv-offset))) |
808 |
|
(values sorted-slots sorted-calls))) |
809 |
|
|
810 |
|
(defun symbol-pkg-name (sym) |
811 |
|
(let ((pkg (symbol-package sym))) |
812 |
|
(if pkg (package-name pkg) ""))) |
813 |
|
|
814 |
|
(defun symbol-lessp (a b) |
815 |
|
(if (eq (symbol-package a) |
816 |
|
(symbol-package b)) |
817 |
|
(string-lessp (symbol-name a) |
818 |
|
(symbol-name b)) |
819 |
|
(string-lessp (symbol-pkg-name a) |
820 |
|
(symbol-pkg-name b)))) |
821 |
|
|
822 |
|
(defun symbol-or-cons-lessp (a b) |
823 |
|
(etypecase a |
824 |
|
(symbol (etypecase b |
825 |
|
(symbol (symbol-lessp a b)) |
826 |
|
(cons t))) |
827 |
|
(cons (etypecase b |
828 |
|
(symbol nil) |
829 |
|
(cons (if (eq (car a) (car b)) |
830 |
|
(symbol-or-cons-lessp (cdr a) (cdr b)) |
831 |
|
(symbol-or-cons-lessp (car a) (car b)))))))) |
832 |
|
|
833 |
|
(defun sort-slots (slots) |
834 |
|
(mapcar #'(lambda (parameter-entry) |
835 |
|
(cons (car parameter-entry) |
836 |
|
(sort (cdr parameter-entry) ;slot entries |
837 |
|
#'symbol-or-cons-lessp |
838 |
|
:key #'car))) |
839 |
|
slots)) |
840 |
|
|
841 |
|
(defun sort-calls (calls) |
842 |
|
(sort calls #'symbol-or-cons-lessp :key #'car)) |
843 |
|
|
844 |
|
|
845 |
|
;;; |
846 |
|
;;; This needs to work in terms of metatypes and also needs to work for |
847 |
|
;;; automatically generated reader and writer functions. |
848 |
|
;;; -- Automatically generated reader and writer functions use this stuff too. |
849 |
|
|
850 |
|
(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) |
851 |
|
&body body) |
852 |
|
(with-gathering ((slot-vars (collecting)) |
853 |
|
(pv-parameters (collecting))) |
854 |
|
(iterate ((slots (list-elements slot-name-lists)) |
855 |
|
(required-parameter (list-elements required-parameters)) |
856 |
|
(i (interval :from 0))) |
857 |
|
(when slots |
858 |
|
(gather required-parameter pv-parameters) |
859 |
|
(gather (slot-vector-symbol i) slot-vars))) |
860 |
|
`(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars) |
861 |
|
,@body))) |
862 |
|
|
863 |
|
(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) |
864 |
|
&body body) |
865 |
|
`(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) |
866 |
|
(let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) |
867 |
|
slot-vars pv-parameters)) |
868 |
|
,@body))) |
869 |
|
|
870 |
|
;This gets used only when the default make-method-lambda is overriden. |
871 |
|
(defmacro pv-env ((pv calls pv-table-symbol pv-parameters) |
872 |
|
&rest forms) |
873 |
|
`(let* ((.pv-table. ,pv-table-symbol) |
874 |
|
(.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) |
875 |
|
(,pv (car .pv-cell.)) |
876 |
|
(,calls (cdr .pv-cell.))) |
877 |
|
(declare ,(make-pv-type-declaration pv)) |
878 |
|
(declare ,(make-calls-type-declaration calls)) |
879 |
|
,@(when (symbolp pv-table-symbol) |
880 |
|
`((declare (special ,pv-table-symbol)))) |
881 |
|
,@(progn |
882 |
|
#-cmu `(,pv ,calls) |
883 |
|
#+cmu `(declare (ignorable ,pv ,calls))) |
884 |
|
,@forms)) |
885 |
|
|
886 |
|
(defvar *non-variable-declarations* |
887 |
|
'(method-name method-lambda-list |
888 |
|
optimize ftype inline notinline)) |
889 |
|
|
890 |
|
(defvar *variable-declarations-with-argument* |
891 |
|
'(class |
892 |
|
type)) |
893 |
|
|
894 |
|
(defvar *variable-declarations-without-argument* |
895 |
|
'(ignore ignorable special dynamic-extent |
896 |
|
array atom base-char bignum bit bit-vector character common compiled-function |
897 |
|
complex cons double-float extended-char fixnum float function hash-table integer |
898 |
|
keyword list long-float nil null number package pathname random-state ratio |
899 |
|
rational readtable sequence short-float signed-byte simple-array |
900 |
|
simple-bit-vector simple-string simple-vector single-float standard-char |
901 |
|
stream string-char symbol t unsigned-byte vector)) |
902 |
|
|
903 |
|
(defun split-declarations (body args) |
904 |
|
(let ((inner-decls nil) (outer-decls nil) decl) |
905 |
|
(loop (when (null body) (return nil)) |
906 |
|
(setq decl (car body)) |
907 |
|
(unless (and (consp decl) |
908 |
|
(eq (car decl) 'declare)) |
909 |
|
(return nil)) |
910 |
|
(dolist (form (cdr decl)) |
911 |
|
(when (consp form) |
912 |
|
(let ((declaration-name (car form))) |
913 |
|
(if (member declaration-name *non-variable-declarations*) |
914 |
|
(push `(declare ,form) outer-decls) |
915 |
|
(let ((arg-p |
916 |
|
(member declaration-name |
917 |
|
*variable-declarations-with-argument*)) |
918 |
|
(non-arg-p |
919 |
|
(member declaration-name |
920 |
|
*variable-declarations-without-argument*)) |
921 |
|
(dname (list (pop form))) |
922 |
|
(inners nil) (outers nil)) |
923 |
|
(unless (or arg-p non-arg-p) |
924 |
|
(warn "The declaration ~S is not understood by ~S.~@ |
925 |
|
Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ |
926 |
|
(Assuming it is a variable declarations without argument)." |
927 |
|
declaration-name 'split-declarations |
928 |
|
declaration-name |
929 |
|
'*non-variable-declarations* |
930 |
|
'*variable-declarations-with-argument* |
931 |
|
'*variable-declarations-without-argument*) |
932 |
|
(push declaration-name |
933 |
|
*variable-declarations-without-argument*)) |
934 |
|
(when arg-p |
935 |
|
(setq dname (append dname (list (pop form))))) |
936 |
|
(dolist (var form) |
937 |
|
(if (member var args) |
938 |
|
(push var outers) |
939 |
|
(push var inners))) |
940 |
|
(when outers |
941 |
|
(push `(declare (,@dname ,@outers)) outer-decls)) |
942 |
|
(when inners |
943 |
|
(push `(declare (,@dname ,@inners)) inner-decls))))))) |
944 |
|
(setq body (cdr body))) |
945 |
|
(values outer-decls inner-decls body))) |
946 |
|
|
947 |
|
(defun make-method-initargs-form-internal (method-lambda initargs env) |
948 |
|
(declare (ignore env)) |
949 |
|
(let (method-lambda-args lmf lmf-params) |
950 |
|
(if (not (and (= 3 (length method-lambda)) |
951 |
|
(= 2 (length (setq method-lambda-args (cadr method-lambda)))) |
952 |
|
(consp (setq lmf (third method-lambda))) |
953 |
|
(eq 'simple-lexical-method-functions (car lmf)) |
954 |
|
(eq (car method-lambda-args) (cadr (setq lmf-params (cadr lmf)))) |
955 |
|
(eq (cadr method-lambda-args) (caddr lmf-params)))) |
956 |
|
`(list* :function #',method-lambda |
957 |
|
',initargs) |
958 |
|
(let* ((lambda-list (car lmf-params)) |
959 |
|
(nreq 0)(restp nil)(args nil)) |
960 |
|
(dolist (arg lambda-list) |
961 |
|
(when (member arg '(&optional &rest &key)) |
962 |
|
(setq restp t)(return nil)) |
963 |
|
(when (eq arg '&aux) (return nil)) |
964 |
|
(incf nreq)(push arg args)) |
965 |
|
(setq args (nreverse args)) |
966 |
|
(setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) |
967 |
|
(make-method-initargs-form-internal1 |
968 |
|
initargs (cddr lmf) args lmf-params restp))))) |
969 |
|
|
970 |
|
(defun make-method-initargs-form-internal1 |
971 |
|
(initargs body req-args lmf-params restp) |
972 |
|
(multiple-value-bind (outer-decls inner-decls body) |
973 |
|
(split-declarations body req-args) |
974 |
|
(let* ((rest-arg (when restp '.rest-arg.)) |
975 |
|
(args+rest-arg (if restp (append req-args (list rest-arg)) req-args))) |
976 |
|
`(list* :fast-function |
977 |
|
#'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg) |
978 |
|
,@outer-decls |
979 |
|
.pv-cell. .next-method-call. |
980 |
|
(macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) |
981 |
|
&rest forms) |
982 |
|
(declare (ignore pv-table-symbol pv-parameters)) |
983 |
|
`(let ((,pv (car .pv-cell.)) |
984 |
|
(,calls (cdr .pv-cell.))) |
985 |
|
(declare ,(make-pv-type-declaration pv) |
986 |
|
,(make-calls-type-declaration calls)) |
987 |
|
,pv ,calls |
988 |
|
,@forms))) |
989 |
|
(fast-lexical-method-functions |
990 |
|
(,(car lmf-params) .next-method-call. ,req-args ,rest-arg |
991 |
|
,@(cdddr lmf-params)) |
992 |
|
,@inner-decls |
993 |
|
,@body))) |
994 |
|
',initargs)))) |
995 |
|
|
996 |
|
;use arrays and hash tables and the fngen stuff to make this much better. |
997 |
|
;It doesn't really matter, though, because a function returned by this |
998 |
|
;will get called only when the user explicitly funcalls a result of method-function. |
999 |
|
;BUT, this is needed to make early methods work. |
1000 |
|
(defun method-function-from-fast-function (fmf) |
1001 |
|
(declare (type function fmf)) |
1002 |
|
(let* ((method-function nil) (pv-table nil) |
1003 |
|
(arg-info (method-function-get fmf ':arg-info)) |
1004 |
|
(nreq (car arg-info)) |
1005 |
|
(restp (cdr arg-info))) |
1006 |
|
(setq method-function |
1007 |
|
#'(lambda (method-args next-methods) |
1008 |
|
(unless pv-table |
1009 |
|
(setq pv-table (method-function-pv-table fmf))) |
1010 |
|
(let* ((pv-cell (when pv-table |
1011 |
|
(get-method-function-pv-cell |
1012 |
|
method-function method-args pv-table))) |
1013 |
|
(nm (car next-methods)) |
1014 |
|
(nms (cdr next-methods)) |
1015 |
|
(nmc (when nm |
1016 |
|
(make-method-call :function (if (std-instance-p nm) |
1017 |
|
(method-function nm) |
1018 |
|
nm) |
1019 |
|
:call-method-args (list nms))))) |
1020 |
|
(if restp |
1021 |
|
(let* ((rest (nthcdr nreq method-args)) |
1022 |
|
(args (ldiff method-args rest))) |
1023 |
|
(apply fmf pv-cell nmc (nconc args (list rest)))) |
1024 |
|
(apply fmf pv-cell nmc method-args))))) |
1025 |
|
(let* ((fname (method-function-get fmf :name)) |
1026 |
|
(name `(,(or (get (car fname) 'method-sym) |
1027 |
|
(setf (get (car fname) 'method-sym) |
1028 |
|
(let ((str (symbol-name (car fname)))) |
1029 |
|
(if (string= "FAST-" str :end2 5) |
1030 |
|
(intern (subseq str 5) *the-pcl-package*) |
1031 |
|
(car fname))))) |
1032 |
|
,@(cdr fname)))) |
1033 |
|
(set-function-name method-function name)) |
1034 |
|
(setf (method-function-get method-function :fast-function) fmf) |
1035 |
|
method-function)) |
1036 |
|
|
1037 |
|
(defun get-method-function-pv-cell (method-function method-args &optional pv-table) |
1038 |
|
(let ((pv-table (or pv-table (method-function-pv-table method-function)))) |
1039 |
|
(when pv-table |
1040 |
|
(let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) |
1041 |
|
(when pv-wrappers |
1042 |
|
(pv-table-lookup pv-table pv-wrappers)))))) |
1043 |
|
|
1044 |
|
(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) |
1045 |
|
(pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) |
1046 |
|
|
1047 |
|
(defun pv-wrappers-from-pv-args (&rest args) |
1048 |
|
(let* ((nkeys (length args)) |
1049 |
|
(pv-wrappers (make-list nkeys)) |
1050 |
|
w (w-t pv-wrappers)) |
1051 |
|
(declare (fixnum nkeys)) |
1052 |
|
(dolist (arg args) |
1053 |
|
(setq w |
1054 |
|
#+cmu17 (wrapper-of arg) |
1055 |
|
#-cmu17 |
1056 |
|
(cond ((std-instance-p arg) |
1057 |
|
(std-instance-wrapper arg)) |
1058 |
|
((fsc-instance-p arg) |
1059 |
|
(fsc-instance-wrapper arg)) |
1060 |
|
(t |
1061 |
|
#+new-kcl-wrapper |
1062 |
|
(built-in-wrapper-of arg) |
1063 |
|
#-new-kcl-wrapper |
1064 |
|
(built-in-or-structure-wrapper arg)))) |
1065 |
|
(unless (eq 't (wrapper-state w)) |
1066 |
|
(setq w (check-wrapper-validity arg))) |
1067 |
|
(setf (car w-t) w)) |
1068 |
|
(setq w-t (cdr w-t)) |
1069 |
|
(when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) |
1070 |
|
pv-wrappers)) |
1071 |
|
|
1072 |
|
(defun pv-wrappers-from-all-args (pv-table args) |
1073 |
|
(let ((nkeys 0) |
1074 |
|
(slot-name-lists (pv-table-slot-name-lists pv-table))) |
1075 |
|
(declare (fixnum nkeys)) |
1076 |
|
(dolist (sn slot-name-lists) |
1077 |
|
(when sn (incf nkeys))) |
1078 |
|
(let* ((pv-wrappers (make-list nkeys)) |
1079 |
|
(pv-w-t pv-wrappers)) |
1080 |
|
(dolist (sn slot-name-lists) |
1081 |
|
(when sn |
1082 |
|
(let* ((arg (car args)) |
1083 |
|
(w (wrapper-of arg))) |
1084 |
|
(unless w ; can-optimize-access prevents this from happening. |
1085 |
|
(error "error in pv-wrappers-from-all-args")) |
1086 |
|
(setf (car pv-w-t) w) |
1087 |
|
(setq pv-w-t (cdr pv-w-t)))) |
1088 |
|
(setq args (cdr args))) |
1089 |
|
(when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) |
1090 |
|
pv-wrappers))) |
1091 |
|
|
1092 |
|
(defun pv-wrappers-from-all-wrappers (pv-table wrappers) |
1093 |
|
(let ((nkeys 0) |
1094 |
|
(slot-name-lists (pv-table-slot-name-lists pv-table))) |
1095 |
|
(declare (fixnum nkeys)) |
1096 |
|
(dolist (sn slot-name-lists) |
1097 |
|
(when sn (incf nkeys))) |
1098 |
|
(let* ((pv-wrappers (make-list nkeys)) |
1099 |
|
(pv-w-t pv-wrappers)) |
1100 |
|
(dolist (sn slot-name-lists) |
1101 |
|
(when sn |
1102 |
|
(let ((w (car wrappers))) |
1103 |
|
(unless w ; can-optimize-access prevents this from happening. |
1104 |
|
(error "error in pv-wrappers-from-all-wrappers")) |
1105 |
|
(setf (car pv-w-t) w) |
1106 |
|
(setq pv-w-t (cdr pv-w-t)))) |
1107 |
|
(setq wrappers (cdr wrappers))) |
1108 |
|
(when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) |
1109 |
|
pv-wrappers))) |