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
28 (defvar *compile-make-instance-functions-p* nil)
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)))
36 (defun constant-symbol-p (form)
38 (let ((object (eval form)))
40 (symbol-package object)))))
42 (defvar *make-instance-function-keys* nil)
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))
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))
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*)
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-fun-name sym)
75 `(,sym ',class (list ,@initargs)))))))
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)))
81 ,@(when *make-instance-function-keys*
82 `((get-make-instance-functions ',*make-instance-function-keys*)))
85 (defmacro expanding-make-instance (&rest forms &environment env)
87 ,@(mapcar (lambda (form)
89 (lambda (subform context env)
90 (declare (ignore env))
91 (or (and (eq context :eval)
93 (eq (car subform) 'make-instance)
94 (expand-make-instance-form subform))
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
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)))))))
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)))
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*)
128 (*print-case* :upcase)
129 (*print-pretty* nil))
131 "MAKE-INSTANCE ~S ~S ~S"
134 allow-other-keys-p))))))))
136 (defun make-instance-1 (class initargs)
137 (apply #'make-instance class initargs))
139 (defmacro define-cached-reader (type name trap)
140 (let ((reader-name (intern (format nil "~A-~A" type name)))
141 (cached-name (intern (format nil "~A-CACHED-~A" type name))))
142 `(defmacro ,reader-name (info)
143 `(let ((value (,',cached-name ,info)))
144 (if (eq value :unknown)
146 (,',trap ,info ',',name)
147 (,',cached-name ,info))
150 (eval-when (:compile-toplevel :load-toplevel :execute)
151 (defparameter *initialize-info-cached-slots*
152 '(valid-p ; t or (:invalid key)
156 default-initargs-function
157 shared-initialize-t-fun
158 shared-initialize-nil-fun
160 combined-initialize-function ; allocate-instance + shared-initialize
161 make-instance-function ; nil means use gf
162 make-instance-function-symbol)))
164 (defmacro define-initialize-info ()
165 (let ((cached-slot-names
166 (mapcar (lambda (name)
167 (intern (format nil "CACHED-~A" name)))
168 *initialize-info-cached-slots*))
170 (mapcar (lambda (name)
171 (intern (format nil "~A-CACHED-~A"
172 'initialize-info name)))
173 *initialize-info-cached-slots*)))
175 (defstruct (initialize-info (:copier nil))
177 ,@(mapcar (lambda (name)
180 (defmacro reset-initialize-info-internal (info)
182 ,@(mapcar (lambda (cname)
183 `(setf (,cname ,info) :unknown))
185 (defun initialize-info-bound-slots (info)
187 ,@(mapcar (lambda (name cached-name)
188 `(unless (eq :unknown (,cached-name info))
189 (push ',name slots)))
190 *initialize-info-cached-slots* cached-names)
192 ,@(mapcar (lambda (name)
193 `(define-cached-reader initialize-info ,name
194 update-initialize-info-internal))
195 *initialize-info-cached-slots*))))
197 (define-initialize-info)
199 (defvar *initialize-info-cache-class* nil)
200 (defvar *initialize-info-cache-initargs* nil)
201 (defvar *initialize-info-cache-info* nil)
203 (defvar *revert-initialize-info-p* nil)
205 (defun reset-initialize-info (info)
206 (setf (initialize-info-wrapper info)
207 (class-wrapper (car (initialize-info-key info))))
208 (let ((slots-to-revert (if *revert-initialize-info-p*
209 (initialize-info-bound-slots info)
210 '(make-instance-function))))
211 (reset-initialize-info-internal info)
212 (dolist (slot slots-to-revert)
213 (update-initialize-info-internal info slot))
216 (defun reset-class-initialize-info (class)
217 (reset-class-initialize-info-1 (class-initialize-info class)))
219 (defun reset-class-initialize-info-1 (cell)
222 (reset-initialize-info (car cell)))
223 (let ((alist (cdr cell)))
225 (reset-class-initialize-info-1 (cdr a))))))
227 (defun initialize-info (class
231 allow-other-keys-arg)
233 (if (and (eq *initialize-info-cache-class* class)
234 (eq *initialize-info-cache-initargs* initargs))
235 (setq info *initialize-info-cache-info*)
236 (let ((initargs-tail initargs)
237 (cell (or (class-initialize-info class)
238 (setf (class-initialize-info class) (cons nil nil)))))
239 (loop (when (null initargs-tail) (return nil))
240 (let ((keyword (pop initargs-tail))
243 (if (eq keyword :allow-other-keys)
244 (setq allow-other-keys-arg (pop initargs-tail))
245 (pop initargs-tail)))
246 (loop (let ((alist (cdr alist-cell)))
248 (setq cell (cons nil nil))
249 (setf (cdr alist-cell) (list (cons keyword cell)))
251 (when (eql keyword (caar alist))
252 (setq cell (cdar alist))
254 (setq alist-cell alist)))))
255 (setq info (or (car cell)
256 (setf (car cell) (make-initialize-info))))))
257 (let ((wrapper (initialize-info-wrapper info)))
258 (unless (eq wrapper (class-wrapper class))
260 (let* ((initargs-tail initargs)
261 (klist-cell (list nil))
262 (klist-tail klist-cell))
263 (loop (when (null initargs-tail) (return nil))
264 (let ((key (pop initargs-tail)))
265 (setf (cdr klist-tail) (list key)))
266 (setf klist-tail (cdr klist-tail))
267 (when plist-p (pop initargs-tail)))
268 (setf (initialize-info-key info)
269 (list class (cdr klist-cell) allow-other-keys-arg))))
270 (reset-initialize-info info)))
271 (setq *initialize-info-cache-class* class)
272 (setq *initialize-info-cache-initargs* initargs)
273 (setq *initialize-info-cache-info* info)
276 (defun update-initialize-info-internal (info name)
277 (let* ((key (initialize-info-key info))
280 (allow-other-keys-arg (caddr key)))
282 ((initargs-form-list new-keys)
283 (multiple-value-bind (initargs-form-list new-keys)
284 (make-default-initargs-form-list class keys)
285 (setf (initialize-info-cached-initargs-form-list info)
287 (setf (initialize-info-cached-new-keys info) new-keys)))
288 ((default-initargs-function)
289 (let ((initargs-form-list (initialize-info-initargs-form-list info)))
290 (setf (initialize-info-cached-default-initargs-function info)
291 (initialize-instance-simple-fun
292 'default-initargs-function info
293 class initargs-form-list))))
294 ((valid-p ri-valid-p)
295 (flet ((compute-valid-p (methods)
296 (or (not (null allow-other-keys-arg))
297 (multiple-value-bind (legal allow-other-keys)
298 (check-initargs-values class methods)
299 (or (not (null allow-other-keys))
301 (unless (member key legal)
302 (return (cons :invalid key)))))))))
303 (let ((proto (class-prototype class)))
304 (setf (initialize-info-cached-valid-p info)
306 (list (list* 'allocate-instance class nil)
307 (list* 'initialize-instance proto nil)
308 (list* 'shared-initialize proto t nil))))
309 (setf (initialize-info-cached-ri-valid-p info)
311 (list (list* 'reinitialize-instance proto nil)
312 (list* 'shared-initialize proto nil nil)))))))
313 ((shared-initialize-t-fun)
314 (multiple-value-bind (initialize-form-list ignore)
315 (make-shared-initialize-form-list class keys t nil)
316 (declare (ignore ignore))
317 (setf (initialize-info-cached-shared-initialize-t-fun info)
318 (initialize-instance-simple-fun
319 'shared-initialize-t-fun info
320 class initialize-form-list))))
321 ((shared-initialize-nil-fun)
322 (multiple-value-bind (initialize-form-list ignore)
323 (make-shared-initialize-form-list class keys nil nil)
324 (declare (ignore ignore))
325 (setf (initialize-info-cached-shared-initialize-nil-fun info)
326 (initialize-instance-simple-fun
327 'shared-initialize-nil-fun info
328 class initialize-form-list))))
329 ((constants combined-initialize-function)
330 (let ((initargs-form-list (initialize-info-initargs-form-list info))
331 (new-keys (initialize-info-new-keys info)))
332 (multiple-value-bind (initialize-form-list constants)
333 (make-shared-initialize-form-list class new-keys t t)
334 (setf (initialize-info-cached-constants info) constants)
335 (setf (initialize-info-cached-combined-initialize-function info)
336 (initialize-instance-simple-fun
337 'combined-initialize-function info
338 class (append initargs-form-list initialize-form-list))))))
339 ((make-instance-function-symbol)
340 (setf (initialize-info-cached-make-instance-function-symbol info)
341 (make-instance-function-symbol key)))
342 ((make-instance-function)
343 (let* ((function (get-make-instance-function key))
344 (symbol (initialize-info-make-instance-function-symbol info)))
345 (setf (initialize-info-cached-make-instance-function info) function)
346 (when symbol (setf (gdefinition symbol)
347 (or function #'make-instance-1)))))))
350 (defun get-make-instance-function (key)
351 (let* ((class (car key))
353 (unless (eq *boot-state* 'complete)
354 (return-from get-make-instance-function nil))
355 (when (symbolp class)
356 (setq class (find-class class)))
358 (unless (class-finalized-p class) (finalize-inheritance class)))
359 (let* ((initargs (mapcan (lambda (key) (list key nil)) keys))
360 (class-and-initargs (list* class initargs))
361 (make-instance (gdefinition 'make-instance))
362 (make-instance-methods
363 (compute-applicable-methods make-instance class-and-initargs))
364 (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
365 (class+initargs (list class initargs))
366 (default-initargs (gdefinition 'default-initargs))
367 (default-initargs-methods
368 (compute-applicable-methods default-initargs class+initargs))
369 (proto (and (classp class) (class-prototype class)))
370 (initialize-instance-methods
372 (compute-applicable-methods (gdefinition 'initialize-instance)
373 (list* proto initargs))))
374 (shared-initialize-methods
376 (compute-applicable-methods (gdefinition 'shared-initialize)
377 (list* proto t initargs)))))
378 (when (null make-instance-methods)
379 (return-from get-make-instance-function
380 (lambda (class initargs)
381 (apply #'no-applicable-method make-instance class initargs))))
382 (unless (and (null (cdr make-instance-methods))
383 (eq (car make-instance-methods) std-mi-meth)
384 (null (cdr default-initargs-methods))
385 (eq (car (method-specializers
386 (car default-initargs-methods)))
387 *the-class-slot-class*)
388 (flet ((check-meth (meth)
389 (let ((quals (method-qualifiers meth)))
391 (eq (car (method-specializers meth))
392 *the-class-slot-object*)
393 (and (null (cdr quals))
394 (or (eq (car quals) :before)
395 (eq (car quals) :after)))))))
396 (and (every #'check-meth initialize-instance-methods)
397 (every #'check-meth shared-initialize-methods))))
398 (return-from get-make-instance-function nil))
399 (get-make-instance-function-internal
400 class key (default-initargs class initargs)
401 initialize-instance-methods shared-initialize-methods))))
403 (defun get-make-instance-function-internal (class key initargs
404 initialize-instance-methods
405 shared-initialize-methods)
406 (let* ((keys (cadr key))
407 (allow-other-keys-p (caddr key))
408 (allocate-instance-methods
409 (compute-applicable-methods (gdefinition 'allocate-instance)
410 (list* class initargs))))
411 (unless allow-other-keys-p
412 (unless (check-initargs-1
414 (append allocate-instance-methods
415 initialize-instance-methods
416 shared-initialize-methods)
418 (return-from get-make-instance-function-internal nil)))
419 (if (or (cdr allocate-instance-methods)
420 (some #'complicated-instance-creation-method
421 initialize-instance-methods)
422 (some #'complicated-instance-creation-method
423 shared-initialize-methods))
424 (make-instance-function-complex
426 initialize-instance-methods shared-initialize-methods)
427 (make-instance-function-simple
429 initialize-instance-methods shared-initialize-methods))))
431 (defun complicated-instance-creation-method (m)
432 (let ((qual (method-qualifiers m)))
434 (not (and (null (cdr qual)) (eq (car qual) :after)))
435 (let ((specl (car (method-specializers m))))
436 (or (not (classp specl))
437 (not (eq 'slot-object (class-name specl))))))))
439 (defun find-standard-ii-method (methods class-names)
441 (when (null (method-qualifiers m))
442 (let ((specl (car (method-specializers m))))
443 (when (and (classp specl)
444 (if (listp class-names)
445 (member (class-name specl) class-names)
446 (eq (class-name specl) class-names)))
449 (defmacro call-initialize-function (initialize-function instance initargs)
450 `(let ((.function. ,initialize-function))
451 (if (and (consp .function.)
452 (eq (car .function.) 'call-initialize-instance-simple))
453 (initialize-instance-simple (cadr .function.) (caddr .function.)
455 (funcall (the function .function.) ,instance ,initargs))))
457 (defun make-instance-function-simple (key class keys
458 initialize-instance-methods
459 shared-initialize-methods)
460 (multiple-value-bind (initialize-function constants)
461 (get-simple-initialization-function class keys (caddr key))
462 (let* ((wrapper (class-wrapper class))
463 (lwrapper (list wrapper))
465 (cond ((structure-class-p class)
466 #'allocate-structure-instance)
467 ((standard-class-p class)
468 #'allocate-standard-instance)
469 ((funcallable-standard-class-p class)
470 #'allocate-funcallable-instance)
472 (error "error in make-instance-function-simple"))))
473 (std-si-meth (find-standard-ii-method shared-initialize-methods
476 (nreverse (mapcar (lambda (method)
477 (make-effective-method-function
479 `(call-method ,method nil)
481 (remove std-si-meth shared-initialize-methods))))
482 (std-ii-meth (find-standard-ii-method initialize-instance-methods
485 (nreverse (mapcar (lambda (method)
486 (make-effective-method-function
487 #'initialize-instance
488 `(call-method ,method nil)
491 initialize-instance-methods)))))
492 (lambda (class1 initargs)
493 (if (not (eq wrapper (class-wrapper class)))
494 (let* ((info (initialize-info (coerce-to-class class1) initargs))
495 (fn (initialize-info-make-instance-function info)))
496 (declare (type function fn))
497 (funcall fn class1 initargs))
498 (let* ((instance (funcall allocate-function wrapper constants))
499 (initargs (call-initialize-function initialize-function
501 (dolist (fn shared-initfns)
502 (invoke-effective-method-function fn t instance t initargs))
503 (dolist (fn initialize-initfns)
504 (invoke-effective-method-function fn t instance initargs))
507 (defun make-instance-function-complex (key class keys
508 initialize-instance-methods
509 shared-initialize-methods)
510 (multiple-value-bind (initargs-function initialize-function)
511 (get-complex-initialization-functions class keys (caddr key))
512 (let* ((wrapper (class-wrapper class))
514 (get-secondary-dispatch-function
515 #'shared-initialize shared-initialize-methods
516 `((class-eq ,class) t t)
517 `((,(find-standard-ii-method shared-initialize-methods
519 ,(lambda (instance init-type &rest initargs)
520 (declare (ignore init-type))
521 (call-initialize-function initialize-function
524 (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
526 (get-secondary-dispatch-function
527 #'initialize-instance initialize-instance-methods
528 `((class-eq ,class) t)
529 `((,(find-standard-ii-method initialize-instance-methods
531 ,(lambda (instance &rest initargs)
532 (invoke-effective-method-function
533 shared-initialize t instance t initargs))))
534 (list wrapper *the-wrapper-of-t*))))
535 (lambda (class1 initargs)
536 (if (not (eq wrapper (class-wrapper class)))
537 (let* ((info (initialize-info (coerce-to-class class1) initargs))
538 (fn (initialize-info-make-instance-function info)))
539 (declare (type function fn))
540 (funcall fn class1 initargs))
541 (let* ((initargs (call-initialize-function initargs-function
543 (instance (apply #'allocate-instance class initargs)))
544 (invoke-effective-method-function
545 initialize-instance t instance initargs)
548 (defun get-simple-initialization-function (class
550 &optional allow-other-keys-arg)
551 (let ((info (initialize-info class keys nil allow-other-keys-arg)))
552 (values (initialize-info-combined-initialize-function info)
553 (initialize-info-constants info))))
555 (defun get-complex-initialization-functions (class
560 (let* ((info (initialize-info class keys nil allow-other-keys-arg))
561 (default-initargs-function (initialize-info-default-initargs-function
564 (values default-initargs-function
565 (initialize-info-shared-initialize-t-fun info))
566 (values default-initargs-function
567 (initialize-info-shared-initialize-t-fun
568 (initialize-info class (initialize-info-new-keys info)
569 nil allow-other-keys-arg))))))
571 (defun add-forms (forms forms-list)
573 (setq forms (copy-list forms))
574 (if (null (car forms-list))
575 (setf (car forms-list) forms)
576 (setf (cddr forms-list) forms))
577 (setf (cdr forms-list) (last forms)))
580 (defun make-default-initargs-form-list (class keys &optional (separate-p t))
581 (let ((initargs-form-list (cons nil nil))
582 (default-initargs (class-default-initargs class))
585 (mapcan (lambda (slot)
586 (mapcar (lambda (arg)
588 (slot-definition-initargs slot)))
589 (class-slots class)))
592 (pushnew (cdr (assoc key slots-alist)) nslots))
593 (dolist (default default-initargs)
594 (let* ((key (car default))
595 (slot (cdr (assoc key slots-alist)))
596 (function (cadr default)))
597 (unless (member slot nslots)
598 (add-forms `((funcall ,function) (push-initarg ,key))
601 (push slot nslots))))
603 (add-forms `((update-initialize-info-cache
604 ,class ,(initialize-info class nkeys nil)))
606 (add-forms `((finish-pushing-initargs))
608 (values (car initargs-form-list) nkeys)))
610 (defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
611 (let* ((initialize-form-list (cons nil nil))
612 (type (cond ((structure-class-p class)
614 ((standard-class-p class)
616 ((funcallable-standard-class-p class)
618 (t (error "error in make-shared-initialize-form-list"))))
619 (wrapper (class-wrapper class))
620 (constants (when simple-p
621 (make-list (wrapper-no-of-instance-slots wrapper)
622 :initial-element +slot-unbound+)))
623 (slots (class-slots class))
624 (slot-names (mapcar #'slot-definition-name slots))
625 (slots-key (mapcar (lambda (slot)
626 (let ((index most-positive-fixnum))
627 (dolist (key (slot-definition-initargs slot))
628 (let ((pos (position key keys)))
629 (when pos (setq index (min index pos)))))
632 (slots (stable-sort slots-key #'< :key #'cdr)))
634 (dolist (slot+index slots)
635 (let* ((slot (car slot+index))
636 (name (slot-definition-name slot))
637 (npop (1+ (- (cdr slot+index) n-popped))))
638 (unless (eql (cdr slot+index) most-positive-fixnum)
639 (let* ((pv-offset (1+ (position name slot-names))))
640 (add-forms `(,@(when (plusp npop)
641 `((pop-initargs ,(* 2 npop))))
642 (instance-set ,pv-offset ,slot))
643 initialize-form-list))
644 (incf n-popped npop)))))
645 (dolist (slot+index slots)
646 (let* ((slot (car slot+index))
647 (name (slot-definition-name slot)))
648 (when (and (eql (cdr slot+index) most-positive-fixnum)
649 (or (eq si-slot-names t)
650 (member name si-slot-names)))
651 (let* ((initform (slot-definition-initform slot))
652 (initfunction (slot-definition-initfunction slot))
653 (location (unless (eq type 'structure)
654 (slot-definition-location slot)))
655 (pv-offset (1+ (position name slot-names)))
656 (forms (cond ((null initfunction)
658 ((constantp initform)
659 (let ((value (funcall initfunction)))
660 (if (and simple-p (integerp location))
661 (progn (setf (nth location constants)
665 (instance-set ,pv-offset ,slot)))))
667 `((funcall ,(slot-definition-initfunction slot))
668 (instance-set ,pv-offset ,slot))))))
669 (add-forms `(,@(unless (or simple-p (null forms))
670 `((skip-when-instance-boundp ,pv-offset ,slot
673 initialize-form-list)))))
674 (values (car initialize-form-list) constants)))
676 (defvar *class-pv-table-table* (make-hash-table :test 'eq))
678 (defun get-pv-cell-for-class (class)
679 (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
680 (slot-name-lists (list (cons nil slot-names)))
681 (pv-table (gethash class *class-pv-table-table*)))
682 (unless (and pv-table
683 (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
684 (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
685 (setf (gethash class *class-pv-table-table*) pv-table))
686 (pv-table-lookup pv-table (class-wrapper class))))
688 (defvar *initialize-instance-simple-alist* nil)
689 (defvar *note-iis-entry-p* nil)
691 (defvar *compiled-initialize-instance-simple-funs*
692 (make-hash-table :test 'equal))
694 (defun initialize-instance-simple-fun (use info class form-list)
695 (let* ((pv-cell (get-pv-cell-for-class class))
696 (key (initialize-info-key info))
697 (sf-key (list* use (class-name (car key)) (cdr key))))
698 (if (or *compile-make-instance-functions-p*
699 (gethash sf-key *compiled-initialize-instance-simple-funs*))
700 (multiple-value-bind (form args)
701 (form-list-to-lisp pv-cell form-list)
702 (let ((entry (assoc form *initialize-instance-simple-alist*
704 (setf (gethash sf-key
705 *compiled-initialize-instance-simple-funs*)
708 (setf (cdddr entry) (union (list sf-key) (cdddr entry)
711 (setq entry (list* form nil nil (list sf-key)))
712 (setq *initialize-instance-simple-alist*
713 (nconc *initialize-instance-simple-alist*
715 (unless (or *note-iis-entry-p* (cadr entry))
716 (setf (cadr entry) (compile nil (car entry))))
718 (apply (the function (cadr entry)) args)
719 `(call-initialize-instance-simple ,pv-cell ,form-list))))
721 (lambda (instance initargs)
722 (initialize-instance-simple pv-cell form-list instance initargs))
724 `(call-initialize-instance-simple ,pv-cell ,form-list))))
726 (defun load-precompiled-iis-entry (form function system uses)
727 (let ((entry (assoc form *initialize-instance-simple-alist*
730 (setq entry (list* form nil nil nil))
731 (setq *initialize-instance-simple-alist*
732 (nconc *initialize-instance-simple-alist*
734 (setf (cadr entry) function)
735 (setf (caddr entry) system)
737 (setf (gethash use *compiled-initialize-instance-simple-funs*) t))
738 (setf (cdddr entry) (union uses (cdddr entry)
741 (defmacro precompile-iis-functions (&optional system)
744 (dolist (iis-entry *initialize-instance-simple-alist*)
745 (when (or (null (caddr iis-entry))
746 (eq (caddr iis-entry) system))
747 (when system (setf (caddr iis-entry) system))
748 (push `(load-precompiled-iis-entry
754 (nreverse collect))))
756 (defun compile-iis-functions (after-p)
757 (let ((*compile-make-instance-functions-p* t)
758 (*revert-initialize-info-p* t)
759 (*note-iis-entry-p* (not after-p)))
760 (declare (special *compile-make-instance-functions-p*))
761 (when (eq *boot-state* 'complete)
762 (update-make-instance-function-table))))
766 ;(push-initarg const)
767 ;(pop-supplied count) ; a positive odd number
768 ;(instance-set pv-offset slotd)
769 ;(skip-when-instance-boundp pv-offset slotd n)
771 (defun initialize-instance-simple (pv-cell form-list instance initargs)
772 (let ((pv (car pv-cell))
773 (initargs-tail initargs)
774 (slots (get-slots-or-nil instance))
775 (class (class-of instance))
777 (loop (when (null form-list) (return nil))
778 (let ((form (pop form-list)))
781 (push value initargs)
782 (push (cadr form) initargs))
784 (setq value (cadr form)))
786 (setq value (funcall (the function (cadr form)))))
788 (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
789 (setq value (pop initargs-tail)))
791 (instance-write-internal
792 pv slots (cadr form) value
793 (setf (slot-value-using-class class instance (caddr form))
795 (skip-when-instance-boundp
796 (when (instance-boundp-internal
798 (slot-boundp-using-class class instance (caddr form)))
799 (dotimes-fixnum (i (cadddr form))
801 (update-initialize-info-cache
802 (when (consp initargs)
803 (setq initargs (cons (car initargs) (cdr initargs))))
804 (setq *initialize-info-cache-class* (cadr form))
805 (setq *initialize-info-cache-initargs* initargs)
806 (setq *initialize-info-cache-info* (caddr form)))
807 (finish-pushing-initargs
808 (setq initargs-tail initargs)))))
811 (defun add-to-cvector (cvector constant)
812 (or (position constant cvector)
813 (prog1 (fill-pointer cvector)
814 (vector-push-extend constant cvector))))
816 (defvar *inline-iis-instance-locations-p* t)
818 (defun first-form-to-lisp (forms cvector pv)
819 (flet ((const (constant)
820 (cond ((or (numberp constant) (characterp constant))
822 ((and (symbolp constant) (symbol-package constant))
825 `(svref cvector ,(add-to-cvector cvector constant))))))
826 (let ((form (pop (car forms))))
829 `((push value initargs)
830 (push ,(const (cadr form)) initargs)))
832 `((setq value ,(const (cadr form)))))
834 `((setq value (funcall (the function ,(const (cadr form)))))))
836 `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
842 (setq value (pop initargs-tail))))
844 (let* ((pv-offset (cadr form))
845 (location (pvref pv pv-offset))
846 (default `(setf (slot-value-using-class class instance
847 ,(const (caddr form)))
849 (if *inline-iis-instance-locations-p*
852 (setf (clos-slots-ref slots ,(const location))
854 (cons `((setf (cdr ,(const location)) value)))
856 `((instance-write-internal pv slots ,(const pv-offset) value
862 (skip-when-instance-boundp
863 (let* ((pv-offset (cadr form))
864 (location (pvref pv pv-offset))
865 (default `(slot-boundp-using-class class instance
866 ,(const (caddr form)))))
867 `((unless ,(if *inline-iis-instance-locations-p*
869 (fixnum `(not (and slots
874 (cons `(not (eq (cdr ,(const location))
877 `(instance-boundp-internal
878 pv slots ,(const pv-offset)
880 ,(typecase (pvref pv pv-offset)
884 ,@(let ((sforms (cons nil nil)))
885 (dotimes-fixnum (i (cadddr form) (car sforms))
886 (add-forms (first-form-to-lisp forms cvector pv)
888 (update-initialize-info-cache
889 `((when (consp initargs)
890 (setq initargs (cons (car initargs) (cdr initargs))))
891 (setq *initialize-info-cache-class* ,(const (cadr form)))
892 (setq *initialize-info-cache-initargs* initargs)
893 (setq *initialize-info-cache-info* ,(const (caddr form)))))
894 (finish-pushing-initargs
895 `((setq initargs-tail initargs)))))))
897 (defmacro iis-body (&body forms)
898 `(let ((initargs-tail initargs)
899 (slots (get-slots-or-nil instance))
900 (class (class-of instance))
903 initargs instance initargs-tail pv cvector slots class value
906 (defun form-list-to-lisp (pv-cell form-list)
907 (let* ((forms (list form-list))
908 (cvector (make-array (floor (length form-list) 2)
909 :fill-pointer 0 :adjustable t))
911 (body (let ((rforms (cons nil nil)))
912 (loop (when (null (car forms)) (return (car rforms)))
913 (add-forms (first-form-to-lisp forms cvector pv)
915 (cvector-type `(simple-vector ,(length cvector))))
917 `(lambda (pv-cell cvector)
918 (declare (type ,cvector-type cvector))
919 (lambda (instance initargs)
920 (declare #.*optimize-speed*)
923 (list pv-cell (coerce cvector cvector-type)))))
925 ;;; The effect of this is to cause almost all of the overhead of
926 ;;; MAKE-INSTANCE to happen at load time (or maybe at precompile time,
927 ;;; as explained in a previous message) rather than the first time
928 ;;; that MAKE-INSTANCE is called with a given class-name and sequence
931 ;;; This optimization applies only when the first argument and all the
932 ;;; even numbered arguments are constants evaluating to interned
935 (declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
937 (define-compiler-macro make-instance (&whole form &rest args)
938 (declare (ignore args))
939 (let* ((*make-instance-function-keys* nil)
940 (expanded-form (expand-make-instance-form form)))
942 `(funcall (fdefinition
943 ;; The name is guaranteed to be fbound.
944 ;; Is there a way to declare this?
946 (get-make-instance-function-symbol
947 ',(first *make-instance-function-keys*))))
948 ,@(cdr expanded-form))
951 (defun get-make-instance-function-symbol (key)
952 (get-make-instance-functions (list key))
953 (make-instance-function-symbol key))