diff --git a/src/CHANGELOG b/src/CHANGELOG index 5ec3d38ca..e83d88880 100644 --- a/src/CHANGELOG +++ b/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" diff --git a/src/clos/boot.lsp b/src/clos/boot.lsp index ba533a86a..5993fc283 100644 --- a/src/clos/boot.lsp +++ b/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 diff --git a/src/clos/inspect.lsp b/src/clos/inspect.lsp index b61bb5360..bbb680496 100644 --- a/src/clos/inspect.lsp +++ b/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) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 9b7606806..94d5320dc 100644 --- a/src/clos/kernel.lsp +++ b/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) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index bcff55e63..215b75f8f 100644 --- a/src/clos/method.lsp +++ b/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) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index dfd08bd07..d2a84dd7b 100644 --- a/src/clos/standard.lsp +++ b/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)))