Fixed the optimizer for slot access. All classes have DOCUMENTATION slot. CLASS-PROTOTYPE is now a reader, not an accessor.

src/CHANGELOG

@@ -37,6 +37,9 @@ ECL 0.9f
  - Globals declared with DEFPARAMETER toplevel forms were not recognized by
    the compiler as special variables.
 
+ - Fixed the optimizer for slot access, which now only operates if the
+   variables have been declared of type STANDARD-OBJECT.
+
 * Foreign function interface (FFI):
 
  - ext:c-uint-max and ext:c-ulong-max did not have the right bignum value.
@@ -122,6 +125,8 @@ ECL 0.9f
    DIRECT/EFFECTIVE-SLOT-DEFINITION-CLASS. (Position field in slot-def. objects
    still missing).
 
+ - CLASS-PROTOTYPE is now only a reader.
+
 * Contributed modules:
 
  - MIT test unit rt.lisp is now available as #p"sys:rt"

src/clos/boot.lsp

@@ -17,7 +17,7 @@
 ;;; SLOT-VALUE does not work.
 
 (defun make-empty-standard-class (name metaclass)
-  (let ((class (si:allocate-raw-instance nil metaclass 12)))
+  (let ((class (si:allocate-raw-instance nil metaclass #.(length +standard-class-slots+))))
     (unless metaclass
       (si:instance-class-set class class))
     (setf (class-id                  class) name
@@ -29,10 +29,10 @@
 	  (class-default-initargs    class) nil
 	  (class-precedence-list     class) nil
 	  (class-finalized-p         class) t
-	  (slot-index-table          class) (make-hash-table :size 2)
-	  (class-shared-slots        class) nil
-	  (find-class name) class
-	  )
+	  (find-class name) class)
+    (unless (eq name 'T)
+      (setf (slot-index-table          class) (make-hash-table :size 2)
+	    (class-shared-slots        class) nil))
     class))
 
 ;; 1) Create the classes
@@ -43,7 +43,7 @@
 (let* ((standard-class (make-empty-standard-class 'STANDARD-CLASS nil))
        (standard-object (make-empty-standard-class 'STANDARD-OBJECT standard-class))
        (the-class (make-empty-standard-class 'CLASS standard-class))
-       (the-t (make-empty-standard-class 'T standard-class))
+       (the-t (make-empty-standard-class 'T the-class))
        (class-slots (mapcar #'canonical-slot-to-direct-slot (parse-slots '#.+class-slots+)))
        (standard-slots (mapcar #'canonical-slot-to-direct-slot
 				  (parse-slots '#.+standard-class-slots+)))
@@ -88,9 +88,14 @@
   ;; 5) Generate accessors (In macros.lsp)
 )
 
-(defmethod OPTIMIZE-SLOT-VALUE ((class t) form) form)
+(defmethod class-prototype ((class class))
+  (unless (slot-boundp class 'prototype)
+    (setf (slot-value class 'prototype) (allocate-instance class)))
+  (slot-value class 'prototype))
 
-(defmethod OPTIMIZE-SET-SLOT-VALUE ((class t) form) form)
+(defmethod OPTIMIZE-SLOT-VALUE ((prototype t) form) form)
+
+(defmethod OPTIMIZE-SET-SLOT-VALUE ((prototype t) form) form)
 
 ;;; ----------------------------------------------------------------------
 ;;; SLOTS READING AND WRITING

src/clos/inspect.lsp

@@ -456,7 +456,7 @@ q (or Q):             quits the inspection.~%~
     (si::set-documentation object 'package new-value)))
 
 (defmethod documentation ((object class) doc-type)
-  (when (member doc-type '(t type))
+  (when (and (member doc-type '(t type)) (slot-boundp object 'documentation))
     (slot-value object 'documentation)))
 
 (defmethod (setf documentation) (new-value (object class) doc-type)

src/clos/kernel.lsp

@@ -57,7 +57,8 @@
        :initform nil :accessor class-direct-default-initargs)
       (default-initargs :accessor class-default-initargs)
       (finalized :initform nil :accessor class-finalized-p)
-      (prototype :accessor class-prototype))))
+      (documentation :initarg :documentation :initform nil)
+      (prototype))))
 
 #.(create-accessors +class-slots+ 'class)
 
@@ -69,7 +70,6 @@
     (append +class-slots+
 	    '((slot-index-table :accessor slot-index-table)
 	      (shared-slots :initform nil :accessor class-shared-slots)
-	      (documentation :initarg :documentation :initform nil)
 	      (forward)))))
 
 #.(create-accessors +standard-class-slots+ 'standard-class)

src/clos/method.lsp

@@ -234,10 +234,10 @@
 		   ((and (eq (car form) 'SLOT-VALUE)
 			 (symbolp (second form))
 			 (constantp (third form)))
-		    (multiple-value-bind (ignore class)
+		    (multiple-value-bind (ignore prototype)
 			(can-optimize-access (second form) env)
-		      (if class
-			  (optimize-slot-value class form)
+		      (if prototype
+			  (optimize-slot-value prototype form)
 			  form)))
 		   ;; does not work for (push x (slot-value y 's))
 		   ;; and similia, since push is turned into
@@ -259,14 +259,14 @@
 					'SLOT-VALUE)
 				    (symbolp (second instance-access))
 				    (constantp (third instance-access)))
-			       (multiple-value-bind (ignore class)
+			       (multiple-value-bind (ignore prototype)
 				   (can-optimize-access
 				    (second instance-access) env)
 				 (let ((new-form
 					(list 'SETF instance-access
 					      value)))
-				   (if class
-				       (optimize-set-slot-value class
+				   (if prototype
+				       (optimize-set-slot-value prototype
 								new-form)
 				       new-form)))
 			       (list 'SETF instance-access value))
@@ -284,11 +284,11 @@
 				  form))
 			    form)))
 		   ((eq (car form) 'STANDARD-INSTANCE-ACCESS)
-		    (multiple-value-bind (parameter class)
+		    (multiple-value-bind (parameter prototype)
 			(can-optimize-access (second form) env)
-		      (if class
+		      (if prototype
 			  (optimize-standard-instance-access
-			   class parameter form slots)
+			   (class-of prototype) parameter form slots)
 			  form)))
 		   (t form))))
       (values (walk-form method-lambda env #'walk-function)
@@ -629,12 +629,14 @@
   (declare (si::c-local))
   ;; (values required-parameter class)
   (let ((required-parameter?
-	  (or (third (variable-declaration 'VARIABLE-REBINDING var env))
-	      var)))
-    (if required-parameter?
-	(values required-parameter?
-		(find-class (variable-class required-parameter? env) 'NIL))
-	(values nil nil))))
+	 (or (third (variable-declaration 'VARIABLE-REBINDING var env))
+		  var))
+	(class-prototype nil))
+    (when required-parameter?
+      (let ((class (find-class (variable-class required-parameter? env) 'NIL)))
+	(when class
+	  (setf class-prototype (class-prototype class)))))
+    (values required-parameter? class-prototype)))
 
 
 (defun optimize-standard-instance-access (class parameter form slots)

src/clos/standard.lsp

@@ -219,8 +219,7 @@ because it contains a reference to the undefined class~%  ~A"
     (setf (class-precedence-list class) cpl
 	  (class-slots class) (compute-slots class)
 	  (class-default-initargs class) (compute-default-initargs class)
-	  (class-finalized-p class) t
-	  (class-prototype class) (allocate-instance class))
+	  (class-finalized-p class) t)
     ;;
     ;; This is not really needed, because when we modify the list of slots
     ;; all instances automatically become obsolete (See change.lsp)
@@ -592,13 +591,13 @@ because it contains a reference to the undefined class~%  ~A"
 ;;; ----------------------------------------------------------------------
 ;;;                                                             optimizers
 
-(defmethod OPTIMIZE-SLOT-VALUE ((class standard-class) form)
+(defmethod OPTIMIZE-SLOT-VALUE ((prototype standard-object) form)
   (let* ((instance (second form))
 	 (slot-name (third form)))
     `(standard-instance-access ,instance
 			       ',(reduce-constant slot-name) . ,(cdddr form))))
 
-(defmethod OPTIMIZE-SET-SLOT-VALUE ((class standard-class) form)
+(defmethod OPTIMIZE-SET-SLOT-VALUE ((prototype standard-object) form)
   (let* ((instance (cadadr form))
 	 (slot-name (caddr (second form)))
 	 (new-value (third form)))