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

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5