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

Contents of /src/pcl/dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.12: +5 -4 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
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 gerd 1.12 (file-comment
28 rtoy 1.13 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/dlisp.lisp,v 1.13 2010/03/19 15:19:03 rtoy Rel $")
29 dtc 1.5 ;;;
30 ram 1.1
31 phg 1.2 (in-package :pcl)
32 rtoy 1.13 (intl:textdomain "cmucl")
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 gerd 1.11 (defun emit-one-class-boundp (class-slot-p)
44     (emit-reader/writer :boundp 1 class-slot-p))
45    
46 ram 1.1 (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 gerd 1.11 (defun emit-two-class-boundp (class-slot-p)
53     (emit-reader/writer :boundp 2 class-slot-p))
54    
55 ram 1.1 (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 gerd 1.11 (defun emit-one-index-boundps (class-slot-p)
64     (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
65    
66 ram 1.1 (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 gerd 1.11 (defun emit-n-n-boundps ()
73     (emit-one-or-n-index-reader/writer :boundp t nil))
74    
75 ram 1.1 (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 gerd 1.11 (defvar *optimize-cache-functions-p* t)
98    
99 ram 1.1 (defun emit-default-only (metatypes applyp)
100 gerd 1.11 (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 ram 1.1 (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 pw 1.7 #'(kernel:instance-lambda ,args
121 gerd 1.11 ;;
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 ram 1.1 ,form)))))
127     (values (if *precompiling-lap*
128     `#',lambda
129     (compile-lambda lambda))
130     nil)))
131    
132 gerd 1.11 ;;;
133 pw 1.3 ;;; cmu17 note: since std-instance-p is weakened, that branch may run
134 gerd 1.11 ;;; 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 pw 1.3 ;;;
140 ram 1.1 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
141 gerd 1.11 (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 ram 1.1 `(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 dtc 1.4 (fsc-instance-wrapper ,instance)))))
169     (block access
170     (when (and wrapper
171 gerd 1.11 (not (zerop (kernel:layout-hash wrapper 0)))
172 dtc 1.4 ,@(if (eql 1 1-or-2-class)
173     `((eq wrapper wrapper-0))
174     `((or (eq wrapper wrapper-0)
175     (eq wrapper wrapper-1)))))
176 gerd 1.11 ,@(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 dtc 1.4 (funcall miss-fn ,@arglist))))))
187 ram 1.1
188     (defun emit-slot-read-form (class-slot-p index slots)
189     (if class-slot-p
190     `(cdr ,index)
191 gerd 1.11 `(%slot-ref ,slots ,index)))
192 ram 1.1
193     (defun emit-boundp-check (value-form miss-fn arglist)
194     `(let ((value ,value-form))
195 pmai 1.9 (if (eq value +slot-unbound+)
196 ram 1.1 (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 gerd 1.11 (:boundp `(not (eq +slot-unbound+ ,read-form)))
204 ram 1.1 (: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 gerd 1.11 (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 ram 1.1 (multiple-value-bind (arglist metatypes)
219     (ecase reader/writer
220 gerd 1.11 ((: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 ram 1.1 (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 gerd 1.11 (emit-one-or-n-index-reader/writer reader/writer cached-index-p
243     class-slot-p))))
244 ram 1.1
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 gerd 1.11 (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 ram 1.1 (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 pmai 1.8 (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 ram 1.1 args metatypes))
282     (wrappers (mapcar #'car wrapper-bindings)))
283     (declare (fixnum index))
284 rtoy 1.13 (assert (not (null wrappers)) () _"Every metatype is T.")
285 ram 1.1 `(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 gerd 1.11 (let ((location primary))
356     (declare (fixnum location))
357 ram 1.1 (block search
358 gerd 1.11 (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 ram 1.1 ,@(when value
370 gerd 1.11 `((setq location (the fixnum (1+ location)))
371     (setq ,value (%svref cache-vector location))))
372 ram 1.1 (return-from search nil))
373 gerd 1.11 (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 ram 1.1 (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 gerd 1.11 `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field)))
390 ram 1.1 (declare (fixnum wrapper-cache-no))
391 gerd 1.11 (when (zerop wrapper-cache-no)
392     (go ,miss-label))
393     ,(let ((form `(logand mask wrapper-cache-no)))
394 pw 1.6 `(the fixnum ,form))))
395 ram 1.1
396 gerd 1.11 #-pcl-xorhash
397 ram 1.1 (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 pmai 1.8 (mapcar (lambda (wrapper)
404 gerd 1.11 `(let ((wrapper-cache-no (kernel:layout-hash ,wrapper field)))
405 pmai 1.8 (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 gerd 1.11 (when (or (zerop (mod adds +max-hash-code-additions+))
411 pmai 1.8 (eql adds len))
412     `((setq primary
413     ,(let ((form `(logand primary mask)))
414     `(the fixnum ,form))))))))
415 ram 1.1 wrappers))))
416 gerd 1.11
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 pw 1.3 ;;; 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 ram 1.1 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
445     (ecase metatype
446 pw 1.6 ((standard-instance)
447 ram 1.1 `(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 rtoy 1.13 (assert (null slot) () _"Can't do a slot reg for this metatype.")
457 ram 1.1 `(wrapper-of-macro ,argument))
458 pw 1.6 ((built-in-instance structure-instance)
459 rtoy 1.13 (assert (null slot) () _"Can't do a slot reg for this metatype.")
460 gerd 1.11 `(built-in-or-structure-wrapper ,argument))))
461 ram 1.1

  ViewVC Help
Powered by ViewVC 1.1.5