0.6.11.16:
[sbcl.git] / src / pcl / fast-init.lisp
1 ;;;; This file defines the optimized make-instance functions.
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5
6 ;;;; This software is derived from software originally released by Xerox
7 ;;;; Corporation. Copyright and release statements follow. Later modifications
8 ;;;; to the software are in the public domain and are provided with
9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; information.
11
12 ;;;; copyright information from original PCL sources:
13 ;;;;
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
16 ;;;;
17 ;;;; Use and copying of this software and preparation of derivative works based
18 ;;;; upon this software are permitted. Any distribution of this software or
19 ;;;; derivative works must comply with all applicable United States export
20 ;;;; control laws.
21 ;;;;
22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
23 ;;;; warranty about the software, its performance or its conformity to any
24 ;;;; specification.
25
26 (in-package "SB-PCL")
27 \f
28 (defvar *compile-make-instance-functions-p* nil)
29
30 (defun update-make-instance-function-table (&optional (class *the-class-t*))
31   (when (symbolp class) (setq class (find-class class)))
32     (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
33     (when (memq *the-class-slot-object* (class-precedence-list class))
34       (map-all-classes #'reset-class-initialize-info class)))
35
36 (defun constant-symbol-p (form)
37   (and (constantp form)
38        (let ((object (eval form)))
39          (and (symbolp object)
40               (symbol-package object)))))
41
42 (defvar *make-instance-function-keys* nil)
43
44 (defun expand-make-instance-form (form)
45   (let ((class (cadr form)) (initargs (cddr form))
46         (keys nil)(allow-other-keys-p nil) key value)
47     (when (and (constant-symbol-p class)
48                (let ((initargs-tail initargs))
49                  (loop (when (null initargs-tail) (return t))
50                        (unless (constant-symbol-p (car initargs-tail))
51                          (return nil))
52                        (setq key (eval (pop initargs-tail)))
53                        (setq value (pop initargs-tail))
54                        (when (eq ':allow-other-keys key)
55                          (setq allow-other-keys-p value))
56                        (push key keys))))
57       (let* ((class (eval class))
58              (keys (nreverse keys))
59              (key (list class keys allow-other-keys-p))
60              (sym (make-instance-function-symbol key)))
61         (push key *make-instance-function-keys*)
62         (when sym
63           ;; (famous last words:
64           ;;   1. Don't worry, I know what I'm doing.
65           ;;   2. You and what army?
66           ;;   3. If you were as smart as you think you are, you
67           ;;      wouldn't be a copy.
68           ;; This is case #1.:-) Even if SYM hasn't been defined yet,
69           ;; it must be an implementation function, or we we wouldn't
70           ;; have expanded into it. So declare SYM as defined, so that
71           ;; even if it hasn't been defined yet, the user doesn't get
72           ;; obscure warnings about undefined internal implementation
73           ;; functions like HAIRY-MAKE-instance-name.
74           (sb-kernel:become-defined-function-name sym)
75           `(,sym ',class (list ,@initargs)))))))
76
77 (defmacro expanding-make-instance-top-level (&rest forms &environment env)
78   (let* ((*make-instance-function-keys* nil)
79          (form (macroexpand `(expanding-make-instance ,@forms) env)))
80     `(progn
81        ,@(when *make-instance-function-keys*
82            `((get-make-instance-functions ',*make-instance-function-keys*)))
83        ,form)))
84
85 (defmacro expanding-make-instance (&rest forms &environment env)
86   `(progn
87      ,@(mapcar #'(lambda (form)
88                    (walk-form form env
89                               #'(lambda (subform context env)
90                                   (declare (ignore env))
91                                   (or (and (eq context ':eval)
92                                            (consp subform)
93                                            (eq (car subform) 'make-instance)
94                                            (expand-make-instance-form subform))
95                                       subform))))
96                forms)))
97
98 (defmacro defconstructor
99           (name class lambda-list &rest initialization-arguments)
100   `(expanding-make-instance-top-level
101     (defun ,name ,lambda-list
102       (make-instance ',class ,@initialization-arguments))))
103
104 (defun get-make-instance-functions (key-list)
105   (dolist (key key-list)
106     (let* ((cell (find-class-cell (car key)))
107            (make-instance-function-keys
108             (find-class-cell-make-instance-function-keys cell))
109            (mif-key (cons (cadr key) (caddr key))))
110       (unless (find mif-key make-instance-function-keys
111                     :test #'equal)
112         (push mif-key (find-class-cell-make-instance-function-keys cell))
113         (let ((class (find-class-cell-class cell)))
114           (when (and class (not (forward-referenced-class-p class)))
115             (update-initialize-info-internal
116              (initialize-info class (car mif-key) nil (cdr mif-key))
117              'make-instance-function)))))))
118
119 (defun make-instance-function-symbol (key)
120   (let* ((class (car key))
121          (symbolp (symbolp class)))
122     (when (or symbolp (classp class))
123       (let* ((class-name (if (symbolp class) class (class-name class)))
124              (keys (cadr key))
125              (allow-other-keys-p (caddr key)))
126         (when (and (or symbolp
127                        (and (symbolp class-name)
128                             (eq class (find-class class-name nil))))
129                    (symbol-package class-name))
130           (let ((*package* *pcl-package*)
131                 (*print-length* nil)
132                 (*print-level* nil)
133                 (*print-circle* nil)
134                 (*print-case* :upcase)
135                 (*print-pretty* nil))
136             (intern (format nil
137                             "MAKE-INSTANCE ~S ~S ~S"
138                             class-name
139                             keys
140                             allow-other-keys-p))))))))
141
142 (defun make-instance-1 (class initargs)
143   (apply #'make-instance class initargs))
144
145 (defmacro define-cached-reader (type name trap)
146   (let ((reader-name (intern (format nil "~A-~A" type name)))
147         (cached-name (intern (format nil "~A-CACHED-~A" type name))))
148     `(defmacro ,reader-name (info)
149        `(let ((value (,',cached-name ,info)))
150           (if (eq value ':unknown)
151               (progn
152                 (,',trap ,info ',',name)
153                 (,',cached-name ,info))
154               value)))))
155
156 (eval-when (:compile-toplevel :load-toplevel :execute)
157 (defparameter *initialize-info-cached-slots*
158   '(valid-p                             ; t or (:invalid key)
159     ri-valid-p
160     initargs-form-list
161     new-keys
162     default-initargs-function
163     shared-initialize-t-function
164     shared-initialize-nil-function
165     constants
166     combined-initialize-function ; allocate-instance + shared-initialize
167     make-instance-function ; nil means use gf
168     make-instance-function-symbol)))
169
170 (defmacro define-initialize-info ()
171   (let ((cached-slot-names
172          (mapcar #'(lambda (name)
173                      (intern (format nil "CACHED-~A" name)))
174                  *initialize-info-cached-slots*))
175         (cached-names
176          (mapcar #'(lambda (name)
177                      (intern (format nil "~A-CACHED-~A"
178                                      'initialize-info name)))
179                  *initialize-info-cached-slots*)))
180     `(progn
181        (defstruct (initialize-info (:copier nil))
182          key wrapper
183          ,@(mapcar #'(lambda (name)
184                        `(,name :unknown))
185                    cached-slot-names))
186        (defmacro reset-initialize-info-internal (info)
187          `(progn
188             ,@(mapcar #'(lambda (cname)
189                           `(setf (,cname ,info) ':unknown))
190                       ',cached-names)))
191        (defun initialize-info-bound-slots (info)
192          (let ((slots nil))
193            ,@(mapcar #'(lambda (name cached-name)
194                          `(unless (eq ':unknown (,cached-name info))
195                             (push ',name slots)))
196                      *initialize-info-cached-slots* cached-names)
197            slots))
198       ,@(mapcar #'(lambda (name)
199                     `(define-cached-reader initialize-info ,name
200                       update-initialize-info-internal))
201                 *initialize-info-cached-slots*))))
202
203 (define-initialize-info)
204
205 (defvar *initialize-info-cache-class* nil)
206 (defvar *initialize-info-cache-initargs* nil)
207 (defvar *initialize-info-cache-info* nil)
208
209 (defvar *revert-initialize-info-p* nil)
210
211 (defun reset-initialize-info (info)
212   (setf (initialize-info-wrapper info)
213         (class-wrapper (car (initialize-info-key info))))
214   (let ((slots-to-revert (if *revert-initialize-info-p*
215                              (initialize-info-bound-slots info)
216                              '(make-instance-function))))
217     (reset-initialize-info-internal info)
218     (dolist (slot slots-to-revert)
219       (update-initialize-info-internal info slot))
220     info))
221
222 (defun reset-class-initialize-info (class)
223   (reset-class-initialize-info-1 (class-initialize-info class)))
224
225 (defun reset-class-initialize-info-1 (cell)
226   (when (consp cell)
227     (when (car cell)
228       (reset-initialize-info (car cell)))
229     (let ((alist (cdr cell)))
230       (dolist (a alist)
231         (reset-class-initialize-info-1 (cdr a))))))
232
233 (defun initialize-info (class
234                         initargs
235                         &optional
236                         (plist-p t)
237                         allow-other-keys-arg)
238   (let ((info nil))
239     (if (and (eq *initialize-info-cache-class* class)
240              (eq *initialize-info-cache-initargs* initargs))
241         (setq info *initialize-info-cache-info*)
242         (let ((initargs-tail initargs)
243               (cell (or (class-initialize-info class)
244                         (setf (class-initialize-info class) (cons nil nil)))))
245           (loop (when (null initargs-tail) (return nil))
246                 (let ((keyword (pop initargs-tail))
247                       (alist-cell cell))
248                   (when plist-p
249                     (if (eq keyword :allow-other-keys)
250                         (setq allow-other-keys-arg (pop initargs-tail))
251                         (pop initargs-tail)))
252                   (loop (let ((alist (cdr alist-cell)))
253                           (when (null alist)
254                             (setq cell (cons nil nil))
255                             (setf (cdr alist-cell) (list (cons keyword cell)))
256                             (return nil))
257                           (when (eql keyword (caar alist))
258                             (setq cell (cdar alist))
259                             (return nil))
260                           (setq alist-cell alist)))))
261           (setq info (or (car cell)
262                          (setf (car cell) (make-initialize-info))))))
263     (let ((wrapper (initialize-info-wrapper info)))
264       (unless (eq wrapper (class-wrapper class))
265         (unless wrapper
266           (let* ((initargs-tail initargs)
267                  (klist-cell (list nil))
268                  (klist-tail klist-cell))
269             (loop (when (null initargs-tail) (return nil))
270                   (let ((key (pop initargs-tail)))
271                     (setf (cdr klist-tail) (list key)))
272                   (setf klist-tail (cdr klist-tail))
273                   (when plist-p (pop initargs-tail)))
274             (setf (initialize-info-key info)
275                   (list class (cdr klist-cell) allow-other-keys-arg))))
276         (reset-initialize-info info)))
277     (setq *initialize-info-cache-class* class)
278     (setq *initialize-info-cache-initargs* initargs)
279     (setq *initialize-info-cache-info* info)
280     info))
281
282 (defun update-initialize-info-internal (info name)
283   (let* ((key (initialize-info-key info))
284          (class (car key))
285          (keys (cadr key))
286          (allow-other-keys-arg (caddr key)))
287     (ecase name
288       ((initargs-form-list new-keys)
289        (multiple-value-bind (initargs-form-list new-keys)
290            (make-default-initargs-form-list class keys)
291          (setf (initialize-info-cached-initargs-form-list info)
292                initargs-form-list)
293          (setf (initialize-info-cached-new-keys info) new-keys)))
294       ((default-initargs-function)
295        (let ((initargs-form-list (initialize-info-initargs-form-list info)))
296          (setf (initialize-info-cached-default-initargs-function info)
297                (initialize-instance-simple-function
298                 'default-initargs-function info
299                 class initargs-form-list))))
300       ((valid-p ri-valid-p)
301        (flet ((compute-valid-p (methods)
302                 (or (not (null allow-other-keys-arg))
303                     (multiple-value-bind (legal allow-other-keys)
304                         (check-initargs-values class methods)
305                       (or (not (null allow-other-keys))
306                           (dolist (key keys t)
307                             (unless (member key legal)
308                               (return (cons :invalid key)))))))))
309          (let ((proto (class-prototype class)))
310            (setf (initialize-info-cached-valid-p info)
311                  (compute-valid-p
312                   (list (list* 'allocate-instance class nil)
313                         (list* 'initialize-instance proto nil)
314                         (list* 'shared-initialize proto t nil))))
315            (setf (initialize-info-cached-ri-valid-p info)
316                  (compute-valid-p
317                   (list (list* 'reinitialize-instance proto nil)
318                         (list* 'shared-initialize proto nil nil)))))))
319       ((shared-initialize-t-function)
320        (multiple-value-bind (initialize-form-list ignore)
321            (make-shared-initialize-form-list class keys t nil)
322          (declare (ignore ignore))
323          (setf (initialize-info-cached-shared-initialize-t-function info)
324                (initialize-instance-simple-function
325                 'shared-initialize-t-function info
326                 class initialize-form-list))))
327       ((shared-initialize-nil-function)
328        (multiple-value-bind (initialize-form-list ignore)
329            (make-shared-initialize-form-list class keys nil nil)
330          (declare (ignore ignore))
331          (setf (initialize-info-cached-shared-initialize-nil-function info)
332                (initialize-instance-simple-function
333                 'shared-initialize-nil-function info
334                 class initialize-form-list))))
335       ((constants combined-initialize-function)
336        (let ((initargs-form-list (initialize-info-initargs-form-list info))
337              (new-keys (initialize-info-new-keys info)))
338          (multiple-value-bind (initialize-form-list constants)
339              (make-shared-initialize-form-list class new-keys t t)
340            (setf (initialize-info-cached-constants info) constants)
341            (setf (initialize-info-cached-combined-initialize-function info)
342                  (initialize-instance-simple-function
343                   'combined-initialize-function info
344                   class (append initargs-form-list initialize-form-list))))))
345       ((make-instance-function-symbol)
346        (setf (initialize-info-cached-make-instance-function-symbol info)
347              (make-instance-function-symbol key)))
348       ((make-instance-function)
349        (let* ((function (get-make-instance-function key))
350               (symbol (initialize-info-make-instance-function-symbol info)))
351          (setf (initialize-info-cached-make-instance-function info) function)
352          (when symbol (setf (gdefinition symbol)
353                             (or function #'make-instance-1)))))))
354   info)
355
356 (defun get-make-instance-function (key)
357   (let* ((class (car key))
358          (keys (cadr key)))
359     (unless (eq *boot-state* 'complete)
360       (return-from get-make-instance-function nil))
361     (when (symbolp class)
362       (setq class (find-class class)))
363     (when (classp class)
364       (unless (class-finalized-p class) (finalize-inheritance class)))
365     (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
366            (class-and-initargs (list* class initargs))
367            (make-instance (gdefinition 'make-instance))
368            (make-instance-methods
369             (compute-applicable-methods make-instance class-and-initargs))
370            (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
371            (class+initargs (list class initargs))
372            (default-initargs (gdefinition 'default-initargs))
373            (default-initargs-methods
374                (compute-applicable-methods default-initargs class+initargs))
375            (proto (and (classp class) (class-prototype class)))
376            (initialize-instance-methods
377             (when proto
378               (compute-applicable-methods (gdefinition 'initialize-instance)
379                                           (list* proto initargs))))
380            (shared-initialize-methods
381             (when proto
382               (compute-applicable-methods (gdefinition 'shared-initialize)
383                                           (list* proto t initargs)))))
384       (when (null make-instance-methods)
385         (return-from get-make-instance-function
386           #'(lambda (class initargs)
387               (apply #'no-applicable-method make-instance class initargs))))
388       (unless (and (null (cdr make-instance-methods))
389                    (eq (car make-instance-methods) std-mi-meth)
390                    (null (cdr default-initargs-methods))
391                    (eq (car (method-specializers
392                              (car default-initargs-methods)))
393                        *the-class-slot-class*)
394                    (flet ((check-meth (meth)
395                             (let ((quals (method-qualifiers meth)))
396                               (if (null quals)
397                                   (eq (car (method-specializers meth))
398                                       *the-class-slot-object*)
399                                   (and (null (cdr quals))
400                                        (or (eq (car quals) ':before)
401                                            (eq (car quals) ':after)))))))
402                      (and (every #'check-meth initialize-instance-methods)
403                           (every #'check-meth shared-initialize-methods))))
404         (return-from get-make-instance-function nil))
405       (get-make-instance-function-internal
406        class key (default-initargs class initargs)
407        initialize-instance-methods shared-initialize-methods))))
408
409 (defun get-make-instance-function-internal (class key initargs
410                                                   initialize-instance-methods
411                                                   shared-initialize-methods)
412   (let* ((keys (cadr key))
413          (allow-other-keys-p (caddr key))
414          (allocate-instance-methods
415           (compute-applicable-methods (gdefinition 'allocate-instance)
416                                       (list* class initargs))))
417     (unless allow-other-keys-p
418       (unless (check-initargs-1
419                class initargs
420                (append allocate-instance-methods
421                        initialize-instance-methods
422                        shared-initialize-methods)
423                t nil)
424         (return-from get-make-instance-function-internal nil)))
425     (if (or (cdr allocate-instance-methods)
426             (some #'complicated-instance-creation-method
427                   initialize-instance-methods)
428             (some #'complicated-instance-creation-method
429                   shared-initialize-methods))
430         (make-instance-function-complex
431          key class keys
432          initialize-instance-methods shared-initialize-methods)
433         (make-instance-function-simple
434          key class keys
435          initialize-instance-methods shared-initialize-methods))))
436
437 (defun complicated-instance-creation-method (m)
438   (let ((qual (method-qualifiers m)))
439     (if qual
440         (not (and (null (cdr qual)) (eq (car qual) ':after)))
441         (let ((specl (car (method-specializers m))))
442           (or (not (classp specl))
443               (not (eq 'slot-object (class-name specl))))))))
444
445 (defun find-standard-ii-method (methods class-names)
446   (dolist (m methods)
447     (when (null (method-qualifiers m))
448       (let ((specl (car (method-specializers m))))
449         (when (and (classp specl)
450                    (if (listp class-names)
451                        (member (class-name specl) class-names)
452                        (eq (class-name specl) class-names)))
453           (return m))))))
454
455 (defmacro call-initialize-function (initialize-function instance initargs)
456   `(let ((.function. ,initialize-function))
457      (if (and (consp .function.)
458               (eq (car .function.) 'call-initialize-instance-simple))
459          (initialize-instance-simple (cadr .function.) (caddr .function.)
460                                      ,instance ,initargs)
461          (funcall (the function .function.) ,instance ,initargs))))
462
463 (defun make-instance-function-simple (key class keys
464                                           initialize-instance-methods
465                                           shared-initialize-methods)
466   (multiple-value-bind (initialize-function constants)
467       (get-simple-initialization-function class keys (caddr key))
468     (let* ((wrapper (class-wrapper class))
469            (lwrapper (list wrapper))
470            (allocate-function
471             (cond ((structure-class-p class)
472                    #'allocate-structure-instance)
473                   ((standard-class-p class)
474                    #'allocate-standard-instance)
475                   ((funcallable-standard-class-p class)
476                    #'allocate-funcallable-instance)
477                   (t
478                    (error "error in make-instance-function-simple"))))
479            (std-si-meth (find-standard-ii-method shared-initialize-methods
480                                                  'slot-object))
481            (shared-initfns
482             (nreverse (mapcar #'(lambda (method)
483                                   (make-effective-method-function
484                                    #'shared-initialize
485                                    `(call-method ,method nil)
486                                    nil lwrapper))
487                               (remove std-si-meth shared-initialize-methods))))
488            (std-ii-meth (find-standard-ii-method initialize-instance-methods
489                                                  'slot-object))
490            (initialize-initfns
491             (nreverse (mapcar #'(lambda (method)
492                                   (make-effective-method-function
493                                    #'initialize-instance
494                                    `(call-method ,method nil)
495                                    nil lwrapper))
496                               (remove std-ii-meth
497                                       initialize-instance-methods)))))
498       #'(lambda (class1 initargs)
499           (if (not (eq wrapper (class-wrapper class)))
500               (let* ((info (initialize-info class1 initargs))
501                      (fn (initialize-info-make-instance-function info)))
502                 (declare (type function fn))
503                 (funcall fn class1 initargs))
504               (let* ((instance (funcall allocate-function wrapper constants))
505                      (initargs (call-initialize-function initialize-function
506                                                          instance initargs)))
507                 (dolist (fn shared-initfns)
508                   (invoke-effective-method-function fn t instance t initargs))
509                 (dolist (fn initialize-initfns)
510                   (invoke-effective-method-function fn t instance initargs))
511                 instance))))))
512
513 (defun make-instance-function-complex (key class keys
514                                            initialize-instance-methods
515                                            shared-initialize-methods)
516   (multiple-value-bind (initargs-function initialize-function)
517       (get-complex-initialization-functions class keys (caddr key))
518     (let* ((wrapper (class-wrapper class))
519            (shared-initialize
520             (get-secondary-dispatch-function
521              #'shared-initialize shared-initialize-methods
522              `((class-eq ,class) t t)
523              `((,(find-standard-ii-method shared-initialize-methods
524                                           'slot-object)
525                 ,#'(lambda (instance init-type &rest initargs)
526                      (declare (ignore init-type))
527                      (call-initialize-function initialize-function
528                                                instance initargs)
529                      instance)))
530              (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
531            (initialize-instance
532             (get-secondary-dispatch-function
533              #'initialize-instance initialize-instance-methods
534              `((class-eq ,class) t)
535              `((,(find-standard-ii-method initialize-instance-methods
536                                           'slot-object)
537                 ,#'(lambda (instance &rest initargs)
538                      (invoke-effective-method-function
539                       shared-initialize t instance t initargs))))
540              (list wrapper *the-wrapper-of-t*))))
541       #'(lambda (class1 initargs)
542           (if (not (eq wrapper (class-wrapper class)))
543               (let* ((info (initialize-info class1 initargs))
544                      (fn (initialize-info-make-instance-function info)))
545                 (declare (type function fn))
546                 (funcall fn class1 initargs))
547               (let* ((initargs (call-initialize-function initargs-function
548                                                          nil initargs))
549                      (instance (apply #'allocate-instance class initargs)))
550                 (invoke-effective-method-function
551                  initialize-instance t instance initargs)
552                 instance))))))
553
554 (defun get-simple-initialization-function (class
555                                            keys
556                                            &optional allow-other-keys-arg)
557   (let ((info (initialize-info class keys nil allow-other-keys-arg)))
558     (values (initialize-info-combined-initialize-function info)
559             (initialize-info-constants info))))
560
561 (defun get-complex-initialization-functions (class
562                                              keys
563                                              &optional
564                                              allow-other-keys-arg
565                                              separate-p)
566   (let* ((info (initialize-info class keys nil allow-other-keys-arg))
567          (default-initargs-function (initialize-info-default-initargs-function
568                                      info)))
569     (if separate-p
570         (values default-initargs-function
571                 (initialize-info-shared-initialize-t-function info))
572         (values default-initargs-function
573                 (initialize-info-shared-initialize-t-function
574                  (initialize-info class (initialize-info-new-keys info)
575                                   nil allow-other-keys-arg))))))
576
577 (defun add-forms (forms forms-list)
578   (when forms
579     (setq forms (copy-list forms))
580     (if (null (car forms-list))
581         (setf (car forms-list) forms)
582         (setf (cddr forms-list) forms))
583     (setf (cdr forms-list) (last forms)))
584   (car forms-list))
585
586 (defun make-default-initargs-form-list (class keys &optional (separate-p t))
587   (let ((initargs-form-list (cons nil nil))
588         (default-initargs (class-default-initargs class))
589         (nkeys keys)
590         (slots-alist
591          (mapcan #'(lambda (slot)
592                      (mapcar #'(lambda (arg)
593                                  (cons arg slot))
594                              (slot-definition-initargs slot)))
595                  (class-slots class)))
596         (nslots nil))
597     (dolist (key nkeys)
598       (pushnew (cdr (assoc key slots-alist)) nslots))
599     (dolist (default default-initargs)
600       (let* ((key (car default))
601              (slot (cdr (assoc key slots-alist)))
602              (function (cadr default)))
603         (unless (member slot nslots)
604           (add-forms `((funcall ,function) (push-initarg ,key))
605                      initargs-form-list)
606           (push key nkeys)
607           (push slot nslots))))
608     (when separate-p
609       (add-forms `((update-initialize-info-cache
610                     ,class ,(initialize-info class nkeys nil)))
611                  initargs-form-list))
612     (add-forms `((finish-pushing-initargs))
613                initargs-form-list)
614     (values (car initargs-form-list) nkeys)))
615
616 (defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
617   (let* ((initialize-form-list (cons nil nil))
618          (type (cond ((structure-class-p class)
619                       'structure)
620                      ((standard-class-p class)
621                       'standard)
622                      ((funcallable-standard-class-p class)
623                       'funcallable)
624                      (t (error "error in make-shared-initialize-form-list"))))
625          (wrapper (class-wrapper class))
626          (constants (when simple-p
627                       (make-list (wrapper-no-of-instance-slots wrapper)
628                                  ':initial-element +slot-unbound+)))
629          (slots (class-slots class))
630          (slot-names (mapcar #'slot-definition-name slots))
631          (slots-key (mapcar #'(lambda (slot)
632                                 (let ((index most-positive-fixnum))
633                                   (dolist (key (slot-definition-initargs slot))
634                                     (let ((pos (position key keys)))
635                                       (when pos (setq index (min index pos)))))
636                                   (cons slot index)))
637                             slots))
638          (slots (stable-sort slots-key #'< :key #'cdr)))
639     (let ((n-popped 0))
640       (dolist (slot+index slots)
641         (let* ((slot (car slot+index))
642                (name (slot-definition-name slot))
643                (npop (1+ (- (cdr slot+index) n-popped))))
644           (unless (eql (cdr slot+index) most-positive-fixnum)
645             (let* ((pv-offset (1+ (position name slot-names))))
646               (add-forms `(,@(when (plusp npop)
647                                `((pop-initargs ,(* 2 npop))))
648                            (instance-set ,pv-offset ,slot))
649                          initialize-form-list))
650             (incf n-popped npop)))))
651     (dolist (slot+index slots)
652       (let* ((slot (car slot+index))
653              (name (slot-definition-name slot)))
654         (when (and (eql (cdr slot+index) most-positive-fixnum)
655                    (or (eq si-slot-names t)
656                        (member name si-slot-names)))
657           (let* ((initform (slot-definition-initform slot))
658                  (initfunction (slot-definition-initfunction slot))
659                  (location (unless (eq type 'structure)
660                              (slot-definition-location slot)))
661                  (pv-offset (1+ (position name slot-names)))
662                  (forms (cond ((null initfunction)
663                                nil)
664                               ((constantp initform)
665                                (let ((value (funcall initfunction)))
666                                  (if (and simple-p (integerp location))
667                                      (progn (setf (nth location constants)
668                                                   value)
669                                             nil)
670                                      `((const ,value)
671                                        (instance-set ,pv-offset ,slot)))))
672                               (t
673                                `((funcall ,(slot-definition-initfunction slot))
674                                  (instance-set ,pv-offset ,slot))))))
675             (add-forms `(,@(unless (or simple-p (null forms))
676                              `((skip-when-instance-boundp ,pv-offset ,slot
677                                 ,(length forms))))
678                          ,@forms)
679                        initialize-form-list)))))
680     (values (car initialize-form-list) constants)))
681
682 (defvar *class-pv-table-table* (make-hash-table :test 'eq))
683
684 (defun get-pv-cell-for-class (class)
685   (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
686          (slot-name-lists (list (cons nil slot-names)))
687          (pv-table (gethash class *class-pv-table-table*)))
688     (unless (and pv-table
689                  (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
690       (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
691       (setf (gethash class *class-pv-table-table*) pv-table))
692     (pv-table-lookup pv-table (class-wrapper class))))
693
694 (defvar *initialize-instance-simple-alist* nil)
695 (defvar *note-iis-entry-p* nil)
696
697 (defvar *compiled-initialize-instance-simple-functions*
698   (make-hash-table :test 'equal))
699
700 (defun initialize-instance-simple-function (use info class form-list)
701   (let* ((pv-cell (get-pv-cell-for-class class))
702          (key (initialize-info-key info))
703          (sf-key (list* use (class-name (car key)) (cdr key))))
704     (if (or *compile-make-instance-functions-p*
705             (gethash sf-key *compiled-initialize-instance-simple-functions*))
706         (multiple-value-bind (form args)
707             (form-list-to-lisp pv-cell form-list)
708           (let ((entry (assoc form *initialize-instance-simple-alist*
709                               :test #'equal)))
710             (setf (gethash sf-key
711                            *compiled-initialize-instance-simple-functions*)
712                   t)
713             (if entry
714                 (setf (cdddr entry) (union (list sf-key) (cdddr entry)
715                                            :test #'equal))
716                 (progn
717                   (setq entry (list* form nil nil (list sf-key)))
718                   (setq *initialize-instance-simple-alist*
719                         (nconc *initialize-instance-simple-alist*
720                                (list entry)))))
721             (unless (or *note-iis-entry-p* (cadr entry))
722               (setf (cadr entry) (compile nil (car entry))))
723             (if (cadr entry)
724                 (apply (the function (cadr entry)) args)
725                 `(call-initialize-instance-simple ,pv-cell ,form-list))))
726         #||
727         #'(lambda (instance initargs)
728             (initialize-instance-simple pv-cell form-list instance initargs))
729         ||#
730         `(call-initialize-instance-simple ,pv-cell ,form-list))))
731
732 (defun load-precompiled-iis-entry (form function system uses)
733   (let ((entry (assoc form *initialize-instance-simple-alist*
734                       :test #'equal)))
735     (unless entry
736       (setq entry (list* form nil nil nil))
737       (setq *initialize-instance-simple-alist*
738             (nconc *initialize-instance-simple-alist*
739                    (list entry))))
740     (setf (cadr entry) function)
741     (setf (caddr entry) system)
742     (dolist (use uses)
743       (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
744     (setf (cdddr entry) (union uses (cdddr entry)
745                                :test #'equal))))
746
747 (defmacro precompile-iis-functions (&optional system)
748   `(progn
749     ,@(gathering1 (collecting)
750                   (dolist (iis-entry *initialize-instance-simple-alist*)
751                     (when (or (null (caddr iis-entry))
752                               (eq (caddr iis-entry) system))
753                       (when system (setf (caddr iis-entry) system))
754                       (gather1
755                        `(load-precompiled-iis-entry
756                          ',(car iis-entry)
757                          #',(car iis-entry)
758                          ',system
759                          ',(cdddr iis-entry))))))))
760
761 (defun compile-iis-functions (after-p)
762   (let ((*compile-make-instance-functions-p* t)
763         (*revert-initialize-info-p* t)
764         (*note-iis-entry-p* (not after-p)))
765     (declare (special *compile-make-instance-functions-p*))
766     (when (eq *boot-state* 'complete)
767       (update-make-instance-function-table))))
768
769 ;(const const)
770 ;(funcall function)
771 ;(push-initarg const)
772 ;(pop-supplied count) ; a positive odd number
773 ;(instance-set pv-offset slotd)
774 ;(skip-when-instance-boundp pv-offset slotd n)
775
776 (defun initialize-instance-simple (pv-cell form-list instance initargs)
777   (let ((pv (car pv-cell))
778         (initargs-tail initargs)
779         (slots (get-slots-or-nil instance))
780         (class (class-of instance))
781         value)
782     (loop (when (null form-list) (return nil))
783           (let ((form (pop form-list)))
784             (ecase (car form)
785               (push-initarg
786                (push value initargs)
787                (push (cadr form) initargs))
788               (const
789                (setq value (cadr form)))
790               (funcall
791                (setq value (funcall (the function (cadr form)))))
792               (pop-initargs
793                (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
794                (setq value (pop initargs-tail)))
795               (instance-set
796                (instance-write-internal
797                 pv slots (cadr form) value
798                 (setf (slot-value-using-class class instance (caddr form))
799                       value)))
800               (skip-when-instance-boundp
801                (when (instance-boundp-internal
802                       pv slots (cadr form)
803                       (slot-boundp-using-class class instance (caddr form)))
804                  (dotimes-fixnum (i (cadddr form))
805                    (pop form-list))))
806               (update-initialize-info-cache
807                (when (consp initargs)
808                  (setq initargs (cons (car initargs) (cdr initargs))))
809                (setq *initialize-info-cache-class* (cadr form))
810                (setq *initialize-info-cache-initargs* initargs)
811                (setq *initialize-info-cache-info* (caddr form)))
812               (finish-pushing-initargs
813                (setq initargs-tail initargs)))))
814     initargs))
815
816 (defun add-to-cvector (cvector constant)
817   (or (position constant cvector)
818       (prog1 (fill-pointer cvector)
819         (vector-push-extend constant cvector))))
820
821 (defvar *inline-iis-instance-locations-p* t)
822
823 (defun first-form-to-lisp (forms cvector pv)
824   (flet ((const (constant)
825            (cond ((or (numberp constant) (characterp constant))
826                   constant)
827                  ((and (symbolp constant) (symbol-package constant))
828                   `',constant)
829                  (t
830                   `(svref cvector ,(add-to-cvector cvector constant))))))
831     (let ((form (pop (car forms))))
832       (ecase (car form)
833         (push-initarg
834          `((push value initargs)
835            (push ,(const (cadr form)) initargs)))
836         (const
837          `((setq value ,(const (cadr form)))))
838         (funcall
839          `((setq value (funcall (the function ,(const (cadr form)))))))
840         (pop-initargs
841          `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
842                                     (case pop
843                                       (1 `(cdr))
844                                       (3 `(cdddr))
845                                       (t `(nthcdr ,pop))))
846                                 initargs-tail))
847            (setq value (pop initargs-tail))))
848         (instance-set
849          (let* ((pv-offset (cadr form))
850                 (location (pvref pv pv-offset))
851                 (default `(setf (slot-value-using-class class instance
852                                                         ,(const (caddr form)))
853                                 value)))
854            (if *inline-iis-instance-locations-p*
855                (typecase location
856                  (fixnum `((and slots
857                                 (setf (clos-slots-ref slots ,(const location))
858                                       value))))
859                  (cons `((setf (cdr ,(const location)) value)))
860                  (t `(,default)))
861                `((instance-write-internal pv slots ,(const pv-offset) value
862                   ,default
863                   ,(typecase location
864                      (fixnum ':instance)
865                      (cons ':class)
866                      (t ':default)))))))
867         (skip-when-instance-boundp
868          (let* ((pv-offset (cadr form))
869                 (location (pvref pv pv-offset))
870                 (default `(slot-boundp-using-class class instance
871                            ,(const (caddr form)))))
872            `((unless ,(if *inline-iis-instance-locations-p*
873                           (typecase location
874                             (fixnum `(not (and slots
875                                                (eq (clos-slots-ref
876                                                     slots
877                                                     ,(const location))
878                                                    +slot-unbound+))))
879                             (cons `(not (eq (cdr ,(const location))
880                                             +slot-unbound+)))
881                             (t default))
882                           `(instance-boundp-internal
883                             pv slots ,(const pv-offset)
884                             ,default
885                             ,(typecase (pvref pv pv-offset)
886                                (fixnum ':instance)
887                                (cons ':class)
888                                (t ':default))))
889                ,@(let ((sforms (cons nil nil)))
890                    (dotimes-fixnum (i (cadddr form) (car sforms))
891                      (add-forms (first-form-to-lisp forms cvector pv)
892                                 sforms)))))))
893         (update-initialize-info-cache
894          `((when (consp initargs)
895              (setq initargs (cons (car initargs) (cdr initargs))))
896            (setq *initialize-info-cache-class* ,(const (cadr form)))
897            (setq *initialize-info-cache-initargs* initargs)
898            (setq *initialize-info-cache-info* ,(const (caddr form)))))
899         (finish-pushing-initargs
900          `((setq initargs-tail initargs)))))))
901
902 (defmacro iis-body (&body forms)
903   `(let ((initargs-tail initargs)
904          (slots (get-slots-or-nil instance))
905          (class (class-of instance))
906          (pv (car pv-cell))
907          value)
908      initargs instance initargs-tail pv cvector slots class value
909      ,@forms))
910
911 (defun form-list-to-lisp (pv-cell form-list)
912   (let* ((forms (list form-list))
913          (cvector (make-array (floor (length form-list) 2)
914                               :fill-pointer 0 :adjustable t))
915          (pv (car pv-cell))
916          (body (let ((rforms (cons nil nil)))
917                  (loop (when (null (car forms)) (return (car rforms)))
918                        (add-forms (first-form-to-lisp forms cvector pv)
919                                   rforms))))
920          (cvector-type `(simple-vector ,(length cvector))))
921     (values
922      `(lambda (pv-cell cvector)
923         (declare (type ,cvector-type cvector))
924         #'(lambda (instance initargs)
925             (declare #.*optimize-speed*)
926             (iis-body ,@body)
927             initargs))
928      (list pv-cell (coerce cvector cvector-type)))))
929 \f
930 ;;; The effect of this is to cause almost all of the overhead of
931 ;;; MAKE-INSTANCE to happen at load time (or maybe at precompile time,
932 ;;; as explained in a previous message) rather than the first time
933 ;;; that MAKE-INSTANCE is called with a given class-name and sequence
934 ;;; of keywords.
935
936 ;;; This optimization applies only when the first argument and all the
937 ;;; even numbered arguments are constants evaluating to interned
938 ;;; symbols.
939
940 (declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
941
942 (define-compiler-macro make-instance (&whole form &rest args)
943   (declare (ignore args))
944   (let* ((*make-instance-function-keys* nil)
945          (expanded-form (expand-make-instance-form form)))
946     (if expanded-form
947         `(funcall (fdefinition
948                    ;; The name is guaranteed to be fbound.
949                    ;; Is there a way to declare this?
950                    (load-time-value
951                     (get-make-instance-function-symbol
952                      ',(first *make-instance-function-keys*))))
953                   ,@(cdr expanded-form))
954         form)))
955
956 (defun get-make-instance-function-symbol (key)
957   (get-make-instance-functions (list key))
958   (make-instance-function-symbol key))