X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=b2b1f21dcf2aa5a0651b2e0a6b6731e33e2a0b94;hb=57b330cc8334015f9953d7fb82a30afc82d2a471;hp=8abdb899765688cc0f771ad770f7e283cbdd504d;hpb=990728854b8ba017888811d1b0453b15dfa8a581;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 8abdb89..b2b1f21 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -56,9 +56,9 @@ (setf reader-specializers (mapcar #'find-class reader-specializers)) (setf writer-specializers (mapcar #'find-class writer-specializers)))) -(defmacro accessor-slot-value (object slot-name) - (aver (constantp slot-name)) - (let* ((slot-name (constant-form-value slot-name)) +(defmacro accessor-slot-value (object slot-name &environment env) + (aver (constantp slot-name env)) + (let* ((slot-name (constant-form-value slot-name env)) (reader-name (slot-reader-name slot-name))) `(let ((.ignore. (load-time-value (ensure-accessor 'reader ',reader-name ',slot-name)))) @@ -67,14 +67,14 @@ (funcall #',reader-name ,object))))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) - (aver (constantp slot-name)) + (aver (constantp slot-name env)) (setq object (macroexpand object env)) - (setq slot-name (macroexpand slot-name env)) - (let* ((slot-name (constant-form-value slot-name)) - (bindings (unless (or (constantp new-value) (atom new-value)) - (let ((object-var (gensym))) - (prog1 `((,object-var ,object)) - (setq object object-var))))) + (let* ((slot-name (constant-form-value slot-name env)) + (bind-object (unless (or (constantp new-value env) (atom new-value)) + (let* ((object-var (gensym)) + (bind `((,object-var ,object)))) + (setf object object-var) + bind))) (writer-name (slot-writer-name slot-name)) (form `(let ((.ignore. @@ -84,13 +84,13 @@ (declare (ignore .ignore.)) (funcall #',writer-name .new-value. ,object) .new-value.))) - (if bindings - `(let ,bindings ,form) + (if bind-object + `(let ,bind-object ,form) form))) -(defmacro accessor-slot-boundp (object slot-name) - (aver (constantp slot-name)) - (let* ((slot-name (constant-form-value slot-name)) +(defmacro accessor-slot-boundp (object slot-name &environment env) + (aver (constantp slot-name env)) + (let* ((slot-name (constant-form-value slot-name env)) (boundp-name (slot-boundp-name slot-name))) `(let ((.ignore. (load-time-value (ensure-accessor 'boundp ',boundp-name ',slot-name)))) @@ -205,20 +205,22 @@ (slot-definition-class slotd) (safe-p (slot-definition-class slotd)))) (writer-fun (etypecase location - (fixnum (if fsc-p - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) - location) - nv)) - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) - location) - nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr location) nv))) + (fixnum + (if fsc-p + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv)))) + (cons + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (cdr location) nv))) (null (lambda (nv instance) (declare (ignore nv instance)) @@ -226,21 +228,18 @@ slotd '(setf slot-value-using-class)))))) (checking-fun (lambda (new-value instance) - (check-obsolete-instance instance) - ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it. - (let* (;; Note that this CLASS is not neccessarily - ;; the SLOT-DEFINITION-CLASS of the - ;; SLOTD passed to M-O-S-W-M-F, since it's - ;; e.g. possible for a subclass to define - ;; a slot of the same name but with no - ;; accessors. So we need to fetch the SLOTD - ;; when CHECKING-FUN is called, instead of - ;; just closing over it. - (class (class-of instance)) - (slotd (find-slot-definition class slot-name)) + ;; If we have a TYPE-CHECK-FUNCTION, call it. + (let* (;; Note that the class of INSTANCE here is not + ;; neccessarily the SLOT-DEFINITION-CLASS of + ;; the SLOTD passed to M-O-S-W-M-F, since it's + ;; e.g. possible for a subclass to define a + ;; slot of the same name but with no accessors. + ;; So we need to fetch the right type check function + ;; from the wrapper instead of just closing over it. + (wrapper (valid-wrapper-of instance)) (type-check-function - (when slotd - (slot-definition-type-check-function slotd)))) + (cadr (find-slot-cell wrapper slot-name)))) + (declare (type (or function null) type-check-function)) (when type-check-function (funcall type-check-function new-value))) ;; Then call the real writer. @@ -459,9 +458,8 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-read-internal .pv. instance-slots 0 (slot-value instance slot-name)))))))) @@ -489,17 +487,15 @@ (make-method-function (lambda (nv instance) (funcall check-fun nv instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 0 nv (setf (slot-value instance slot-name) nv))))) (make-method-function (lambda (nv instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 0 nv (setf (slot-value instance slot-name) nv))))))))) @@ -512,12 +508,103 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-boundp-internal .pv. instance-slots 0 (slot-boundp instance slot-name)))))))) (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. +;;; +;;; Current SBCL hashes the effective slot definitions, and some +;;; information pulled out from them 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-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. +;;; +;;; 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. +;;; +;;; In addition to the slot-definition we also store the slot-location +;;; and type-check function for instances of standard metaclasses, so +;;; that SLOT-VALUE &co using variable slot names can get at them +;;; without additional GF calls. +;;; +;;; Notes: +;;; It would be probably better to store the vector in wrapper +;;; instead: one less memory indirection, one less CLOS slot +;;; access to get at it. +;;; +;;; It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P +;;; generic instead of checking versus STANDARD-CLASS and +;;; FUNCALLABLE-STANDARD-CLASS. + +(defun find-slot-definition (class slot-name) + (dolist (slotd (class-slots class)) + (when (eq slot-name (slot-definition-name slotd)) + (return slotd)))) + +(defun find-slot-cell (wrapper slot-name) + (declare (symbol slot-name)) + (let* ((vector (layout-slot-table wrapper)) + (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-table (class slots &optional bootstrap) + (let* ((n (+ (length slots) 2)) + (vector (make-array n :initial-element nil)) + (save-slot-location-p + (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 (eq 'complete *boot-state*) (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* (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) + (svref vector index)))))) + (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))