/[gcl]/gcl/pcl/gcl_pcl_dlisp.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_dlisp.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 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    (in-package :pcl)
29    
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                        (fin-lambda-fn ,args
108                          #+copy-&rest-arg
109                          ,@(when rest
110                              `((setq .lap-rest-arg. (copy-list .lap-rest-arg.))))
111                          (let ()
112                            (declare #.*optimize-speed*)
113                            ,form)))))
114        (values (if *precompiling-lap*
115                    `#',lambda
116                    (compile-lambda lambda))
117                nil)))
118    
119    ;;; cmu17 note: since std-instance-p is weakened, that branch may run
120    ;;; on non-pcl instances (structures).  The result will be the
121    ;;; non-wrapper layout for the structure, which will cause a miss.  The "slots"
122    ;;; will be whatever the first slot is, but will be ignored.  Similarly,
123    ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
124    ;;;
125    (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
126      (when (and (null *precompiling-lap*) *emit-function-p*)
127        (return-from emit-reader/writer
128          (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
129      (let ((instance nil)
130            (arglist  ())
131            (closure-variables ())
132            (field (first-wrapper-cache-number-index))
133            (readp (eq reader/writer :reader))
134            (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
135        ;;we need some field to do the fast obsolete check
136        (ecase reader/writer
137          (:reader (setq instance (dfun-arg-symbol 0)
138                         arglist  (list instance)))
139          (:writer (setq instance (dfun-arg-symbol 1)
140                         arglist  (list (dfun-arg-symbol 0) instance))))
141        (ecase 1-or-2-class
142          (1 (setq closure-variables '(wrapper-0 index miss-fn)))
143          (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
144        (generating-lisp closure-variables
145                         arglist
146           `(let* (,@(unless class-slot-p `((slots nil)))
147                   (wrapper (cond ((std-instance-p ,instance)
148                                   ,@(unless class-slot-p
149                                       `((setq slots (std-instance-slots ,instance))))
150                                   (std-instance-wrapper ,instance))
151                                  ((fsc-instance-p ,instance)
152                                   ,@(unless class-slot-p
153                                       `((setq slots (fsc-instance-slots ,instance))))
154                                   (fsc-instance-wrapper ,instance))))
155                   ,@(when readp '(value)))
156              (if (or (null wrapper)
157                      (zerop (wrapper-cache-number-vector-ref wrapper ,field))
158                      (not (or (eq wrapper wrapper-0)
159                               ,@(when (eql 2 1-or-2-class)
160                                   `((eq wrapper wrapper-1)))))
161                      ,@(when readp `((eq *slot-unbound* (setq value ,read-form)))))
162                  (funcall miss-fn ,@arglist)
163                  ,(if readp
164                       'value
165                       `(setf ,read-form ,(car arglist))))))))
166    
167    (defun emit-slot-read-form (class-slot-p index slots)
168      (if class-slot-p
169          `(cdr ,index)
170          `(%instance-ref ,slots ,index)))
171    
172    (defun emit-boundp-check (value-form miss-fn arglist)
173      `(let ((value ,value-form))
174         (if (eq value *slot-unbound*)
175             (funcall ,miss-fn ,@arglist)
176             value)))
177    
178    (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
179      (let ((read-form (emit-slot-read-form class-slot-p index slots)))
180        (ecase reader/writer
181          (:reader (emit-boundp-check read-form miss-fn arglist))
182          (:writer `(setf ,read-form ,(car arglist))))))
183    
184    (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
185      (let ((*emit-function-p* nil)
186            (*precompiling-lap* t))
187        (values
188         (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
189    
190    (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
191      (when (and (null *precompiling-lap*) *emit-function-p*)
192        (return-from emit-one-or-n-index-reader/writer
193          (emit-one-or-n-index-reader/writer-function
194           reader/writer cached-index-p class-slot-p)))
195      (multiple-value-bind (arglist metatypes)
196          (ecase reader/writer
197            (:reader (values (list (dfun-arg-symbol 0))
198                             '(standard-instance)))
199            (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
200                             '(t standard-instance))))
201        (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
202                         arglist
203          `(let (,@(unless class-slot-p '(slots))
204                 ,@(when cached-index-p '(index)))
205             ,(emit-dlap arglist metatypes
206                         (emit-slot-access reader/writer class-slot-p
207                                           'slots 'index 'miss-fn arglist)
208                         `(funcall miss-fn ,@arglist)
209                         (when cached-index-p 'index)
210                         (unless class-slot-p '(slots)))))))
211    
212    (defmacro emit-one-or-n-index-reader/writer-macro
213        (reader/writer cached-index-p class-slot-p)
214      (let ((*emit-function-p* nil)
215            (*precompiling-lap* t))
216        (values
217         (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
218    
219    (defun emit-miss (miss-fn args &optional applyp)
220      (let ((restl (when applyp '(.lap-rest-arg.))))
221        (if restl
222            `(apply ,miss-fn ,@args ,@restl)
223            `(funcall ,miss-fn ,@args ,@restl))))
224    
225    (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
226      (when (and (null *precompiling-lap*) *emit-function-p*)
227        (return-from emit-checking-or-caching
228          (emit-checking-or-caching-function
229           cached-emf-p return-value-p metatypes applyp)))
230      (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
231             (args (remove '&rest dlap-lambda-list))
232             (restl (when applyp '(.lap-rest-arg.))))
233        (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
234                         dlap-lambda-list
235          `(let (,@(when cached-emf-p '(emf)))
236             ,(emit-dlap args
237                         metatypes
238                         (if return-value-p
239                             (if cached-emf-p 'emf t)
240                             `(invoke-effective-method-function emf ,applyp
241                               ,@args ,@restl))
242                         (emit-miss 'miss-fn args applyp)
243                         (when cached-emf-p 'emf))))))
244    
245    (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
246      (let ((*emit-function-p* nil)
247            (*precompiling-lap* t))
248        (values
249         (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
250    
251    (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
252      (let* ((index -1)
253             (wrapper-bindings (mapcan #'(lambda (arg mt)
254                                           (unless (eq mt 't)
255                                             (incf index)
256                                             `((,(intern (format nil "WRAPPER-~D" index)
257                                                         *the-pcl-package*)
258                                                ,(emit-fetch-wrapper mt arg 'miss
259                                                  (pop slot-regs))))))
260                                       args metatypes))
261             (wrappers (mapcar #'car wrapper-bindings)))
262        (declare (fixnum index))
263        (unless wrappers (error "Every metatype is T."))
264        `(block dfun
265           (tagbody
266              (let ((field (cache-field cache))
267                    (cache-vector (cache-vector cache))
268                    (mask (cache-mask cache))
269                    (size (cache-size cache))
270                    (overflow (cache-overflow cache))
271                    ,@wrapper-bindings)
272                (declare (fixnum size field mask))
273                ,(cond ((cdr wrappers)
274                        (emit-greater-than-1-dlap wrappers 'miss value-reg))
275                       (value-reg
276                        (emit-1-t-dlap (car wrappers) 'miss value-reg))
277                       (t
278                        (emit-1-nil-dlap (car wrappers) 'miss)))
279                (return-from dfun ,hit))
280            miss
281              (return-from dfun ,miss)))))
282    
283    (defun emit-1-nil-dlap (wrapper miss-label)
284      `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
285              (location primary))
286         (declare (fixnum primary location))
287         (block search
288           (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
289                   (return-from search nil))
290                 (setq location (the fixnum (+ location 1)))
291                 (when (= location size)
292                   (setq location 0))
293                 (when (= location primary)
294                   (dolist (entry overflow)
295                     (when (eq (car entry) ,wrapper)
296                       (return-from search nil)))
297                   (go ,miss-label))))))
298    
299    (defmacro get-cache-vector-lock-count (cache-vector)
300      `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
301         (unless (typep lock-count 'fixnum)
302           (error "my cache got freed somehow"))
303         (the fixnum lock-count)))
304    
305    (defun emit-1-t-dlap (wrapper miss-label value)
306      `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
307             (initial-lock-count (get-cache-vector-lock-count cache-vector)))
308         (declare (fixnum primary initial-lock-count))
309         (let ((location primary))
310           (declare (fixnum location))
311           (block search
312             (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
313                     (setq ,value (cache-vector-ref cache-vector (1+ location)))
314                     (return-from search nil))
315                   (setq location (the fixnum (+ location 2)))
316                   (when (= location size)
317                     (setq location 0))
318                   (when (= location primary)
319                     (dolist (entry overflow)
320                       (when (eq (car entry) ,wrapper)
321                         (setq ,value (cdr entry))
322                         (return-from search nil)))
323                     (go ,miss-label))))
324           (unless (= initial-lock-count
325                      (get-cache-vector-lock-count cache-vector))
326             (go ,miss-label)))))
327    
328    (defun emit-greater-than-1-dlap (wrappers miss-label value)
329      (declare (type list wrappers))
330      (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
331        `(let ((primary 0) (size-1 (the fixnum (- size 1))))
332           (declare (fixnum primary size-1))
333           ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
334           (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
335             (declare (fixnum initial-lock-count))
336             (let ((location primary) (next-location 0))
337               (declare (fixnum location next-location))
338               (block search
339                 (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
340                       (when (and ,@(mapcar
341                                     #'(lambda (wrapper)
342                                         `(eq ,wrapper
343                                           (cache-vector-ref cache-vector
344                                            (setq location
345                                             (the fixnum (+ location 1))))))
346                                     wrappers))
347                         ,@(when value
348                             `((setq location (the fixnum (+ location 1)))
349                               (setq ,value (cache-vector-ref cache-vector location))))
350                         (return-from search nil))
351                       (setq location next-location)
352                       (when (= location size-1)
353                         (setq location 0))
354                       (when (= location primary)
355                         (dolist (entry overflow)
356                           (let ((entry-wrappers (car entry)))
357                             (when (and ,@(mapcar #'(lambda (wrapper)
358                                                      `(eq ,wrapper (pop entry-wrappers)))
359                                                  wrappers))
360                               ,@(when value
361                                   `((setq ,value (cdr entry))))
362                               (return-from search nil))))
363                         (go ,miss-label))))
364               (unless (= initial-lock-count
365                          (get-cache-vector-lock-count cache-vector))
366                 (go ,miss-label)))))))
367    
368    (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
369      `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
370         (declare (fixnum wrapper-cache-no))
371         (when (zerop wrapper-cache-no) (go ,miss-label))
372         ,(let ((form `(#+lucid %logand #-lucid logand
373                        mask wrapper-cache-no)))
374            #+lucid form
375            #-lucid `(the fixnum ,form))))
376    
377    (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
378      (declare (type list wrappers))
379      ;; this returns 1 less that the actual location
380      `(progn
381         ,@(let ((adds 0) (len (length wrappers)))
382             (declare (fixnum adds len))
383             (mapcar #'(lambda (wrapper)
384                         `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
385                                                   ,wrapper field)))
386                            (declare (fixnum wrapper-cache-no))
387                            (when (zerop wrapper-cache-no) (go ,miss-label))
388                            (setq primary (the fixnum (+ primary wrapper-cache-no)))
389                            ,@(progn
390                                (incf adds)
391                                (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
392                                          (eql adds len))
393                                  `((setq primary
394                                          ,(let ((form `(#+lucid %logand #-lucid logand
395                                                         primary mask)))
396                                             #+lucid form
397                                             #-lucid `(the fixnum ,form))))))))
398                     wrappers))))
399        
400    ;;; 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    (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
407      (ecase metatype
408        ((standard-instance #+new-kcl-wrapper structure-instance)
409         `(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        ((built-in-instance #-new-kcl-wrapper structure-instance)
421         (when slot (error "Can't do a slot reg for this metatype."))
422         `(#+new-kcl-wrapper built-in-wrapper-of
423           #-new-kcl-wrapper built-in-or-structure-wrapper
424           ,argument))))
425    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26