/[cmucl]/src/pcl/dlisp.lisp
ViewVC logotype

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3.2.1 - (show annotations)
Tue Jun 23 11:25:31 1998 UTC (15 years, 10 months ago) by pw
Branch: RELENG_18
CVS Tags: RELEASE_18b
Changes since 1.3: +14 -12 lines
This (huge) revision brings the RELENG_18 branch up to the current HEAD.
Note code/unix-glib2.lisp not yet included -- not sure it is ready to go.
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 #'(#+cmu kernel:instance-lambda #-cmu lambda ,args
108 #+copy-&rest-arg
109 ,@(when rest
110 `((setq .lap-rest-arg.
111 (copy-list .lap-rest-arg.))))
112 (let ()
113 (declare #.*optimize-speed*)
114 ,form)))))
115 (values (if *precompiling-lap*
116 `#',lambda
117 (compile-lambda lambda))
118 nil)))
119
120 ;;; cmu17 note: since std-instance-p is weakened, that branch may run
121 ;;; on non-pcl instances (structures). The result will be the
122 ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
123 ;;; will be whatever the first slot is, but will be ignored. Similarly,
124 ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
125 ;;;
126 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
127 (when (and (null *precompiling-lap*) *emit-function-p*)
128 (return-from emit-reader/writer
129 (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
130 (let ((instance nil)
131 (arglist ())
132 (closure-variables ())
133 (field (first-wrapper-cache-number-index))
134 (readp (eq reader/writer :reader))
135 (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
136 ;;we need some field to do the fast obsolete check
137 (ecase reader/writer
138 (:reader (setq instance (dfun-arg-symbol 0)
139 arglist (list instance)))
140 (:writer (setq instance (dfun-arg-symbol 1)
141 arglist (list (dfun-arg-symbol 0) instance))))
142 (ecase 1-or-2-class
143 (1 (setq closure-variables '(wrapper-0 index miss-fn)))
144 (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
145 (generating-lisp closure-variables
146 arglist
147 `(let* (,@(unless class-slot-p `((slots nil)))
148 (wrapper (cond ((std-instance-p ,instance)
149 ,@(unless class-slot-p
150 `((setq slots (std-instance-slots ,instance))))
151 (std-instance-wrapper ,instance))
152 ((fsc-instance-p ,instance)
153 ,@(unless class-slot-p
154 `((setq slots (fsc-instance-slots ,instance))))
155 (fsc-instance-wrapper ,instance)))))
156 (block access
157 (when (and wrapper
158 (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
159 ,@(if (eql 1 1-or-2-class)
160 `((eq wrapper wrapper-0))
161 `((or (eq wrapper wrapper-0)
162 (eq wrapper wrapper-1)))))
163 ,@(if readp
164 `((let ((value ,read-form))
165 (unless (eq value *slot-unbound*)
166 (return-from access value))))
167 `((return-from access (setf ,read-form ,(car arglist))))))
168 (funcall miss-fn ,@arglist))))))
169
170 (defun emit-slot-read-form (class-slot-p index slots)
171 (if class-slot-p
172 `(cdr ,index)
173 `(%instance-ref ,slots ,index)))
174
175 (defun emit-boundp-check (value-form miss-fn arglist)
176 `(let ((value ,value-form))
177 (if (eq value *slot-unbound*)
178 (funcall ,miss-fn ,@arglist)
179 value)))
180
181 (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
182 (let ((read-form (emit-slot-read-form class-slot-p index slots)))
183 (ecase reader/writer
184 (:reader (emit-boundp-check read-form miss-fn arglist))
185 (:writer `(setf ,read-form ,(car arglist))))))
186
187 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
188 (let ((*emit-function-p* nil)
189 (*precompiling-lap* t))
190 (values
191 (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
192
193 (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
194 (when (and (null *precompiling-lap*) *emit-function-p*)
195 (return-from emit-one-or-n-index-reader/writer
196 (emit-one-or-n-index-reader/writer-function
197 reader/writer cached-index-p class-slot-p)))
198 (multiple-value-bind (arglist metatypes)
199 (ecase reader/writer
200 (:reader (values (list (dfun-arg-symbol 0))
201 '(standard-instance)))
202 (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
203 '(t standard-instance))))
204 (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
205 arglist
206 `(let (,@(unless class-slot-p '(slots))
207 ,@(when cached-index-p '(index)))
208 ,(emit-dlap arglist metatypes
209 (emit-slot-access reader/writer class-slot-p
210 'slots 'index 'miss-fn arglist)
211 `(funcall miss-fn ,@arglist)
212 (when cached-index-p 'index)
213 (unless class-slot-p '(slots)))))))
214
215 (defmacro emit-one-or-n-index-reader/writer-macro
216 (reader/writer cached-index-p class-slot-p)
217 (let ((*emit-function-p* nil)
218 (*precompiling-lap* t))
219 (values
220 (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
221
222 (defun emit-miss (miss-fn args &optional applyp)
223 (let ((restl (when applyp '(.lap-rest-arg.))))
224 (if restl
225 `(apply ,miss-fn ,@args ,@restl)
226 `(funcall ,miss-fn ,@args ,@restl))))
227
228 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
229 (when (and (null *precompiling-lap*) *emit-function-p*)
230 (return-from emit-checking-or-caching
231 (emit-checking-or-caching-function
232 cached-emf-p return-value-p metatypes applyp)))
233 (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
234 (args (remove '&rest dlap-lambda-list))
235 (restl (when applyp '(.lap-rest-arg.))))
236 (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
237 dlap-lambda-list
238 `(let (,@(when cached-emf-p '(emf)))
239 ,(emit-dlap args
240 metatypes
241 (if return-value-p
242 (if cached-emf-p 'emf t)
243 `(invoke-effective-method-function emf ,applyp
244 ,@args ,@restl))
245 (emit-miss 'miss-fn args applyp)
246 (when cached-emf-p 'emf))))))
247
248 (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
249 (let ((*emit-function-p* nil)
250 (*precompiling-lap* t))
251 (values
252 (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
253
254 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
255 (let* ((index -1)
256 (wrapper-bindings (mapcan #'(lambda (arg mt)
257 (unless (eq mt 't)
258 (incf index)
259 `((,(intern (format nil "WRAPPER-~D" index)
260 *the-pcl-package*)
261 ,(emit-fetch-wrapper mt arg 'miss
262 (pop slot-regs))))))
263 args metatypes))
264 (wrappers (mapcar #'car wrapper-bindings)))
265 (declare (fixnum index))
266 (unless wrappers (error "Every metatype is T."))
267 `(block dfun
268 (tagbody
269 (let ((field (cache-field cache))
270 (cache-vector (cache-vector cache))
271 (mask (cache-mask cache))
272 (size (cache-size cache))
273 (overflow (cache-overflow cache))
274 ,@wrapper-bindings)
275 (declare (fixnum size field mask))
276 ,(cond ((cdr wrappers)
277 (emit-greater-than-1-dlap wrappers 'miss value-reg))
278 (value-reg
279 (emit-1-t-dlap (car wrappers) 'miss value-reg))
280 (t
281 (emit-1-nil-dlap (car wrappers) 'miss)))
282 (return-from dfun ,hit))
283 miss
284 (return-from dfun ,miss)))))
285
286 (defun emit-1-nil-dlap (wrapper miss-label)
287 `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
288 (location primary))
289 (declare (fixnum primary location))
290 (block search
291 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
292 (return-from search nil))
293 (setq location (the fixnum (+ location 1)))
294 (when (= location size)
295 (setq location 0))
296 (when (= location primary)
297 (dolist (entry overflow)
298 (when (eq (car entry) ,wrapper)
299 (return-from search nil)))
300 (go ,miss-label))))))
301
302 (defmacro get-cache-vector-lock-count (cache-vector)
303 `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
304 (unless (typep lock-count 'fixnum)
305 (error "my cache got freed somehow"))
306 (the fixnum lock-count)))
307
308 (defun emit-1-t-dlap (wrapper miss-label value)
309 `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
310 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
311 (declare (fixnum primary initial-lock-count))
312 (let ((location primary))
313 (declare (fixnum location))
314 (block search
315 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
316 (setq ,value (cache-vector-ref cache-vector (1+ location)))
317 (return-from search nil))
318 (setq location (the fixnum (+ location 2)))
319 (when (= location size)
320 (setq location 0))
321 (when (= location primary)
322 (dolist (entry overflow)
323 (when (eq (car entry) ,wrapper)
324 (setq ,value (cdr entry))
325 (return-from search nil)))
326 (go ,miss-label))))
327 (unless (= initial-lock-count
328 (get-cache-vector-lock-count cache-vector))
329 (go ,miss-label)))))
330
331 (defun emit-greater-than-1-dlap (wrappers miss-label value)
332 (declare (type list wrappers))
333 (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
334 `(let ((primary 0) (size-1 (the fixnum (- size 1))))
335 (declare (fixnum primary size-1))
336 ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
337 (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
338 (declare (fixnum initial-lock-count))
339 (let ((location primary) (next-location 0))
340 (declare (fixnum location next-location))
341 (block search
342 (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
343 (when (and ,@(mapcar
344 #'(lambda (wrapper)
345 `(eq ,wrapper
346 (cache-vector-ref cache-vector
347 (setq location
348 (the fixnum (+ location 1))))))
349 wrappers))
350 ,@(when value
351 `((setq location (the fixnum (+ location 1)))
352 (setq ,value (cache-vector-ref cache-vector location))))
353 (return-from search nil))
354 (setq location next-location)
355 (when (= location size-1)
356 (setq location 0))
357 (when (= location primary)
358 (dolist (entry overflow)
359 (let ((entry-wrappers (car entry)))
360 (when (and ,@(mapcar #'(lambda (wrapper)
361 `(eq ,wrapper (pop entry-wrappers)))
362 wrappers))
363 ,@(when value
364 `((setq ,value (cdr entry))))
365 (return-from search nil))))
366 (go ,miss-label))))
367 (unless (= initial-lock-count
368 (get-cache-vector-lock-count cache-vector))
369 (go ,miss-label)))))))
370
371 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
372 `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
373 (declare (fixnum wrapper-cache-no))
374 (when (zerop wrapper-cache-no) (go ,miss-label))
375 ,(let ((form `(#+lucid %logand #-lucid logand
376 mask wrapper-cache-no)))
377 #+lucid form
378 #-lucid `(the fixnum ,form))))
379
380 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
381 (declare (type list wrappers))
382 ;; this returns 1 less that the actual location
383 `(progn
384 ,@(let ((adds 0) (len (length wrappers)))
385 (declare (fixnum adds len))
386 (mapcar #'(lambda (wrapper)
387 `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
388 ,wrapper field)))
389 (declare (fixnum wrapper-cache-no))
390 (when (zerop wrapper-cache-no) (go ,miss-label))
391 (setq primary (the fixnum (+ primary wrapper-cache-no)))
392 ,@(progn
393 (incf adds)
394 (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
395 (eql adds len))
396 `((setq primary
397 ,(let ((form `(#+lucid %logand #-lucid logand
398 primary mask)))
399 #+lucid form
400 #-lucid `(the fixnum ,form))))))))
401 wrappers))))
402
403 ;;; cmu17 note: since std-instance-p is weakened, that branch may run
404 ;;; on non-pcl instances (structures). The result will be the
405 ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
406 ;;; will be whatever the first slot is, but will be ignored. Similarly,
407 ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
408 ;;;
409 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
410 (ecase metatype
411 ((standard-instance #+new-kcl-wrapper structure-instance)
412 `(cond ((std-instance-p ,argument)
413 ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
414 (std-instance-wrapper ,argument))
415 ((fsc-instance-p ,argument)
416 ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
417 (fsc-instance-wrapper ,argument))
418 (t
419 (go ,miss-label))))
420 (class
421 (when slot (error "Can't do a slot reg for this metatype."))
422 `(wrapper-of-macro ,argument))
423 ((built-in-instance #-new-kcl-wrapper structure-instance)
424 (when slot (error "Can't do a slot reg for this metatype."))
425 `(#+new-kcl-wrapper built-in-wrapper-of
426 #-new-kcl-wrapper built-in-or-structure-wrapper
427 ,argument))))
428

  ViewVC Help
Powered by ViewVC 1.1.5