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

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12.48.2 - (show annotations)
Sat Feb 13 01:28:04 2010 UTC (4 years, 2 months ago) by rtoy
Branch: intl-branch
CVS Tags: intl-branch-working-2010-02-19-1000, intl-branch-2010-03-18-1300
Changes since 1.12.48.1: +4 -4 lines
Mark translatable strings; regenerate cmucl.pot and cmucl.po
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 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/dlisp.lisp,v 1.12.48.2 2010/02/13 01:28:04 rtoy Exp $")
29 ;;;
30
31 (in-package :pcl)
32 (intl:textdomain "cmucl")
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-boundp (class-slot-p)
44 (emit-reader/writer :boundp 1 class-slot-p))
45
46 (defun emit-one-class-writer (class-slot-p)
47 (emit-reader/writer :writer 1 class-slot-p))
48
49 (defun emit-two-class-reader (class-slot-p)
50 (emit-reader/writer :reader 2 class-slot-p))
51
52 (defun emit-two-class-boundp (class-slot-p)
53 (emit-reader/writer :boundp 2 class-slot-p))
54
55 (defun emit-two-class-writer (class-slot-p)
56 (emit-reader/writer :writer 2 class-slot-p))
57
58 ;;; --------------------------------
59
60 (defun emit-one-index-readers (class-slot-p)
61 (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
62
63 (defun emit-one-index-boundps (class-slot-p)
64 (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
65
66 (defun emit-one-index-writers (class-slot-p)
67 (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
68
69 (defun emit-n-n-readers ()
70 (emit-one-or-n-index-reader/writer :reader t nil))
71
72 (defun emit-n-n-boundps ()
73 (emit-one-or-n-index-reader/writer :boundp t nil))
74
75 (defun emit-n-n-writers ()
76 (emit-one-or-n-index-reader/writer :writer t nil))
77
78 ;;; --------------------------------
79
80 (defun emit-checking (metatypes applyp)
81 (emit-checking-or-caching nil nil metatypes applyp))
82
83 (defun emit-caching (metatypes applyp)
84 (emit-checking-or-caching t nil metatypes applyp))
85
86 (defun emit-in-checking-cache-p (metatypes)
87 (emit-checking-or-caching nil t metatypes nil))
88
89 (defun emit-constant-value (metatypes)
90 (emit-checking-or-caching t t metatypes nil))
91
92 ;;; --------------------------------
93
94 (defvar *precompiling-lap* nil)
95 (defvar *emit-function-p* t)
96
97 (defvar *optimize-cache-functions-p* t)
98
99 (defun emit-default-only (metatypes applyp)
100 (unless *optimize-cache-functions-p*
101 (when (and (null *precompiling-lap*) *emit-function-p*)
102 (return-from emit-default-only
103 (emit-default-only-function metatypes applyp))))
104 (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
105 (args (remove '&rest dlap-lambda-list))
106 (restl (when applyp '(.lap-rest-arg.))))
107 (generating-lisp '(emf)
108 dlap-lambda-list
109 `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
110
111 ;;; --------------------------------
112
113 (defun generating-lisp (closure-variables args form)
114 (let* ((rest (memq '&rest args))
115 (ldiff (and rest (ldiff args rest)))
116 (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
117 (lambda `(lambda ,closure-variables
118 ,@(when (member 'miss-fn closure-variables)
119 `((declare (type function miss-fn))))
120 #'(kernel:instance-lambda ,args
121 ;;
122 ;; Don't ask me why LOCALLY is necessary here.
123 ;; Fact is that without it the resulting code is
124 ;; up ta 25% slower. --gerd 2002-10-26.
125 (locally (declare #.*optimize-speed*)
126 ,form)))))
127 (values (if *precompiling-lap*
128 `#',lambda
129 (compile-lambda lambda))
130 nil)))
131
132 ;;;
133 ;;; cmu17 note: since std-instance-p is weakened, that branch may run
134 ;;; on non-pcl instances (structures). The result will be the
135 ;;; non-wrapper layout for the structure, which will cause a miss.
136 ;;; The "slots" will be whatever the first slot is, but will be
137 ;;; ignored. Similarly, fsc-instance-p returns true on funcallable
138 ;;; structures as well as PCL fins.
139 ;;;
140 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
141 (unless *optimize-cache-functions-p*
142 (when (and (null *precompiling-lap*) *emit-function-p*)
143 (return-from emit-reader/writer
144 (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p))))
145 (let* ((instance
146 (ecase reader/writer
147 ((:reader :boundp) (dfun-arg-symbol 0))
148 (:writer (dfun-arg-symbol 1))))
149 (arglist
150 (ecase reader/writer
151 ((:reader :boundp) (list instance))
152 (:writer (list (dfun-arg-symbol 0) instance))))
153 (closure-variables
154 (ecase 1-or-2-class
155 (1 '(wrapper-0 index miss-fn))
156 (2 '(wrapper-0 wrapper-1 index miss-fn))))
157 (read-form
158 (emit-slot-read-form class-slot-p 'index 'slots)))
159 (generating-lisp closure-variables arglist
160 `(let* (,@(unless class-slot-p `((slots nil)))
161 (wrapper (cond ((std-instance-p ,instance)
162 ,@(unless class-slot-p
163 `((setq slots (std-instance-slots ,instance))))
164 (std-instance-wrapper ,instance))
165 ((fsc-instance-p ,instance)
166 ,@(unless class-slot-p
167 `((setq slots (fsc-instance-slots ,instance))))
168 (fsc-instance-wrapper ,instance)))))
169 (block access
170 (when (and wrapper
171 (not (zerop (kernel:layout-hash wrapper 0)))
172 ,@(if (eql 1 1-or-2-class)
173 `((eq wrapper wrapper-0))
174 `((or (eq wrapper wrapper-0)
175 (eq wrapper wrapper-1)))))
176 ,@(ecase reader/writer
177 (:reader
178 `((let ((value ,read-form))
179 (unless (eq value +slot-unbound+)
180 (return-from access value)))))
181 (:boundp
182 `((let ((value ,read-form))
183 (return-from access (not (eq value +slot-unbound+))))))
184 (:writer
185 `((return-from access (setf ,read-form ,(car arglist)))))))
186 (funcall miss-fn ,@arglist))))))
187
188 (defun emit-slot-read-form (class-slot-p index slots)
189 (if class-slot-p
190 `(cdr ,index)
191 `(%slot-ref ,slots ,index)))
192
193 (defun emit-boundp-check (value-form miss-fn arglist)
194 `(let ((value ,value-form))
195 (if (eq value +slot-unbound+)
196 (funcall ,miss-fn ,@arglist)
197 value)))
198
199 (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
200 (let ((read-form (emit-slot-read-form class-slot-p index slots)))
201 (ecase reader/writer
202 (:reader (emit-boundp-check read-form miss-fn arglist))
203 (:boundp `(not (eq +slot-unbound+ ,read-form)))
204 (:writer `(setf ,read-form ,(car arglist))))))
205
206 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
207 (let ((*emit-function-p* nil)
208 (*precompiling-lap* t))
209 (values
210 (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
211
212 (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
213 (unless *optimize-cache-functions-p*
214 (when (and (null *precompiling-lap*) *emit-function-p*)
215 (return-from emit-one-or-n-index-reader/writer
216 (emit-one-or-n-index-reader/writer-function
217 reader/writer cached-index-p class-slot-p))))
218 (multiple-value-bind (arglist metatypes)
219 (ecase reader/writer
220 ((:reader :boundp)
221 (values (list (dfun-arg-symbol 0))
222 '(standard-instance)))
223 (:writer
224 (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
225 '(t standard-instance))))
226 (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
227 arglist
228 `(let (,@(unless class-slot-p '(slots))
229 ,@(when cached-index-p '(index)))
230 ,(emit-dlap arglist metatypes
231 (emit-slot-access reader/writer class-slot-p
232 'slots 'index 'miss-fn arglist)
233 `(funcall miss-fn ,@arglist)
234 (when cached-index-p 'index)
235 (unless class-slot-p '(slots)))))))
236
237 (defmacro emit-one-or-n-index-reader/writer-macro
238 (reader/writer cached-index-p class-slot-p)
239 (let ((*emit-function-p* nil)
240 (*precompiling-lap* t))
241 (values
242 (emit-one-or-n-index-reader/writer reader/writer cached-index-p
243 class-slot-p))))
244
245 (defun emit-miss (miss-fn args &optional applyp)
246 (let ((restl (when applyp '(.lap-rest-arg.))))
247 (if restl
248 `(apply ,miss-fn ,@args ,@restl)
249 `(funcall ,miss-fn ,@args ,@restl))))
250
251 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
252 (unless *optimize-cache-functions-p*
253 (when (and (null *precompiling-lap*) *emit-function-p*)
254 (return-from emit-checking-or-caching
255 (emit-checking-or-caching-function
256 cached-emf-p return-value-p metatypes applyp))))
257 (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
258 (args (remove '&rest dlap-lambda-list))
259 (restl (when applyp '(.lap-rest-arg.))))
260 (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
261 dlap-lambda-list
262 `(let (,@(when cached-emf-p '(emf)))
263 ,(emit-dlap args
264 metatypes
265 (if return-value-p
266 (if cached-emf-p 'emf t)
267 `(invoke-effective-method-function emf ,applyp
268 ,@args ,@restl))
269 (emit-miss 'miss-fn args applyp)
270 (when cached-emf-p 'emf))))))
271
272 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
273 (let* ((index -1)
274 (wrapper-bindings (mapcan (lambda (arg mt)
275 (unless (eq mt t)
276 (incf index)
277 `((,(intern (format nil "WRAPPER-~D" index)
278 *the-pcl-package*)
279 ,(emit-fetch-wrapper mt arg 'miss
280 (pop slot-regs))))))
281 args metatypes))
282 (wrappers (mapcar #'car wrapper-bindings)))
283 (declare (fixnum index))
284 (assert (not (null wrappers)) () _"Every metatype is T.")
285 `(block dfun
286 (tagbody
287 (let ((field (cache-field cache))
288 (cache-vector (cache-vector cache))
289 (mask (cache-mask cache))
290 (size (cache-size cache))
291 (overflow (cache-overflow cache))
292 ,@wrapper-bindings)
293 (declare (fixnum size field mask))
294 ,(cond ((cdr wrappers)
295 (emit-greater-than-1-dlap wrappers 'miss value-reg))
296 (value-reg
297 (emit-1-t-dlap (car wrappers) 'miss value-reg))
298 (t
299 (emit-1-nil-dlap (car wrappers) 'miss)))
300 (return-from dfun ,hit))
301 miss
302 (return-from dfun ,miss)))))
303
304 (defun emit-1-nil-dlap (wrapper miss-label)
305 `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
306 (location primary))
307 (declare (fixnum primary location))
308 (block search
309 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
310 (return-from search nil))
311 (setq location (the fixnum (+ location 1)))
312 (when (= location size)
313 (setq location 0))
314 (when (= location primary)
315 (dolist (entry overflow)
316 (when (eq (car entry) ,wrapper)
317 (return-from search nil)))
318 (go ,miss-label))))))
319
320 (defmacro get-cache-vector-lock-count (cache-vector)
321 `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
322 (the fixnum lock-count)))
323
324 (defun emit-1-t-dlap (wrapper miss-label value)
325 `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
326 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
327 (declare (fixnum primary initial-lock-count))
328 (let ((location primary))
329 (declare (fixnum location))
330 (block search
331 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
332 (setq ,value (cache-vector-ref cache-vector (1+ location)))
333 (return-from search nil))
334 (setq location (the fixnum (+ location 2)))
335 (when (= location size)
336 (setq location 0))
337 (when (= location primary)
338 (dolist (entry overflow)
339 (when (eq (car entry) ,wrapper)
340 (setq ,value (cdr entry))
341 (return-from search nil)))
342 (go ,miss-label))))
343 (unless (= initial-lock-count
344 (get-cache-vector-lock-count cache-vector))
345 (go ,miss-label)))))
346
347 (defun emit-greater-than-1-dlap (wrappers miss-label value)
348 (declare (type list wrappers))
349 (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
350 `(let ((primary 0) (size-1 (the fixnum (- size 1))))
351 (declare (fixnum primary size-1))
352 ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
353 (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
354 (declare (fixnum initial-lock-count))
355 (let ((location primary))
356 (declare (fixnum location))
357 (block search
358 (loop
359 (let ((next-location (the fixnum (+ location ,cache-line-size))))
360 (declare #.*optimize-speed*)
361 (declare (fixnum next-location))
362 (when (and ,@(mapcar
363 (lambda (wrapper)
364 `(eq ,wrapper
365 (%svref cache-vector
366 (setq location
367 (the fixnum (1+ location))))))
368 wrappers))
369 ,@(when value
370 `((setq location (the fixnum (1+ location)))
371 (setq ,value (%svref cache-vector location))))
372 (return-from search nil))
373 (setq location next-location)
374 (when (= location size-1)
375 (setq location 0))
376 (when (= location primary)
377 (loop for (ws . v) in overflow
378 when (and ,@(mapcar (lambda (w)
379 `(eq ,w (pop ws)))
380 wrappers)) do
381 ,@(when value `((setq ,value v)))
382 (return-from search nil))
383 (go ,miss-label)))))
384 (unless (= initial-lock-count
385 (get-cache-vector-lock-count cache-vector))
386 (go ,miss-label)))))))
387
388 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
389 `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field)))
390 (declare (fixnum wrapper-cache-no))
391 (when (zerop wrapper-cache-no)
392 (go ,miss-label))
393 ,(let ((form `(logand mask wrapper-cache-no)))
394 `(the fixnum ,form))))
395
396 #-pcl-xorhash
397 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
398 (declare (type list wrappers))
399 ;; this returns 1 less that the actual location
400 `(progn
401 ,@(let ((adds 0) (len (length wrappers)))
402 (declare (fixnum adds len))
403 (mapcar (lambda (wrapper)
404 `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field)))
405 (declare (fixnum wrapper-cache-no))
406 (when (zerop wrapper-cache-no) (go ,miss-label))
407 (setq primary (the fixnum (+ primary wrapper-cache-no)))
408 ,@(progn
409 (incf adds)
410 (when (or (zerop (mod adds +max-hash-code-additions+))
411 (eql adds len))
412 `((setq primary
413 ,(let ((form `(logand primary mask)))
414 `(the fixnum ,form))))))))
415 wrappers))))
416
417 #+pcl-xorhash
418 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
419 (declare (type list wrappers))
420 ;; this returns 1 less that the actual location
421 `(progn
422 ,@(let ((adds 0) (len (length wrappers)))
423 (declare (fixnum adds len))
424 (mapcar (lambda (wrapper)
425 `(let ((hash (kernel:layout-hash ,wrapper field)))
426 (declare (fixnum hash))
427 (when (zerop hash) (go ,miss-label))
428 (setq primary (logxor primary hash))
429 ,@(progn
430 (incf adds)
431 (when (eql adds len)
432 `((setq primary
433 ,(let ((form `(logand primary mask)))
434 `(the fixnum ,form))))))))
435 wrappers))))
436
437 ;;;
438 ;;; cmu17 note: since std-instance-p is weakened, that branch may run
439 ;;; on non-pcl instances (structures). The result will be the
440 ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
441 ;;; will be whatever the first slot is, but will be ignored. Similarly,
442 ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
443 ;;;
444 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
445 (ecase metatype
446 ((standard-instance)
447 `(cond ((std-instance-p ,argument)
448 ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
449 (std-instance-wrapper ,argument))
450 ((fsc-instance-p ,argument)
451 ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
452 (fsc-instance-wrapper ,argument))
453 (t
454 (go ,miss-label))))
455 (class
456 (assert (null slot) () _"Can't do a slot reg for this metatype.")
457 `(wrapper-of-macro ,argument))
458 ((built-in-instance structure-instance)
459 (assert (null slot) () _"Can't do a slot reg for this metatype.")
460 `(built-in-or-structure-wrapper ,argument))))
461

  ViewVC Help
Powered by ViewVC 1.1.5