1.0.29.41: inline CTOR caches for MAKE-INSTANCE
[sbcl.git] / src / pcl / ctor.lisp
index aebc884..26b64e2 100644 (file)
         else if (or (null test) (funcall test (car more)))
           collect (car more)))
 
+(defun constant-class-arg-p (form)
+  (and (constantp form)
+       (let ((constant (constant-form-value form)))
+         (or (and (symbolp constant)
+                  (not (null (symbol-package constant))))
+             (classp form)))))
+
 (defun constant-symbol-p (form)
   (and (constantp form)
        (let ((constant (constant-form-value form)))
 ;;; funcallable instance is set to it.
 ;;;
 (!defstruct-with-alternate-metaclass ctor
-  :slot-names (function-name class-name class initargs safe-p)
+  :slot-names (function-name class-or-name class initargs safe-p)
   :boa-constructor %make-ctor
   :superclass-name function
   :metaclass-name static-classoid
   :runtime-type-checks-p nil)
 
 ;;; List of all defined ctors.
-
 (defvar *all-ctors* ())
 
 (defun make-ctor-parameter-list (ctor)
 ;;; optimized constructor function when called.
 (defun install-initial-constructor (ctor &key force-p)
   (when (or force-p (ctor-class ctor))
-    (setf (ctor-class ctor) nil)
-    (setf (funcallable-instance-fun ctor)
-          #'(lambda (&rest args)
-              (install-optimized-constructor ctor)
-              (apply ctor args)))
-    (setf (%funcallable-instance-info ctor 1)
-          (ctor-function-name ctor))))
+    (let ((*installing-ctor* t))
+      (setf (ctor-class ctor) nil)
+      (setf (funcallable-instance-fun ctor)
+            #'(lambda (&rest args)
+                (install-optimized-constructor ctor)
+                (apply ctor args)))
+      (setf (%funcallable-instance-info ctor 1)
+            (ctor-function-name ctor)))))
 
 (defun make-ctor-function-name (class-name initargs safe-code-p)
   (list* 'ctor class-name safe-code-p initargs))
      (setf (fdefinition function-name) ctor)
      (install-initial-constructor ctor :force-p t)
      ctor)))
