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