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
  28 (sb-int:file-comment
  29   "$Header$")
  30 \f
  31 (defvar *compile-make-instance-functions-p* nil)
  32
  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)))
  38
  39 (defun constant-symbol-p (form)
  40   (and (constantp form)
  41        (let ((object (eval form)))
  42          (and (symbolp object)
  43               (symbol-package object)))))
  44
  45 (defvar *make-instance-function-keys* nil)
  46
  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))
  54                          (return nil))
  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))
  59                        (push key keys))))
  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*)
  65         (when sym
  66           `(,sym ',class (list ,@initargs)))))))
  67
  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)))
  71     `(progn
  72        ,@(when *make-instance-function-keys*
  73            `((get-make-instance-functions ',*make-instance-function-keys*)))
  74        ,form)))
  75
  76 (defmacro expanding-make-instance (&rest forms &environment env)
  77   `(progn
  78      ,@(mapcar #'(lambda (form)
  79                    (walk-form form env
  80                               #'(lambda (subform context env)
  81                                   (declare (ignore env))
  82                                   (or (and (eq context ':eval)
  83                                            (consp subform)
  84                                            (eq (car subform) 'make-instance)
  85                                            (expand-make-instance-form subform))
  86                                       subform))))
  87                forms)))
  88
  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))))
  94
  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
 102                     :test #'equal)
 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)))))))
 109
 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)))
 115              (keys (cadr key))
 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*)
 122                 (*print-length* nil)
 123                 (*print-level* nil)
 124                 (*print-circle* nil)
 125                 (*print-case* :upcase)
 126                 (*print-pretty* nil))
 127             (intern (format nil
 128                             "MAKE-INSTANCE ~S ~S ~S"
 129                             class-name
 130                             keys
 131                             allow-other-keys-p))))))))
 132
 133 (defun make-instance-1 (class initargs)
 134   (apply #'make-instance class initargs))
 135
 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)
 142               (progn
 143                 (,',trap ,info ',',name)
 144                 (,',cached-name ,info))
 145               value)))))
 146
 147 (eval-when (:compile-toplevel :load-toplevel :execute)
 148 (defparameter *initialize-info-cached-slots*
 149   '(valid-p                             ; t or (:invalid key)
 150     ri-valid-p
 151     initargs-form-list
 152     new-keys
 153     default-initargs-function
 154     shared-initialize-t-function
 155     shared-initialize-nil-function
 156     constants
 157     combined-initialize-function ; allocate-instance + shared-initialize
 158     make-instance-function ; nil means use gf
 159     make-instance-function-symbol)))
 160
 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*))
 166         (cached-names
 167          (mapcar #'(lambda (name)
 168                      (intern (format nil "~A-CACHED-~A"
 169                                      'initialize-info name)))
 170                  *initialize-info-cached-slots*)))
 171     `(progn
 172        (defstruct initialize-info
 173          key wrapper
 174          ,@(mapcar #'(lambda (name)
 175                        `(,name :unknown))
 176                    cached-slot-names))
 177        (defmacro reset-initialize-info-internal (info)
 178          `(progn
 179             ,@(mapcar #'(lambda (cname)
 180                           `(setf (,cname ,info) ':unknown))
 181                       ',cached-names)))
 182        (defun initialize-info-bound-slots (info)
 183          (let ((slots nil))
 184            ,@(mapcar #'(lambda (name cached-name)
 185                          `(unless (eq ':unknown (,cached-name info))
 186                             (push ',name slots)))
 187                      *initialize-info-cached-slots* cached-names)
 188            slots))
 189       ,@(mapcar #'(lambda (name)
 190                     `(define-cached-reader initialize-info ,name
 191                       update-initialize-info-internal))
 192                 *initialize-info-cached-slots*))))
 193
 194 (define-initialize-info)
 195
 196 (defvar *initialize-info-cache-class* nil)
 197 (defvar *initialize-info-cache-initargs* nil)
 198 (defvar *initialize-info-cache-info* nil)
 199
 200 (defvar *revert-initialize-info-p* nil)
 201
 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))
 211     info))
 212
 213 (defun reset-class-initialize-info (class)
 214   (reset-class-initialize-info-1 (class-initialize-info class)))
 215
 216 (defun reset-class-initialize-info-1 (cell)
 217   (when (consp cell)
 218     (when (car cell)
 219       (reset-initialize-info (car cell)))
 220     (let ((alist (cdr cell)))
 221       (dolist (a alist)
 222         (reset-class-initialize-info-1 (cdr a))))))
 223
 224 (defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
 225   (let ((info nil))
 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))
 234                       (alist-cell cell))
 235                   (when plist-p
 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)))
 240                           (when (null alist)
 241                             (setq cell (cons nil nil))
 242                             (setf (cdr alist-cell) (list (cons keyword cell)))
 243                             (return nil))
 244                           (when (eql keyword (caar alist))
 245                             (setq cell (cdar alist))
 246                             (return nil))
 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))
 252         (unless wrapper
 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)
 267     info))
 268
 269 (defun update-initialize-info-internal (info name)
 270   (let* ((key (initialize-info-key info))
 271          (class (car key))
 272          (keys (cadr key))
 273          (allow-other-keys-arg (caddr key)))
 274     (ecase name
 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))
 292                           (dolist (key keys t)
 293                             (unless (member key legal)
 294                               (return (cons :invalid key)))))))))
 295          (let ((proto (class-prototype class)))
 296            (setf (initialize-info-cached-valid-p info)
 297                  (compute-valid-p
 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)
 302                  (compute-valid-p
 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)))))))
 340   info)
 341
 342 (defun get-make-instance-function (key)
 343   (let* ((class (car key))
 344          (keys (cadr 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)))
 349     (when (classp 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
 363             (when proto
 364               (compute-applicable-methods (gdefinition 'initialize-instance)
 365                                           (list* proto initargs))))
 366            (shared-initialize-methods
 367             (when proto
 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)))
 381                               (if (null quals)
 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))))
 393
 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
 404                class initargs
 405                (append allocate-instance-methods
 406                        initialize-instance-methods
 407                        shared-initialize-methods)
 408                t nil)
 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
 416          key class keys
 417          initialize-instance-methods shared-initialize-methods)
 418         (make-instance-function-simple
 419          key class keys
 420          initialize-instance-methods shared-initialize-methods))))
 421
 422 (defun complicated-instance-creation-method (m)
 423   (let ((qual (method-qualifiers m)))
 424     (if qual
 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))))))))
 429
 430 (defun find-standard-ii-method (methods class-names)
 431   (dolist (m methods)
 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)))
 438           (return m))))))
 439
 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.)
 445                                      ,instance ,initargs)
 446          (funcall (the function .function.) ,instance ,initargs))))
 447
 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))
 455            (allocate-function
 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)
 462                   (t
 463                    (error "error in make-instance-function-simple"))))
 464            (std-si-meth (find-standard-ii-method shared-initialize-methods
 465                                                  'slot-object))
 466            (shared-initfns
 467             (nreverse (mapcar #'(lambda (method)
 468                                   (make-effective-method-function
 469                                    #'shared-initialize
 470                                    `(call-method ,method nil)
 471                                    nil lwrapper))
 472                               (remove std-si-meth shared-initialize-methods))))
 473            (std-ii-meth (find-standard-ii-method initialize-instance-methods
 474                                                  'slot-object))
 475            (initialize-initfns
 476             (nreverse (mapcar #'(lambda (method)
 477                                   (make-effective-method-function
 478                                    #'initialize-instance
 479                                    `(call-method ,method nil)
 480                                    nil lwrapper))
 481                               (remove std-ii-meth
 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
 491                                                          instance initargs)))
 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))
 496                 instance))))))
 497
 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))
 504            (shared-initialize
 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
 512                                                instance initargs)
 513                      instance)))
 514              (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
 515            (initialize-instance
 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
 531                                                          nil initargs))
 532                      (instance (apply #'allocate-instance class initargs)))
 533                 (invoke-effective-method-function
 534                  initialize-instance t instance initargs)
 535                 instance))))))
 536
 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))))
 541
 542 (defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
 543                                                    separate-p)
 544   (let* ((info (initialize-info class keys nil allow-other-keys-arg))
 545          (default-initargs-function (initialize-info-default-initargs-function info)))
 546     (if separate-p
 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))))))
 553
 554 (defun add-forms (forms forms-list)
 555   (when forms
 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)))
 561   (car forms-list))
 562
 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))
 566         (nkeys keys)
 567         (slots-alist
 568          (mapcan #'(lambda (slot)
 569                      (mapcar #'(lambda (arg)
 570                                  (cons arg slot))
 571                              (slot-definition-initargs slot)))
 572                  (class-slots class)))
 573         (nslots nil))
 574     (dolist (key nkeys)
 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))
 582                      initargs-form-list)
 583           (push key nkeys)
 584           (push slot nslots))))
 585     (when separate-p
 586       (add-forms `((update-initialize-info-cache
 587                     ,class ,(initialize-info class nkeys nil)))
 588                  initargs-form-list))
 589     (add-forms `((finish-pushing-initargs))
 590                initargs-form-list)
 591     (values (car initargs-form-list) nkeys)))
 592
 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)
 596                       'structure)
 597                      ((standard-class-p class)
 598                       'standard)
 599                      ((funcallable-standard-class-p class)
 600                       'funcallable)
 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)))))
 613                                   (cons slot index)))
 614                             slots))
 615          (slots (stable-sort slots-key #'< :key #'cdr)))
 616     (let ((n-popped 0))
 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)
 640                                nil)
 641                               ((constantp initform)
 642                                (let ((value (funcall initfunction)))
 643                                  (if (and simple-p (integerp location))
 644                                      (progn (setf (nth location constants) value)
 645                                             nil)
 646                                      `((const ,value)
 647                                        (instance-set ,pv-offset ,slot)))))
 648                               (t
 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
 653                                 ,(length forms))))
 654                          ,@forms)
 655                        initialize-form-list)))))
 656     (values (car initialize-form-list) constants)))
 657
 658 (defvar *class-pv-table-table* (make-hash-table :test 'eq))
 659
 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))))
 669
 670 (defvar *initialize-instance-simple-alist* nil)
 671 (defvar *note-iis-entry-p* nil)
 672
 673 (defvar *compiled-initialize-instance-simple-functions*
 674   (make-hash-table :test 'equal))
 675
 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*
 685                               :test #'equal)))
 686             (setf (gethash sf-key
 687                            *compiled-initialize-instance-simple-functions*)
 688                   t)
 689             (if entry
 690                 (setf (cdddr entry) (union (list sf-key) (cdddr entry)
 691                                            :test #'equal))
 692                 (progn
 693                   (setq entry (list* form nil nil (list sf-key)))
 694                   (setq *initialize-instance-simple-alist*
 695                         (nconc *initialize-instance-simple-alist*
 696                                (list entry)))))
 697             (unless (or *note-iis-entry-p* (cadr entry))
 698               (setf (cadr entry) (compile-lambda (car entry))))
 699             (if (cadr entry)
 700                 (apply (the function (cadr entry)) args)
 701                 `(call-initialize-instance-simple ,pv-cell ,form-list))))
 702         #||
 703         #'(lambda (instance initargs)
 704             (initialize-instance-simple pv-cell form-list instance initargs))
 705         ||#
 706         `(call-initialize-instance-simple ,pv-cell ,form-list))))
 707
 708 (defun load-precompiled-iis-entry (form function system uses)
 709   (let ((entry (assoc form *initialize-instance-simple-alist*
 710                       :test #'equal)))
 711     (unless entry
 712       (setq entry (list* form nil nil nil))
 713       (setq *initialize-instance-simple-alist*
 714             (nconc *initialize-instance-simple-alist*
 715                    (list entry))))
 716     (setf (cadr entry) function)
 717     (setf (caddr entry) system)
 718     (dolist (use uses)
 719       (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
 720     (setf (cdddr entry) (union uses (cdddr entry)
 721                                :test #'equal))))
 722
 723 (defmacro precompile-iis-functions (&optional system)
 724   (let ((index -1))
 725     `(progn
 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))
 731              (gather1
 732               (make-top-level-form
 733                `(precompile-initialize-instance-simple ,system ,(incf index))
 734                '(:load-toplevel)
 735                `(load-precompiled-iis-entry
 736                  ',(car iis-entry)
 737                  #',(car iis-entry)
 738                  ',system
 739                  ',(cdddr iis-entry))))))))))
 740
 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))))
 748
 749 ;(const const)
 750 ;(funcall function)
 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)
 755
 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))
 761         value)
 762     (loop (when (null form-list) (return nil))
 763           (let ((form (pop form-list)))
 764             (ecase (car form)
 765               (push-initarg
 766                (push value initargs)
 767                (push (cadr form) initargs))
 768               (const
 769                (setq value (cadr form)))
 770               (funcall
 771                (setq value (funcall (the function (cadr form)))))
 772               (pop-initargs
 773                (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
 774                (setq value (pop initargs-tail)))
 775               (instance-set
 776                (instance-write-internal
 777                 pv slots (cadr form) value
 778                 (setf (slot-value-using-class class instance (caddr form))
 779                       value)))
 780               (skip-when-instance-boundp
 781                (when (instance-boundp-internal
 782                       pv slots (cadr form)
 783                       (slot-boundp-using-class class instance (caddr form)))
 784                  (dotimes-fixnum (i (cadddr form))
 785                    (pop form-list))))
 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)))))
 794     initargs))
 795
 796 (defun add-to-cvector (cvector constant)
 797   (or (position constant cvector)
 798       (prog1 (fill-pointer cvector)
 799         (vector-push-extend constant cvector))))
 800
 801 (defvar *inline-iis-instance-locations-p* t)
 802
 803 (defun first-form-to-lisp (forms cvector pv)
 804   (flet ((const (constant)
 805            (cond ((or (numberp constant) (characterp constant))
 806                   constant)
 807                  ((and (symbolp constant) (symbol-package constant))
 808                   `',constant)
 809                  (t
 810                   `(svref cvector ,(add-to-cvector cvector constant))))))
 811     (let ((form (pop (car forms))))
 812       (ecase (car form)
 813         (push-initarg
 814          `((push value initargs)
 815            (push ,(const (cadr form)) initargs)))
 816         (const
 817          `((setq value ,(const (cadr form)))))
 818         (funcall
 819          `((setq value (funcall (the function ,(const (cadr form)))))))
 820         (pop-initargs
 821          `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
 822                                     (case pop
 823                                       (1 `(cdr))
 824                                       (3 `(cdddr))
 825                                       (t `(nthcdr ,pop))))
 826                                 initargs-tail))
 827            (setq value (pop initargs-tail))))
 828         (instance-set
 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)))
 833                                 value)))
 834            (if *inline-iis-instance-locations-p*
 835                (typecase location
 836                  (fixnum `((setf (%instance-ref slots ,(const location)) value)))
 837                  (cons `((setf (cdr ,(const location)) value)))
 838                  (t `(,default)))
 839                `((instance-write-internal pv slots ,(const pv-offset) value
 840                   ,default
 841                   ,(typecase location
 842                      (fixnum ':instance)
 843                      (cons ':class)
 844                      (t ':default)))))))
 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*
 851                           (typecase location
 852                             (fixnum `(not (eq (%instance-ref slots ,(const location))
 853                                               ',*slot-unbound*)))
 854                             (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
 855                             (t default))
 856                           `(instance-boundp-internal pv slots ,(const pv-offset)
 857                             ,default
 858                             ,(typecase (pvref pv pv-offset)
 859                                (fixnum ':instance)
 860                                (cons ':class)
 861                                (t ':default))))
 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)))))))
 873
 874 (defmacro iis-body (&body forms)
 875   `(let ((initargs-tail initargs)
 876          (slots (get-slots-or-nil instance))
 877          (class (class-of instance))
 878          (pv (car pv-cell))
 879          value)
 880      initargs instance initargs-tail pv cvector slots class value
 881      ,@forms))
 882
 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))
 887          (pv (car pv-cell))
 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)
 891                                   rforms))))
 892          (cvector-type `(simple-vector ,(length cvector))))
 893     (values
 894      `(lambda (pv-cell cvector)
 895         (declare (type ,cvector-type cvector))
 896         #'(lambda (instance initargs)
 897             (declare #.*optimize-speed*)
 898             (iis-body ,@body)
 899             initargs))
 900      (list pv-cell (coerce cvector cvector-type)))))
 901 \f
 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.
 906
 907 ;;; This optimization applies only when the first argument and all the even
 908 ;;; numbered arguments are constants evaluating to interned symbols.
 909
 910 (declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
 911
 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)))
 916     (if expanded-form
 917         `(funcall (symbol-function
 918                    ;; The symbol is guaranteed to be fbound.
 919                    ;; Is there a way to declare this?
 920                    (load-time-value
 921                     (get-make-instance-function-symbol
 922                      ',(first *make-instance-function-keys*))))
 923                   ,@(cdr expanded-form))
 924         form)))
 925
 926 (defun get-make-instance-function-symbol (key)
 927   (get-make-instance-functions (list key))
 928   (make-instance-function-symbol key))