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

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Thu Nov 28 16:23:33 2002 UTC (11 years, 4 months ago) by pmai
Branch: MAIN
CVS Tags: release-18e-base, release-18e-pre2, cold-pcl-base, release-18e, release-18e-pre1
Branch point for: release-18e-branch, cold-pcl
Changes since 1.9: +1 -5 lines
Flushed the #+copy-&rest-arg controlled copying of rest arguments, since
the code was both unused in CMUCL, and was erroneous in places, too.  This
brings us in line with SBCL which removed the code early on.
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     ;;;
27 pw 1.7
28 dtc 1.5 (ext:file-comment
29 pmai 1.10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/dlisp.lisp,v 1.10 2002/11/28 16:23:33 pmai Exp $")
30 dtc 1.5 ;;;
31 ram 1.1
32 phg 1.2 (in-package :pcl)
33 ram 1.1
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 pw 1.7 #'(kernel:instance-lambda ,args
112 ram 1.1 (let ()
113     (declare #.*optimize-speed*)
114     ,form)))))
115     (values (if *precompiling-lap*
116     `#',lambda
117     (compile-lambda lambda))
118     nil)))
119    
120 pw 1.3 ;;; 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 ram 1.1 (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 phg 1.2 (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
130 ram 1.1 (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 dtc 1.4 (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 pmai 1.9 (unless (eq value +slot-unbound+)
166 dtc 1.4 (return-from access value))))
167     `((return-from access (setf ,read-form ,(car arglist))))))
168     (funcall miss-fn ,@arglist))))))
169 ram 1.1
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 pmai 1.9 (if (eq value +slot-unbound+)
178 ram 1.1 (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 pmai 1.8 (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 ram 1.1 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 pmai 1.8 (lambda (wrapper)
345     `(eq ,wrapper
346     (cache-vector-ref cache-vector
347     (setq location
348     (the fixnum (+ location 1))))))
349 ram 1.1 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 pmai 1.8 (when (and ,@(mapcar (lambda (wrapper)
361     `(eq ,wrapper (pop entry-wrappers)))
362 ram 1.1 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 pw 1.6 ,(let ((form `(logand
376 ram 1.1 mask wrapper-cache-no)))
377 pw 1.6 `(the fixnum ,form))))
378 ram 1.1
379     (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
380     (declare (type list wrappers))
381     ;; this returns 1 less that the actual location
382     `(progn
383     ,@(let ((adds 0) (len (length wrappers)))
384     (declare (fixnum adds len))
385 pmai 1.8 (mapcar (lambda (wrapper)
386     `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
387     ,wrapper field)))
388     (declare (fixnum wrapper-cache-no))
389     (when (zerop wrapper-cache-no) (go ,miss-label))
390     (setq primary (the fixnum (+ primary wrapper-cache-no)))
391     ,@(progn
392     (incf adds)
393     (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
394     (eql adds len))
395     `((setq primary
396     ,(let ((form `(logand primary mask)))
397     `(the fixnum ,form))))))))
398 ram 1.1 wrappers))))
399    
400 pw 1.3 ;;; 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 ram 1.1 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
407     (ecase metatype
408 pw 1.6 ((standard-instance)
409 ram 1.1 `(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 pw 1.6 ((built-in-instance structure-instance)
421 ram 1.1 (when slot (error "Can't do a slot reg for this metatype."))
422 pw 1.6 `(built-in-or-structure-wrapper
423 ram 1.1 ,argument))))
424    

  ViewVC Help
Powered by ViewVC 1.1.5