1;;;; This software is part of the SBCL system. See the README file for
2;;;; more information.
3
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
8;;;; information.
9
10;;;; copyright information from original PCL sources:
11;;;;
12;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13;;;; All rights reserved.
14;;;;
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
18;;;; control laws.
19;;;;
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
22;;;; specification.
23
24(in-package "SB-PCL")
25
26
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.
31
32(declaim (list *dfun-arg-symbols*))
33(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
34
35(defun dfun-arg-symbol (arg-number)
36  (or (nth arg-number *dfun-arg-symbols*)
37      (format-symbol *pcl-package* ".ARG~A." arg-number)))
38
39(declaim (list *slot-vector-symbols*))
40(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
41
42(defun slot-vector-symbol (arg-number)
43  (or (nth arg-number *slot-vector-symbols*)
44      (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
45
46(declaim (inline make-dfun-required-args))
47(defun make-dfun-required-args (count)
48  (declare (type index count))
49  (let (result)
50    (dotimes (i count (nreverse result))
51      (push (dfun-arg-symbol i) result))))
52
53(defun make-dfun-lambda-list (nargs applyp)
54  (let ((required (make-dfun-required-args nargs)))
55    (if applyp
56        (nconc required
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
60               ;; pieces.
61               '(&more .dfun-more-context. .dfun-more-count.))
62        required)))
63
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
68    ;; parameters used.
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.
73    (if applyp
74        (values (append required '(&more .more-context. .more-count.))
75                required
76                '((sb-c:%listify-rest-args
77                   .more-context. (the (and unsigned-byte fixnum)
78                                    .more-count.)))
79                '(.more-context. .more-count.))
80        (values required required nil nil))))
81
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)
87       ,fn-variable
88       ,applyp
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.
93       :rest-arg ,(if applyp
94                      ;; Creates a list from the &MORE arguments.
95                      '((sb-c:%listify-rest-args ; See above re. voodoo
96                         .dfun-more-context.
97                         (the (and unsigned-byte fixnum)
98                           .dfun-more-count.)))
99                      nil)
100       :more-arg ,(when applyp
101                    '(.dfun-more-context. .dfun-more-count.)))))
102
103(defun make-fast-method-call-lambda-list (nargs applyp)
104  (list* '.pv. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
105
106;;; Emitting various accessors.
107
108(defun emit-one-class-reader (class-slot-p)
109  (emit-reader/writer :reader 1 class-slot-p))
110
111(defun emit-one-class-boundp (class-slot-p)
112  (emit-reader/writer :boundp 1 class-slot-p))
113
114(defun emit-one-class-writer (class-slot-p)
115  (emit-reader/writer :writer 1 class-slot-p))
116
117(defun emit-two-class-reader (class-slot-p)
118  (emit-reader/writer :reader 2 class-slot-p))
119
120(defun emit-two-class-boundp (class-slot-p)
121  (emit-reader/writer :boundp 2 class-slot-p))
122
123(defun emit-two-class-writer (class-slot-p)
124  (emit-reader/writer :writer 2 class-slot-p))
125
126;;; --------------------------------
127
128(defun emit-one-index-readers (class-slot-p)
129  (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
130
131(defun emit-one-index-boundps (class-slot-p)
132  (emit-one-or-n-index-reader/writer :boundp nil class-slot-p))
133
134(defun emit-one-index-writers (class-slot-p)
135  (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
136
137(defun emit-n-n-readers ()
138  (emit-one-or-n-index-reader/writer :reader t nil))
139
140(defun emit-n-n-boundps ()
141  (emit-one-or-n-index-reader/writer :boundp t nil))
142
143(defun emit-n-n-writers ()
144  (emit-one-or-n-index-reader/writer :writer t nil))
145
146;;; --------------------------------
147
148(defun emit-checking (metatypes applyp)
149  (emit-checking-or-caching nil nil metatypes applyp))
150
151(defun emit-caching (metatypes applyp)
152  (emit-checking-or-caching t nil metatypes applyp))
153
154(defun emit-in-checking-cache-p (metatypes)
155  (emit-checking-or-caching nil t metatypes nil))
156
157(defun emit-constant-value (metatypes)
158  (emit-checking-or-caching t t metatypes nil))
159
160;;; --------------------------------
161
162;;; FIXME: What do these variables mean?
163(defvar *precompiling-lap* nil)
164
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)
169                     lambda-list
170                     `(invoke-effective-method-function emf
171                                                        ,applyp
172                                                        :required-args ,args
173                                                        :more-arg ,more-arg
174                                                        :rest-arg ,rest-arg))))
175
176;;; --------------------------------
177
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))))
182                   #'(lambda ,args
183                       (let ()
184                         (declare #.*optimize-speed*)
185                         ,form)))))
186    (values (if *precompiling-lap*
187                `#',lambda
188                (compile nil lambda))
189            nil)))
190
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
197;;; PCL fins.
198(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
199  (let ((instance nil)
200        (arglist  ())
201        (closure-variables ())
202        (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
203    (ecase reader/writer
204      ((:reader :boundp)
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))))
209    (ecase 1-or-2-class
210      (1 (setq closure-variables '(wrapper-0 index miss-fn)))
211      (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
212    (generating-lisp
213     closure-variables
214     arglist
215     `(let* (,@(unless class-slot-p `((slots nil)))
216               (wrapper (cond ((std-instance-p ,instance)
217                               ,@(unless class-slot-p
218                                   `((setq slots
219                                           (std-instance-slots ,instance))))
220                               (std-instance-wrapper ,instance))
221                              ((fsc-instance-p ,instance)
222                               ,@(unless class-slot-p
223                                   `((setq slots
224                                           (fsc-instance-slots ,instance))))
225                               (fsc-instance-wrapper ,instance)))))
226        (block access
227          (when (and wrapper
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
234                (:reader
235                 `((let ((value ,read-form))
236                     (unless (eq value +slot-unbound+)
237                       (return-from access value)))))
238                (:boundp
239                 `((let ((value ,read-form))
240                     (return-from access (not (eq value +slot-unbound+))))))
241                (:writer
242                 `((return-from access (setf ,read-form ,(car arglist)))))))
243          (funcall miss-fn ,@arglist))))))
244
245(defun emit-slot-read-form (class-slot-p index slots)
246  (if class-slot-p
247      `(cdr ,index)
248      `(clos-slots-ref ,slots ,index)))
249
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)
254         value)))
255
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)))
259    (ecase reader/writer
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))))))
263
264(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
265  (let ((*precompiling-lap* t))
266    (values
267     (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
268
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
273                                          cached-index-p
274                                          class-slot-p)
275  (multiple-value-bind (arglist metatypes)
276      (ecase reader/writer
277        ((:reader :boundp)
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))))
282    (generating-lisp
283     `(cache ,@(unless cached-index-p '(index)) miss-fn)
284     arglist
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)))))))
293
294(defmacro emit-one-or-n-index-reader/writer-macro
295    (reader/writer cached-index-p class-slot-p)
296  (let ((*precompiling-lap* t))
297    (values
298     (emit-one-or-n-index-reader/writer reader/writer
299                                        cached-index-p
300                                        class-slot-p))))
301
302(defun emit-miss (miss-fn args applyp)
303  (if applyp
304      `(multiple-value-call ,miss-fn ,@args
305                            (sb-c::%more-arg-values .more-context.
306                                                    0
307                                                    .more-count.))
308      `(funcall ,miss-fn ,@args)))
309
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.
315;;
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)
321    (generating-lisp
322     `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
323     lambda-list
324     `(let (,@(when cached-emf-p '(emf)))
325        ,(emit-dlap 'cache args metatypes
326                    (if return-value-p
327                        (if cached-emf-p 'emf t)
328                        `(invoke-effective-method-function
329                          emf ,applyp
330                          :required-args ,args
331                          :more-arg ,more-arg
332                          :rest-arg ,rest-arg))
333                    (emit-miss 'miss-fn args applyp)
334                    (when cached-emf-p 'emf))))))
335
336(defmacro emit-checking-or-caching-macro (cached-emf-p
337                                          return-value-p
338                                          metatypes
339                                          applyp)
340  (let ((*precompiling-lap* t))
341    (values
342     (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
343
344(defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
345                  &optional slot-vars)
346  (let* ((index -1)
347         (miss-tag (gensym "MISSED"))
348         (wrapper-bindings (mapcan (lambda (arg mt)
349                                     (unless (eq mt t)
350                                       (incf index)
351                                       `((,(format-symbol *pcl-package*
352                                                          "WRAPPER-~D"
353                                                          index)
354                                          ,(emit-fetch-wrapper
355                                            mt arg miss-tag (pop slot-vars))))))
356                                   args metatypes))
357         (wrapper-vars (mapcar #'car wrapper-bindings)))
358    (declare (fixnum index))
359    (unless wrapper-vars
360      (error "Every metatype is T."))
361    `(prog ()
362        (return
363          (let ,wrapper-bindings
364            ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var)
365            ,hit-form))
366      ,miss-tag
367        (return ,miss-form))))
368
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)
372  (ecase metatype
373    ((standard-instance)
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.
379     ;;
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)
385               ,(if slots-var
386                    `(let ((,wrapper (std-instance-wrapper ,argument)))
387                       (when (layout-for-std-class-p ,wrapper)
388                         (setq ,slots-var (std-instance-slots ,argument)))
389                       ,wrapper)
390                    `(std-instance-wrapper ,argument)))
391              ((fsc-instance-p ,argument)
392               ,(if slots-var
393                    `(let ((,wrapper (fsc-instance-wrapper ,argument)))
394                       (when (layout-for-std-class-p ,wrapper)
395                         (setq ,slots-var (fsc-instance-slots ,argument)))
396                       ,wrapper)
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)
405     (when slots-var
406       (bug "SLOT requested for metatype ~S, but it isn't going to happen."
407            metatype))
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
413    ;; specializer.
414    ((t nil)
415     (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))
416