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
27 ;;;; some support stuff for getting a hold of symbols that we need when
28 ;;;; building the discriminator codes. It's OK for these to be interned
29 ;;;; symbols because we don't capture any user code in the scope in which
30 ;;;; these symbols are bound.
32 (declaim (list *dfun-arg-symbols
*))
33 (defvar *dfun-arg-symbols
* '(.ARG0. .ARG1. .ARG2. .ARG3.
))
35 (defun dfun-arg-symbol (arg-number)
36 (or (nth arg-number
*dfun-arg-symbols
*)
37 (format-symbol *pcl-package
* ".ARG~A." arg-number
)))
39 (declaim (list *slot-vector-symbols
*))
40 (defvar *slot-vector-symbols
* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.
))
42 (defun slot-vector-symbol (arg-number)
43 (or (nth arg-number
*slot-vector-symbols
*)
44 (format-symbol *pcl-package
* ".SLOTS~A." arg-number
)))
46 (declaim (inline make-dfun-required-args
))
47 (defun make-dfun-required-args (count)
48 (declare (type index count
))
50 (dotimes (i count
(nreverse result
))
51 (push (dfun-arg-symbol i
) result
))))
53 (defun make-dfun-lambda-list (nargs applyp
)
54 (let ((required (make-dfun-required-args nargs
)))
57 ;; Use &MORE arguments to avoid consing up an &REST list
58 ;; that we might not need at all. See MAKE-EMF-CALL and
59 ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other
61 '(&more .dfun-more-context. .dfun-more-count.
))
64 (defun make-dlap-lambda-list (nargs applyp
)
65 (let ((required (make-dfun-required-args nargs
)))
66 ;; Return the full lambda list, the required arguments, a form
67 ;; that will generate a rest-list, and a list of the &MORE
69 ;; Beware of deep voodoo! The DEFKNOWN for %LISTIFY-REST-ARGS says that its
70 ;; second argument is INDEX, but the THE form below is "weaker" on account
71 ;; of the vop operand restrictions or something that I don't understand.
72 ;; Which is to say, PCL compilation reliably broke when changed to INDEX.
74 (values (append required
'(&more .more-context. .more-count.
))
76 '((sb-c:%listify-rest-args
77 .more-context.
(the (and unsigned-byte fixnum
)
79 '(.more-context. .more-count.
))
80 (values required required nil nil
))))
82 (defun make-emf-call (nargs applyp fn-variable
&optional emf-type
)
83 (let ((required (make-dfun-required-args nargs
)))
84 `(,(if (eq emf-type
'fast-method-call
)
85 'invoke-effective-method-function-fast
86 'invoke-effective-method-function
)
89 :required-args
,required
90 ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use
91 ;; the :REST-ARG version or the :MORE-ARG version depending on
92 ;; the type of the EMF.
94 ;; Creates a list from the &MORE arguments.
95 '((sb-c:%listify-rest-args
; See above re. voodoo
97 (the (and unsigned-byte fixnum
)
100 :more-arg
,(when applyp
101 '(.dfun-more-context. .dfun-more-count.
)))))
103 (defun make-fast-method-call-lambda-list (nargs applyp
)
104 (list* '.pv.
'.next-method-call.
(make-dfun-lambda-list nargs applyp
)))
106 ;;; Emitting various accessors.
108 (defun emit-one-class-reader (class-slot-p)
109 (emit-reader/writer
:reader
1 class-slot-p
))
111 (defun emit-one-class-boundp (class-slot-p)
112 (emit-reader/writer
:boundp
1 class-slot-p
))
114 (defun emit-one-class-writer (class-slot-p)
115 (emit-reader/writer
:writer
1 class-slot-p
))
117 (defun emit-two-class-reader (class-slot-p)
118 (emit-reader/writer
:reader
2 class-slot-p
))
120 (defun emit-two-class-boundp (class-slot-p)
121 (emit-reader/writer
:boundp
2 class-slot-p
))
123 (defun emit-two-class-writer (class-slot-p)
124 (emit-reader/writer
:writer
2 class-slot-p
))
126 ;;; --------------------------------
128 (defun emit-one-index-readers (class-slot-p)
129 (emit-one-or-n-index-reader/writer
:reader nil class-slot-p
))
131 (defun emit-one-index-boundps (class-slot-p)
132 (emit-one-or-n-index-reader/writer
:boundp nil class-slot-p
))
134 (defun emit-one-index-writers (class-slot-p)
135 (emit-one-or-n-index-reader/writer
:writer nil class-slot-p
))
137 (defun emit-n-n-readers ()
138 (emit-one-or-n-index-reader/writer
:reader t nil
))
140 (defun emit-n-n-boundps ()
141 (emit-one-or-n-index-reader/writer
:boundp t nil
))
143 (defun emit-n-n-writers ()
144 (emit-one-or-n-index-reader/writer
:writer t nil
))
146 ;;; --------------------------------
148 (defun emit-checking (metatypes applyp
)
149 (emit-checking-or-caching nil nil metatypes applyp
))
151 (defun emit-caching (metatypes applyp
)
152 (emit-checking-or-caching t nil metatypes applyp
))
154 (defun emit-in-checking-cache-p (metatypes)
155 (emit-checking-or-caching nil t metatypes nil
))
157 (defun emit-constant-value (metatypes)
158 (emit-checking-or-caching t t metatypes nil
))
160 ;;; --------------------------------
162 ;;; FIXME: What do these variables mean?
163 (defvar *precompiling-lap
* nil
)
165 (defun emit-default-only (metatypes applyp
)
166 (multiple-value-bind (lambda-list args rest-arg more-arg
)
167 (make-dlap-lambda-list (length metatypes
) applyp
)
168 (generating-lisp '(emf)
170 `(invoke-effective-method-function emf
174 :rest-arg
,rest-arg
))))
176 ;;; --------------------------------
178 (defun generating-lisp (closure-variables args form
)
179 (let ((lambda `(lambda ,closure-variables
180 ,@(when (member 'miss-fn closure-variables
)
181 `((declare (type function miss-fn
))))
184 (declare #.
*optimize-speed
*)
186 (values (if *precompiling-lap
*
188 (compile nil lambda
))
191 ;;; note on implementation for CMU 17 and later (including SBCL):
192 ;;; Since STD-INSTANCE-P is weakened, that branch may run on non-PCL
193 ;;; instances (structures). The result will be the non-wrapper layout
194 ;;; for the structure, which will cause a miss. The "slots" will be
195 ;;; whatever the first slot is, but will be ignored. Similarly,
196 ;;; FSC-INSTANCE-P returns true on funcallable structures as well as
198 (defun emit-reader/writer
(reader/writer
1-or-2-class class-slot-p
)
201 (closure-variables ())
202 (read-form (emit-slot-read-form class-slot-p
'index
'slots
)))
205 (setq instance
(dfun-arg-symbol 0)
206 arglist
(list instance
)))
207 (:writer
(setq instance
(dfun-arg-symbol 1)
208 arglist
(list (dfun-arg-symbol 0) instance
))))
210 (1 (setq closure-variables
'(wrapper-0 index miss-fn
)))
211 (2 (setq closure-variables
'(wrapper-0 wrapper-1 index miss-fn
))))
215 `(let* (,@(unless class-slot-p
`((slots nil
)))
216 (wrapper (cond ((std-instance-p ,instance
)
217 ,@(unless class-slot-p
219 (std-instance-slots ,instance
))))
220 (std-instance-wrapper ,instance
))
221 ((fsc-instance-p ,instance
)
222 ,@(unless class-slot-p
224 (fsc-instance-slots ,instance
))))
225 (fsc-instance-wrapper ,instance
)))))
228 (not (zerop (layout-clos-hash wrapper
)))
229 ,@(if (eql 1 1-or-2-class
)
230 `((eq wrapper wrapper-0
))
231 `((or (eq wrapper wrapper-0
)
232 (eq wrapper wrapper-1
)))))
233 ,@(ecase reader
/writer
235 `((let ((value ,read-form
))
236 (unless (eq value
+slot-unbound
+)
237 (return-from access value
)))))
239 `((let ((value ,read-form
))
240 (return-from access
(not (eq value
+slot-unbound
+))))))
242 `((return-from access
(setf ,read-form
,(car arglist
)))))))
243 (funcall miss-fn
,@arglist
))))))
245 (defun emit-slot-read-form (class-slot-p index slots
)
248 `(clos-slots-ref ,slots
,index
)))
250 (defun emit-boundp-check (value-form miss-fn arglist
)
251 `(let ((value ,value-form
))
252 (if (eq value
+slot-unbound
+)
253 (funcall ,miss-fn
,@arglist
)
256 (defun emit-slot-access (reader/writer class-slot-p slots
257 index miss-fn arglist
)
258 (let ((read-form (emit-slot-read-form class-slot-p index slots
)))
260 (:reader
(emit-boundp-check read-form miss-fn arglist
))
261 (:boundp
`(not (eq ,read-form
+slot-unbound
+)))
262 (:writer
`(setf ,read-form
,(car arglist
))))))
264 (defmacro emit-reader
/writer-macro
(reader/writer
1-or-2-class class-slot-p
)
265 (let ((*precompiling-lap
* t
))
267 (emit-reader/writer reader
/writer
1-or-2-class class-slot-p
))))
269 ;; If CACHED-INDEX-P is false, then the slot location is a constant and
270 ;; the cache holds layouts eligible to use that index.
271 ;; If true, then the cache is a map of layout -> index.
272 (defun emit-one-or-n-index-reader/writer
(reader/writer
275 (multiple-value-bind (arglist metatypes
)
278 (values (list (dfun-arg-symbol 0))
279 '(standard-instance)))
280 (:writer
(values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
281 '(t standard-instance
))))
283 `(cache ,@(unless cached-index-p
'(index)) miss-fn
)
285 `(let (,@(unless class-slot-p
'(slots))
286 ,@(when cached-index-p
'(index)))
287 ,(emit-dlap 'cache arglist metatypes
288 (emit-slot-access reader
/writer class-slot-p
289 'slots
'index
'miss-fn arglist
)
290 `(funcall miss-fn
,@arglist
)
291 (when cached-index-p
'index
)
292 (unless class-slot-p
'(slots)))))))
294 (defmacro emit-one-or-n-index-reader
/writer-macro
295 (reader/writer cached-index-p class-slot-p
)
296 (let ((*precompiling-lap
* t
))
298 (emit-one-or-n-index-reader/writer reader
/writer
302 (defun emit-miss (miss-fn args applyp
)
304 `(multiple-value-call ,miss-fn
,@args
305 (sb-c::%more-arg-values .more-context.
308 `(funcall ,miss-fn
,@args
)))
310 ;; (cache-emf, return-value):
311 ;; NIL / NIL : GF has a single EMF. Invoke it when layouts are in cache.
312 ;; NIL / T : GF has a single EMF. Return T when layouts are in cache.
313 ;; T / NIL : Look for the EMF for argument layouts. Invoke it when in cache.
314 ;; T / T : Look for the EMF for argument layouts. Return it when in cache.
316 ;; METATYPES must be acceptable to EMIT-FETCH-WRAPPER.
317 ;; APPLYP says whether there is a &MORE context.
318 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp
)
319 (multiple-value-bind (lambda-list args rest-arg more-arg
)
320 (make-dlap-lambda-list (length metatypes
) applyp
)
322 `(cache ,@(unless cached-emf-p
'(emf)) miss-fn
)
324 `(let (,@(when cached-emf-p
'(emf)))
325 ,(emit-dlap 'cache args metatypes
327 (if cached-emf-p
'emf t
)
328 `(invoke-effective-method-function
332 :rest-arg
,rest-arg
))
333 (emit-miss 'miss-fn args applyp
)
334 (when cached-emf-p
'emf
))))))
336 (defmacro emit-checking-or-caching-macro
(cached-emf-p
340 (let ((*precompiling-lap
* t
))
342 (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp
))))
344 (defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
347 (miss-tag (gensym "MISSED"))
348 (wrapper-bindings (mapcan (lambda (arg mt
)
351 `((,(format-symbol *pcl-package
*
355 mt arg miss-tag
(pop slot-vars
))))))
357 (wrapper-vars (mapcar #'car wrapper-bindings
)))
358 (declare (fixnum index
))
360 (error "Every metatype is T."))
363 (let ,wrapper-bindings
364 ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var
)
367 (return ,miss-form
))))
369 ;; SLOTS-VAR, if supplied, is the variable to update with instance-slots
370 ;; by side-effect of fetching the wrapper for ARGUMENT.
371 (defun emit-fetch-wrapper (metatype argument miss-tag
&optional slots-var
)
374 ;; This branch may run on non-pcl instances (structures). The
375 ;; result will be the non-wrapper layout for the structure, which
376 ;; will cause a miss. Since refencing the structure is rather iffy
377 ;; if it should have no slots, or only raw slots, we use FOR-STD-CLASS-P
378 ;; to ensure that we have a wrapper.
380 ;; FIXME: If we unify layouts and wrappers we can use
381 ;; instance-slots-layout instead of for-std-class-p, as if there
382 ;; are no layouts there are no slots to worry about.
383 (with-unique-names (wrapper)
384 `(cond ((std-instance-p ,argument
)
386 `(let ((,wrapper
(std-instance-wrapper ,argument
)))
387 (when (layout-for-std-class-p ,wrapper
)
388 (setq ,slots-var
(std-instance-slots ,argument
)))
390 `(std-instance-wrapper ,argument
)))
391 ((fsc-instance-p ,argument
)
393 `(let ((,wrapper
(fsc-instance-wrapper ,argument
)))
394 (when (layout-for-std-class-p ,wrapper
)
395 (setq ,slots-var
(fsc-instance-slots ,argument
)))
397 `(fsc-instance-wrapper ,argument
)))
398 (t (go ,miss-tag
)))))
399 ;; Sep92 PCL used to distinguish between some of these cases (and
400 ;; spuriously exclude others). Since in SBCL
401 ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
402 ;; equivalent and inlined to each other, we can collapse some
403 ;; spurious differences.
404 ((class system-instance structure-instance condition-instance
)
406 (bug "SLOT requested for metatype ~S, but it isn't going to happen."
408 `(layout-of ,argument
))
409 ;; a metatype of NIL should never be seen here, as NIL is only in
410 ;; the metatypes before a generic function is fully initialized.
411 ;; T should never be seen because we never need to get a wrapper
412 ;; to do dispatch if all methods have T as the respective
415 (bug "~@<metatype ~S seen in ~S.~@:>" metatype
'emit-fetch-wrapper
))))