0.9.10.30
[sbcl.git] / src / pcl / dlisp.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 ;;; This file is (almost) functionally equivalent to dlap.lisp, but
27 ;;; easier to read.
28
29 ;;; Might generate faster code, too, depending on the compiler and
30 ;;; whether an implementation-specific lap assembler was used.
31
32 (defun emit-one-class-reader (class-slot-p)
33   (emit-reader/writer :reader 1 class-slot-p))
34
35 (defun emit-one-class-boundp (class-slot-p)
36   (emit-reader/writer :boundp 1 class-slot-p))
37
38 (defun emit-one-class-writer (class-slot-p)
39   (emit-reader/writer :writer 1 class-slot-p))
40
41 (defun emit-two-class-reader (class-slot-p)
42   (emit-reader/writer :reader 2 class-slot-p))
43
44 (defun emit-two-class-boundp (class-slot-p)
45   (emit-reader/writer :boundp 2 class-slot-p))
46
47 (defun emit-two-class-writer (class-slot-p)
48   (emit-reader/writer :writer 2 class-slot-p))
49
50 ;;; --------------------------------
51
52 (defun emit-one-index-readers (class-slot-p)
53   (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
54
55 (defun emit-one-index-boundps (class-slot-p)
56   (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
57
58 (defun emit-one-index-writers (class-slot-p)
59   (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
60
61 (defun emit-n-n-readers ()
62   (emit-one-or-n-index-reader/writer :reader t nil))
63
64 (defun emit-n-n-boundps ()
65   (emit-one-or-n-index-reader/writer :boundp t nil))
66
67 (defun emit-n-n-writers ()
68   (emit-one-or-n-index-reader/writer :writer t nil))
69
70 ;;; --------------------------------
71
72 (defun emit-checking (metatypes applyp)
73   (emit-checking-or-caching nil nil metatypes applyp))
74
75 (defun emit-caching (metatypes applyp)
76   (emit-checking-or-caching t nil metatypes applyp))
77
78 (defun emit-in-checking-cache-p (metatypes)
79   (emit-checking-or-caching nil t metatypes nil))
80
81 (defun emit-constant-value (metatypes)
82   (emit-checking-or-caching t t metatypes nil))
83
84 ;;; --------------------------------
85
86 ;;; FIXME: What do these variables mean?
87 (defvar *precompiling-lap* nil)
88 (defvar *emit-function-p* t)
89
90 ;;; FIXME: This variable is motivated by Gerd Moellman's observation,
91 ;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
92 ;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
93 ;;; order-of-magnitude slowdown.  We include this variable for now,
94 ;;; but maybe its effect should rather be controlled by compilation
95 ;;; policy if there is a noticeable space difference between the
96 ;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
97 ;;; deleted.  It's not clear to me how all of this works, though, so
98 ;;; until proper benchmarks are done it's probably safest simply to
99 ;;; have this pseudo-constant to hide code.  -- CSR, 2003-02-14
100 (defvar *optimize-cache-functions-p* t)
101
102 (defun emit-default-only (metatypes applyp)
103   (unless *optimize-cache-functions-p*
104     (when (and (null *precompiling-lap*) *emit-function-p*)
105       (return-from emit-default-only
106         (emit-default-only-function metatypes applyp))))
107   (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
108          (args (remove '&rest dlap-lambda-list))
109          (restl (when applyp '(.lap-rest-arg.))))
110     (generating-lisp '(emf)
111                      dlap-lambda-list
112                      `(invoke-effective-method-function emf
113                                                         ,applyp
114                                                         ,@args
115                                                         ,@restl))))
116
117 ;;; --------------------------------
118
119 (defun generating-lisp (closure-variables args form)
120   (let* ((rest (memq '&rest args))
121          (ldiff (and rest (ldiff args rest)))
122          (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
123          (lambda `(lambda ,closure-variables
124                     ,@(when (member 'miss-fn closure-variables)
125                         `((declare (type function miss-fn))))
126                     #'(lambda ,args
127                         (let ()
128                           (declare #.*optimize-speed*)
129                           ,form)))))
130     (values (if *precompiling-lap*
131                 `#',lambda
132                 (compile nil lambda))
133             nil)))
134
135 ;;; note on implementation for CMU 17 and later (including SBCL):
136 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
137 ;;; instances (structures). The result will be the non-wrapper layout
138 ;;; for the structure, which will cause a miss. The "slots" will be
139 ;;; whatever the first slot is, but will be ignored. Similarly,
140 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
141 ;;; PCL fins.
142 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
143   (unless *optimize-cache-functions-p*
144     (when (and (null *precompiling-lap*) *emit-function-p*)
145       (return-from emit-reader/writer
146         (emit-reader/writer-function
147          reader/writer 1-or-2-class class-slot-p))))
148   (let ((instance nil)
149         (arglist  ())
150         (closure-variables ())
151         (field +first-wrapper-cache-number-index+)
152         (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
153     ;;we need some field to do the fast obsolete check
154     (ecase reader/writer
155       ((:reader :boundp)
156        (setq instance (dfun-arg-symbol 0)
157              arglist  (list instance)))
158       (:writer (setq instance (dfun-arg-symbol 1)
159                      arglist  (list (dfun-arg-symbol 0) instance))))
160     (ecase 1-or-2-class
161       (1 (setq closure-variables '(wrapper-0 index miss-fn)))
162       (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
163     (generating-lisp
164      closure-variables
165      arglist
166      `(let* (,@(unless class-slot-p `((slots nil)))
167                (wrapper (cond ((std-instance-p ,instance)
168                                ,@(unless class-slot-p
169                                    `((setq slots
170                                            (std-instance-slots ,instance))))
171                                (std-instance-wrapper ,instance))
172                               ((fsc-instance-p ,instance)
173                                ,@(unless class-slot-p
174                                    `((setq slots
175                                            (fsc-instance-slots ,instance))))
176                                (fsc-instance-wrapper ,instance)))))
177         (block access
178           (when (and wrapper
179                      (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
180                      ,@(if (eql 1 1-or-2-class)
181                            `((eq wrapper wrapper-0))
182                            `((or (eq wrapper wrapper-0)
183                                  (eq wrapper wrapper-1)))))
184             ,@(ecase reader/writer
185                 (:reader
186                  `((let ((value ,read-form))
187                      (unless (eq value +slot-unbound+)
188                        (return-from access value)))))
189                 (:boundp
190                  `((let ((value ,read-form))
191                       (return-from access (not (eq value +slot-unbound+))))))
192                 (:writer
193                  `((return-from access (setf ,read-form ,(car arglist)))))))
194           (funcall miss-fn ,@arglist))))))
195
196 (defun emit-slot-read-form (class-slot-p index slots)
197   (if class-slot-p
198       `(cdr ,index)
199       `(clos-slots-ref ,slots ,index)))
200
201 (defun emit-boundp-check (value-form miss-fn arglist)
202   `(let ((value ,value-form))
203      (if (eq value +slot-unbound+)
204          (funcall ,miss-fn ,@arglist)
205          value)))
206
207 (defun emit-slot-access (reader/writer class-slot-p slots
208                          index miss-fn arglist)
209   (let ((read-form (emit-slot-read-form class-slot-p index slots)))
210     (ecase reader/writer
211       (:reader (emit-boundp-check read-form miss-fn arglist))
212       (:boundp `(not (eq ,read-form +slot-unbound+)))
213       (:writer `(setf ,read-form ,(car arglist))))))
214
215 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
216   (let ((*emit-function-p* nil)
217         (*precompiling-lap* t))
218     (values
219      (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
220
221 (defun emit-one-or-n-index-reader/writer (reader/writer
222                                           cached-index-p
223                                           class-slot-p)
224   (unless *optimize-cache-functions-p*
225     (when (and (null *precompiling-lap*) *emit-function-p*)
226       (return-from emit-one-or-n-index-reader/writer
227         (emit-one-or-n-index-reader/writer-function
228          reader/writer cached-index-p class-slot-p))))
229   (multiple-value-bind (arglist metatypes)
230       (ecase reader/writer
231         ((:reader :boundp)
232          (values (list (dfun-arg-symbol 0))
233                  '(standard-instance)))
234         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
235                          '(t standard-instance))))
236     (generating-lisp
237      `(cache ,@(unless cached-index-p '(index)) miss-fn)
238      arglist
239      `(let (,@(unless class-slot-p '(slots))
240             ,@(when cached-index-p '(index)))
241         ,(emit-dlap arglist metatypes
242                     (emit-slot-access reader/writer class-slot-p
243                                       'slots 'index 'miss-fn arglist)
244                     `(funcall miss-fn ,@arglist)
245                     (when cached-index-p 'index)
246                     (unless class-slot-p '(slots)))))))
247
248 (defmacro emit-one-or-n-index-reader/writer-macro
249     (reader/writer cached-index-p class-slot-p)
250   (let ((*emit-function-p* nil)
251         (*precompiling-lap* t))
252     (values
253      (emit-one-or-n-index-reader/writer reader/writer
254                                         cached-index-p
255                                         class-slot-p))))
256
257 (defun emit-miss (miss-fn args &optional applyp)
258   (let ((restl (when applyp '(.lap-rest-arg.))))
259     (if restl
260         `(apply ,miss-fn ,@args ,@restl)
261         `(funcall ,miss-fn ,@args ,@restl))))
262
263 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
264   (unless *optimize-cache-functions-p*
265     (when (and (null *precompiling-lap*) *emit-function-p*)
266       (return-from emit-checking-or-caching
267         (emit-checking-or-caching-function
268          cached-emf-p return-value-p metatypes applyp))))
269   (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
270          (args (remove '&rest dlap-lambda-list))
271          (restl (when applyp '(.lap-rest-arg.))))
272     (generating-lisp
273      `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
274      dlap-lambda-list
275      `(let (,@(when cached-emf-p '(emf)))
276         ,(emit-dlap args
277                     metatypes
278                     (if return-value-p
279                         (if cached-emf-p 'emf t)
280                         `(invoke-effective-method-function
281                           emf ,applyp ,@args ,@restl))
282                     (emit-miss 'miss-fn args applyp)
283                     (when cached-emf-p 'emf))))))
284
285 (defmacro emit-checking-or-caching-macro (cached-emf-p
286                                           return-value-p
287                                           metatypes
288                                           applyp)
289   (let ((*emit-function-p* nil)
290         (*precompiling-lap* t))
291     (values
292      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
293
294 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
295   (let* ((index -1)
296          (wrapper-bindings (mapcan (lambda (arg mt)
297                                      (unless (eq mt t)
298                                        (incf index)
299                                        `((,(format-symbol *pcl-package*
300                                                           "WRAPPER-~D"
301                                                           index)
302                                           ,(emit-fetch-wrapper
303                                             mt arg 'miss (pop slot-regs))))))
304                                    args metatypes))
305          (wrappers (mapcar #'car wrapper-bindings)))
306     (declare (fixnum index))
307     (unless wrappers (error "Every metatype is T."))
308     `(block dfun
309        (tagbody
310           (let ((field (cache-field cache))
311                 (cache-vector (cache-vector cache))
312                 (mask (cache-mask cache))
313                 (size (cache-size cache))
314                 (overflow (cache-overflow cache))
315                 ,@wrapper-bindings)
316             (declare (fixnum size field mask))
317             ,(cond ((cdr wrappers)
318                     (emit-greater-than-1-dlap wrappers 'miss value-reg))
319                    (value-reg
320                     (emit-1-t-dlap (car wrappers) 'miss value-reg))
321                    (t
322                     (emit-1-nil-dlap (car wrappers) 'miss)))
323             (return-from dfun ,hit))
324         miss
325           (return-from dfun ,miss)))))
326
327 (defun emit-1-nil-dlap (wrapper miss-label)
328   `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
329                                                                    miss-label))
330           (location primary))
331      (declare (fixnum primary location))
332      (block search
333        (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
334                (return-from search nil))
335              (setq location (the fixnum (+ location 1)))
336              (when (= location size)
337                (setq location 0))
338              (when (= location primary)
339                (dolist (entry overflow)
340                  (when (eq (car entry) ,wrapper)
341                    (return-from search nil)))
342                (go ,miss-label))))))
343
344 (defmacro get-cache-vector-lock-count (cache-vector)
345   `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
346      (unless (typep lock-count 'fixnum)
347        (error "My cache got freed somehow."))
348      (the fixnum lock-count)))
349
350 (defun emit-1-t-dlap (wrapper miss-label value)
351   `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
352                                                                   miss-label))
353          (initial-lock-count (get-cache-vector-lock-count cache-vector)))
354      (declare (fixnum primary initial-lock-count))
355      (let ((location primary))
356        (declare (fixnum location))
357        (block search
358          (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
359                  (setq ,value (cache-vector-ref cache-vector (1+ location)))
360                  (return-from search nil))
361                (setq location (the fixnum (+ location 2)))
362                (when (= location size)
363                  (setq location 0))
364                (when (= location primary)
365                  (dolist (entry overflow)
366                    (when (eq (car entry) ,wrapper)
367                      (setq ,value (cdr entry))
368                      (return-from search nil)))
369                  (go ,miss-label))))
370        (unless (= initial-lock-count
371                   (get-cache-vector-lock-count cache-vector))
372          (go ,miss-label)))))
373
374 (defun emit-greater-than-1-dlap (wrappers miss-label value)
375   (declare (type list wrappers))
376   (let ((cache-line-size (compute-line-size (+ (length wrappers)
377                                                (if value 1 0)))))
378     `(let ((primary 0)
379            (size-1 (the fixnum (- size 1))))
380        (declare (fixnum primary size-1))
381        ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
382        (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
383          (declare (fixnum initial-lock-count))
384          (let ((location primary)
385                (next-location 0))
386            (declare (fixnum location next-location))
387            (block search
388              (loop (setq next-location
389                          (the fixnum (+ location ,cache-line-size)))
390                    (when (and ,@(mapcar
391                                  (lambda (wrapper)
392                                    `(eq ,wrapper
393                                         (cache-vector-ref
394                                          cache-vector
395                                          (setq location
396                                                (the fixnum (+ location 1))))))
397                                  wrappers))
398                      ,@(when value
399                          `((setq location (the fixnum (+ location 1)))
400                            (setq ,value (cache-vector-ref cache-vector
401                                                           location))))
402                      (return-from search nil))
403                    (setq location next-location)
404                    (when (= location size-1)
405                      (setq location 0))
406                    (when (= location primary)
407                      (dolist (entry overflow)
408                        (let ((entry-wrappers (car entry)))
409                          (when (and ,@(mapcar (lambda (wrapper)
410                                                 `(eq ,wrapper
411                                                      (pop entry-wrappers)))
412                                               wrappers))
413                            ,@(when value
414                                `((setq ,value (cdr entry))))
415                            (return-from search nil))))
416                      (go ,miss-label))))
417            (unless (= initial-lock-count
418                       (get-cache-vector-lock-count cache-vector))
419              (go ,miss-label)))))))
420
421 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
422   `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
423      (declare (fixnum wrapper-cache-no))
424      (when (zerop wrapper-cache-no) (go ,miss-label))
425      ,(let ((form `(logand mask wrapper-cache-no)))
426         `(the fixnum ,form))))
427
428 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
429   (declare (type list wrappers))
430   ;; This returns 1 less that the actual location.
431   `(progn
432      ,@(let ((adds 0) (len (length wrappers)))
433          (declare (fixnum adds len))
434          (mapcar (lambda (wrapper)
435                    `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
436                                              ,wrapper field)))
437                       (declare (fixnum wrapper-cache-no))
438                       (when (zerop wrapper-cache-no) (go ,miss-label))
439                       (setq primary (the fixnum (+ primary wrapper-cache-no)))
440                       ,@(progn
441                           (incf adds)
442                           (when (or (zerop (mod adds
443                                                 wrapper-cache-number-adds-ok))
444                                     (eql adds len))
445                             `((setq primary
446                                     ,(let ((form `(logand primary mask)))
447                                        `(the fixnum ,form))))))))
448                  wrappers))))
449
450 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
451 ;;; CMU/SBCL approach of using funcallable instances, that branch may
452 ;;; run on non-pcl instances (structures). The result will be the
453 ;;; non-wrapper layout for the structure, which will cause a miss. The
454 ;;; "slots" will be whatever the first slot is, but will be ignored.
455 ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
456 ;;; as well as PCL fins.
457 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
458   (ecase metatype
459     ((standard-instance)
460      `(cond ((std-instance-p ,argument)
461              ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
462              (std-instance-wrapper ,argument))
463             ((fsc-instance-p ,argument)
464              ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
465              (fsc-instance-wrapper ,argument))
466             (t
467              (go ,miss-label))))
468     (class
469      (when slot (error "can't do a slot reg for this metatype"))
470      `(wrapper-of-macro ,argument))
471     ((built-in-instance structure-instance)
472      (when slot (error "can't do a slot reg for this metatype"))
473      `(built-in-or-structure-wrapper
474        ,argument))))
475