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