1 ;;;; This file defines the optimized make-instance functions.
3 ;;;; This software is part of the SBCL system. See the README file for
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
12 ;;;; copyright information from original PCL sources:
14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
15 ;;;; All rights reserved.
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
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
31 (defvar *compile-make-instance-functions-p* nil)
33 (defun update-make-instance-function-table (&optional (class *the-class-t*))
34 (when (symbolp class) (setq class (find-class class)))
35 (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
36 (when (memq *the-class-slot-object* (class-precedence-list class))
37 (map-all-classes #'reset-class-initialize-info class)))
39 (defun constant-symbol-p (form)
41 (let ((object (eval form)))
43 (symbol-package object)))))
45 (defvar *make-instance-function-keys* nil)
47 (defun expand-make-instance-form (form)
48 (let ((class (cadr form)) (initargs (cddr form))
49 (keys nil)(allow-other-keys-p nil) key value)
50 (when (and (constant-symbol-p class)
51 (let ((initargs-tail initargs))
52 (loop (when (null initargs-tail) (return t))
53 (unless (constant-symbol-p (car initargs-tail))
55 (setq key (eval (pop initargs-tail)))
56 (setq value (pop initargs-tail))
57 (when (eq ':allow-other-keys key)
58 (setq allow-other-keys-p value))
60 (let* ((class (eval class))
61 (keys (nreverse keys))
62 (key (list class keys allow-other-keys-p))
63 (sym (make-instance-function-symbol key)))
64 (push key *make-instance-function-keys*)
66 `(,sym ',class (list ,@initargs)))))))
68 (defmacro expanding-make-instance-top-level (&rest forms &environment env)
69 (let* ((*make-instance-function-keys* nil)
70 (form (macroexpand `(expanding-make-instance ,@forms) env)))
72 ,@(when *make-instance-function-keys*
73 `((get-make-instance-functions ',*make-instance-function-keys*)))
76 (defmacro expanding-make-instance (&rest forms &environment env)
78 ,@(mapcar #'(lambda (form)
80 #'(lambda (subform context env)
81 (declare (ignore env))
82 (or (and (eq context ':eval)
84 (eq (car subform) 'make-instance)
85 (expand-make-instance-form subform))
89 (defmacro defconstructor
90 (name class lambda-list &rest initialization-arguments)
91 `(expanding-make-instance-top-level
92 (defun ,name ,lambda-list
93 (make-instance ',class ,@initialization-arguments))))
95 (defun get-make-instance-functions (key-list)
96 (dolist (key key-list)
97 (let* ((cell (find-class-cell (car key)))
98 (make-instance-function-keys
99 (find-class-cell-make-instance-function-keys cell))
100 (mif-key (cons (cadr key) (caddr key))))
101 (unless (find mif-key make-instance-function-keys
103 (push mif-key (find-class-cell-make-instance-function-keys cell))
104 (let ((class (find-class-cell-class cell)))
105 (when (and class (not (forward-referenced-class-p class)))
106 (update-initialize-info-internal
107 (initialize-info class (car mif-key) nil (cdr mif-key))
108 'make-instance-function)))))))
110 (defun make-instance-function-symbol (key)
111 (let* ((class (car key))
112 (symbolp (symbolp class)))
113 (when (or symbolp (classp class))
114 (let* ((class-name (if (symbolp class) class (class-name class)))
116 (allow-other-keys-p (caddr key)))
117 (when (and (or symbolp
118 (and (symbolp class-name)
119 (eq class (find-class class-name nil))))
120 (symbol-package class-name))
121 (let ((*package* *pcl-package*)
125 (*print-case* :upcase)
126 (*print-pretty* nil))
128 "MAKE-INSTANCE ~S ~S ~S"
131 allow-other-keys-p))))))))
133 (defun make-instance-1 (class initargs)
134 (apply #'make-instance class initargs))
136 (defmacro define-cached-reader (type name trap)
137 (let ((reader-name (intern (format nil "~A-~A" type name)))
138 (cached-name (intern (format nil "~A-CACHED-~A" type name))))
139 `(defmacro ,reader-name (info)
140 `(let ((value (,',cached-name ,info)))
141 (if (eq value ':unknown)
143 (,',trap ,info ',',name)
144 (,',cached-name ,info))
147 (eval-when (:compile-toplevel :load-toplevel :execute)
148 (defparameter *initialize-info-cached-slots*
149 '(valid-p ; t or (:invalid key)
153 default-initargs-function
154 shared-initialize-t-function
155 shared-initialize-nil-function
157 combined-initialize-function ; allocate-instance + shared-initialize
158 make-instance-function ; nil means use gf
159 make-instance-function-symbol)))
161 (defmacro define-initialize-info ()
162 (let ((cached-slot-names
163 (mapcar #'(lambda (name)
164 (intern (format nil "CACHED-~A" name)))
165 *initialize-info-cached-slots*))
167 (mapcar #'(lambda (name)
168 (intern (format nil "~A-CACHED-~A"
169 'initialize-info name)))
170 *initialize-info-cached-slots*)))
172 (defstruct initialize-info
174 ,@(mapcar #'(lambda (name)
177 (defmacro reset-initialize-info-internal (info)
179 ,@(mapcar #'(lambda (cname)
180 `(setf (,cname ,info) ':unknown))
182 (defun initialize-info-bound-slots (info)
184 ,@(mapcar #'(lambda (name cached-name)
185 `(unless (eq ':unknown (,cached-name info))
186 (push ',name slots)))
187 *initialize-info-cached-slots* cached-names)
189 ,@(mapcar #'(lambda (name)
190 `(define-cached-reader initialize-info ,name
191 update-initialize-info-internal))
192 *initialize-info-cached-slots*))))
194 (define-initialize-info)
196 (defvar *initialize-info-cache-class* nil)
197 (defvar *initialize-info-cache-initargs* nil)
198 (defvar *initialize-info-cache-info* nil)
200 (defvar *revert-initialize-info-p* nil)
202 (defun reset-initialize-info (info)
203 (setf (initialize-info-wrapper info)
204 (class-wrapper (car (initialize-info-key info))))
205 (let ((slots-to-revert (if *revert-initialize-info-p*
206 (initialize-info-bound-slots info)
207 '(make-instance-function))))
208 (reset-initialize-info-internal info)
209 (dolist (slot slots-to-revert)
210 (update-initialize-info-internal info slot))
213 (defun reset-class-initialize-info (class)
214 (reset-class-initialize-info-1 (class-initialize-info class)))
216 (defun reset-class-initialize-info-1 (cell)
219 (reset-initialize-info (car cell)))
220 (let ((alist (cdr cell)))
222 (reset-class-initialize-info-1 (cdr a))))))
224 (defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
226 (if (and (eq *initialize-info-cache-class* class)
227 (eq *initialize-info-cache-initargs* initargs))
228 (setq info *initialize-info-cache-info*)
229 (let ((initargs-tail initargs)
230 (cell (or (class-initialize-info class)
231 (setf (class-initialize-info class) (cons nil nil)))))
232 (loop (when (null initargs-tail) (return nil))
233 (let ((keyword (pop initargs-tail))
236 (if (eq keyword :allow-other-keys)
237 (setq allow-other-keys-arg (pop initargs-tail))
238 (pop initargs-tail)))
239 (loop (let ((alist (cdr alist-cell)))
241 (setq cell (cons nil nil))
242 (setf (cdr alist-cell) (list (cons keyword cell)))
244 (when (eql keyword (caar alist))
245 (setq cell (cdar alist))
247 (setq alist-cell alist)))))
248 (setq info (or (car cell)
249 (setf (car cell) (make-initialize-info))))))
250 (let ((wrapper (initialize-info-wrapper info)))
251 (unless (eq wrapper (class-wrapper class))
253 (let* ((initargs-tail initargs)
254 (klist-cell (list nil))
255 (klist-tail klist-cell))
256 (loop (when (null initargs-tail) (return nil))
257 (let ((key (pop initargs-tail)))
258 (setf (cdr klist-tail) (list key)))
259 (setf klist-tail (cdr klist-tail))
260 (when plist-p (pop initargs-tail)))
261 (setf (initialize-info-key info)
262 (list class (cdr klist-cell) allow-other-keys-arg))))
263 (reset-initialize-info info)))
264 (setq *initialize-info-cache-class* class)
265 (setq *initialize-info-cache-initargs* initargs)
266 (setq *initialize-info-cache-info* info)
269 (defun update-initialize-info-internal (info name)
270 (let* ((key (initialize-info-key info))
273 (allow-other-keys-arg (caddr key)))
275 ((initargs-form-list new-keys)
276 (multiple-value-bind (initargs-form-list new-keys)
277 (make-default-initargs-form-list class keys)
278 (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
279 (setf (initialize-info-cached-new-keys info) new-keys)))
280 ((default-initargs-function)
281 (let ((initargs-form-list (initialize-info-initargs-form-list info)))
282 (setf (initialize-info-cached-default-initargs-function info)
283 (initialize-instance-simple-function
284 'default-initargs-function info
285 class initargs-form-list))))
286 ((valid-p ri-valid-p)
287 (flet ((compute-valid-p (methods)
288 (or (not (null allow-other-keys-arg))
289 (multiple-value-bind (legal allow-other-keys)
290 (check-initargs-values class methods)
291 (or (not (null allow-other-keys))
293 (unless (member key legal)
294 (return (cons :invalid key)))))))))
295 (let ((proto (class-prototype class)))
296 (setf (initialize-info-cached-valid-p info)
298 (list (list* 'allocate-instance class nil)
299 (list* 'initialize-instance proto nil)
300 (list* 'shared-initialize proto t nil))))
301 (setf (initialize-info-cached-ri-valid-p info)
303 (list (list* 'reinitialize-instance proto nil)
304 (list* 'shared-initialize proto nil nil)))))))
305 ((shared-initialize-t-function)
306 (multiple-value-bind (initialize-form-list ignore)
307 (make-shared-initialize-form-list class keys t nil)
308 (declare (ignore ignore))
309 (setf (initialize-info-cached-shared-initialize-t-function info)
310 (initialize-instance-simple-function
311 'shared-initialize-t-function info
312 class initialize-form-list))))
313 ((shared-initialize-nil-function)
314 (multiple-value-bind (initialize-form-list ignore)
315 (make-shared-initialize-form-list class keys nil nil)
316 (declare (ignore ignore))
317 (setf (initialize-info-cached-shared-initialize-nil-function info)
318 (initialize-instance-simple-function
319 'shared-initialize-nil-function info
320 class initialize-form-list))))
321 ((constants combined-initialize-function)
322 (let ((initargs-form-list (initialize-info-initargs-form-list info))
323 (new-keys (initialize-info-new-keys info)))
324 (multiple-value-bind (initialize-form-list constants)
325 (make-shared-initialize-form-list class new-keys t t)
326 (setf (initialize-info-cached-constants info) constants)
327 (setf (initialize-info-cached-combined-initialize-function info)
328 (initialize-instance-simple-function
329 'combined-initialize-function info
330 class (append initargs-form-list initialize-form-list))))))
331 ((make-instance-function-symbol)
332 (setf (initialize-info-cached-make-instance-function-symbol info)
333 (make-instance-function-symbol key)))
334 ((make-instance-function)
335 (let* ((function (get-make-instance-function key))
336 (symbol (initialize-info-make-instance-function-symbol info)))
337 (setf (initialize-info-cached-make-instance-function info) function)
338 (when symbol (setf (gdefinition symbol)
339 (or function #'make-instance-1)))))))
342 (defun get-make-instance-function (key)
343 (let* ((class (car key))
345 (unless (eq *boot-state* 'complete)
346 (return-from get-make-instance-function nil))
347 (when (symbolp class)
348 (setq class (find-class class)))
350 (unless (class-finalized-p class) (finalize-inheritance class)))
351 (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
352 (class-and-initargs (list* class initargs))
353 (make-instance (gdefinition 'make-instance))
354 (make-instance-methods
355 (compute-applicable-methods make-instance class-and-initargs))
356 (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
357 (class+initargs (list class initargs))
358 (default-initargs (gdefinition 'default-initargs))
359 (default-initargs-methods
360 (compute-applicable-methods default-initargs class+initargs))
361 (proto (and (classp class) (class-prototype class)))
362 (initialize-instance-methods
364 (compute-applicable-methods (gdefinition 'initialize-instance)
365 (list* proto initargs))))
366 (shared-initialize-methods
368 (compute-applicable-methods (gdefinition 'shared-initialize)
369 (list* proto t initargs)))))
370 (when (null make-instance-methods)
371 (return-from get-make-instance-function
372 #'(lambda (class initargs)
373 (apply #'no-applicable-method make-instance class initargs))))
374 (unless (and (null (cdr make-instance-methods))
375 (eq (car make-instance-methods) std-mi-meth)
376 (null (cdr default-initargs-methods))
377 (eq (car (method-specializers (car default-initargs-methods)))
378 *the-class-slot-class*)
379 (flet ((check-meth (meth)
380 (let ((quals (method-qualifiers meth)))
382 (eq (car (method-specializers meth))
383 *the-class-slot-object*)
384 (and (null (cdr quals))
385 (or (eq (car quals) ':before)
386 (eq (car quals) ':after)))))))
387 (and (every #'check-meth initialize-instance-methods)
388 (every #'check-meth shared-initialize-methods))))
389 (return-from get-make-instance-function nil))
390 (get-make-instance-function-internal
391 class key (default-initargs class initargs)
392 initialize-instance-methods shared-initialize-methods))))
394 (defun get-make-instance-function-internal (class key initargs
395 initialize-instance-methods
396 shared-initialize-methods)
397 (let* ((keys (cadr key))
398 (allow-other-keys-p (caddr key))
399 (allocate-instance-methods
400 (compute-applicable-methods (gdefinition 'allocate-instance)
401 (list* class initargs))))
402 (unless allow-other-keys-p
403 (unless (check-initargs-1
405 (append allocate-instance-methods
406 initialize-instance-methods
407 shared-initialize-methods)
409 (return-from get-make-instance-function-internal nil)))
410 (if (or (cdr allocate-instance-methods)
411 (some #'complicated-instance-creation-method
412 initialize-instance-methods)
413 (some #'complicated-instance-creation-method
414 shared-initialize-methods))
415 (make-instance-function-complex
417 initialize-instance-methods shared-initialize-methods)
418 (make-instance-function-simple
420 initialize-instance-methods shared-initialize-methods))))
422 (defun complicated-instance-creation-method (m)
423 (let ((qual (method-qualifiers m)))
425 (not (and (null (cdr qual)) (eq (car qual) ':after)))
426 (let ((specl (car (method-specializers m))))
427 (or (not (classp specl))
428 (not (eq 'slot-object (class-name specl))))))))
430 (defun find-standard-ii-method (methods class-names)
432 (when (null (method-qualifiers m))
433 (let ((specl (car (method-specializers m))))
434 (when (and (classp specl)
435 (if (listp class-names)
436 (member (class-name specl) class-names)
437 (eq (class-name specl) class-names)))
440 (defmacro call-initialize-function (initialize-function instance initargs)
441 `(let ((.function. ,initialize-function))
442 (if (and (consp .function.)
443 (eq (car .function.) 'call-initialize-instance-simple))
444 (initialize-instance-simple (cadr .function.) (caddr .function.)
446 (funcall (the function .function.) ,instance ,initargs))))
448 (defun make-instance-function-simple (key class keys
449 initialize-instance-methods
450 shared-initialize-methods)
451 (multiple-value-bind (initialize-function constants)
452 (get-simple-initialization-function class keys (caddr key))
453 (let* ((wrapper (class-wrapper class))
454 (lwrapper (list wrapper))
456 (cond ((structure-class-p class)
457 #'allocate-structure-instance)
458 ((standard-class-p class)
459 #'allocate-standard-instance)
460 ((funcallable-standard-class-p class)
461 #'allocate-funcallable-instance)
463 (error "error in make-instance-function-simple"))))
464 (std-si-meth (find-standard-ii-method shared-initialize-methods
467 (nreverse (mapcar #'(lambda (method)
468 (make-effective-method-function
470 `(call-method ,method nil)
472 (remove std-si-meth shared-initialize-methods))))
473 (std-ii-meth (find-standard-ii-method initialize-instance-methods
476 (nreverse (mapcar #'(lambda (method)
477 (make-effective-method-function
478 #'initialize-instance
479 `(call-method ,method nil)
482 initialize-instance-methods)))))
483 #'(lambda (class1 initargs)
484 (if (not (eq wrapper (class-wrapper class)))
485 (let* ((info (initialize-info class1 initargs))
486 (fn (initialize-info-make-instance-function info)))
487 (declare (type function fn))
488 (funcall fn class1 initargs))
489 (let* ((instance (funcall allocate-function wrapper constants))
490 (initargs (call-initialize-function initialize-function
492 (dolist (fn shared-initfns)
493 (invoke-effective-method-function fn t instance t initargs))
494 (dolist (fn initialize-initfns)
495 (invoke-effective-method-function fn t instance initargs))
498 (defun make-instance-function-complex (key class keys
499 initialize-instance-methods
500 shared-initialize-methods)
501 (multiple-value-bind (initargs-function initialize-function)
502 (get-complex-initialization-functions class keys (caddr key))
503 (let* ((wrapper (class-wrapper class))
505 (get-secondary-dispatch-function
506 #'shared-initialize shared-initialize-methods
507 `((class-eq ,class) t t)
508 `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
509 ,#'(lambda (instance init-type &rest initargs)
510 (declare (ignore init-type))
511 (call-initialize-function initialize-function
514 (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
516 (get-secondary-dispatch-function
517 #'initialize-instance initialize-instance-methods
518 `((class-eq ,class) t)
519 `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
520 ,#'(lambda (instance &rest initargs)
521 (invoke-effective-method-function
522 shared-initialize t instance t initargs))))
523 (list wrapper *the-wrapper-of-t*))))
524 #'(lambda (class1 initargs)
525 (if (not (eq wrapper (class-wrapper class)))
526 (let* ((info (initialize-info class1 initargs))
527 (fn (initialize-info-make-instance-function info)))
528 (declare (type function fn))
529 (funcall fn class1 initargs))
530 (let* ((initargs (call-initialize-function initargs-function
532 (instance (apply #'allocate-instance class initargs)))
533 (invoke-effective-method-function
534 initialize-instance t instance initargs)
537 (defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
538 (let ((info (initialize-info class keys nil allow-other-keys-arg)))
539 (values (initialize-info-combined-initialize-function info)
540 (initialize-info-constants info))))
542 (defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
544 (let* ((info (initialize-info class keys nil allow-other-keys-arg))
545 (default-initargs-function (initialize-info-default-initargs-function info)))
547 (values default-initargs-function
548 (initialize-info-shared-initialize-t-function info))
549 (values default-initargs-function
550 (initialize-info-shared-initialize-t-function
551 (initialize-info class (initialize-info-new-keys info)
552 nil allow-other-keys-arg))))))
554 (defun add-forms (forms forms-list)
556 (setq forms (copy-list forms))
557 (if (null (car forms-list))
558 (setf (car forms-list) forms)
559 (setf (cddr forms-list) forms))
560 (setf (cdr forms-list) (last forms)))
563 (defun make-default-initargs-form-list (class keys &optional (separate-p t))
564 (let ((initargs-form-list (cons nil nil))
565 (default-initargs (class-default-initargs class))
568 (mapcan #'(lambda (slot)
569 (mapcar #'(lambda (arg)
571 (slot-definition-initargs slot)))
572 (class-slots class)))
575 (pushnew (cdr (assoc key slots-alist)) nslots))
576 (dolist (default default-initargs)
577 (let* ((key (car default))
578 (slot (cdr (assoc key slots-alist)))
579 (function (cadr default)))
580 (unless (member slot nslots)
581 (add-forms `((funcall ,function) (push-initarg ,key))
584 (push slot nslots))))
586 (add-forms `((update-initialize-info-cache
587 ,class ,(initialize-info class nkeys nil)))
589 (add-forms `((finish-pushing-initargs))
591 (values (car initargs-form-list) nkeys)))
593 (defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
594 (let* ((initialize-form-list (cons nil nil))
595 (type (cond ((structure-class-p class)
597 ((standard-class-p class)
599 ((funcallable-standard-class-p class)
601 (t (error "error in make-shared-initialize-form-list"))))
602 (wrapper (class-wrapper class))
603 (constants (when simple-p
604 (make-list (wrapper-no-of-instance-slots wrapper)
605 ':initial-element *slot-unbound*)))
606 (slots (class-slots class))
607 (slot-names (mapcar #'slot-definition-name slots))
608 (slots-key (mapcar #'(lambda (slot)
609 (let ((index most-positive-fixnum))
610 (dolist (key (slot-definition-initargs slot))
611 (let ((pos (position key keys)))
612 (when pos (setq index (min index pos)))))
615 (slots (stable-sort slots-key #'< :key #'cdr)))
617 (dolist (slot+index slots)
618 (let* ((slot (car slot+index))
619 (name (slot-definition-name slot))
620 (npop (1+ (- (cdr slot+index) n-popped))))
621 (unless (eql (cdr slot+index) most-positive-fixnum)
622 (let* ((pv-offset (1+ (position name slot-names))))
623 (add-forms `(,@(when (plusp npop)
624 `((pop-initargs ,(* 2 npop))))
625 (instance-set ,pv-offset ,slot))
626 initialize-form-list))
627 (incf n-popped npop)))))
628 (dolist (slot+index slots)
629 (let* ((slot (car slot+index))
630 (name (slot-definition-name slot)))
631 (when (and (eql (cdr slot+index) most-positive-fixnum)
632 (or (eq si-slot-names 't)
633 (member name si-slot-names)))
634 (let* ((initform (slot-definition-initform slot))
635 (initfunction (slot-definition-initfunction slot))
636 (location (unless (eq type 'structure)
637 (slot-definition-location slot)))
638 (pv-offset (1+ (position name slot-names)))
639 (forms (cond ((null initfunction)
641 ((constantp initform)
642 (let ((value (funcall initfunction)))
643 (if (and simple-p (integerp location))
644 (progn (setf (nth location constants) value)
647 (instance-set ,pv-offset ,slot)))))
649 `((funcall ,(slot-definition-initfunction slot))
650 (instance-set ,pv-offset ,slot))))))
651 (add-forms `(,@(unless (or simple-p (null forms))
652 `((skip-when-instance-boundp ,pv-offset ,slot
655 initialize-form-list)))))
656 (values (car initialize-form-list) constants)))
658 (defvar *class-pv-table-table* (make-hash-table :test 'eq))
660 (defun get-pv-cell-for-class (class)
661 (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
662 (slot-name-lists (list (cons nil slot-names)))
663 (pv-table (gethash class *class-pv-table-table*)))
664 (unless (and pv-table
665 (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
666 (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
667 (setf (gethash class *class-pv-table-table*) pv-table))
668 (pv-table-lookup pv-table (class-wrapper class))))
670 (defvar *initialize-instance-simple-alist* nil)
671 (defvar *note-iis-entry-p* nil)
673 (defvar *compiled-initialize-instance-simple-functions*
674 (make-hash-table :test 'equal))
676 (defun initialize-instance-simple-function (use info class form-list)
677 (let* ((pv-cell (get-pv-cell-for-class class))
678 (key (initialize-info-key info))
679 (sf-key (list* use (class-name (car key)) (cdr key))))
680 (if (or *compile-make-instance-functions-p*
681 (gethash sf-key *compiled-initialize-instance-simple-functions*))
682 (multiple-value-bind (form args)
683 (form-list-to-lisp pv-cell form-list)
684 (let ((entry (assoc form *initialize-instance-simple-alist*
686 (setf (gethash sf-key
687 *compiled-initialize-instance-simple-functions*)
690 (setf (cdddr entry) (union (list sf-key) (cdddr entry)
693 (setq entry (list* form nil nil (list sf-key)))
694 (setq *initialize-instance-simple-alist*
695 (nconc *initialize-instance-simple-alist*
697 (unless (or *note-iis-entry-p* (cadr entry))
698 (setf (cadr entry) (compile-lambda (car entry))))
700 (apply (the function (cadr entry)) args)
701 `(call-initialize-instance-simple ,pv-cell ,form-list))))
703 #'(lambda (instance initargs)
704 (initialize-instance-simple pv-cell form-list instance initargs))
706 `(call-initialize-instance-simple ,pv-cell ,form-list))))
708 (defun load-precompiled-iis-entry (form function system uses)
709 (let ((entry (assoc form *initialize-instance-simple-alist*
712 (setq entry (list* form nil nil nil))
713 (setq *initialize-instance-simple-alist*
714 (nconc *initialize-instance-simple-alist*
716 (setf (cadr entry) function)
717 (setf (caddr entry) system)
719 (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
720 (setf (cdddr entry) (union uses (cdddr entry)
723 (defmacro precompile-iis-functions (&optional system)
726 ,@(gathering1 (collecting)
727 (dolist (iis-entry *initialize-instance-simple-alist*)
728 (when (or (null (caddr iis-entry))
729 (eq (caddr iis-entry) system))
730 (when system (setf (caddr iis-entry) system))
733 `(precompile-initialize-instance-simple ,system ,(incf index))
735 `(load-precompiled-iis-entry
739 ',(cdddr iis-entry))))))))))
741 (defun compile-iis-functions (after-p)
742 (let ((*compile-make-instance-functions-p* t)
743 (*revert-initialize-info-p* t)
744 (*note-iis-entry-p* (not after-p)))
745 (declare (special *compile-make-instance-functions-p*))
746 (when (eq *boot-state* 'complete)
747 (update-make-instance-function-table))))
751 ;(push-initarg const)
752 ;(pop-supplied count) ; a positive odd number
753 ;(instance-set pv-offset slotd)
754 ;(skip-when-instance-boundp pv-offset slotd n)
756 (defun initialize-instance-simple (pv-cell form-list instance initargs)
757 (let ((pv (car pv-cell))
758 (initargs-tail initargs)
759 (slots (get-slots-or-nil instance))
760 (class (class-of instance))
762 (loop (when (null form-list) (return nil))
763 (let ((form (pop form-list)))
766 (push value initargs)
767 (push (cadr form) initargs))
769 (setq value (cadr form)))
771 (setq value (funcall (the function (cadr form)))))
773 (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
774 (setq value (pop initargs-tail)))
776 (instance-write-internal
777 pv slots (cadr form) value
778 (setf (slot-value-using-class class instance (caddr form))
780 (skip-when-instance-boundp
781 (when (instance-boundp-internal
783 (slot-boundp-using-class class instance (caddr form)))
784 (dotimes-fixnum (i (cadddr form))
786 (update-initialize-info-cache
787 (when (consp initargs)
788 (setq initargs (cons (car initargs) (cdr initargs))))
789 (setq *initialize-info-cache-class* (cadr form))
790 (setq *initialize-info-cache-initargs* initargs)
791 (setq *initialize-info-cache-info* (caddr form)))
792 (finish-pushing-initargs
793 (setq initargs-tail initargs)))))
796 (defun add-to-cvector (cvector constant)
797 (or (position constant cvector)
798 (prog1 (fill-pointer cvector)
799 (vector-push-extend constant cvector))))
801 (defvar *inline-iis-instance-locations-p* t)
803 (defun first-form-to-lisp (forms cvector pv)
804 (flet ((const (constant)
805 (cond ((or (numberp constant) (characterp constant))
807 ((and (symbolp constant) (symbol-package constant))
810 `(svref cvector ,(add-to-cvector cvector constant))))))
811 (let ((form (pop (car forms))))
814 `((push value initargs)
815 (push ,(const (cadr form)) initargs)))
817 `((setq value ,(const (cadr form)))))
819 `((setq value (funcall (the function ,(const (cadr form)))))))
821 `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
827 (setq value (pop initargs-tail))))
829 (let* ((pv-offset (cadr form))
830 (location (pvref pv pv-offset))
831 (default `(setf (slot-value-using-class class instance
832 ,(const (caddr form)))
834 (if *inline-iis-instance-locations-p*
836 (fixnum `((setf (%instance-ref slots ,(const location)) value)))
837 (cons `((setf (cdr ,(const location)) value)))
839 `((instance-write-internal pv slots ,(const pv-offset) value
845 (skip-when-instance-boundp
846 (let* ((pv-offset (cadr form))
847 (location (pvref pv pv-offset))
848 (default `(slot-boundp-using-class class instance
849 ,(const (caddr form)))))
850 `((unless ,(if *inline-iis-instance-locations-p*
852 (fixnum `(not (eq (%instance-ref slots ,(const location))
854 (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
856 `(instance-boundp-internal pv slots ,(const pv-offset)
858 ,(typecase (pvref pv pv-offset)
862 ,@(let ((sforms (cons nil nil)))
863 (dotimes-fixnum (i (cadddr form) (car sforms))
864 (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
865 (update-initialize-info-cache
866 `((when (consp initargs)
867 (setq initargs (cons (car initargs) (cdr initargs))))
868 (setq *initialize-info-cache-class* ,(const (cadr form)))
869 (setq *initialize-info-cache-initargs* initargs)
870 (setq *initialize-info-cache-info* ,(const (caddr form)))))
871 (finish-pushing-initargs
872 `((setq initargs-tail initargs)))))))
874 (defmacro iis-body (&body forms)
875 `(let ((initargs-tail initargs)
876 (slots (get-slots-or-nil instance))
877 (class (class-of instance))
880 initargs instance initargs-tail pv cvector slots class value
883 (defun form-list-to-lisp (pv-cell form-list)
884 (let* ((forms (list form-list))
885 (cvector (make-array (floor (length form-list) 2)
886 :fill-pointer 0 :adjustable t))
888 (body (let ((rforms (cons nil nil)))
889 (loop (when (null (car forms)) (return (car rforms)))
890 (add-forms (first-form-to-lisp forms cvector pv)
892 (cvector-type `(simple-vector ,(length cvector))))
894 `(lambda (pv-cell cvector)
895 (declare (type ,cvector-type cvector))
896 #'(lambda (instance initargs)
897 (declare #.*optimize-speed*)
900 (list pv-cell (coerce cvector cvector-type)))))
902 ;;; The effect of this is to cause almost all of the overhead of MAKE-INSTANCE
903 ;;; to happen at load time (or maybe at precompile time, as explained in a
904 ;;; previous message) rather than the first time that MAKE-INSTANCE is called
905 ;;; with a given class-name and sequence of keywords.
907 ;;; This optimization applies only when the first argument and all the even
908 ;;; numbered arguments are constants evaluating to interned symbols.
910 (declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
912 (define-compiler-macro make-instance (&whole form &rest args)
913 (declare (ignore args))
914 (let* ((*make-instance-function-keys* nil)
915 (expanded-form (expand-make-instance-form form)))
917 `(funcall (symbol-function
918 ;; The symbol is guaranteed to be fbound.
919 ;; Is there a way to declare this?
921 (get-make-instance-function-symbol
922 ',(first *make-instance-function-keys*))))
923 ,@(cdr expanded-form))
926 (defun get-make-instance-function-symbol (key)
927 (get-make-instance-functions (list key))
928 (make-instance-function-symbol key))