From da304936655b6690b4ddf15fb2936fe3d219f2ac Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Tue, 17 Jul 2007 20:50:15 +0000 Subject: [PATCH] 1.0.7.27: SLOT-CLASS cleanups * No need for two separate implementations of FIND-SLOT-DEFINITION -- just move the one we care about to slots-boot.lisp along with MAKE-SLOT-VECTOR (which it is intimately tied up with.) Add comments for posterity. * There should be no (SETF CLASS-SLOTS) or (SETF CLASS-DIRECT-SLOTS), so :READER, not :ACCESSOR in SLOT-CLASS. --- src/pcl/defs.lisp | 26 ++-------------------- src/pcl/fixup.lisp | 12 ---------- src/pcl/slots-boot.lisp | 56 +++++++++++++++++++++++++++++++++++++++++++++++ src/pcl/slots.lisp | 6 +---- version.lisp-expr | 2 +- 5 files changed, 60 insertions(+), 42 deletions(-) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 9a718ab..e01064e 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -657,36 +657,14 @@ (defclass slot-class (pcl-class) ((direct-slots :initform () - :accessor class-direct-slots) + :reader class-direct-slots) (slots :initform () - :accessor class-slots) + :reader class-slots) (slot-vector :initform #(nil) :reader class-slot-vector))) -;;; Make the slot-vector accessed by the after-fixup FIND-SLOT-DEFINITION. -;;; The slot vector is a simple-vector containing plists of slot-definitions -;;; keyd by their names. Slot definitions are put in the position indicated -;;; by (REM (SXHASH SLOT-NAME) (LENGTH SLOT-VECTOR)). -;;; -;;; We make the vector slightly longer then the number of slots both -;;; to reduce collisions (but we're not too picky, really) and to -;;; allow FIND-SLOT-DEFINTIONS work on slotless classes without -;;; needing to check for zero-length vectors. -(defun make-slot-vector (slots) - (let* ((n (+ (length slots) 2)) - (vector (make-array n :initial-element nil))) - (flet ((add-to-vector (name slot) - (setf (svref vector (rem (sxhash name) n)) - (list* name slot (svref vector (rem (sxhash name) n)))))) - (if (eq 'complete *boot-state*) - (dolist (slot slots) - (add-to-vector (slot-definition-name slot) slot)) - (dolist (slot slots) - (add-to-vector (early-slot-definition-name slot) slot)))) - vector)) - ;;; The class STD-CLASS is an implementation-specific common ;;; superclass of the classes STANDARD-CLASS and ;;; FUNCALLABLE-STANDARD-CLASS. diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp index b7b4f21..e3d7f0a 100644 --- a/src/pcl/fixup.lisp +++ b/src/pcl/fixup.lisp @@ -35,15 +35,3 @@ (declare (ignore depth)) (print-object instance stream)) -;;; Access the slot-vector created by MAKE-SLOT-VECTOR. -(defun find-slot-definition (class slot-name) - (declare (symbol slot-name) (inline getf)) - (let* ((vector (class-slot-vector class)) - (index (rem (sxhash slot-name) (length vector)))) - (declare (simple-vector vector) (index index)) - (do ((plist (svref vector index) (cdr plist))) - ((not plist)) - (let ((key (car plist))) - (setf plist (cdr plist)) - (when (eq key slot-name) - (return (car plist))))))) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 6bef614..752b190 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -521,3 +521,59 @@ (setf (getf (getf initargs 'plist) :slot-name-lists) (list (list nil slot-name))) initargs)) + +;;;; FINDING SLOT DEFINITIONS +;;; +;;; Historical PCL found slot definitions by iterating over +;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover +;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in +;;; list up to the desired one. +;;; +;;; As of 1.0.7.26 SBCL hashes the effective slot definitions into a +;;; simple-vector, with bucket 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 +;;; effective slot definitions, and FIND-SLOT-DEFINITION knows how to +;;; look up slots in that vector. +;;; +;;; The only bit of cleverness in the implementation is to make the +;;; vectors fairly tight, but always longer then 0 elements: +;;; +;;; -- We don't want to waste huge amounts of space no these vectors, +;;; which are mostly required by things like SLOT-VALUE with a +;;; variable slot name, so a constant extension over the minimum +;;; size seems like a good choise. +;;; +;;; -- As long as the vector always has a length > 0 +;;; FIND-SLOT-DEFINITION doesn't need to handle the rare case of an +;;; empty vector separately: it just returns a NIL. + +(defun find-slot-definition (class slot-name) + (declare (symbol slot-name) (inline getf)) + (let* ((vector (class-slot-vector class)) + (index (rem (sxhash slot-name) (length vector)))) + (declare (simple-vector vector) (index index) + (optimize (sb-c::insert-array-bounds-checks 0))) + (do ((plist (the list (svref vector index)) (cdr plist))) + ((not (consp plist))) + (let ((key (car plist))) + (setf plist (cdr plist)) + (when (eq key slot-name) + (return (car plist))))))) + +(defun make-slot-vector (slots) + (let* ((n (+ (length slots) 2)) + (vector (make-array n :initial-element nil))) + (flet ((add-to-vector (name slot) + (declare (symbol name) + (optimize (sb-c::insert-array-bounds-checks 0))) + (setf (svref vector (rem (sxhash name) n)) + (list* name slot (svref vector (rem (sxhash name) n)))))) + (if (eq 'complete *boot-state*) + (dolist (slot slots) + (add-to-vector (slot-definition-name slot) slot)) + (dolist (slot slots) + (add-to-vector (early-slot-definition-name slot) slot)))) + vector)) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 266a085..da5f09d 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -75,11 +75,7 @@ (t (error "unrecognized instance type"))))) -(defun early-find-slot-definition (class slot-name) - (dolist (slot (class-slots class) nil) - (when (eql slot-name (slot-definition-name slot)) - (return slot)))) -(setf (fdefinition 'find-slot-definition) #'early-find-slot-definition) +;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) diff --git a/version.lisp-expr b/version.lisp-expr index 910b093..fb8db34 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.7.26" +"1.0.7.27" -- 1.7.10.4