[armedbear-cvs] r12586 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Apr  9 17:27:14 2010
New Revision: 12586

Log:
Reduce function dispatch speed with 6% by
  replacing dynamic STANDARD-CLASS lookup with
  a defined constant.

Modified:
   trunk/abcl/src/org/armedbear/lisp/clos.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/clos.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/clos.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/clos.lisp	Fri Apr  9 17:27:14 2010
@@ -52,6 +52,7 @@
 (in-package #:mop)
 
 (export '(class-precedence-list class-slots))
+(defconstant +the-standard-class+ (find-class 'standard-class))
 
 ;; Don't use DEFVAR, because that disallows loading clos.lisp
 ;; after compiling it: the binding won't get assigned to T anymore
@@ -296,7 +297,7 @@
 
 (defun std-finalize-inheritance (class)
   (setf (class-precedence-list class)
-   (funcall (if (eq (class-of class) (find-class 'standard-class))
+   (funcall (if (eq (class-of class) +the-standard-class+)
                 #'std-compute-class-precedence-list
                 #'compute-class-precedence-list)
             class))
@@ -304,7 +305,7 @@
     (when (typep class 'forward-referenced-class)
       (return-from std-finalize-inheritance)))
   (setf (class-slots class)
-                   (funcall (if (eq (class-of class) (find-class 'standard-class))
+                   (funcall (if (eq (class-of class) +the-standard-class+)
                                 #'std-compute-slots
                      #'compute-slots) class))
   (let ((old-layout (class-layout class))
@@ -437,7 +438,7 @@
                      (mapcar #'%slot-definition-name all-slots))))
     (mapcar #'(lambda (name)
                (funcall
-                (if (eq (class-of class) (find-class 'standard-class))
+                (if (eq (class-of class) +the-standard-class+)
                     #'std-compute-effective-slot-definition
                     #'compute-effective-slot-definition)
                 class
@@ -486,14 +487,14 @@
     (and layout (layout-slot-location layout slot-name))))
 
 (defun slot-value (object slot-name)
-  (if (eq (class-of (class-of object)) (find-class 'standard-class))
+  (if (eq (class-of (class-of object)) +the-standard-class+)
       (std-slot-value object slot-name)
       (slot-value-using-class (class-of object) object slot-name)))
 
 (defsetf std-slot-value set-std-slot-value)
 
 (defun %set-slot-value (object slot-name new-value)
-  (if (eq (class-of (class-of object)) (find-class 'standard-class))
+  (if (eq (class-of (class-of object)) +the-standard-class+)
       (setf (std-slot-value object slot-name) new-value)
       (set-slot-value-using-class new-value (class-of object)
                                   object slot-name)))
@@ -501,7 +502,7 @@
 (defsetf slot-value %set-slot-value)
 
 (defun slot-boundp (object slot-name)
-  (if (eq (class-of (class-of object)) (find-class 'standard-class))
+  (if (eq (class-of (class-of object)) +the-standard-class+)
       (std-slot-boundp object slot-name)
       (slot-boundp-using-class (class-of object) object slot-name)))
 
@@ -516,7 +517,7 @@
   instance)
 
 (defun slot-makunbound (object slot-name)
-  (if (eq (class-of (class-of object)) (find-class 'standard-class))
+  (if (eq (class-of (class-of object)) +the-standard-class+)
       (std-slot-makunbound object slot-name)
       (slot-makunbound-using-class (class-of object) object slot-name)))
 
@@ -525,7 +526,7 @@
                    :key #'%slot-definition-name))))
 
 (defun slot-exists-p (object slot-name)
-  (if (eq (class-of (class-of object)) (find-class 'standard-class))
+  (if (eq (class-of (class-of object)) +the-standard-class+)
       (std-slot-exists-p object slot-name)
       (slot-exists-p-using-class (class-of object) object slot-name)))
 
@@ -538,7 +539,7 @@
                                      documentation
                                      &allow-other-keys)
   (declare (ignore metaclass))
-  (let ((class (std-allocate-instance (find-class 'standard-class))))
+  (let ((class (std-allocate-instance +the-standard-class+)))
     (%set-class-name name class)
     (%set-class-layout nil class)
     (%set-class-direct-subclasses ()  class)
@@ -569,7 +570,7 @@
       (dolist (writer (%slot-definition-writers direct-slot))
         (add-writer-method class writer (%slot-definition-name direct-slot)))))
   (setf (class-direct-default-initargs class) direct-default-initargs)
-  (funcall (if (eq (class-of class) (find-class 'standard-class))
+  (funcall (if (eq (class-of class) +the-standard-class+)
                #'std-finalize-inheritance
                #'finalize-inheritance)
            class)
@@ -613,7 +614,7 @@
                   (error "The symbol ~S names a built-in class." name))
                  ((typep old-class 'forward-referenced-class)
                   (let ((new-class (apply #'make-instance-standard-class
-                                          (find-class 'standard-class)
+                                          +the-standard-class+
                                           :name name all-keys)))
                     (%set-find-class name new-class)
                     (dolist (subclass (class-direct-subclasses old-class))
@@ -631,7 +632,7 @@
                                    #'make-instance
                                    #'make-instance-standard-class)
                                (or metaclass
-                                   (find-class 'standard-class))
+                                   +the-standard-class+)
                                :name name all-keys)))
              (%set-find-class name class)
              class)))))
@@ -1778,7 +1779,7 @@
 
 (defun add-reader-method (class function-name slot-name)
   (let* ((lambda-expression
-          (if (eq (class-of class) (find-class 'standard-class))
+          (if (eq (class-of class) +the-standard-class+)
               `(lambda (object) (std-slot-value object ',slot-name))
               `(lambda (object) (slot-value object ',slot-name))))
          (method-function (compute-method-function lambda-expression))
@@ -1805,7 +1806,7 @@
 
 (defun add-writer-method (class function-name slot-name)
   (let* ((lambda-expression
-          (if (eq (class-of class) (find-class 'standard-class))
+          (if (eq (class-of class) +the-standard-class+)
               `(lambda (new-value object)
                  (setf (std-slot-value object ',slot-name) new-value))
               `(lambda (new-value object)