1.0.29.45: another CTOR optimization

[sbcl.git] / src / pcl / braid.lisp

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index ab4588a..67df452 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -85,20 +85,6 @@
           (allocate-standard-funcallable-instance-slots
            wrapper slots-init-p slots-init))
     fin))
-
-(defun allocate-structure-instance (wrapper &optional
-                                            (slots-init nil slots-init-p))
-  (let* ((class (wrapper-class wrapper))
-         (constructor (class-defstruct-constructor class)))
-    (if constructor
-        (let ((instance (funcall constructor))
-              (slots (class-slots class)))
-          (when slots-init-p
-            (dolist (slot slots)
-              (setf (slot-value-using-class class instance slot)
-                    (pop slots-init))))
-          instance)
-        (error "can't allocate an instance of class ~S" (class-name class)))))
 \f
 ;;;; BOOTSTRAP-META-BRAID
 ;;;;
@@ -538,12 +524,10 @@
 (defun eval-form (form)
   (lambda () (eval form)))
 
-(defun ensure-non-standard-class (name &optional existing-class)
+(defun ensure-non-standard-class (name classoid &optional existing-class)
   (flet
       ((ensure (metaclass &optional (slots nil slotsp))
-         (let ((supers
-                (mapcar #'classoid-name (classoid-direct-superclasses
-                                         (find-classoid name)))))
+         (let ((supers (mapcar #'classoid-name (classoid-direct-superclasses classoid))))
            (if slotsp
                (ensure-class-using-class existing-class name
                                          :metaclass metaclass :name name
@@ -584,16 +568,16 @@
           ((condition-type-p name)
            (ensure 'condition-class
                    (mapcar #'slot-initargs-from-condition-slot
-                           (condition-classoid-slots (find-classoid name)))))
+                           (condition-classoid-slots classoid))))
           (t
            (error "~@<~S is not the name of a class.~@:>" name)))))
 
 (defun ensure-deffoo-class (classoid)
   (let ((class (classoid-pcl-class classoid)))
     (cond (class
-           (ensure-non-standard-class (class-name class) class))
+           (ensure-non-standard-class (class-name class) classoid class))
           ((eq 'complete *boot-state*)
-           (ensure-non-standard-class (classoid-name classoid))))))
+           (ensure-non-standard-class (classoid-name classoid) classoid)))))
 
 (pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
 (pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*)
@@ -631,7 +615,8 @@
 
 ;;; Set the inherits from CPL, and register the layout. This actually
 ;;; installs the class in the Lisp type system.
-(defun update-lisp-class-layout (class layout)
+(defun %update-lisp-class-layout (class layout)
+  ;; Protected by *world-lock* in callers.
   (let ((classoid (layout-classoid layout))
         (olayout (class-wrapper class)))
     (unless (eq (classoid-layout classoid) layout)
@@ -651,7 +636,7 @@
         (when (and name (symbolp name) (eq name (classoid-name classoid)))
           (setf (find-classoid name) classoid))))))
 
-(defun set-class-type-translation (class classoid)
+(defun %set-class-type-translation (class classoid)
   (when (not (typep classoid 'classoid))
     (setq classoid (find-classoid classoid nil)))
   (etypecase classoid
@@ -670,7 +655,6 @@
      (setf (info :type :translator class)
            (lambda (spec) (declare (ignore spec)) classoid)))))
 
-(clrhash *find-class*)
 (!bootstrap-meta-braid)
 (!bootstrap-accessor-definitions t)
 (!bootstrap-class-predicates t)
@@ -678,24 +662,25 @@
 (!bootstrap-class-predicates nil)
 (!bootstrap-built-in-classes)
 
-(dohash ((name x) *find-class*)
-  (let* ((class (find-class-from-cell name x))
-         (layout (class-wrapper class))
-         (lclass (layout-classoid layout))
-         (lclass-pcl-class (classoid-pcl-class lclass))
-         (olclass (find-classoid name nil)))
-    (if lclass-pcl-class
-        (aver (eq class lclass-pcl-class))
-        (setf (classoid-pcl-class lclass) class))
-
-    (update-lisp-class-layout class layout)
-
-    (cond (olclass
-           (aver (eq lclass olclass)))
-          (t
-           (setf (find-classoid name) lclass)))
-
-    (set-class-type-translation class name)))
+(dohash ((name x) sb-kernel::*classoid-cells*)
+  (when (classoid-cell-pcl-class x)
+    (let* ((class (find-class-from-cell name x))
+           (layout (class-wrapper class))
+           (lclass (layout-classoid layout))
+           (lclass-pcl-class (classoid-pcl-class lclass))
+           (olclass (find-classoid name nil)))
+      (if lclass-pcl-class
+          (aver (eq class lclass-pcl-class))
+          (setf (classoid-pcl-class lclass) class))
+
+      (%update-lisp-class-layout class layout)
+
+      (cond (olclass
+             (aver (eq lclass olclass)))
+            (t
+             (setf (find-classoid name) lclass)))
+
+      (%set-class-type-translation class name))))
 
 (setq *boot-state* 'braid)