-
+\f
+;;; *****************
+;;; Inline CTOR cache
+;;; *****************
+;;;
+;;; The cache starts out as a list of CTORs, sorted with the most recently
+;;; used CTORs near the head. If it expands too much, we switch to a vector
+;;; with a simple hashing scheme.
+
+;;; Find CTOR for KEY (which is a class or class name) in a list. If the CTOR
+;;; is in the list but not one of the 4 first ones, return a new list with the
+;;; found CTOR at the head. Thread-safe: the new list shares structure with
+;;; the old, but is not desctructively modified. Returning the old list for
+;;; hits close to the head reduces ping-ponging with multiple threads seeking
+;;; the same list.
+(defun find-ctor (key list)
+  (labels ((walk (tail from-head depth)
+             (declare (fixnum depth))
+             (if tail
+                 (let ((ctor (car tail)))
+                   (if (eq (ctor-class-or-name ctor) key)
+                       (if (> depth 3)
+                           (values ctor
+                                   (nconc (list ctor) (nreverse from-head) (cdr tail)))
+                           (values ctor
+                                   list))
+                       (walk (cdr tail)
+                             (cons ctor from-head)
+                             (logand #xf (1+ depth)))))
+                 (values nil list))))
+    (walk list nil 0)))
+
+(declaim (inline sxhash-symbol-or-class))
+(defun sxhash-symbol-or-class (x)
+  (cond ((symbolp x) (sxhash x))
+        ((std-instance-p x) (std-instance-hash x))
+        ((fsc-instance-p x) (fsc-instance-hash x))
+        (t
+         (bug "Something strange where symbol or class expected."))))
+
+;;; Max number of CTORs kept in an inline list cache. Once this is
+;;; exceeded we switch to a table.
+(defconstant +ctor-list-max-size+ 12)
+;;; Max table size for CTOR cache. If the table fills up at this size
+;;; we keep the same size and drop 50% of the old entries.
+(defconstant +ctor-table-max-size+ (expt 2 8))
+;;; Even if there is space in the cache, if we cannot fit a new entry
+;;; with max this number of collisions we expand the table (if possible)
+;;; and rehash.
+(defconstant +ctor-table-max-probe-depth+ 5)
+
+(defun make-ctor-table (size)
+  (declare (index size))
+  (let ((real-size (power-of-two-ceiling size)))
+    (if (< real-size +ctor-table-max-size+)
+        (values (make-array real-size :initial-element nil) nil)
+        (values (make-array +ctor-table-max-size+ :initial-element nil) t))))
+
+(declaim (inline mix-ctor-hash))
+(defun mix-ctor-hash (hash base)
+  (logand most-positive-fixnum (+ hash base 1)))
+
+(defun put-ctor (ctor table)
+  (cond ((try-put-ctor ctor table)
+         (values ctor table))
+        (t
+         (expand-ctor-table ctor table))))
+
+;;; Thread-safe: if two threads write to the same index in parallel, the other
+;;; result is just lost. This is not an issue as the CTORs are used as their
+;;; own keys. If both were EQ, we're good. If non-EQ, the next time the other
+;;; one is needed we just cache it again -- hopefully not getting stomped on
+;;; that time.
+(defun try-put-ctor (ctor table)
+  (declare (simple-vector table) (optimize speed))
+  (let* ((class (ctor-class-or-name ctor))
+         (base (sxhash-symbol-or-class class))
+         (hash base)
+         (mask (1- (length table))))
+    (declare (fixnum base hash mask))
+    (loop repeat +ctor-table-max-probe-depth+
+          do (let* ((index (logand mask hash))
+                    (old (aref table index)))
+               (cond ((and old (neq class (ctor-class-or-name old)))
+                      (setf hash (mix-ctor-hash hash base)))
+                     (t
+                      (setf (aref table index) ctor)
+                      (return-from try-put-ctor t)))))
+    ;; Didn't fit, must expand
+    nil))
+
+(defun get-ctor (class table)
+  (declare (simple-vector table) (optimize speed))
+  (let* ((base (sxhash-symbol-or-class class))
+         (hash base)
+         (mask (1- (length table))))
+    (declare (fixnum base hash mask))
+    (loop repeat +ctor-table-max-probe-depth+
+          do (let* ((index (logand mask hash))
+                    (old (aref table index)))
+               (if (and old (eq class (ctor-class-or-name old)))
+                   (return-from get-ctor old)
+                   (setf hash (mix-ctor-hash hash base)))))
+    ;; Nothing.
+    nil))
+
+;;; Thread safe: the old table is read, but if another thread mutates
+;;; it while we're reading we still get a sane result -- either the old
+;;; or the new entry. The new table is locally allocated, so that's ok
+;;; too.
+(defun expand-ctor-table (ctor old)
+  (declare (simple-vector old))
+  (let* ((old-size (length old))
+         (new-size (* 2 old-size))
+         (drop-random-entries nil))
+    (tagbody
+     :again
+       (multiple-value-bind (new max-size-p) (make-ctor-table new-size)
+         (let ((action (if drop-random-entries
+                           ;; Same logic as in method caches -- see comment
+                           ;; there.
+                           (randomly-punting-lambda (old-ctor)
+                             (try-put-ctor old-ctor new))
+                           (lambda (old-ctor)
+                             (unless (try-put-ctor old-ctor new)
+                               (if max-size-p
+                                   (setf drop-random-entries t)
+                                   (setf new-size (* 2 new-size)))
+                               (go :again))))))
+           (aver (try-put-ctor ctor new))
+           (dotimes (i old-size)
+             (let ((old-ctor (aref old i)))
+               (when old-ctor
+                 (funcall action old-ctor))))
+           (return-from expand-ctor-table (values ctor new)))))))
+
+(defun ctor-list-to-table (list)
+  (let ((table (make-ctor-table (length list))))
+    (dolist (ctor list)
+      (setf table (nth-value 1 (put-ctor ctor table))))
+    table))
+
+(defun ctor-for-caching (class-name initargs safe-code-p)
+  (let ((name (make-ctor-function-name class-name initargs safe-code-p)))
+    (or (ensure-ctor name class-name initargs safe-code-p)
+        (fdefinition name))))
+
+(defun ensure-cached-ctor (class-name store initargs safe-code-p)
+  (if (listp store)
+      (multiple-value-bind (ctor list) (find-ctor class-name store)
+        (if ctor
+            (values ctor list)
+            (let ((ctor (ctor-for-caching class-name initargs safe-code-p)))
+              (if (< (length list) +ctor-list-max-size+)
+                  (values ctor (cons ctor list))
+                  (values ctor (ctor-list-to-table list))))))
+      (let ((ctor (get-ctor class-name store)))
+        (if ctor
+            (values ctor store)
+            (put-ctor (ctor-for-caching class-name initargs safe-code-p)
+                      store)))))
 \f
 ;;; ***********************************************
 ;;; Compile-Time Expansion of MAKE-INSTANCE *******
 ;;; ***********************************************
 
+(defvar *compiling-optimized-constructor* nil)
+
 (define-compiler-macro make-instance (&whole form &rest args &environment env)
   (declare (ignore args))
-  (or (make-instance->constructor-call form (safe-code-p env))
+  ;; Compiling an optimized constructor for a non-standard class means compiling a
+  ;; lambda with (MAKE-INSTANCE #<SOME-CLASS X> ...) in it -- need
+  ;; to make sure we don't recurse there.
+  (or (unless *compiling-optimized-constructor*
+        (make-instance->constructor-call form (safe-code-p env)))
       form))
 
 (defun make-instance->constructor-call (form safe-code-p)
-  (destructuring-bind (fn class-name &rest args) form
-    (declare (ignore fn))
+  (destructuring-bind (class-arg &rest args) (cdr form)
     (flet (;;
            ;; Return the name of parameter number I of a constructor
            ;; function.
                (if (array-in-bounds-p ps i)
                    (aref ps i)
                    (format-symbol *pcl-package* ".P~D." i))))
-           ;; Check if CLASS-NAME is a constant symbol.  Give up if
+           ;; Check if CLASS-ARG is a constant symbol.  Give up if
            ;; not.
-           (check-class ()
-             (unless (and class-name (constant-symbol-p class-name))
-               (return-from make-instance->constructor-call nil)))
+           (constant-class-p ()
+             (and class-arg (constant-class-arg-p class-arg)))
            ;; Check if ARGS are suitable for an optimized constructor.
            ;; Return NIL from the outer function if not.
            (check-args ()
              (loop for (key . more) on args by #'cddr do
-                     (when (or (null more)
-                               (not (constant-symbol-p key))
-                               (eq :allow-other-keys (constant-form-value key)))
-                       (return-from make-instance->constructor-call nil)))))
-      (check-class)
+                      (when (or (null more)
+                                (not (constant-symbol-p key))
+                                (eq :allow-other-keys (constant-form-value key)))
+                        (return-from make-instance->constructor-call nil)))))
       (check-args)
       ;; Collect a plist of initargs and constant values/parameter names
       ;; in INITARGS.  Collect non-constant initialization forms in
           (loop for (key value) on args by #'cddr and i from 0
                 collect (constant-form-value key) into initargs
                 if (constantp value)
-                  collect value into initargs
+                collect value into initargs
                 else
-                  collect (parameter-name i) into initargs
-                  and collect value into value-forms
+                collect (parameter-name i) into initargs
+                and collect value into value-forms
                 finally
-                  (return (values initargs value-forms)))
-        (let* ((class-name (constant-form-value class-name))
-               (function-name (make-ctor-function-name class-name initargs
-                                                       safe-code-p)))
-          ;; Prevent compiler warnings for calling the ctor.
-          (proclaim-as-fun-name function-name)
-          (note-name-defined function-name :function)
-          (when (eq (info :function :where-from function-name) :assumed)
-            (setf (info :function :where-from function-name) :defined)
-            (when (info :function :assumed-type function-name)
-              (setf (info :function :assumed-type function-name) nil)))
-          ;; Return code constructing a ctor at load time, which, when
-          ;; called, will set its funcallable instance function to an
-          ;; optimized constructor function.
-          `(locally
-               (declare (disable-package-locks ,function-name))
-            (let ((.x. (load-time-value
-                        (ensure-ctor ',function-name ',class-name ',initargs
-                                     ',safe-code-p))))
-              (declare (ignore .x.))
-              ;; ??? check if this is worth it.
-              (declare
-               (ftype (or (function ,(make-list (length value-forms)
-                                                :initial-element t)
-                                    t)
-                          (function (&rest t) t))
-                      ,function-name))
-              (funcall (function ,function-name) ,@value-forms))))))))
-
+                (return (values initargs value-forms)))
+        (if (constant-class-p)
+            (let* ((class-or-name (constant-form-value class-arg))
+                   (function-name (make-ctor-function-name class-or-name initargs
+                                                           safe-code-p)))
+              ;; Prevent compiler warnings for calling the ctor.
+              (proclaim-as-fun-name function-name)
+              (note-name-defined function-name :function)
+              (when (eq (info :function :where-from function-name) :assumed)
+                (setf (info :function :where-from function-name) :defined)
+                (when (info :function :assumed-type function-name)
+                  (setf (info :function :assumed-type function-name) nil)))
+              ;; Return code constructing a ctor at load time, which, when
+              ;; called, will set its funcallable instance function to an
+              ;; optimized constructor function.
+              `(locally
+                   (declare (disable-package-locks ,function-name))
+                 (let ((.x. (load-time-value
+                             (ensure-ctor ',function-name ',class-or-name ',initargs
+                                          ',safe-code-p))))
+                   (declare (ignore .x.))
+                   ;; ??? check if this is worth it.
+                   (declare
+                    (ftype (or (function ,(make-list (length value-forms)
+                                                     :initial-element t)
+                                         t)
+                               (function (&rest t) t))
+                           ,function-name))
+                   (funcall (function ,function-name) ,@value-forms))))
+            (when class-arg
+              ;; Build an inline cache: a CONS, with the actual cache in the CDR.
+              `(locally (declare (disable-package-locks .cache. .class-arg. .store. .fun.
+                                                        make-instance))
+                 (let* ((.cache. (load-time-value (cons 'ctor-cache nil)))
+                        (.store. (cdr .cache.))
+                        (.class-arg. ,class-arg))
+                   (multiple-value-bind (.fun. .new-store.)
+                       (ensure-cached-ctor .class-arg. .store. ',initargs ',safe-code-p)
+                     ;; Thread safe: if multiple threads hit this in paralle, the update
+                     ;; from the other one is just lost -- no harm done, except for the
+                     ;; need to redo the work next time.
+                     (unless (eq .store. .new-store.)
+                       (setf (cdr .cache.) .new-store.))
+                     (funcall (truly-the function .fun.) ,@value-forms))))))))))
 \f
 ;;; **************************************************
 ;;; Load-Time Constructor Function Generation  *******
 
 (defun install-optimized-constructor (ctor)
   (with-world-lock ()
-    (let ((class (find-class (ctor-class-name ctor))))
+    (let* ((class-or-name (ctor-class-or-name ctor))
+           (class (if (symbolp class-or-name)
+                      (find-class class-or-name)
+                      class-or-name)))
       (unless (class-finalized-p class)
         (finalize-inheritance class))
       ;; We can have a class with an invalid layout here.  Such a class
       (setf (funcallable-instance-fun ctor)
             (multiple-value-bind (form locations names)
                 (constructor-function-form ctor)
-              (apply (compile nil `(lambda ,names ,form)) locations))))))
+              (apply
+               (let ((*compiling-optimized-constructor* t))
+                 (compile nil `(lambda ,names ,form)))
+               locations))))))
 
 (defun constructor-function-form (ctor)
   (let* ((class (ctor-class ctor))
       ;; NAME must have been specified.
       (setf-find-class
        (loop for ctor in *all-ctors*
-             when (eq (ctor-class-name ctor) name) do
+             when (eq (ctor-class-or-name ctor) name) do
              (when (ctor-class ctor)
                (reset (ctor-class ctor)))
              (loop-finish)))
 (defun precompile-ctors ()
   (dolist (ctor *all-ctors*)
     (when (null (ctor-class ctor))
-      (let ((class (find-class (ctor-class-name ctor) nil)))
+      (let ((class (find-class (ctor-class-or-name ctor) nil)))
         (when (and class (class-finalized-p class))
           (install-optimized-constructor ctor))))))