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

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Sun Dec 20 04:30:19 1998 UTC (15 years, 4 months ago) by dtc
Branch: MAIN
Changes since 1.4: +4 -0 lines
Add CMUCL style file-comments; from Peter Van Eynde.
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 dtc 1.5 #+cmu
28     (ext:file-comment
29     "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/dlisp.lisp,v 1.5 1998/12/20 04:30:19 dtc Exp $")
30     ;;;
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.3 #'(#+cmu kernel:instance-lambda #-cmu lambda ,args
112 phg 1.2 #+copy-&rest-arg
113     ,@(when rest
114     `((setq .lap-rest-arg.
115     (copy-list .lap-rest-arg.))))
116 ram 1.1 (let ()
117     (declare #.*optimize-speed*)
118     ,form)))))
119     (values (if *precompiling-lap*
120     `#',lambda
121     (compile-lambda lambda))
122     nil)))
123    
124 pw 1.3 ;;; 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 ram 1.1 (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 phg 1.2 (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
134 ram 1.1 (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 dtc 1.4 (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 ram 1.1
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 `(#+lucid %logand #-lucid logand
380     mask wrapper-cache-no)))
381     #+lucid form
382     #-lucid `(the fixnum ,form))))
383    
384     (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
385     (declare (type list wrappers))
386     ;; this returns 1 less that the actual location
387     `(progn
388     ,@(let ((adds 0) (len (length wrappers)))
389     (declare (fixnum adds len))
390     (mapcar #'(lambda (wrapper)
391     `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
392     ,wrapper field)))
393     (declare (fixnum wrapper-cache-no))
394     (when (zerop wrapper-cache-no) (go ,miss-label))
395     (setq primary (the fixnum (+ primary wrapper-cache-no)))
396     ,@(progn
397     (incf adds)
398     (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
399     (eql adds len))
400     `((setq primary
401     ,(let ((form `(#+lucid %logand #-lucid logand
402     primary mask)))
403     #+lucid form
404     #-lucid `(the fixnum ,form))))))))
405     wrappers))))
406    
407 pw 1.3 ;;; cmu17 note: since std-instance-p is weakened, that branch may run
408     ;;; on non-pcl instances (structures). The result will be the
409     ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
410     ;;; will be whatever the first slot is, but will be ignored. Similarly,
411     ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
412     ;;;
413 ram 1.1 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
414     (ecase metatype
415     ((standard-instance #+new-kcl-wrapper structure-instance)
416     `(cond ((std-instance-p ,argument)
417     ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
418     (std-instance-wrapper ,argument))
419     ((fsc-instance-p ,argument)
420     ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
421     (fsc-instance-wrapper ,argument))
422     (t
423     (go ,miss-label))))
424     (class
425     (when slot (error "Can't do a slot reg for this metatype."))
426     `(wrapper-of-macro ,argument))
427     ((built-in-instance #-new-kcl-wrapper structure-instance)
428     (when slot (error "Can't do a slot reg for this metatype."))
429     `(#+new-kcl-wrapper built-in-wrapper-of
430     #-new-kcl-wrapper built-in-or-structure-wrapper
431     ,argument))))
432    

  ViewVC Help
Powered by ViewVC 1.1.5