src/pcl/fast-init.lisp

   1 ;;;; This file defines the optimized make-instance functions.
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5
   6 ;;;; This software is derived from software originally released by Xerox
   7 ;;;; Corporation. Copyright and release statements follow. Later modifications
   8 ;;;; to the software are in the public domain and are provided with
   9 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
  10 ;;;; information.
  11
  12 ;;;; copyright information from original PCL sources:
  13 ;;;;
  14 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  15 ;;;; All rights reserved.
  16 ;;;;
  17 ;;;; Use and copying of this software and preparation of derivative works based
  18 ;;;; upon this software are permitted. Any distribution of this software or
  19 ;;;; derivative works must comply with all applicable United States export
  20 ;;;; control laws.
  21 ;;;;
  22 ;;;; This software is made available AS IS, and Xerox Corporation makes no
  23 ;;;; warranty about the software, its performance or its conformity to any
  24 ;;;; specification.
  25
  26 (in-package "SB-PCL")
  27 \f
  28 (defvar *compile-make-instance-functions-p* nil)
  29
  30 (defun update-make-instance-function-table (&optional (class *the-class-t*))
  31   (when (symbolp class) (setq class (find-class class)))
  32     (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
  33     (when (memq *the-class-slot-object* (class-precedence-list class))
  34       (map-all-classes #'reset-class-initialize-info class)))
  35
  36 (defun constant-symbol-p (form)
  37   (and (constantp form)
  38        (let ((object (eval form)))
  39          (and (symbolp object)
  40               (symbol-package object)))))
  41
  42 (defvar *make-instance-function-keys* nil)
  43
  44 (defun expand-make-instance-form (form)
  45   (let ((class (cadr form)) (initargs (cddr form))
  46         (keys nil)(allow-other-keys-p nil) key value)
  47     (when (and (constant-symbol-p class)
  48                (let ((initargs-tail initargs))
  49                  (loop (when (null initargs-tail) (return t))
  50                        (unless (constant-symbol-p (car initargs-tail))
  51                          (return nil))
  52                        (setq key (eval (pop initargs-tail)))
  53                        (setq value (pop initargs-tail))
  54                        (when (eq :allow-other-keys key)
  55                          (setq allow-other-keys-p value))
  56                        (push key keys))))
  57       (let* ((class (eval class))
  58              (keys (nreverse keys))
  59              (key (list class keys allow-other-keys-p))
  60              (sym (make-instance-function-symbol key)))
  61         (push key *make-instance-function-keys*)
  62         (when sym
  63           ;; (famous last words:
  64           ;;   1. Don't worry, I know what I'm doing.
  65           ;;   2. You and what army?
  66           ;;   3. If you were as smart as you think you are, you
  67           ;;      wouldn't be a copy.
  68           ;; This is case #1.:-) Even if SYM hasn't been defined yet,
  69           ;; it must be an implementation function, or we we wouldn't
  70           ;; have expanded into it. So declare SYM as defined, so that
  71           ;; even if it hasn't been defined yet, the user doesn't get
  72           ;; obscure warnings about undefined internal implementation
  73           ;; functions like HAIRY-MAKE-instance-name.
  74           (sb-kernel:become-defined-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 ~S ~S ~S"
 132                             class-name
 133                             keys
 134                             allow-other-keys-p))))))))
 135
 136 (defun make-instance-1 (class initargs)
 137   (apply #'make-instance class initargs))
 138
 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)
 145               (progn
 146                 (,',trap ,info ',',name)
 147                 (,',cached-name ,info))
 148               value)))))
 149
 150 (eval-when (:compile-toplevel :load-toplevel :execute)
 151 (defparameter *initialize-info-cached-slots*
 152   '(valid-p                             ; t or (:invalid key)
 153     ri-valid-p
 154     initargs-form-list
 155     new-keys
 156     default-initargs-function
 157     shared-initialize-t-fun
 158     shared-initialize-nil-fun
 159     constants
 160     combined-initialize-function ; allocate-instance + shared-initialize
 161     make-instance-function ; nil means use gf
 162     make-instance-function-symbol)))
 163
 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*))
 169         (cached-names
 170          (mapcar (lambda (name)
 171                    (intern (format nil "~A-CACHED-~A"
 172                                    'initialize-info name)))
 173                  *initialize-info-cached-slots*)))
 174     `(progn
 175        (defstruct (initialize-info (:copier nil))
 176          key wrapper
 177          ,@(mapcar (lambda (name)
 178                      `(,name :unknown))
 179                    cached-slot-names))
 180        (defmacro reset-initialize-info-internal (info)
 181          `(progn
 182             ,@(mapcar (lambda (cname)
 183                         `(setf (,cname ,info) :unknown))
 184                       ',cached-names)))
 185        (defun initialize-info-bound-slots (info)
 186          (let ((slots nil))
 187            ,@(mapcar (lambda (name cached-name)
 188                        `(unless (eq :unknown (,cached-name info))
 189                           (push ',name slots)))
 190                      *initialize-info-cached-slots* cached-names)
 191            slots))
 192       ,@(mapcar (lambda (name)
 193                   `(define-cached-reader initialize-info ,name
 194                      update-initialize-info-internal))
 195                 *initialize-info-cached-slots*))))
 196
 197 (define-initialize-info)
 198
 199 (defvar *initialize-info-cache-class* nil)
 200 (defvar *initialize-info-cache-initargs* nil)
 201 (defvar *initialize-info-cache-info* nil)
 202
 203 (defvar *revert-initialize-info-p* nil)
 204
 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))
 214     info))
 215
 216 (defun reset-class-initialize-info (class)
 217   (reset-class-initialize-info-1 (class-initialize-info class)))
 218
 219 (defun reset-class-initialize-info-1 (cell)
 220   (when (consp cell)
 221     (when (car cell)
 222       (reset-initialize-info (car cell)))
 223     (let ((alist (cdr cell)))
 224       (dolist (a alist)
 225         (reset-class-initialize-info-1 (cdr a))))))
 226
 227 (defun initialize-info (class
 228                         initargs
 229                         &optional
 230                         (plist-p t)
 231                         allow-other-keys-arg)
 232   (let ((info nil))
 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))
 241                       (alist-cell cell))
 242                   (when plist-p
 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)))
 247                           (when (null alist)
 248                             (setq cell (cons nil nil))
 249                             (setf (cdr alist-cell) (list (cons keyword cell)))
 250                             (return nil))
 251                           (when (eql keyword (caar alist))
 252                             (setq cell (cdar alist))
 253                             (return nil))
 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))
 259         (unless wrapper
 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)
 274     info))
 275
 276 (defun update-initialize-info-internal (info name)
 277   (let* ((key (initialize-info-key info))
 278          (class (car key))
 279          (keys (cadr key))
 280          (allow-other-keys-arg (caddr key)))
 281     (ecase name
 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)
 286                initargs-form-list)
 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))
 300                           (dolist (key keys t)
 301                             (unless (member key legal)
 302                               (return (cons :invalid key)))))))))
 303          (let ((proto (class-prototype class)))
 304            (setf (initialize-info-cached-valid-p info)
 305                  (compute-valid-p
 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)
 310                  (compute-valid-p
 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)))))))
 348   info)
 349
 350 (defun get-make-instance-function (key)
 351   (let* ((class (car key))
 352          (keys (cadr 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)))
 357     (when (classp 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
 371             (when proto
 372               (compute-applicable-methods (gdefinition 'initialize-instance)
 373                                           (list* proto initargs))))
 374            (shared-initialize-methods
 375             (when proto
 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)))
 390                               (if (null quals)
 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))))
 402
 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
 413                class initargs
 414                (append allocate-instance-methods
 415                        initialize-instance-methods
 416                        shared-initialize-methods)
 417                t nil)
 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
 425          key class keys
 426          initialize-instance-methods shared-initialize-methods)
 427         (make-instance-function-simple
 428          key class keys
 429          initialize-instance-methods shared-initialize-methods))))
 430
 431 (defun complicated-instance-creation-method (m)
 432   (let ((qual (method-qualifiers m)))
 433     (if qual
 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))))))))
 438
 439 (defun find-standard-ii-method (methods class-names)
 440   (dolist (m methods)
 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)))
 447           (return m))))))
 448
 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.)
 454                                      ,instance ,initargs)
 455          (funcall (the function .function.) ,instance ,initargs))))
 456
 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))
 464            (allocate-function
 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)
 471                   (t
 472                    (error "error in make-instance-function-simple"))))
 473            (std-si-meth (find-standard-ii-method shared-initialize-methods
 474                                                  'slot-object))
 475            (shared-initfns
 476             (nreverse (mapcar (lambda (method)
 477                                 (make-effective-method-function
 478                                  #'shared-initialize
 479                                  `(call-method ,method nil)
 480                                  nil lwrapper))
 481                               (remove std-si-meth shared-initialize-methods))))
 482            (std-ii-meth (find-standard-ii-method initialize-instance-methods
 483                                                  'slot-object))
 484            (initialize-initfns
 485             (nreverse (mapcar (lambda (method)
 486                                 (make-effective-method-function
 487                                  #'initialize-instance
 488                                  `(call-method ,method nil)
 489                                  nil lwrapper))
 490                               (remove std-ii-meth
 491                                       initialize-instance-methods)))))
 492       (lambda (class1 initargs)
 493         (if (not (eq wrapper (class-wrapper class)))
 494             (let* ((info (initialize-info 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
 500                                                        instance initargs)))
 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))
 505               instance))))))
 506
 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))
 513            (shared-initialize
 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
 518                                           'slot-object)
 519                 ,(lambda (instance init-type &rest initargs)
 520                    (declare (ignore init-type))
 521                    (call-initialize-function initialize-function
 522                                              instance initargs)
 523                    instance)))
 524              (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
 525            (initialize-instance
 526             (get-secondary-dispatch-function
 527              #'initialize-instance initialize-instance-methods
 528              `((class-eq ,class) t)
 529              `((,(find-standard-ii-method initialize-instance-methods
 530                                           'slot-object)
 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 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
 542                                                        nil initargs))
 543                    (instance (apply #'allocate-instance class initargs)))
 544               (invoke-effective-method-function
 545                initialize-instance t instance initargs)
 546               instance))))))
 547
 548 (defun get-simple-initialization-function (class
 549                                            keys
 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))))
 554
 555 (defun get-complex-initialization-functions (class
 556                                              keys
 557                                              &optional
 558                                              allow-other-keys-arg
 559                                              separate-p)
 560   (let* ((info (initialize-info class keys nil allow-other-keys-arg))
 561          (default-initargs-function (initialize-info-default-initargs-function
 562                                      info)))
 563     (if separate-p
 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))))))
 570
 571 (defun add-forms (forms forms-list)
 572   (when forms
 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)))
 578   (car forms-list))
 579
 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))
 583         (nkeys keys)
 584         (slots-alist
 585          (mapcan (lambda (slot)
 586                    (mapcar (lambda (arg)
 587                              (cons arg slot))
 588                            (slot-definition-initargs slot)))
 589                  (class-slots class)))
 590         (nslots nil))
 591     (dolist (key nkeys)
 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))
 599                      initargs-form-list)
 600           (push key nkeys)
 601           (push slot nslots))))
 602     (when separate-p
 603       (add-forms `((update-initialize-info-cache
 604                     ,class ,(initialize-info class nkeys nil)))
 605                  initargs-form-list))
 606     (add-forms `((finish-pushing-initargs))
 607                initargs-form-list)
 608     (values (car initargs-form-list) nkeys)))
 609
 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)
 613                       'structure)
 614                      ((standard-class-p class)
 615                       'standard)
 616                      ((funcallable-standard-class-p class)
 617                       'funcallable)
 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)))))
 630                                 (cons slot index)))
 631                             slots))
 632          (slots (stable-sort slots-key #'< :key #'cdr)))
 633     (let ((n-popped 0))
 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)
 657                                nil)
 658                               ((constantp initform)
 659                                (let ((value (funcall initfunction)))
 660                                  (if (and simple-p (integerp location))
 661                                      (progn (setf (nth location constants)
 662                                                   value)
 663                                             nil)
 664                                      `((const ,value)
 665                                        (instance-set ,pv-offset ,slot)))))
 666                               (t
 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
 671                                 ,(length forms))))
 672                          ,@forms)
 673                        initialize-form-list)))))
 674     (values (car initialize-form-list) constants)))
 675
 676 (defvar *class-pv-table-table* (make-hash-table :test 'eq))
 677
 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))))
 687
 688 (defvar *initialize-instance-simple-alist* nil)
 689 (defvar *note-iis-entry-p* nil)
 690
 691 (defvar *compiled-initialize-instance-simple-funs*
 692   (make-hash-table :test 'equal))
 693
 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*
 703                               :test #'equal)))
 704             (setf (gethash sf-key
 705                            *compiled-initialize-instance-simple-funs*)
 706                   t)
 707             (if entry
 708                 (setf (cdddr entry) (union (list sf-key) (cdddr entry)
 709                                            :test #'equal))
 710                 (progn
 711                   (setq entry (list* form nil nil (list sf-key)))
 712                   (setq *initialize-instance-simple-alist*
 713                         (nconc *initialize-instance-simple-alist*
 714                                (list entry)))))
 715             (unless (or *note-iis-entry-p* (cadr entry))
 716               (setf (cadr entry) (compile nil (car entry))))
 717             (if (cadr entry)
 718                 (apply (the function (cadr entry)) args)
 719                 `(call-initialize-instance-simple ,pv-cell ,form-list))))
 720         #||
 721         (lambda (instance initargs)
 722           (initialize-instance-simple pv-cell form-list instance initargs))
 723         ||#
 724         `(call-initialize-instance-simple ,pv-cell ,form-list))))
 725
 726 (defun load-precompiled-iis-entry (form function system uses)
 727   (let ((entry (assoc form *initialize-instance-simple-alist*
 728                       :test #'equal)))
 729     (unless entry
 730       (setq entry (list* form nil nil nil))
 731       (setq *initialize-instance-simple-alist*
 732             (nconc *initialize-instance-simple-alist*
 733                    (list entry))))
 734     (setf (cadr entry) function)
 735     (setf (caddr entry) system)
 736     (dolist (use uses)
 737       (setf (gethash use *compiled-initialize-instance-simple-funs*) t))
 738     (setf (cdddr entry) (union uses (cdddr entry)
 739                                :test #'equal))))
 740
 741 (defmacro precompile-iis-functions (&optional system)
 742   `(progn
 743     ,@(let (collect)
 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
 749                     ',(car iis-entry)
 750                     #',(car iis-entry)
 751                     ',system
 752                     ',(cdddr iis-entry))
 753                   collect)))
 754         (nreverse collect))))
 755
 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))))
 763
 764 ;(const const)
 765 ;(funcall function)
 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)
 770
 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))
 776         value)
 777     (loop (when (null form-list) (return nil))
 778           (let ((form (pop form-list)))
 779             (ecase (car form)
 780               (push-initarg
 781                (push value initargs)
 782                (push (cadr form) initargs))
 783               (const
 784                (setq value (cadr form)))
 785               (funcall
 786                (setq value (funcall (the function (cadr form)))))
 787               (pop-initargs
 788                (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
 789                (setq value (pop initargs-tail)))
 790               (instance-set
 791                (instance-write-internal
 792                 pv slots (cadr form) value
 793                 (setf (slot-value-using-class class instance (caddr form))
 794                       value)))
 795               (skip-when-instance-boundp
 796                (when (instance-boundp-internal
 797                       pv slots (cadr form)
 798                       (slot-boundp-using-class class instance (caddr form)))
 799                  (dotimes-fixnum (i (cadddr form))
 800                    (pop form-list))))
 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)))))
 809     initargs))
 810
 811 (defun add-to-cvector (cvector constant)
 812   (or (position constant cvector)
 813       (prog1 (fill-pointer cvector)
 814         (vector-push-extend constant cvector))))
 815
 816 (defvar *inline-iis-instance-locations-p* t)
 817
 818 (defun first-form-to-lisp (forms cvector pv)
 819   (flet ((const (constant)
 820            (cond ((or (numberp constant) (characterp constant))
 821                   constant)
 822                  ((and (symbolp constant) (symbol-package constant))
 823                   `',constant)
 824                  (t
 825                   `(svref cvector ,(add-to-cvector cvector constant))))))
 826     (let ((form (pop (car forms))))
 827       (ecase (car form)
 828         (push-initarg
 829          `((push value initargs)
 830            (push ,(const (cadr form)) initargs)))
 831         (const
 832          `((setq value ,(const (cadr form)))))
 833         (funcall
 834          `((setq value (funcall (the function ,(const (cadr form)))))))
 835         (pop-initargs
 836          `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
 837                                     (case pop
 838                                       (1 `(cdr))
 839                                       (3 `(cdddr))
 840                                       (t `(nthcdr ,pop))))
 841                                 initargs-tail))
 842            (setq value (pop initargs-tail))))
 843         (instance-set
 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)))
 848                                 value)))
 849            (if *inline-iis-instance-locations-p*
 850                (typecase location
 851                  (fixnum `((and slots
 852                                 (setf (clos-slots-ref slots ,(const location))
 853                                       value))))
 854                  (cons `((setf (cdr ,(const location)) value)))
 855                  (t `(,default)))
 856                `((instance-write-internal pv slots ,(const pv-offset) value
 857                   ,default
 858                   ,(typecase location
 859                      (fixnum :instance)
 860                      (cons :class)
 861                      (t :default)))))))
 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*
 868                           (typecase location
 869                             (fixnum `(not (and slots
 870                                                (eq (clos-slots-ref
 871                                                     slots
 872                                                     ,(const location))
 873                                                    +slot-unbound+))))
 874                             (cons `(not (eq (cdr ,(const location))
 875                                             +slot-unbound+)))
 876                             (t default))
 877                           `(instance-boundp-internal
 878                             pv slots ,(const pv-offset)
 879                             ,default
 880                             ,(typecase (pvref pv pv-offset)
 881                                (fixnum :instance)
 882                                (cons :class)
 883                                (t :default))))
 884                ,@(let ((sforms (cons nil nil)))
 885                    (dotimes-fixnum (i (cadddr form) (car sforms))
 886                      (add-forms (first-form-to-lisp forms cvector pv)
 887                                 sforms)))))))
 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)))))))
 896
 897 (defmacro iis-body (&body forms)
 898   `(let ((initargs-tail initargs)
 899          (slots (get-slots-or-nil instance))
 900          (class (class-of instance))
 901          (pv (car pv-cell))
 902          value)
 903      initargs instance initargs-tail pv cvector slots class value
 904      ,@forms))
 905
 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))
 910          (pv (car pv-cell))
 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)
 914                                   rforms))))
 915          (cvector-type `(simple-vector ,(length cvector))))
 916     (values
 917      `(lambda (pv-cell cvector)
 918         (declare (type ,cvector-type cvector))
 919         (lambda (instance initargs)
 920           (declare #.*optimize-speed*)
 921           (iis-body ,@body)
 922           initargs))
 923      (list pv-cell (coerce cvector cvector-type)))))
 924 \f
 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
 929 ;;; of keywords.
 930
 931 ;;; This optimization applies only when the first argument and all the
 932 ;;; even numbered arguments are constants evaluating to interned
 933 ;;; symbols.
 934
 935 (declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
 936
 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)))
 941     (if expanded-form
 942         `(funcall (fdefinition
 943                    ;; The name is guaranteed to be fbound.
 944                    ;; Is there a way to declare this?
 945                    (load-time-value
 946                     (get-make-instance-function-symbol
 947                      ',(first *make-instance-function-keys*))))
 948                   ,@(cdr expanded-form))
 949         form)))
 950
 951 (defun get-make-instance-function-symbol (key)
 952   (get-make-instance-functions (list key))
 953   (make-instance-function-symbol key))