From: Nikodemus Siivola Date: Sat, 8 Sep 2007 17:32:22 +0000 (+0000) Subject: 1.0.9.46: take pv-slot value from wrapper-slot-table X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8f52542e9da8faa2c2650d37e8cba0f13c3b1c0a;p=sbcl.git 1.0.9.46: take pv-slot value from wrapper-slot-table * Use NIL instead of T in the CAR of the SLOT-TABLE cells to indicate "slot location not saved for some reason". * Better slot location computation for SLOT-TABLES: remaining wrapper copies now also copy the slot-table, and bootstrapping computes the slot locations for rest of the interesting cases. * Use SLOT-TABLE to obtain the slot location for permutation vectors instead of WRAPPER-CLASS-SLOTS and WRAPPER-INSTANCE-SLOTS-LAYOUT. Faster, and slowly point the way to getting rid of WRAPPER/LAYOUT distinction. * We deal with slot names in permutation vectors: remove the unused code that computed things for non-slot-name places in them. --- diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index fd3f49a..2e0f11a 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -219,6 +219,8 @@ name class slots standard-effective-slot-definition-wrapper t)) + (setf (layout-slot-table wrapper) (make-slot-table class slots t)) + (case meta ((standard-class funcallable-standard-class) (!bootstrap-initialize-class @@ -310,7 +312,10 @@ slot-class)) (set-slot 'direct-slots direct-slots) (set-slot 'slots slots) - (setf (layout-slot-table wrapper) (make-slot-table class slots))) + (setf (layout-slot-table wrapper) + (make-slot-table class slots + (member metaclass-name + '(standard-class funcallable-standard-class))))) ;; For all direct superclasses SUPER of CLASS, make sure CLASS is ;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index b96dbd0..1baa572 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -530,7 +530,7 @@ ;;; chains made out of plists keyed by the slot names. This fixes ;;; gives O(1) performance, and avoid the GF calls. ;;; -;;; MAKE-SLOT-VECTOR constructs the hashed vector out of a list of +;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of ;;; effective slot definitions and the class they pertain to, and ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector. ;;; @@ -578,25 +578,27 @@ (when (eq key slot-name) (return (car plist))))))) -(defun make-slot-table (class slots) +(defun make-slot-table (class slots &optional bootstrap) (let* ((n (+ (length slots) 2)) (vector (make-array n :initial-element nil)) (save-slot-location-p - (when (eq 'complete *boot-state*) - (let ((metaclass (class-of class))) - (or (eq metaclass *the-class-standard-class*) - (eq metaclass *the-class-funcallable-standard-class*))))) - (save-type-check-function-p (and save-slot-location-p (safe-p class)))) + (or bootstrap + (when (eq 'complete *boot-state*) + (let ((metaclass (class-of class))) + (or (eq metaclass *the-class-standard-class*) + (eq metaclass *the-class-funcallable-standard-class*)))))) + (save-type-check-function-p + (unless bootstrap + (and save-slot-location-p (safe-p class))))) (flet ((add-to-vector (name slot) (declare (symbol name) (optimize (sb-c::insert-array-bounds-checks 0))) (let ((index (rem (sxhash name) n))) (setf (svref vector index) - (list* name (list* (if save-slot-location-p - (slot-definition-location slot) - ;; T tells SLOT-VALUE & SET-SLOT-VALUE - ;; that this is a non-standard class. - t) + (list* name (list* (when save-slot-location-p + (if bootstrap + (early-slot-definition-location slot) + (slot-definition-location slot))) (when save-type-check-function-p (slot-definition-type-check-function slot)) slot) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 2784334..ed6c25a 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -107,13 +107,13 @@ (funcallable-standard-instance-access object location))) ((consp location) (cdr location)) - ((eq t location) - (return-from slot-value - (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)))) ((not cell) (return-from slot-value (values (slot-missing (wrapper-class* wrapper) object slot-name 'slot-value)))) + ((not location) + (return-from slot-value + (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)))) (t (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) (if (eq +slot-unbound+ value) @@ -141,11 +141,11 @@ new-value))) ((consp location) (setf (cdr location) new-value)) - ((eq t location) - (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)) - new-value)) ((not cell) (slot-missing (wrapper-class* wrapper) object slot-name 'setf new-value)) + ((not location) + (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)) + new-value)) (t (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell)))) new-value) @@ -181,14 +181,14 @@ (funcallable-standard-instance-access object location))) ((consp location) (cdr location)) - ((eq t location) - (return-from slot-boundp - (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell)))) ((not cell) (return-from slot-boundp (and (slot-missing (wrapper-class* wrapper) object slot-name 'slot-boundp) t))) + ((not location) + (return-from slot-boundp + (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell)))) (t (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) (not (eq +slot-unbound+ value)))) @@ -211,10 +211,10 @@ +slot-unbound+))) ((consp location) (setf (cdr location) +slot-unbound+)) - ((eq t location) - (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell))) ((not cell) (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound)) + ((not location) + (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell))) (t (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell)))) object) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 04cdc98..f22b2b0 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -896,10 +896,10 @@ (update-lisp-class-layout class nwrapper) (setf (slot-value class 'slots) eslotds - (layout-slot-table nwrapper) (make-slot-table class eslotds) + (wrapper-slot-table nwrapper) (make-slot-table class eslotds) (wrapper-instance-slots-layout nwrapper) nlayout (wrapper-class-slots nwrapper) nwrapper-class-slots - (layout-length nwrapper) nslots + (wrapper-length nwrapper) nslots (slot-value class 'wrapper) nwrapper) (do* ((slots (slot-value class 'slots) (cdr slots)) (dupes nil)) @@ -1312,6 +1312,8 @@ (wrapper-instance-slots-layout owrapper)) (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) + (setf (wrapper-slot-table nwrapper) + (wrapper-slot-table owrapper)) (with-pcl-lock (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 9aef26d..27e6bfe 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -37,14 +37,6 @@ ;;;; to each such (GF . ARGS) tuple inside a method body, and use this ;;;; to cache effective method functions. -(defmacro instance-slot-index (wrapper slot-name) - `(let ((pos 0)) - (declare (fixnum pos)) - (block loop - (dolist (sn (wrapper-instance-slots-layout ,wrapper)) - (when (eq ,slot-name sn) (return-from loop pos)) - (incf pos))))) - (declaim (inline make-pv-table)) (defstruct (pv-table (:predicate pv-tablep) (:copier nil)) @@ -106,20 +98,9 @@ (and slotd (slot-accessor-std-p slotd type))))) -(defun compute-pv-slot (slot-name wrapper class class-slots) - (if (symbolp slot-name) - (when (optimize-slot-value-by-class-p class slot-name 'all) - (or (instance-slot-index wrapper slot-name) - (assq slot-name class-slots))) - (when (consp slot-name) - (case (first slot-name) - ((reader writer) - (when (eq *boot-state* 'complete) - (let ((gf (gdefinition (second slot-name)))) - (when (generic-function-p gf) - (accessor-values1 gf (first slot-name) class))))) - (t (bug "Don't know how to deal with ~S in ~S" - slot-name 'compute-pv-slots)))))) +(defun compute-pv-slot (slot-name wrapper class) + (when (optimize-slot-value-by-class-p class slot-name 'all) + (car (find-slot-cell wrapper slot-name)))) (defun compute-pv (slot-name-lists wrappers) (unless (listp wrappers) @@ -129,11 +110,10 @@ (when slot-names (let* ((wrapper (pop wrappers)) (std-p (typep wrapper 'wrapper)) - (class (wrapper-class* wrapper)) - (class-slots (and std-p (wrapper-class-slots wrapper)))) + (class (wrapper-class* wrapper))) (dolist (slot-name (cdr slot-names)) (push (if std-p - (compute-pv-slot slot-name wrapper class class-slots) + (compute-pv-slot slot-name wrapper class) nil) elements))))) (let* ((n (length elements)) @@ -180,13 +160,12 @@ (defun update-all-pv-table-caches (class slot-names) (let* ((cwrapper (class-wrapper class)) (std-p (typep cwrapper 'wrapper)) - (class-slots (and std-p (wrapper-class-slots cwrapper))) (new-values (mapcar (lambda (slot-name) (cons slot-name (if std-p - (compute-pv-slot slot-name cwrapper class class-slots) + (compute-pv-slot slot-name cwrapper class) nil))) slot-names)) (pv-tables nil)) diff --git a/version.lisp-expr b/version.lisp-expr index 6729757..b1458fb 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.9.45" +"1.0.9.46"