X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=df80a18f11525f832edd4a9f4844bb0b27bdd8f0;hb=1ca4f69009204caee2484161e6eb89fa6c5fd3f6;hp=9f416cf8d8853e99e88711330d053b75ff5fd7bc;hpb=81e608991b9f616a412564b26186fa29933d814c;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 9f416cf..df80a18 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -64,7 +64,10 @@ (ensure-accessor 'reader ',reader-name ',slot-name)))) (declare (ignore .ignore.)) (truly-the (values t &optional) - (funcall #',reader-name ,object))))) + ;; Don't give a style-warning about undefined function here. + (funcall (locally (declare (muffle-conditions style-warning)) + #',reader-name) + ,object))))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) (aver (constantp slot-name env)) @@ -205,20 +208,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 +231,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 +461,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)))))))) @@ -470,7 +471,7 @@ initargs)) (defun make-std-writer-method-function (class-or-name slot-name) - (let* ((class (when (eq *boot-state* 'complete) + (let* ((class (when (eq **boot-state** 'complete) (if (typep class-or-name 'class) class-or-name (find-class class-or-name nil)))) @@ -489,17 +490,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,9 +511,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-boundp-internal .pv. instance-slots 0 (slot-boundp instance slot-name)))))))) @@ -529,14 +527,14 @@ ;;; 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. +;;; 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-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. +;;; 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: @@ -549,10 +547,29 @@ ;;; -- 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 (class-slot-vector class)) + (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))) @@ -563,15 +580,32 @@ (when (eq key slot-name) (return (car plist))))))) -(defun make-slot-vector (slots) +(defun make-slot-table (class slots &optional bootstrap) (let* ((n (+ (length slots) 2)) - (vector (make-array n :initial-element nil))) + (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))) - (setf (svref vector (rem (sxhash name) n)) - (list* name slot (svref vector (rem (sxhash name) n)))))) - (if (eq 'complete *boot-state*) + (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)