1 ;;;; This software is part of the SBCL system. See the README file for
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
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
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
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
26 ;;;; some support stuff for getting a hold of symbols that we need when
27 ;;;; building the discriminator codes. It's OK for these to be interned
28 ;;;; symbols because we don't capture any user code in the scope in which
29 ;;;; these symbols are bound.
31 (declaim (list *dfun-arg-symbols*))
32 (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
34 (defun dfun-arg-symbol (arg-number)
35 (or (nth arg-number *dfun-arg-symbols*)
36 (format-symbol *pcl-package* ".ARG~A." arg-number)))
38 (declaim (list *slot-vector-symbols*))
39 (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
41 (defun slot-vector-symbol (arg-number)
42 (or (nth arg-number *slot-vector-symbols*)
43 (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
45 (declaim (inline make-dfun-required-args))
46 (defun make-dfun-required-args (count)
47 (declare (type index count))
49 (dotimes (i count (nreverse result))
50 (push (dfun-arg-symbol i) result))))
52 (defun make-dfun-lambda-list (nargs applyp)
53 (let ((required (make-dfun-required-args nargs)))
56 ;; Use &MORE arguments to avoid consing up an &REST list
57 ;; that we might not need at all. See MAKE-EMF-CALL and
58 ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other
60 '(&more .dfun-more-context. .dfun-more-count.))
63 (defun make-dlap-lambda-list (nargs applyp)
64 (let* ((required (make-dfun-required-args nargs))
65 (lambda-list (if applyp
66 (append required '(&more .more-context. .more-count.))
68 ;; Return the full lambda list, the required arguments, a form
69 ;; that will generate a rest-list, and a list of the &MORE
74 '((sb-c::%listify-rest-args
76 (the (and unsigned-byte fixnum)
79 '(.more-context. .more-count.)))))
81 (defun make-emf-call (nargs applyp fn-variable &optional emf-type)
82 (let ((required (make-dfun-required-args nargs)))
83 `(,(if (eq emf-type 'fast-method-call)
84 'invoke-effective-method-function-fast
85 'invoke-effective-method-function)
88 :required-args ,required
89 ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use
90 ;; the :REST-ARG version or the :MORE-ARG version depending on
91 ;; the type of the EMF.
93 ;; Creates a list from the &MORE arguments.
94 '((sb-c::%listify-rest-args
96 (the (and unsigned-byte fixnum)
99 :more-arg ,(when applyp
100 '(.dfun-more-context. .dfun-more-count.)))))
102 (defun make-fast-method-call-lambda-list (nargs applyp)
103 (list* '.pv-cell. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
105 ;;; Emitting various accessors.
107 (defun emit-one-class-reader (class-slot-p)
108 (emit-reader/writer :reader 1 class-slot-p))
110 (defun emit-one-class-boundp (class-slot-p)
111 (emit-reader/writer :boundp 1 class-slot-p))
113 (defun emit-one-class-writer (class-slot-p)
114 (emit-reader/writer :writer 1 class-slot-p))
116 (defun emit-two-class-reader (class-slot-p)
117 (emit-reader/writer :reader 2 class-slot-p))
119 (defun emit-two-class-boundp (class-slot-p)
120 (emit-reader/writer :boundp 2 class-slot-p))
122 (defun emit-two-class-writer (class-slot-p)
123 (emit-reader/writer :writer 2 class-slot-p))
125 ;;; --------------------------------
127 (defun emit-one-index-readers (class-slot-p)
128 (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
130 (defun emit-one-index-boundps (class-slot-p)
131 (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
133 (defun emit-one-index-writers (class-slot-p)
134 (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
136 (defun emit-n-n-readers ()
137 (emit-one-or-n-index-reader/writer :reader t nil))
139 (defun emit-n-n-boundps ()
140 (emit-one-or-n-index-reader/writer :boundp t nil))
142 (defun emit-n-n-writers ()
143 (emit-one-or-n-index-reader/writer :writer t nil))
145 ;;; --------------------------------
147 (defun emit-checking (metatypes applyp)
148 (emit-checking-or-caching nil nil metatypes applyp))
150 (defun emit-caching (metatypes applyp)
151 (emit-checking-or-caching t nil metatypes applyp))
153 (defun emit-in-checking-cache-p (metatypes)
154 (emit-checking-or-caching nil t metatypes nil))
156 (defun emit-constant-value (metatypes)
157 (emit-checking-or-caching t t metatypes nil))
159 ;;; --------------------------------
161 ;;; FIXME: What do these variables mean?
162 (defvar *precompiling-lap* nil)
163 (defvar *emit-function-p* t)
165 ;;; FIXME: This variable is motivated by Gerd Moellman's observation,
166 ;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
167 ;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
168 ;;; order-of-magnitude slowdown. We include this variable for now,
169 ;;; but maybe its effect should rather be controlled by compilation
170 ;;; policy if there is a noticeable space difference between the
171 ;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
172 ;;; deleted. It's not clear to me how all of this works, though, so
173 ;;; until proper benchmarks are done it's probably safest simply to
174 ;;; have this pseudo-constant to hide code. -- CSR, 2003-02-14
175 (defvar *optimize-cache-functions-p* t)
177 (defun emit-default-only (metatypes applyp)
178 (unless *optimize-cache-functions-p*
179 (when (and (null *precompiling-lap*) *emit-function-p*)
180 (return-from emit-default-only
181 (emit-default-only-function metatypes applyp))))
182 (multiple-value-bind (lambda-list args rest-arg more-arg)
183 (make-dlap-lambda-list (length metatypes) applyp)
184 (generating-lisp '(emf)
186 `(invoke-effective-method-function emf
190 :rest-arg ,rest-arg))))
192 ;;; --------------------------------
194 (defun generating-lisp (closure-variables args form)
195 (let ((lambda `(lambda ,closure-variables
196 ,@(when (member 'miss-fn closure-variables)
197 `((declare (type function miss-fn))))
200 (declare #.*optimize-speed*)
202 (values (if *precompiling-lap*
204 (compile nil lambda))
207 ;;; note on implementation for CMU 17 and later (including SBCL):
208 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
209 ;;; instances (structures). The result will be the non-wrapper layout
210 ;;; for the structure, which will cause a miss. The "slots" will be
211 ;;; whatever the first slot is, but will be ignored. Similarly,
212 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
214 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
215 (unless *optimize-cache-functions-p*
216 (when (and (null *precompiling-lap*) *emit-function-p*)
217 (return-from emit-reader/writer
218 (emit-reader/writer-function
219 reader/writer 1-or-2-class class-slot-p))))
222 (closure-variables ())
223 (field +first-wrapper-cache-number-index+)
224 (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
225 ;;we need some field to do the fast obsolete check
228 (setq instance (dfun-arg-symbol 0)
229 arglist (list instance)))
230 (:writer (setq instance (dfun-arg-symbol 1)
231 arglist (list (dfun-arg-symbol 0) instance))))
233 (1 (setq closure-variables '(wrapper-0 index miss-fn)))
234 (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
238 `(let* (,@(unless class-slot-p `((slots nil)))
239 (wrapper (cond ((std-instance-p ,instance)
240 ,@(unless class-slot-p
242 (std-instance-slots ,instance))))
243 (std-instance-wrapper ,instance))
244 ((fsc-instance-p ,instance)
245 ,@(unless class-slot-p
247 (fsc-instance-slots ,instance))))
248 (fsc-instance-wrapper ,instance)))))
251 (/= (layout-clos-hash wrapper ,field) 0)
252 ,@(if (eql 1 1-or-2-class)
253 `((eq wrapper wrapper-0))
254 `((or (eq wrapper wrapper-0)
255 (eq wrapper wrapper-1)))))
256 ,@(ecase reader/writer
258 `((let ((value ,read-form))
259 (unless (eq value +slot-unbound+)
260 (return-from access value)))))
262 `((let ((value ,read-form))
263 (return-from access (not (eq value +slot-unbound+))))))
265 `((return-from access (setf ,read-form ,(car arglist)))))))
266 (funcall miss-fn ,@arglist))))))
268 (defun emit-slot-read-form (class-slot-p index slots)
271 `(clos-slots-ref ,slots ,index)))
273 (defun emit-boundp-check (value-form miss-fn arglist)
274 `(let ((value ,value-form))
275 (if (eq value +slot-unbound+)
276 (funcall ,miss-fn ,@arglist)
279 (defun emit-slot-access (reader/writer class-slot-p slots
280 index miss-fn arglist)
281 (let ((read-form (emit-slot-read-form class-slot-p index slots)))
283 (:reader (emit-boundp-check read-form miss-fn arglist))
284 (:boundp `(not (eq ,read-form +slot-unbound+)))
285 (:writer `(setf ,read-form ,(car arglist))))))
287 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
288 (let ((*emit-function-p* nil)
289 (*precompiling-lap* t))
291 (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
293 (defun emit-one-or-n-index-reader/writer (reader/writer
296 (unless *optimize-cache-functions-p*
297 (when (and (null *precompiling-lap*) *emit-function-p*)
298 (return-from emit-one-or-n-index-reader/writer
299 (emit-one-or-n-index-reader/writer-function
300 reader/writer cached-index-p class-slot-p))))
301 (multiple-value-bind (arglist metatypes)
304 (values (list (dfun-arg-symbol 0))
305 '(standard-instance)))
306 (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
307 '(t standard-instance))))
309 `(cache ,@(unless cached-index-p '(index)) miss-fn)
311 `(let (,@(unless class-slot-p '(slots))
312 ,@(when cached-index-p '(index)))
313 ,(emit-dlap 'cache arglist metatypes
314 (emit-slot-access reader/writer class-slot-p
315 'slots 'index 'miss-fn arglist)
316 `(funcall miss-fn ,@arglist)
317 (when cached-index-p 'index)
318 (unless class-slot-p '(slots)))))))
320 (defmacro emit-one-or-n-index-reader/writer-macro
321 (reader/writer cached-index-p class-slot-p)
322 (let ((*emit-function-p* nil)
323 (*precompiling-lap* t))
325 (emit-one-or-n-index-reader/writer reader/writer
329 (defun emit-miss (miss-fn args applyp)
331 `(multiple-value-call ,miss-fn ,@args
332 (sb-c::%more-arg-values .more-context.
335 `(funcall ,miss-fn ,@args)))
337 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
338 (unless *optimize-cache-functions-p*
339 (when (and (null *precompiling-lap*) *emit-function-p*)
340 (return-from emit-checking-or-caching
341 (emit-checking-or-caching-function
342 cached-emf-p return-value-p metatypes applyp))))
343 (multiple-value-bind (lambda-list args rest-arg more-arg)
344 (make-dlap-lambda-list (length metatypes) applyp)
346 `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
348 `(let (,@(when cached-emf-p '(emf)))
349 ,(emit-dlap 'cache args metatypes
351 (if cached-emf-p 'emf t)
352 `(invoke-effective-method-function
356 :rest-arg ,rest-arg))
357 (emit-miss 'miss-fn args applyp)
358 (when cached-emf-p 'emf))))))
360 (defmacro emit-checking-or-caching-macro (cached-emf-p
364 (let ((*emit-function-p* nil)
365 (*precompiling-lap* t))
367 (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
369 (defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
372 (miss-tag (gensym "MISSED"))
373 (wrapper-bindings (mapcan (lambda (arg mt)
376 `((,(format-symbol *pcl-package*
380 mt arg miss-tag (pop slot-vars))))))
382 (wrapper-vars (mapcar #'car wrapper-bindings)))
383 (declare (fixnum index))
385 (error "Every metatype is T."))
388 (let ((field (cache-field ,cache-var))
389 (cache-vector (cache-vector ,cache-var))
390 (mask (cache-mask ,cache-var))
391 (size (cache-size ,cache-var))
392 (overflow (cache-overflow ,cache-var))
394 (declare (fixnum size field mask))
395 ,(emit-cache-lookup wrapper-vars miss-tag value-var)
398 (return ,miss-form))))
400 (defun emit-cache-lookup (wrapper-vars miss-tag value-reg)
401 (cond ((cdr wrapper-vars)
402 (emit-greater-than-1-dlap wrapper-vars miss-tag value-reg))
404 (emit-1-t-dlap (car wrapper-vars) miss-tag value-reg))
406 (emit-1-nil-dlap (car wrapper-vars) miss-tag))))
408 (defun emit-1-nil-dlap (wrapper miss-label)
409 `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
412 (declare (fixnum primary location))
414 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
415 (return-from search nil))
416 (setq location (the fixnum (+ location 1)))
417 (when (= location size)
419 (when (= location primary)
420 (dolist (entry overflow)
421 (when (eq (car entry) ,wrapper)
422 (return-from search nil)))
423 (go ,miss-label))))))
425 (defmacro get-cache-vector-lock-count (cache-vector)
426 `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
427 (unless (typep lock-count 'fixnum)
428 (error "My cache got freed somehow."))
429 (the fixnum lock-count)))
431 (defun emit-1-t-dlap (wrapper miss-label value)
432 `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
434 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
435 (declare (fixnum primary initial-lock-count))
436 (let ((location primary))
437 (declare (fixnum location))
439 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
440 (setq ,value (cache-vector-ref cache-vector (1+ location)))
441 (return-from search nil))
442 (setq location (the fixnum (+ location 2)))
443 (when (= location size)
445 (when (= location primary)
446 (dolist (entry overflow)
447 (when (eq (car entry) ,wrapper)
448 (setq ,value (cdr entry))
449 (return-from search nil)))
451 (unless (= initial-lock-count
452 (get-cache-vector-lock-count cache-vector))
455 (defun emit-greater-than-1-dlap (wrappers miss-label value)
456 (declare (type list wrappers))
457 (let ((cache-line-size (compute-line-size (+ (length wrappers)
460 (size-1 (the fixnum (- size 1))))
461 (declare (fixnum primary size-1))
462 ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
463 (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
464 (declare (fixnum initial-lock-count))
465 (let ((location primary)
467 (declare (fixnum location next-location))
469 (loop (setq next-location
470 (the fixnum (+ location ,cache-line-size)))
477 (the fixnum (+ location 1))))))
480 `((setq location (the fixnum (+ location 1)))
481 (setq ,value (cache-vector-ref cache-vector
483 (return-from search nil))
484 (setq location next-location)
485 (when (= location size-1)
487 (when (= location primary)
488 (dolist (entry overflow)
489 (let ((entry-wrappers (car entry)))
490 (when (and ,@(mapcar (lambda (wrapper)
492 (pop entry-wrappers)))
495 `((setq ,value (cdr entry))))
496 (return-from search nil))))
498 (unless (= initial-lock-count
499 (get-cache-vector-lock-count cache-vector))
500 (go ,miss-label)))))))
502 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
503 `(let ((wrapper-cache-no (layout-clos-hash ,wrapper field)))
504 (declare (fixnum wrapper-cache-no))
505 (when (zerop wrapper-cache-no) (go ,miss-label))
506 ,(let ((form `(logand mask wrapper-cache-no)))
507 `(the fixnum ,form))))
509 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
510 (declare (type list wrappers))
511 ;; This returns 1 less that the actual location.
513 ,@(let ((adds 0) (len (length wrappers)))
514 (declare (fixnum adds len))
515 (mapcar (lambda (wrapper)
516 `(let ((wrapper-cache-no (layout-clos-hash ,wrapper field)))
517 (declare (fixnum wrapper-cache-no))
518 (when (zerop wrapper-cache-no) (go ,miss-label))
519 (setq primary (the fixnum (+ primary wrapper-cache-no)))
522 (when (or (zerop (mod adds
523 wrapper-cache-number-adds-ok))
526 ,(let ((form `(logand primary mask)))
527 `(the fixnum ,form))))))))
530 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
531 ;;; CMU/SBCL approach of using funcallable instances, that branch may
532 ;;; run on non-pcl instances (structures). The result will be the
533 ;;; non-wrapper layout for the structure, which will cause a miss. The
534 ;;; "slots" will be whatever the first slot is, but will be ignored.
535 ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
536 ;;; as well as PCL fins.
537 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
540 `(cond ((std-instance-p ,argument)
541 ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
542 (std-instance-wrapper ,argument))
543 ((fsc-instance-p ,argument)
544 ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
545 (fsc-instance-wrapper ,argument))
548 ;; Sep92 PCL used to distinguish between some of these cases (and
549 ;; spuriously exclude others). Since in SBCL
550 ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
551 ;; equivalent and inlined to each other, we can collapse some
552 ;; spurious differences.
553 ((class built-in-instance structure-instance condition-instance)
554 (when slot (error "can't do a slot reg for this metatype"))
555 `(wrapper-of ,argument))
556 ;; a metatype of NIL should never be seen here, as NIL is only in
557 ;; the metatypes before a generic function is fully initialized.
558 ;; T should never be seen because we never need to get a wrapper
559 ;; to do dispatch if all methods have T as the respective
562 (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))