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 ;;; This file is (almost) functionally equivalent to dlap.lisp, but easier to
29 ;;; Might generate faster code, too, depending on the compiler and whether an
30 ;;; implementation-specific lap assembler was used.
32 (defun emit-one-class-reader (class-slot-p)
33 (emit-reader/writer :reader 1 class-slot-p))
35 (defun emit-one-class-writer (class-slot-p)
36 (emit-reader/writer :writer 1 class-slot-p))
38 (defun emit-two-class-reader (class-slot-p)
39 (emit-reader/writer :reader 2 class-slot-p))
41 (defun emit-two-class-writer (class-slot-p)
42 (emit-reader/writer :writer 2 class-slot-p))
44 ;;; --------------------------------
46 (defun emit-one-index-readers (class-slot-p)
47 (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
49 (defun emit-one-index-writers (class-slot-p)
50 (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
52 (defun emit-n-n-readers ()
53 (emit-one-or-n-index-reader/writer :reader t nil))
55 (defun emit-n-n-writers ()
56 (emit-one-or-n-index-reader/writer :writer t nil))
58 ;;; --------------------------------
60 (defun emit-checking (metatypes applyp)
61 (emit-checking-or-caching nil nil metatypes applyp))
63 (defun emit-caching (metatypes applyp)
64 (emit-checking-or-caching t nil metatypes applyp))
66 (defun emit-in-checking-cache-p (metatypes)
67 (emit-checking-or-caching nil t metatypes nil))
69 (defun emit-constant-value (metatypes)
70 (emit-checking-or-caching t t metatypes nil))
72 ;;; --------------------------------
74 (defvar *precompiling-lap* nil)
75 (defvar *emit-function-p* t)
77 (defun emit-default-only (metatypes applyp)
78 (when (and (null *precompiling-lap*) *emit-function-p*)
79 (return-from emit-default-only
80 (emit-default-only-function metatypes applyp)))
81 (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
82 (args (remove '&rest dlap-lambda-list))
83 (restl (when applyp '(.lap-rest-arg.))))
84 (generating-lisp '(emf)
86 `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
88 (defmacro emit-default-only-macro (metatypes applyp)
89 (let ((*emit-function-p* nil)
90 (*precompiling-lap* t))
92 (emit-default-only metatypes applyp))))
94 ;;; --------------------------------
96 (defun generating-lisp (closure-variables args form)
97 (let* ((rest (memq '&rest args))
98 (ldiff (and rest (ldiff args rest)))
99 (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
100 (lambda `(lambda ,closure-variables
101 ,@(when (member 'miss-fn closure-variables)
102 `((declare (type function miss-fn))))
103 #'(sb-kernel:instance-lambda ,args
105 (declare #.*optimize-speed*)
107 (values (if *precompiling-lap*
109 (compile-lambda lambda))
112 ;;; note on implementation for CMU 17 and later (including SBCL):
113 ;;; Since std-instance-p is weakened, that branch may run on non-pcl
114 ;;; instances (structures). The result will be the non-wrapper layout
115 ;;; for the structure, which will cause a miss. The "slots" will be
116 ;;; whatever the first slot is, but will be ignored. Similarly,
117 ;;; fsc-instance-p returns true on funcallable structures as well as
119 (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
120 (when (and (null *precompiling-lap*) *emit-function-p*)
121 (return-from emit-reader/writer
122 (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
125 (closure-variables ())
126 (field (first-wrapper-cache-number-index))
127 (readp (eq reader/writer :reader))
128 (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
129 ;;we need some field to do the fast obsolete check
131 (:reader (setq instance (dfun-arg-symbol 0)
132 arglist (list instance)))
133 (:writer (setq instance (dfun-arg-symbol 1)
134 arglist (list (dfun-arg-symbol 0) instance))))
136 (1 (setq closure-variables '(wrapper-0 index miss-fn)))
137 (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
138 (generating-lisp closure-variables
140 `(let* (,@(unless class-slot-p `((slots nil)))
141 (wrapper (cond ((std-instance-p ,instance)
142 ,@(unless class-slot-p
143 `((setq slots (std-instance-slots ,instance))))
144 (std-instance-wrapper ,instance))
145 ((fsc-instance-p ,instance)
146 ,@(unless class-slot-p
147 `((setq slots (fsc-instance-slots ,instance))))
148 (fsc-instance-wrapper ,instance)))))
151 (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
152 ,@(if (eql 1 1-or-2-class)
153 `((eq wrapper wrapper-0))
154 `((or (eq wrapper wrapper-0)
155 (eq wrapper wrapper-1)))))
157 `((let ((value ,read-form))
158 (unless (eq value +slot-unbound+)
159 (return-from access value))))
160 `((return-from access (setf ,read-form ,(car arglist))))))
161 (funcall miss-fn ,@arglist))))))
163 (defun emit-slot-read-form (class-slot-p index slots)
166 `(%instance-ref ,slots ,index)))
168 (defun emit-boundp-check (value-form miss-fn arglist)
169 `(let ((value ,value-form))
170 (if (eq value +slot-unbound+)
171 (funcall ,miss-fn ,@arglist)
174 (defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
175 (let ((read-form (emit-slot-read-form class-slot-p index slots)))
177 (:reader (emit-boundp-check read-form miss-fn arglist))
178 (:writer `(setf ,read-form ,(car arglist))))))
180 (defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
181 (let ((*emit-function-p* nil)
182 (*precompiling-lap* t))
184 (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
186 (defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
187 (when (and (null *precompiling-lap*) *emit-function-p*)
188 (return-from emit-one-or-n-index-reader/writer
189 (emit-one-or-n-index-reader/writer-function
190 reader/writer cached-index-p class-slot-p)))
191 (multiple-value-bind (arglist metatypes)
193 (:reader (values (list (dfun-arg-symbol 0))
194 '(standard-instance)))
195 (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
196 '(t standard-instance))))
197 (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
199 `(let (,@(unless class-slot-p '(slots))
200 ,@(when cached-index-p '(index)))
201 ,(emit-dlap arglist metatypes
202 (emit-slot-access reader/writer class-slot-p
203 'slots 'index 'miss-fn arglist)
204 `(funcall miss-fn ,@arglist)
205 (when cached-index-p 'index)
206 (unless class-slot-p '(slots)))))))
208 (defmacro emit-one-or-n-index-reader/writer-macro
209 (reader/writer cached-index-p class-slot-p)
210 (let ((*emit-function-p* nil)
211 (*precompiling-lap* t))
213 (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
215 (defun emit-miss (miss-fn args &optional applyp)
216 (let ((restl (when applyp '(.lap-rest-arg.))))
218 `(apply ,miss-fn ,@args ,@restl)
219 `(funcall ,miss-fn ,@args ,@restl))))
221 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
222 (when (and (null *precompiling-lap*) *emit-function-p*)
223 (return-from emit-checking-or-caching
224 (emit-checking-or-caching-function
225 cached-emf-p return-value-p metatypes applyp)))
226 (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
227 (args (remove '&rest dlap-lambda-list))
228 (restl (when applyp '(.lap-rest-arg.))))
229 (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
231 `(let (,@(when cached-emf-p '(emf)))
235 (if cached-emf-p 'emf t)
236 `(invoke-effective-method-function emf ,applyp
238 (emit-miss 'miss-fn args applyp)
239 (when cached-emf-p 'emf))))))
241 (defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
242 (let ((*emit-function-p* nil)
243 (*precompiling-lap* t))
245 (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
247 (defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
249 (wrapper-bindings (mapcan #'(lambda (arg mt)
252 `((,(intern (format nil
256 ,(emit-fetch-wrapper mt arg 'miss
259 (wrappers (mapcar #'car wrapper-bindings)))
260 (declare (fixnum index))
261 (unless wrappers (error "Every metatype is T."))
264 (let ((field (cache-field cache))
265 (cache-vector (cache-vector cache))
266 (mask (cache-mask cache))
267 (size (cache-size cache))
268 (overflow (cache-overflow cache))
270 (declare (fixnum size field mask))
271 ,(cond ((cdr wrappers)
272 (emit-greater-than-1-dlap wrappers 'miss value-reg))
274 (emit-1-t-dlap (car wrappers) 'miss value-reg))
276 (emit-1-nil-dlap (car wrappers) 'miss)))
277 (return-from dfun ,hit))
279 (return-from dfun ,miss)))))
281 (defun emit-1-nil-dlap (wrapper miss-label)
282 `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
284 (declare (fixnum primary location))
286 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
287 (return-from search nil))
288 (setq location (the fixnum (+ location 1)))
289 (when (= location size)
291 (when (= location primary)
292 (dolist (entry overflow)
293 (when (eq (car entry) ,wrapper)
294 (return-from search nil)))
295 (go ,miss-label))))))
297 (defmacro get-cache-vector-lock-count (cache-vector)
298 `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
299 (unless (typep lock-count 'fixnum)
300 (error "My cache got freed somehow."))
301 (the fixnum lock-count)))
303 (defun emit-1-t-dlap (wrapper miss-label value)
304 `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
305 (initial-lock-count (get-cache-vector-lock-count cache-vector)))
306 (declare (fixnum primary initial-lock-count))
307 (let ((location primary))
308 (declare (fixnum location))
310 (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
311 (setq ,value (cache-vector-ref cache-vector (1+ location)))
312 (return-from search nil))
313 (setq location (the fixnum (+ location 2)))
314 (when (= location size)
316 (when (= location primary)
317 (dolist (entry overflow)
318 (when (eq (car entry) ,wrapper)
319 (setq ,value (cdr entry))
320 (return-from search nil)))
322 (unless (= initial-lock-count
323 (get-cache-vector-lock-count cache-vector))
326 (defun emit-greater-than-1-dlap (wrappers miss-label value)
327 (declare (type list wrappers))
328 (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
329 `(let ((primary 0) (size-1 (the fixnum (- size 1))))
330 (declare (fixnum primary size-1))
331 ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
332 (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
333 (declare (fixnum initial-lock-count))
334 (let ((location primary) (next-location 0))
335 (declare (fixnum location next-location))
337 (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
341 (cache-vector-ref cache-vector
343 (the fixnum (+ location 1))))))
346 `((setq location (the fixnum (+ location 1)))
347 (setq ,value (cache-vector-ref cache-vector location))))
348 (return-from search nil))
349 (setq location next-location)
350 (when (= location size-1)
352 (when (= location primary)
353 (dolist (entry overflow)
354 (let ((entry-wrappers (car entry)))
355 (when (and ,@(mapcar #'(lambda (wrapper)
356 `(eq ,wrapper (pop entry-wrappers)))
359 `((setq ,value (cdr entry))))
360 (return-from search nil))))
362 (unless (= initial-lock-count
363 (get-cache-vector-lock-count cache-vector))
364 (go ,miss-label)))))))
366 (defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
367 `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
368 (declare (fixnum wrapper-cache-no))
369 (when (zerop wrapper-cache-no) (go ,miss-label))
370 ,(let ((form `(logand mask wrapper-cache-no)))
371 `(the fixnum ,form))))
373 (defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
374 (declare (type list wrappers))
375 ;; This returns 1 less that the actual location.
377 ,@(let ((adds 0) (len (length wrappers)))
378 (declare (fixnum adds len))
379 (mapcar #'(lambda (wrapper)
380 `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
382 (declare (fixnum wrapper-cache-no))
383 (when (zerop wrapper-cache-no) (go ,miss-label))
384 (setq primary (the fixnum (+ primary wrapper-cache-no)))
387 (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
390 ,(let ((form `(logand primary mask)))
391 `(the fixnum ,form))))))))
394 ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL
395 ;;; approach of using funcallable instances, that branch may run
396 ;;; on non-pcl instances (structures). The result will be the
397 ;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
398 ;;; will be whatever the first slot is, but will be ignored. Similarly,
399 ;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
400 (defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
403 `(cond ((std-instance-p ,argument)
404 ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
405 (std-instance-wrapper ,argument))
406 ((fsc-instance-p ,argument)
407 ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
408 (fsc-instance-wrapper ,argument))
412 (when slot (error "can't do a slot reg for this metatype"))
413 `(wrapper-of-macro ,argument))
414 ((built-in-instance structure-instance)
415 (when slot (error "can't do a slot reg for this metatype"))
416 `(built-in-or-structure-wrapper