1.0.9: release, will be tagged as sbcl_1_0_9
[sbcl.git] / src / pcl / dlisp.lisp
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          (lambda-list (if applyp
67                           (append required '(&more .more-context. .more-count.))
68                           required)))
69     ;; Return the full lambda list, the required arguments, a form
70     ;; that will generate a rest-list, and a list of the &MORE
71     ;; parameters used.
72     (values lambda-list
73             required
74             (when applyp
75               '((sb-c::%listify-rest-args
76                  .more-context.
77                  (the (and unsigned-byte fixnum)
78                    .more-count.))))
79             (when applyp
80               '(.more-context. .more-count.)))))
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
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-cell. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
105 \f
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 (defun emit-one-or-n-index-reader/writer (reader/writer
270                                           cached-index-p
271                                           class-slot-p)
272   (multiple-value-bind (arglist metatypes)
273       (ecase reader/writer
274         ((:reader :boundp)
275          (values (list (dfun-arg-symbol 0))
276                  '(standard-instance)))
277         (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
278                          '(t standard-instance))))
279     (generating-lisp
280      `(cache ,@(unless cached-index-p '(index)) miss-fn)
281      arglist
282      `(let (,@(unless class-slot-p '(slots))
283             ,@(when cached-index-p '(index)))
284         ,(emit-dlap 'cache arglist metatypes
285                     (emit-slot-access reader/writer class-slot-p
286                                       'slots 'index 'miss-fn arglist)
287                     `(funcall miss-fn ,@arglist)
288                     (when cached-index-p 'index)
289                     (unless class-slot-p '(slots)))))))
290
291 (defmacro emit-one-or-n-index-reader/writer-macro
292     (reader/writer cached-index-p class-slot-p)
293   (let ((*precompiling-lap* t))
294     (values
295      (emit-one-or-n-index-reader/writer reader/writer
296                                         cached-index-p
297                                         class-slot-p))))
298
299 (defun emit-miss (miss-fn args applyp)
300   (if applyp
301       `(multiple-value-call ,miss-fn ,@args
302                             (sb-c::%more-arg-values .more-context.
303                                                     0
304                                                     .more-count.))
305       `(funcall ,miss-fn ,@args)))
306
307 (defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
308   (multiple-value-bind (lambda-list args rest-arg more-arg)
309       (make-dlap-lambda-list (length metatypes) applyp)
310     (generating-lisp
311      `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
312      lambda-list
313      `(let (,@(when cached-emf-p '(emf)))
314         ,(emit-dlap 'cache args metatypes
315                     (if return-value-p
316                         (if cached-emf-p 'emf t)
317                         `(invoke-effective-method-function
318                           emf ,applyp
319                           :required-args ,args
320                           :more-arg ,more-arg
321                           :rest-arg ,rest-arg))
322                     (emit-miss 'miss-fn args applyp)
323                     (when cached-emf-p 'emf))))))
324
325 (defmacro emit-checking-or-caching-macro (cached-emf-p
326                                           return-value-p
327                                           metatypes
328                                           applyp)
329   (let ((*precompiling-lap* t))
330     (values
331      (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
332
333 (defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
334                   &optional slot-vars)
335   (let* ((index -1)
336          (miss-tag (gensym "MISSED"))
337          (wrapper-bindings (mapcan (lambda (arg mt)
338                                      (unless (eq mt t)
339                                        (incf index)
340                                        `((,(format-symbol *pcl-package*
341                                                           "WRAPPER-~D"
342                                                           index)
343                                           ,(emit-fetch-wrapper
344                                             mt arg miss-tag (pop slot-vars))))))
345                                    args metatypes))
346          (wrapper-vars (mapcar #'car wrapper-bindings)))
347     (declare (fixnum index))
348     (unless wrapper-vars
349       (error "Every metatype is T."))
350     `(prog ()
351         (return
352           (let ,wrapper-bindings
353             ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var)
354             ,hit-form))
355       ,miss-tag
356         (return ,miss-form))))
357
358 (defun emit-fetch-wrapper (metatype argument miss-tag &optional slot)
359   (ecase metatype
360     ((standard-instance)
361      ;; This branch may run on non-pcl instances (structures). The
362      ;; result will be the non-wrapper layout for the structure, which
363      ;; will cause a miss. Since refencing the structure is rather iffy
364      ;; if it should have no slots, or only raw slots, we use FOR-STD-CLASS-P
365      ;; to ensure that we have a wrapper.
366      ;;
367      ;; FIXME: If we unify layouts and wrappers we can use
368      ;; instance-slots-layout instead of for-std-class-p, as if there
369      ;; are no layouts there are no slots to worry about.
370      (with-unique-names (wrapper)
371        `(cond
372           ((std-instance-p ,argument)
373            (let ((,wrapper (std-instance-wrapper ,argument)))
374              ,@(when slot
375                      `((when (layout-for-std-class-p ,wrapper)
376                          (setq ,slot (std-instance-slots ,argument)))))
377              ,wrapper))
378           ((fsc-instance-p ,argument)
379            (let ((,wrapper (fsc-instance-wrapper ,argument)))
380              ,@(when slot
381                      `((when (layout-for-std-class-p ,wrapper)
382                          (setq ,slot (fsc-instance-slots ,argument)))))
383              ,wrapper))
384           (t (go ,miss-tag)))))
385     ;; Sep92 PCL used to distinguish between some of these cases (and
386     ;; spuriously exclude others).  Since in SBCL
387     ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
388     ;; equivalent and inlined to each other, we can collapse some
389     ;; spurious differences.
390     ((class built-in-instance structure-instance condition-instance)
391      (when slot
392        (bug "SLOT requested for metatype ~S, but it isnt' going to happen."
393             metatype))
394      `(wrapper-of ,argument))
395     ;; a metatype of NIL should never be seen here, as NIL is only in
396     ;; the metatypes before a generic function is fully initialized.
397     ;; T should never be seen because we never need to get a wrapper
398     ;; to do dispatch if all methods have T as the respective
399     ;; specializer.
400     ((t nil)
401      (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))