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 (metatypes)
47 ;; Micro-optimizations 'R Us
48 (labels ((rec (types i)
51 (cons (dfun-arg-symbol i)
52 (rec (cdr types) (1+ i))))))
55 (defun make-dfun-lambda-list (metatypes applyp)
56 (let ((required (make-dfun-required-args metatypes)))
59 ;; Use &MORE arguments to avoid consing up an &REST list
60 ;; that we might not need at all. See MAKE-EMF-CALL and
61 ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other
63 '(&more .dfun-more-context. .dfun-more-count.))
66 (defun make-dlap-lambda-list (metatypes applyp)
67 (let* ((required (make-dfun-required-args metatypes))
68 (lambda-list (if applyp
69 (append required '(&more .more-context. .more-count.))
71 ;; Return the full lambda list, the required arguments, a form
72 ;; that will generate a rest-list, and a list of the &MORE
77 '((sb-c::%listify-rest-args
79 (the (and unsigned-byte fixnum)
82 '(.more-context. .more-count.)))))
84 (defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
85 (let ((required (make-dfun-required-args metatypes)))
86 `(,(if (eq emf-type 'fast-method-call)
87 'invoke-effective-method-function-fast
88 'invoke-effective-method-function)
91 :required-args ,required
92 ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use
93 ;; the :REST-ARG version or the :MORE-ARG version depending on
94 ;; the type of the EMF.
96 ;; Creates a list from the &MORE arguments.
97 '((sb-c::%listify-rest-args
99 (the (and unsigned-byte fixnum)
102 :more-arg ,(when applyp
103 '(.dfun-more-context. .dfun-more-count.)))))
105 (defun make-fast-method-call-lambda-list (metatypes applyp)
106 (list* '.pv-cell. '.next-method-call.
107 (make-dfun-lambda-list metatypes applyp)))
109 ;;; Emitting various accessors.
111 (defun emit-one-class-reader (class-slot-p)
112 (emit-reader/writer :reader 1 class-slot-p))
114 (defun emit-one-class-boundp (class-slot-p)
115 (emit-reader/writer :boundp 1 class-slot-p))
117 (defun emit-one-class-writer (class-slot-p)
118 (emit-reader/writer :writer 1 class-slot-p))
120 (defun emit-two-class-reader (class-slot-p)
121 (emit-reader/writer :reader 2 class-slot-p))
123 (defun emit-two-class-boundp (class-slot-p)
124 (emit-reader/writer :boundp 2 class-slot-p))
126 (defun emit-two-class-writer (class-slot-p)
127 (emit-reader/writer :writer 2 class-slot-p))
129 ;;; --------------------------------
131 (defun emit-one-index-readers (class-slot-p)
132 (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
134 (defun emit-one-index-boundps (class-slot-p)
135 (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
137 (defun emit-one-index-writers (class-slot-p)
138 (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
140 (defun emit-n-n-readers ()
141 (emit-one-or-n-index-reader/writer :reader t nil))
143 (defun emit-n-n-boundps ()
144 (emit-one-or-n-index-reader/writer :boundp t nil))
146 (defun emit-n-n-writers ()
147 (emit-one-or-n-index-reader/writer :writer t nil))
149 ;;; --------------------------------
151 (defun emit-checking (metatypes applyp)
152 (emit-checking-or-caching nil nil metatypes applyp))
154 (defun emit-caching (metatypes applyp)
155 (emit-checking-or-caching t nil metatypes applyp))
157 (defun emit-in-checking-cache-p (metatypes)
158 (emit-checking-or-caching nil t metatypes nil))
160 (defun emit-constant-value (metatypes)
161 (emit-checking-or-caching t t metatypes nil))
163 ;;; --------------------------------
165 ;;; FIXME: What do these variables mean?
166 (defvar *precompiling-lap* nil)
167 (defvar *emit-function-p* t)
169 ;;; FIXME: This variable is motivated by Gerd Moellman's observation,
170 ;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
171 ;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
172 ;;; order-of-magnitude slowdown. We include this variable for now,
173 ;;; but maybe its effect should rather be controlled by compilation
174 ;;; policy if there is a noticeable space difference between the
175 ;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
176 ;;; deleted. It's not clear to me how all of this works, though, so
177 ;;; until proper benchmarks are done it's probably safest simply to
178 ;;; have this pseudo-constant to hide code. -- CSR, 2003-02-14
179 (defvar *optimize-cache-functions-p* t)
181 (defun emit-default-only (metatypes applyp)
182 (unless *optimize-cache-functions-p*
183 (when (and (null *precompiling-lap*) *emit-function-p*)
184 (return-from emit-default-only
185 (emit-default-only-function metatypes applyp))))
186 (multiple-value-bind (lambda-list args rest-arg more-arg)
187 (make-dlap-lambda-list metatypes applyp)
188 (generating-lisp '(emf)
190 `(invoke-effective-method-function emf
194 :rest-arg ,rest-arg))))
196 ;;; --------------------------------
198 (defun generating-lisp (closure-variables args form)
199 (let ((lambda `(lambda ,closure-variables
200 ,@(when (member 'miss-fn closure-variables)
201 `((declare (type function miss-fn))))
204 (declare #.*optimize-speed*)
206 (values (if *precompiling-lap*
208 (compile nil lambda))
211 ;;; note on implementation for CMU 17 and later (including SBCL):
212 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
213 ;;; instances (structures). The result will be the non-wrapper layout
214 ;;; for the structure, which will cause a miss. The "slots" will be
215 ;;; whatever the first slot is, but will be ignored. Similarly,
216 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
218 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
219 (unless *optimize-cache-functions-p*
220 (when (and (null *precompiling-lap*) *emit-function-p*)
221 (return-from emit-reader/writer
222 (emit-reader/writer-function
223 reader/writer 1-or-2-class class-slot-p))))
226 (closure-variables ())
227 (field +first-wrapper-cache-number-index+)
228 (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
229 ;;we need some field to do the fast obsolete check
232 (setq instance (dfun-arg-symbol 0)
233 arglist (list instance)))
234 (:writer (setq instance (dfun-arg-symbol 1)
235 arglist (list (dfun-arg-symbol 0) instance))))
237 (1 (setq closure-variables '(wrapper-0 index miss-fn)))
238 (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
242 `(let* (,@(unless class-slot-p `((slots nil)))
243 (wrapper (cond ((std-instance-p ,instance)
244 ,@(unless class-slot-p
246 (std-instance-slots ,instance))))
247 (std-instance-wrapper ,instance))
248 ((fsc-instance-p ,instance)
249 ,@(unless class-slot-p
251 (fsc-instance-slots ,instance))))
252 (fsc-instance-wrapper ,instance)))))
255 (/= (layout-clos-hash wrapper ,field) 0)
256 ,@(if (eql 1 1-or-2-class)
257 `((eq wrapper wrapper-0))
258 `((or (eq wrapper wrapper-0)
259 (eq wrapper wrapper-1)))))
260 ,@(ecase reader/writer
262 `((let ((value ,read-form))
263 (unless (eq value +slot-unbound+)
264 (return-from access value)))))
266 `((let ((value ,read-form))
267 (return-from access (not (eq value +slot-unbound+))))))
269 `((return-from access (setf ,read-form ,(car arglist)))))))
270 (funcall miss-fn ,@arglist))))))
272 (defun emit-slot-read-form (class-slot-p index slots)
275 `(clos-slots-ref ,slots ,index)))
277 (defun emit-boundp-check (value-form miss-fn arglist)
278 `(let ((value ,value-form))
279 (if (eq value +slot-unbound+)
280 (funcall ,miss-fn ,@arglist)
283 (defun emit-slot-access (reader/writer class-slot-p slots
284 index miss-fn arglist)
285 (let ((read-form (emit-slot-read-form class-slot-p index slots)))
287 (:reader (emit-boundp-check read-form miss-fn arglist))
288 (:boundp `(not (eq ,read-form +slot-unbound+)))
289 (:writer `(setf ,read-form ,(car arglist))))))
291 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
292 (let ((*emit-function-p* nil)
293 (*precompiling-lap* t))
295 (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
297 (defun emit-one-or-n-index-reader/writer (reader/writer
300 (unless *optimize-cache-functions-p*
301 (when (and (null *precompiling-lap*) *emit-function-p*)
302 (return-from emit-one-or-n-index-reader/writer
303 (emit-one-or-n-index-reader/writer-function
304 reader/writer cached-index-p class-slot-p))))
305 (multiple-value-bind (arglist metatypes)
308 (values (list (dfun-arg-symbol 0))
309 '(standard-instance)))
310 (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
311 '(t standard-instance))))
313 `(cache ,@(unless cached-index-p '(index)) miss-fn)
315 `(let (,@(unless class-slot-p '(slots))
316 ,@(when cached-index-p '(index)))
317 ,(emit-dlap 'cache arglist metatypes
318 (emit-slot-access reader/writer class-slot-p
319 'slots 'index 'miss-fn arglist)
320 `(funcall miss-fn ,@arglist)
321 (when cached-index-p 'index)
322 (unless class-slot-p '(slots)))))))
324 (defmacro emit-one-or-n-index-reader/writer-macro
325 (reader/writer cached-index-p class-slot-p)
326 (let ((*emit-function-p* nil)
327 (*precompiling-lap* t))
329 (emit-one-or-n-index-reader/writer reader/writer
333 (defun emit-miss (miss-fn args applyp)
335 `(multiple-value-call ,miss-fn ,@args
336 (sb-c::%more-arg-values .more-context.
339 `(funcall ,miss-fn ,@args)))
341 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
342 (unless *optimize-cache-functions-p*
343 (when (and (null *precompiling-lap*) *emit-function-p*)
344 (return-from emit-checking-or-caching
345 (emit-checking-or-caching-function
346 cached-emf-p return-value-p metatypes applyp))))
347 (multiple-value-bind (lambda-list args rest-arg more-arg)
348 (make-dlap-lambda-list metatypes applyp)
350 `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
352 `(let (,@(when cached-emf-p '(emf)))
353 ,(emit-dlap 'cache args metatypes
355 (if cached-emf-p 'emf t)
356 `(invoke-effective-method-function
360 :rest-arg ,rest-arg))
361 (emit-miss 'miss-fn args applyp)
362 (when cached-emf-p 'emf))))))
364 (defmacro emit-checking-or-caching-macro (cached-emf-p
368 (let ((*emit-function-p* nil)
369 (*precompiling-lap* t))
371 (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
373 (defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
376 (miss-tag (gensym "MISSED"))
377 (wrapper-bindings (mapcan (lambda (arg mt)
380 `((,(format-symbol *pcl-package*
384 mt arg miss-tag (pop slot-vars))))))
386 (wrapper-vars (mapcar #'car wrapper-bindings)))
387 (declare (fixnum index))
389 (error "Every metatype is T."))
392 (let ((field (cache-field ,cache-var))
393 (cache-vector (cache-vector ,cache-var))
394 (mask (cache-mask ,cache-var))
395 (size (cache-size ,cache-var))
396 (overflow (cache-overflow ,cache-var))
398 (declare (fixnum size field mask))
399 ,(emit-cache-lookup wrapper-vars miss-tag value-var)
402 (return ,miss-form))))
404 (defun emit-cache-lookup (wrapper-vars miss-tag value-reg)
405 (cond ((cdr wrapper-vars)
406 (emit-greater-than-1-dlap wrapper-vars miss-tag value-reg))
408 (emit-1-t-dlap (car wrapper-vars) miss-tag value-reg))
410 (emit-1-nil-dlap (car wrapper-vars) miss-tag))))
412 (defun emit-1-nil-dlap (wrapper miss-label)
413 `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
416 (declare (fixnum primary location))
418 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
419 (return-from search nil))
420 (setq location (the fixnum (+ location 1)))
421 (when (= location size)
423 (when (= location primary)
424 (dolist (entry overflow)
425 (when (eq (car entry) ,wrapper)
426 (return-from search nil)))
427 (go ,miss-label))))))
429 (defmacro get-cache-vector-lock-count (cache-vector)
430 `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
431 (unless (typep lock-count 'fixnum)
432 (error "My cache got freed somehow."))
433 (the fixnum lock-count)))
435 (defun emit-1-t-dlap (wrapper miss-label value)
436 `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
438 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
439 (declare (fixnum primary initial-lock-count))
440 (let ((location primary))
441 (declare (fixnum location))
443 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
444 (setq ,value (cache-vector-ref cache-vector (1+ location)))
445 (return-from search nil))
446 (setq location (the fixnum (+ location 2)))
447 (when (= location size)
449 (when (= location primary)
450 (dolist (entry overflow)
451 (when (eq (car entry) ,wrapper)
452 (setq ,value (cdr entry))
453 (return-from search nil)))
455 (unless (= initial-lock-count
456 (get-cache-vector-lock-count cache-vector))
459 (defun emit-greater-than-1-dlap (wrappers miss-label value)
460 (declare (type list wrappers))
461 (let ((cache-line-size (compute-line-size (+ (length wrappers)
464 (size-1 (the fixnum (- size 1))))
465 (declare (fixnum primary size-1))
466 ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
467 (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
468 (declare (fixnum initial-lock-count))
469 (let ((location primary)
471 (declare (fixnum location next-location))
473 (loop (setq next-location
474 (the fixnum (+ location ,cache-line-size)))
481 (the fixnum (+ location 1))))))
484 `((setq location (the fixnum (+ location 1)))
485 (setq ,value (cache-vector-ref cache-vector
487 (return-from search nil))
488 (setq location next-location)
489 (when (= location size-1)
491 (when (= location primary)
492 (dolist (entry overflow)
493 (let ((entry-wrappers (car entry)))
494 (when (and ,@(mapcar (lambda (wrapper)
496 (pop entry-wrappers)))
499 `((setq ,value (cdr entry))))
500 (return-from search nil))))
502 (unless (= initial-lock-count
503 (get-cache-vector-lock-count cache-vector))
504 (go ,miss-label)))))))
506 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
507 `(let ((wrapper-cache-no (layout-clos-hash ,wrapper field)))
508 (declare (fixnum wrapper-cache-no))
509 (when (zerop wrapper-cache-no) (go ,miss-label))
510 ,(let ((form `(logand mask wrapper-cache-no)))
511 `(the fixnum ,form))))
513 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
514 (declare (type list wrappers))
515 ;; This returns 1 less that the actual location.
517 ,@(let ((adds 0) (len (length wrappers)))
518 (declare (fixnum adds len))
519 (mapcar (lambda (wrapper)
520 `(let ((wrapper-cache-no (layout-clos-hash ,wrapper field)))
521 (declare (fixnum wrapper-cache-no))
522 (when (zerop wrapper-cache-no) (go ,miss-label))
523 (setq primary (the fixnum (+ primary wrapper-cache-no)))
526 (when (or (zerop (mod adds
527 wrapper-cache-number-adds-ok))
530 ,(let ((form `(logand primary mask)))
531 `(the fixnum ,form))))))))
534 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
535 ;;; CMU/SBCL approach of using funcallable instances, that branch may
536 ;;; run on non-pcl instances (structures). The result will be the
537 ;;; non-wrapper layout for the structure, which will cause a miss. The
538 ;;; "slots" will be whatever the first slot is, but will be ignored.
539 ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
540 ;;; as well as PCL fins.
541 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
544 `(cond ((std-instance-p ,argument)
545 ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
546 (std-instance-wrapper ,argument))
547 ((fsc-instance-p ,argument)
548 ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
549 (fsc-instance-wrapper ,argument))
553 (when slot (error "can't do a slot reg for this metatype"))
554 `(wrapper-of ,argument))
555 ((built-in-instance structure-instance)
556 (when slot (error "can't do a slot reg for this metatype"))
557 `(built-in-or-structure-wrapper