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 |
|
|
28 |
|
(in-package :pcl) |
29 |
|
|
30 |
|
;;; This file is (almost) functionally equivalent to dlap.lisp, |
31 |
|
;;; but easier to read. |
32 |
|
|
33 |
|
;;; Might generate faster code, too, depending on the compiler and |
34 |
|
;;; whether an implementation-specific lap assembler was used. |
35 |
|
|
36 |
|
(defun emit-one-class-reader (class-slot-p) |
37 |
|
(emit-reader/writer :reader 1 class-slot-p)) |
38 |
|
|
39 |
|
(defun emit-one-class-writer (class-slot-p) |
40 |
|
(emit-reader/writer :writer 1 class-slot-p)) |
41 |
|
|
42 |
|
(defun emit-two-class-reader (class-slot-p) |
43 |
|
(emit-reader/writer :reader 2 class-slot-p)) |
44 |
|
|
45 |
|
(defun emit-two-class-writer (class-slot-p) |
46 |
|
(emit-reader/writer :writer 2 class-slot-p)) |
47 |
|
|
48 |
|
;;; -------------------------------- |
49 |
|
|
50 |
|
(defun emit-one-index-readers (class-slot-p) |
51 |
|
(emit-one-or-n-index-reader/writer :reader nil class-slot-p)) |
52 |
|
|
53 |
|
(defun emit-one-index-writers (class-slot-p) |
54 |
|
(emit-one-or-n-index-reader/writer :writer nil class-slot-p)) |
55 |
|
|
56 |
|
(defun emit-n-n-readers () |
57 |
|
(emit-one-or-n-index-reader/writer :reader t nil)) |
58 |
|
|
59 |
|
(defun emit-n-n-writers () |
60 |
|
(emit-one-or-n-index-reader/writer :writer t nil)) |
61 |
|
|
62 |
|
;;; -------------------------------- |
63 |
|
|
64 |
|
(defun emit-checking (metatypes applyp) |
65 |
|
(emit-checking-or-caching nil nil metatypes applyp)) |
66 |
|
|
67 |
|
(defun emit-caching (metatypes applyp) |
68 |
|
(emit-checking-or-caching t nil metatypes applyp)) |
69 |
|
|
70 |
|
(defun emit-in-checking-cache-p (metatypes) |
71 |
|
(emit-checking-or-caching nil t metatypes nil)) |
72 |
|
|
73 |
|
(defun emit-constant-value (metatypes) |
74 |
|
(emit-checking-or-caching t t metatypes nil)) |
75 |
|
|
76 |
|
;;; -------------------------------- |
77 |
|
|
78 |
|
(defvar *precompiling-lap* nil) |
79 |
|
(defvar *emit-function-p* t) |
80 |
|
|
81 |
|
(defun emit-default-only (metatypes applyp) |
82 |
|
(when (and (null *precompiling-lap*) *emit-function-p*) |
83 |
|
(return-from emit-default-only |
84 |
|
(emit-default-only-function metatypes applyp))) |
85 |
|
(let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) |
86 |
|
(args (remove '&rest dlap-lambda-list)) |
87 |
|
(restl (when applyp '(.lap-rest-arg.)))) |
88 |
|
(generating-lisp '(emf) |
89 |
|
dlap-lambda-list |
90 |
|
`(invoke-effective-method-function emf ,applyp ,@args ,@restl)))) |
91 |
|
|
92 |
|
(defmacro emit-default-only-macro (metatypes applyp) |
93 |
|
(let ((*emit-function-p* nil) |
94 |
|
(*precompiling-lap* t)) |
95 |
|
(values |
96 |
|
(emit-default-only metatypes applyp)))) |
97 |
|
|
98 |
|
;;; -------------------------------- |
99 |
|
|
100 |
|
(defun generating-lisp (closure-variables args form) |
101 |
|
(let* ((rest (memq '&rest args)) |
102 |
|
(ldiff (and rest (ldiff args rest))) |
103 |
|
(args (if rest (append ldiff '(&rest .lap-rest-arg.)) args)) |
104 |
|
(lambda `(lambda ,closure-variables |
105 |
|
,@(when (member 'miss-fn closure-variables) |
106 |
|
`((declare (type function miss-fn)))) |
107 |
|
(fin-lambda-fn ,args |
108 |
|
#+copy-&rest-arg |
109 |
|
,@(when rest |
110 |
|
`((setq .lap-rest-arg. (copy-list .lap-rest-arg.)))) |
111 |
|
(let () |
112 |
|
(declare #.*optimize-speed*) |
113 |
|
,form))))) |
114 |
|
(values (if *precompiling-lap* |
115 |
|
`#',lambda |
116 |
|
(compile-lambda lambda)) |
117 |
|
nil))) |
118 |
|
|
119 |
|
;;; cmu17 note: since std-instance-p is weakened, that branch may run |
120 |
|
;;; on non-pcl instances (structures). The result will be the |
121 |
|
;;; non-wrapper layout for the structure, which will cause a miss. The "slots" |
122 |
|
;;; will be whatever the first slot is, but will be ignored. Similarly, |
123 |
|
;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. |
124 |
|
;;; |
125 |
|
(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) |
126 |
|
(when (and (null *precompiling-lap*) *emit-function-p*) |
127 |
|
(return-from emit-reader/writer |
128 |
|
(emit-reader/writer-function reader/writer 1-or-2-class class-slot-p))) |
129 |
|
(let ((instance nil) |
130 |
|
(arglist ()) |
131 |
|
(closure-variables ()) |
132 |
|
(field (first-wrapper-cache-number-index)) |
133 |
|
(readp (eq reader/writer :reader)) |
134 |
|
(read-form (emit-slot-read-form class-slot-p 'index 'slots))) |
135 |
|
;;we need some field to do the fast obsolete check |
136 |
|
(ecase reader/writer |
137 |
|
(:reader (setq instance (dfun-arg-symbol 0) |
138 |
|
arglist (list instance))) |
139 |
|
(:writer (setq instance (dfun-arg-symbol 1) |
140 |
|
arglist (list (dfun-arg-symbol 0) instance)))) |
141 |
|
(ecase 1-or-2-class |
142 |
|
(1 (setq closure-variables '(wrapper-0 index miss-fn))) |
143 |
|
(2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) |
144 |
|
(generating-lisp closure-variables |
145 |
|
arglist |
146 |
|
`(let* (,@(unless class-slot-p `((slots nil))) |
147 |
|
(wrapper (cond ((std-instance-p ,instance) |
148 |
|
,@(unless class-slot-p |
149 |
|
`((setq slots (std-instance-slots ,instance)))) |
150 |
|
(std-instance-wrapper ,instance)) |
151 |
|
((fsc-instance-p ,instance) |
152 |
|
,@(unless class-slot-p |
153 |
|
`((setq slots (fsc-instance-slots ,instance)))) |
154 |
|
(fsc-instance-wrapper ,instance)))) |
155 |
|
,@(when readp '(value))) |
156 |
|
(if (or (null wrapper) |
157 |
|
(zerop (wrapper-cache-number-vector-ref wrapper ,field)) |
158 |
|
(not (or (eq wrapper wrapper-0) |
159 |
|
,@(when (eql 2 1-or-2-class) |
160 |
|
`((eq wrapper wrapper-1))))) |
161 |
|
,@(when readp `((eq *slot-unbound* (setq value ,read-form))))) |
162 |
|
(funcall miss-fn ,@arglist) |
163 |
|
,(if readp |
164 |
|
'value |
165 |
|
`(setf ,read-form ,(car arglist)))))))) |
166 |
|
|
167 |
|
(defun emit-slot-read-form (class-slot-p index slots) |
168 |
|
(if class-slot-p |
169 |
|
`(cdr ,index) |
170 |
|
`(%instance-ref ,slots ,index))) |
171 |
|
|
172 |
|
(defun emit-boundp-check (value-form miss-fn arglist) |
173 |
|
`(let ((value ,value-form)) |
174 |
|
(if (eq value *slot-unbound*) |
175 |
|
(funcall ,miss-fn ,@arglist) |
176 |
|
value))) |
177 |
|
|
178 |
|
(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist) |
179 |
|
(let ((read-form (emit-slot-read-form class-slot-p index slots))) |
180 |
|
(ecase reader/writer |
181 |
|
(:reader (emit-boundp-check read-form miss-fn arglist)) |
182 |
|
(:writer `(setf ,read-form ,(car arglist)))))) |
183 |
|
|
184 |
|
(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p) |
185 |
|
(let ((*emit-function-p* nil) |
186 |
|
(*precompiling-lap* t)) |
187 |
|
(values |
188 |
|
(emit-reader/writer reader/writer 1-or-2-class class-slot-p)))) |
189 |
|
|
190 |
|
(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p) |
191 |
|
(when (and (null *precompiling-lap*) *emit-function-p*) |
192 |
|
(return-from emit-one-or-n-index-reader/writer |
193 |
|
(emit-one-or-n-index-reader/writer-function |
194 |
|
reader/writer cached-index-p class-slot-p))) |
195 |
|
(multiple-value-bind (arglist metatypes) |
196 |
|
(ecase reader/writer |
197 |
|
(:reader (values (list (dfun-arg-symbol 0)) |
198 |
|
'(standard-instance))) |
199 |
|
(:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1)) |
200 |
|
'(t standard-instance)))) |
201 |
|
(generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn) |
202 |
|
arglist |
203 |
|
`(let (,@(unless class-slot-p '(slots)) |
204 |
|
,@(when cached-index-p '(index))) |
205 |
|
,(emit-dlap arglist metatypes |
206 |
|
(emit-slot-access reader/writer class-slot-p |
207 |
|
'slots 'index 'miss-fn arglist) |
208 |
|
`(funcall miss-fn ,@arglist) |
209 |
|
(when cached-index-p 'index) |
210 |
|
(unless class-slot-p '(slots))))))) |
211 |
|
|
212 |
|
(defmacro emit-one-or-n-index-reader/writer-macro |
213 |
|
(reader/writer cached-index-p class-slot-p) |
214 |
|
(let ((*emit-function-p* nil) |
215 |
|
(*precompiling-lap* t)) |
216 |
|
(values |
217 |
|
(emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p)))) |
218 |
|
|
219 |
|
(defun emit-miss (miss-fn args &optional applyp) |
220 |
|
(let ((restl (when applyp '(.lap-rest-arg.)))) |
221 |
|
(if restl |
222 |
|
`(apply ,miss-fn ,@args ,@restl) |
223 |
|
`(funcall ,miss-fn ,@args ,@restl)))) |
224 |
|
|
225 |
|
(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp) |
226 |
|
(when (and (null *precompiling-lap*) *emit-function-p*) |
227 |
|
(return-from emit-checking-or-caching |
228 |
|
(emit-checking-or-caching-function |
229 |
|
cached-emf-p return-value-p metatypes applyp))) |
230 |
|
(let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)) |
231 |
|
(args (remove '&rest dlap-lambda-list)) |
232 |
|
(restl (when applyp '(.lap-rest-arg.)))) |
233 |
|
(generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn) |
234 |
|
dlap-lambda-list |
235 |
|
`(let (,@(when cached-emf-p '(emf))) |
236 |
|
,(emit-dlap args |
237 |
|
metatypes |
238 |
|
(if return-value-p |
239 |
|
(if cached-emf-p 'emf t) |
240 |
|
`(invoke-effective-method-function emf ,applyp |
241 |
|
,@args ,@restl)) |
242 |
|
(emit-miss 'miss-fn args applyp) |
243 |
|
(when cached-emf-p 'emf)))))) |
244 |
|
|
245 |
|
(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp) |
246 |
|
(let ((*emit-function-p* nil) |
247 |
|
(*precompiling-lap* t)) |
248 |
|
(values |
249 |
|
(emit-checking-or-caching cached-emf-p return-value-p metatypes applyp)))) |
250 |
|
|
251 |
|
(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs) |
252 |
|
(let* ((index -1) |
253 |
|
(wrapper-bindings (mapcan #'(lambda (arg mt) |
254 |
|
(unless (eq mt 't) |
255 |
|
(incf index) |
256 |
|
`((,(intern (format nil "WRAPPER-~D" index) |
257 |
|
*the-pcl-package*) |
258 |
|
,(emit-fetch-wrapper mt arg 'miss |
259 |
|
(pop slot-regs)))))) |
260 |
|
args metatypes)) |
261 |
|
(wrappers (mapcar #'car wrapper-bindings))) |
262 |
|
(declare (fixnum index)) |
263 |
|
(unless wrappers (error "Every metatype is T.")) |
264 |
|
`(block dfun |
265 |
|
(tagbody |
266 |
|
(let ((field (cache-field cache)) |
267 |
|
(cache-vector (cache-vector cache)) |
268 |
|
(mask (cache-mask cache)) |
269 |
|
(size (cache-size cache)) |
270 |
|
(overflow (cache-overflow cache)) |
271 |
|
,@wrapper-bindings) |
272 |
|
(declare (fixnum size field mask)) |
273 |
|
,(cond ((cdr wrappers) |
274 |
|
(emit-greater-than-1-dlap wrappers 'miss value-reg)) |
275 |
|
(value-reg |
276 |
|
(emit-1-t-dlap (car wrappers) 'miss value-reg)) |
277 |
|
(t |
278 |
|
(emit-1-nil-dlap (car wrappers) 'miss))) |
279 |
|
(return-from dfun ,hit)) |
280 |
|
miss |
281 |
|
(return-from dfun ,miss))))) |
282 |
|
|
283 |
|
(defun emit-1-nil-dlap (wrapper miss-label) |
284 |
|
`(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) |
285 |
|
(location primary)) |
286 |
|
(declare (fixnum primary location)) |
287 |
|
(block search |
288 |
|
(loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) |
289 |
|
(return-from search nil)) |
290 |
|
(setq location (the fixnum (+ location 1))) |
291 |
|
(when (= location size) |
292 |
|
(setq location 0)) |
293 |
|
(when (= location primary) |
294 |
|
(dolist (entry overflow) |
295 |
|
(when (eq (car entry) ,wrapper) |
296 |
|
(return-from search nil))) |
297 |
|
(go ,miss-label)))))) |
298 |
|
|
299 |
|
(defmacro get-cache-vector-lock-count (cache-vector) |
300 |
|
`(let ((lock-count (cache-vector-lock-count ,cache-vector))) |
301 |
|
(unless (typep lock-count 'fixnum) |
302 |
|
(error "my cache got freed somehow")) |
303 |
|
(the fixnum lock-count))) |
304 |
|
|
305 |
|
(defun emit-1-t-dlap (wrapper miss-label value) |
306 |
|
`(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label)) |
307 |
|
(initial-lock-count (get-cache-vector-lock-count cache-vector))) |
308 |
|
(declare (fixnum primary initial-lock-count)) |
309 |
|
(let ((location primary)) |
310 |
|
(declare (fixnum location)) |
311 |
|
(block search |
312 |
|
(loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) |
313 |
|
(setq ,value (cache-vector-ref cache-vector (1+ location))) |
314 |
|
(return-from search nil)) |
315 |
|
(setq location (the fixnum (+ location 2))) |
316 |
|
(when (= location size) |
317 |
|
(setq location 0)) |
318 |
|
(when (= location primary) |
319 |
|
(dolist (entry overflow) |
320 |
|
(when (eq (car entry) ,wrapper) |
321 |
|
(setq ,value (cdr entry)) |
322 |
|
(return-from search nil))) |
323 |
|
(go ,miss-label)))) |
324 |
|
(unless (= initial-lock-count |
325 |
|
(get-cache-vector-lock-count cache-vector)) |
326 |
|
(go ,miss-label))))) |
327 |
|
|
328 |
|
(defun emit-greater-than-1-dlap (wrappers miss-label value) |
329 |
|
(declare (type list wrappers)) |
330 |
|
(let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0))))) |
331 |
|
`(let ((primary 0) (size-1 (the fixnum (- size 1)))) |
332 |
|
(declare (fixnum primary size-1)) |
333 |
|
,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) |
334 |
|
(let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) |
335 |
|
(declare (fixnum initial-lock-count)) |
336 |
|
(let ((location primary) (next-location 0)) |
337 |
|
(declare (fixnum location next-location)) |
338 |
|
(block search |
339 |
|
(loop (setq next-location (the fixnum (+ location ,cache-line-size))) |
340 |
|
(when (and ,@(mapcar |
341 |
|
#'(lambda (wrapper) |
342 |
|
`(eq ,wrapper |
343 |
|
(cache-vector-ref cache-vector |
344 |
|
(setq location |
345 |
|
(the fixnum (+ location 1)))))) |
346 |
|
wrappers)) |
347 |
|
,@(when value |
348 |
|
`((setq location (the fixnum (+ location 1))) |
349 |
|
(setq ,value (cache-vector-ref cache-vector location)))) |
350 |
|
(return-from search nil)) |
351 |
|
(setq location next-location) |
352 |
|
(when (= location size-1) |
353 |
|
(setq location 0)) |
354 |
|
(when (= location primary) |
355 |
|
(dolist (entry overflow) |
356 |
|
(let ((entry-wrappers (car entry))) |
357 |
|
(when (and ,@(mapcar #'(lambda (wrapper) |
358 |
|
`(eq ,wrapper (pop entry-wrappers))) |
359 |
|
wrappers)) |
360 |
|
,@(when value |
361 |
|
`((setq ,value (cdr entry)))) |
362 |
|
(return-from search nil)))) |
363 |
|
(go ,miss-label)))) |
364 |
|
(unless (= initial-lock-count |
365 |
|
(get-cache-vector-lock-count cache-vector)) |
366 |
|
(go ,miss-label))))))) |
367 |
|
|
368 |
|
(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) |
369 |
|
`(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field))) |
370 |
|
(declare (fixnum wrapper-cache-no)) |
371 |
|
(when (zerop wrapper-cache-no) (go ,miss-label)) |
372 |
|
,(let ((form `(#+lucid %logand #-lucid logand |
373 |
|
mask wrapper-cache-no))) |
374 |
|
#+lucid form |
375 |
|
#-lucid `(the fixnum ,form)))) |
376 |
|
|
377 |
|
(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) |
378 |
|
(declare (type list wrappers)) |
379 |
|
;; this returns 1 less that the actual location |
380 |
|
`(progn |
381 |
|
,@(let ((adds 0) (len (length wrappers))) |
382 |
|
(declare (fixnum adds len)) |
383 |
|
(mapcar #'(lambda (wrapper) |
384 |
|
`(let ((wrapper-cache-no (wrapper-cache-number-vector-ref |
385 |
|
,wrapper field))) |
386 |
|
(declare (fixnum wrapper-cache-no)) |
387 |
|
(when (zerop wrapper-cache-no) (go ,miss-label)) |
388 |
|
(setq primary (the fixnum (+ primary wrapper-cache-no))) |
389 |
|
,@(progn |
390 |
|
(incf adds) |
391 |
|
(when (or (zerop (mod adds wrapper-cache-number-adds-ok)) |
392 |
|
(eql adds len)) |
393 |
|
`((setq primary |
394 |
|
,(let ((form `(#+lucid %logand #-lucid logand |
395 |
|
primary mask))) |
396 |
|
#+lucid form |
397 |
|
#-lucid `(the fixnum ,form)))))))) |
398 |
|
wrappers)))) |
399 |
|
|
400 |
|
;;; cmu17 note: since std-instance-p is weakened, that branch may run |
401 |
|
;;; on non-pcl instances (structures). The result will be the |
402 |
|
;;; non-wrapper layout for the structure, which will cause a miss. The "slots" |
403 |
|
;;; will be whatever the first slot is, but will be ignored. Similarly, |
404 |
|
;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. |
405 |
|
;;; |
406 |
|
(defun emit-fetch-wrapper (metatype argument miss-label &optional slot) |
407 |
|
(ecase metatype |
408 |
|
((standard-instance #+new-kcl-wrapper structure-instance) |
409 |
|
`(cond ((std-instance-p ,argument) |
410 |
|
,@(when slot `((setq ,slot (std-instance-slots ,argument)))) |
411 |
|
(std-instance-wrapper ,argument)) |
412 |
|
((fsc-instance-p ,argument) |
413 |
|
,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) |
414 |
|
(fsc-instance-wrapper ,argument)) |
415 |
|
(t |
416 |
|
(go ,miss-label)))) |
417 |
|
(class |
418 |
|
(when slot (error "Can't do a slot reg for this metatype.")) |
419 |
|
`(wrapper-of-macro ,argument)) |
420 |
|
((built-in-instance #-new-kcl-wrapper structure-instance) |
421 |
|
(when slot (error "Can't do a slot reg for this metatype.")) |
422 |
|
`(#+new-kcl-wrapper built-in-wrapper-of |
423 |
|
#-new-kcl-wrapper built-in-or-structure-wrapper |
424 |
|
,argument)))) |
425 |
|
|