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
29 ;;; This file is (almost) functionally equivalent to dlap.lisp, but easier to
32 ;;; Might generate faster code, too, depending on the compiler and whether an
33 ;;; implementation-specific lap assembler was used.
35 (defun emit-one-class-reader (class-slot-p)
36 (emit-reader/writer :reader 1 class-slot-p))
38 (defun emit-one-class-writer (class-slot-p)
39 (emit-reader/writer :writer 1 class-slot-p))
41 (defun emit-two-class-reader (class-slot-p)
42 (emit-reader/writer :reader 2 class-slot-p))
44 (defun emit-two-class-writer (class-slot-p)
45 (emit-reader/writer :writer 2 class-slot-p))
47 ;;; --------------------------------
49 (defun emit-one-index-readers (class-slot-p)
50 (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
52 (defun emit-one-index-writers (class-slot-p)
53 (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
55 (defun emit-n-n-readers ()
56 (emit-one-or-n-index-reader/writer :reader t nil))
58 (defun emit-n-n-writers ()
59 (emit-one-or-n-index-reader/writer :writer t nil))
61 ;;; --------------------------------
63 (defun emit-checking (metatypes applyp)
64 (emit-checking-or-caching nil nil metatypes applyp))
66 (defun emit-caching (metatypes applyp)
67 (emit-checking-or-caching t nil metatypes applyp))
69 (defun emit-in-checking-cache-p (metatypes)
70 (emit-checking-or-caching nil t metatypes nil))
72 (defun emit-constant-value (metatypes)
73 (emit-checking-or-caching t t metatypes nil))
75 ;;; --------------------------------
77 (defvar *precompiling-lap* nil)
78 (defvar *emit-function-p* t)
80 (defun emit-default-only (metatypes applyp)
81 (when (and (null *precompiling-lap*) *emit-function-p*)
82 (return-from emit-default-only
83 (emit-default-only-function metatypes applyp)))
84 (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
85 (args (remove '&rest dlap-lambda-list))
86 (restl (when applyp '(.lap-rest-arg.))))
87 (generating-lisp '(emf)
89 `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
91 (defmacro emit-default-only-macro (metatypes applyp)
92 (let ((*emit-function-p* nil)
93 (*precompiling-lap* t))
95 (emit-default-only metatypes applyp))))
97 ;;; --------------------------------
99 (defun generating-lisp (closure-variables args form)
100 (let* ((rest (memq '&rest args))
101 (ldiff (and rest (ldiff args rest)))
102 (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
103 (lambda `(lambda ,closure-variables
104 ,@(when (member 'miss-fn closure-variables)
105 `((declare (type function miss-fn))))
106 #'(sb-kernel:instance-lambda ,args
108 (declare #.*optimize-speed*)
110 (values (if *precompiling-lap*
112 (compile-lambda lambda))
115 ;;; note on implementation for CMU 17 and later (including SBCL):
116 ;;; Since std-instance-p is weakened, that branch may run on non-pcl
117 ;;; instances (structures). The result will be the non-wrapper layout
118 ;;; for the structure, which will cause a miss. The "slots" will be
119 ;;; whatever the first slot is, but will be ignored. Similarly,
120 ;;; fsc-instance-p returns true on funcallable structures as well as
122 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
123 (when (and (null *precompiling-lap*) *emit-function-p*)
124 (return-from emit-reader/writer
125 (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
128 (closure-variables ())
129 (field (first-wrapper-cache-number-index))
130 (readp (eq reader/writer :reader))
131 (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
132 ;;we need some field to do the fast obsolete check
134 (:reader (setq instance (dfun-arg-symbol 0)
135 arglist (list instance)))
136 (:writer (setq instance (dfun-arg-symbol 1)
137 arglist (list (dfun-arg-symbol 0) instance))))
139 (1 (setq closure-variables '(wrapper-0 index miss-fn)))
140 (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
141 (generating-lisp closure-variables
143 `(let* (,@(unless class-slot-p `((slots nil)))
144 (wrapper (cond ((std-instance-p ,instance)
145 ,@(unless class-slot-p
146 `((setq slots (std-instance-slots ,instance))))
147 (std-instance-wrapper ,instance))
148 ((fsc-instance-p ,instance)
149 ,@(unless class-slot-p
150 `((setq slots (fsc-instance-slots ,instance))))
151 (fsc-instance-wrapper ,instance)))))
154 (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
155 ,@(if (eql 1 1-or-2-class)
156 `((eq wrapper wrapper-0))
157 `((or (eq wrapper wrapper-0)
158 (eq wrapper wrapper-1)))))
160 `((let ((value ,read-form))
161 (unless (eq value *slot-unbound*)
162 (return-from access value))))
163 `((return-from access (setf ,read-form ,(car arglist))))))
164 (funcall miss-fn ,@arglist))))))
166 (defun emit-slot-read-form (class-slot-p index slots)
169 `(%instance-ref ,slots ,index)))
171 (defun emit-boundp-check (value-form miss-fn arglist)
172 `(let ((value ,value-form))
173 (if (eq value *slot-unbound*)
174 (funcall ,miss-fn ,@arglist)
177 (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
178 (let ((read-form (emit-slot-read-form class-slot-p index slots)))
180 (:reader (emit-boundp-check read-form miss-fn arglist))
181 (:writer `(setf ,read-form ,(car arglist))))))
183 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
184 (let ((*emit-function-p* nil)
185 (*precompiling-lap* t))
187 (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
189 (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
190 (when (and (null *precompiling-lap*) *emit-function-p*)
191 (return-from emit-one-or-n-index-reader/writer
192 (emit-one-or-n-index-reader/writer-function
193 reader/writer cached-index-p class-slot-p)))
194 (multiple-value-bind (arglist metatypes)
196 (:reader (values (list (dfun-arg-symbol 0))
197 '(standard-instance)))
198 (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
199 '(t standard-instance))))
200 (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
202 `(let (,@(unless class-slot-p '(slots))
203 ,@(when cached-index-p '(index)))
204 ,(emit-dlap arglist metatypes
205 (emit-slot-access reader/writer class-slot-p
206 'slots 'index 'miss-fn arglist)
207 `(funcall miss-fn ,@arglist)
208 (when cached-index-p 'index)
209 (unless class-slot-p '(slots)))))))
211 (defmacro emit-one-or-n-index-reader/writer-macro
212 (reader/writer cached-index-p class-slot-p)
213 (let ((*emit-function-p* nil)
214 (*precompiling-lap* t))
216 (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
218 (defun emit-miss (miss-fn args &optional applyp)
219 (let ((restl (when applyp '(.lap-rest-arg.))))
221 `(apply ,miss-fn ,@args ,@restl)
222 `(funcall ,miss-fn ,@args ,@restl))))
224 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
225 (when (and (null *precompiling-lap*) *emit-function-p*)
226 (return-from emit-checking-or-caching
227 (emit-checking-or-caching-function
228 cached-emf-p return-value-p metatypes applyp)))
229 (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
230 (args (remove '&rest dlap-lambda-list))
231 (restl (when applyp '(.lap-rest-arg.))))
232 (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
234 `(let (,@(when cached-emf-p '(emf)))
238 (if cached-emf-p 'emf t)
239 `(invoke-effective-method-function emf ,applyp
241 (emit-miss 'miss-fn args applyp)
242 (when cached-emf-p 'emf))))))
244 (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
245 (let ((*emit-function-p* nil)
246 (*precompiling-lap* t))
248 (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
250 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
252 (wrapper-bindings (mapcan #'(lambda (arg mt)
255 `((,(intern (format nil
259 ,(emit-fetch-wrapper mt arg 'miss
262 (wrappers (mapcar #'car wrapper-bindings)))
263 (declare (fixnum index))
264 (unless wrappers (error "Every metatype is T."))
267 (let ((field (cache-field cache))
268 (cache-vector (cache-vector cache))
269 (mask (cache-mask cache))
270 (size (cache-size cache))
271 (overflow (cache-overflow cache))
273 (declare (fixnum size field mask))
274 ,(cond ((cdr wrappers)
275 (emit-greater-than-1-dlap wrappers 'miss value-reg))
277 (emit-1-t-dlap (car wrappers) 'miss value-reg))
279 (emit-1-nil-dlap (car wrappers) 'miss)))
280 (return-from dfun ,hit))
282 (return-from dfun ,miss)))))
284 (defun emit-1-nil-dlap (wrapper miss-label)
285 `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
287 (declare (fixnum primary location))
289 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
290 (return-from search nil))
291 (setq location (the fixnum (+ location 1)))
292 (when (= location size)
294 (when (= location primary)
295 (dolist (entry overflow)
296 (when (eq (car entry) ,wrapper)
297 (return-from search nil)))
298 (go ,miss-label))))))
300 (defmacro get-cache-vector-lock-count (cache-vector)
301 `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
302 (unless (typep lock-count 'fixnum)
303 (error "My cache got freed somehow."))
304 (the fixnum lock-count)))
306 (defun emit-1-t-dlap (wrapper miss-label value)
307 `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
308 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
309 (declare (fixnum primary initial-lock-count))
310 (let ((location primary))
311 (declare (fixnum location))
313 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
314 (setq ,value (cache-vector-ref cache-vector (1+ location)))
315 (return-from search nil))
316 (setq location (the fixnum (+ location 2)))
317 (when (= location size)
319 (when (= location primary)
320 (dolist (entry overflow)
321 (when (eq (car entry) ,wrapper)
322 (setq ,value (cdr entry))
323 (return-from search nil)))
325 (unless (= initial-lock-count
326 (get-cache-vector-lock-count cache-vector))
329 (defun emit-greater-than-1-dlap (wrappers miss-label value)
330 (declare (type list wrappers))
331 (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
332 `(let ((primary 0) (size-1 (the fixnum (- size 1))))
333 (declare (fixnum primary size-1))
334 ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
335 (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
336 (declare (fixnum initial-lock-count))
337 (let ((location primary) (next-location 0))
338 (declare (fixnum location next-location))
340 (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
344 (cache-vector-ref cache-vector
346 (the fixnum (+ location 1))))))
349 `((setq location (the fixnum (+ location 1)))
350 (setq ,value (cache-vector-ref cache-vector location))))
351 (return-from search nil))
352 (setq location next-location)
353 (when (= location size-1)
355 (when (= location primary)
356 (dolist (entry overflow)
357 (let ((entry-wrappers (car entry)))
358 (when (and ,@(mapcar #'(lambda (wrapper)
359 `(eq ,wrapper (pop entry-wrappers)))
362 `((setq ,value (cdr entry))))
363 (return-from search nil))))
365 (unless (= initial-lock-count
366 (get-cache-vector-lock-count cache-vector))
367 (go ,miss-label)))))))
369 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
370 `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
371 (declare (fixnum wrapper-cache-no))
372 (when (zerop wrapper-cache-no) (go ,miss-label))
373 ,(let ((form `(logand mask wrapper-cache-no)))
374 `(the fixnum ,form))))
376 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
377 (declare (type list wrappers))
378 ;; This returns 1 less that the actual location.
380 ,@(let ((adds 0) (len (length wrappers)))
381 (declare (fixnum adds len))
382 (mapcar #'(lambda (wrapper)
383 `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
385 (declare (fixnum wrapper-cache-no))
386 (when (zerop wrapper-cache-no) (go ,miss-label))
387 (setq primary (the fixnum (+ primary wrapper-cache-no)))
390 (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
393 ,(let ((form `(logand primary mask)))
394 `(the fixnum ,form))))))))
397 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL
398 ;;; approach of using funcallable instances, that branch may run
399 ;;; on non-pcl instances (structures). The result will be the
400 ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
401 ;;; will be whatever the first slot is, but will be ignored. Similarly,
402 ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
403 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
406 `(cond ((std-instance-p ,argument)
407 ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
408 (std-instance-wrapper ,argument))
409 ((fsc-instance-p ,argument)
410 ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
411 (fsc-instance-wrapper ,argument))
415 (when slot (error "can't do a slot reg for this metatype"))
416 `(wrapper-of-macro ,argument))
417 ((built-in-instance structure-instance)
418 (when slot (error "can't do a slot reg for this metatype"))
419 `(built-in-or-structure-wrapper