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

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5