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

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5