X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=9f416cf8d8853e99e88711330d053b75ff5fd7bc;hb=ef716ee5409d0d55020aea422e29a9175c2b4b74;hp=e5e9d9530d115e43cabe3ea45a99dfa13b3f1d67;hpb=7474a620a5538091b9c1cba877156f5645d78aa6;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index e5e9d95..9f416cf 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -23,33 +23,42 @@ (in-package "SB-PCL") -(defun ensure-accessor (type fun-name slot-name) - (unless (fboundp fun-name) - (multiple-value-bind (lambda-list specializers method-class initargs doc) - (ecase type - ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING - ;; behaviour for non-slot-objects too? - (reader - (values '(object) '(slot-object) 'global-reader-method - (make-std-reader-method-function 'slot-object slot-name) - "automatically-generated reader method")) - (writer - (values '(new-value object) '(t slot-object) 'global-writer-method - (make-std-writer-method-function 'slot-object slot-name) - "automatically-generated writer method")) - (boundp - (values '(object) '(slot-object) 'global-boundp-method - (make-std-boundp-method-function 'slot-object slot-name) - "automatically-generated boundp method"))) - (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list))) - (add-method gf (make-a-method method-class - () lambda-list specializers - initargs doc :slot-name slot-name))))) - t) +(let ((reader-specializers '(slot-object)) + (writer-specializers '(t slot-object))) + (defun ensure-accessor (type fun-name slot-name) + (unless (fboundp fun-name) + (multiple-value-bind (lambda-list specializers method-class initargs doc) + (ecase type + ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING + ;; behaviour for non-slot-objects too? + (reader + (values '(object) reader-specializers 'global-reader-method + (make-std-reader-method-function 'slot-object slot-name) + "automatically-generated reader method")) + (writer + (values '(new-value object) writer-specializers + 'global-writer-method + (make-std-writer-method-function 'slot-object slot-name) + "automatically-generated writer method")) + (boundp + (values '(object) reader-specializers 'global-boundp-method + (make-std-boundp-method-function 'slot-object slot-name) + "automatically-generated boundp method"))) + (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list))) + (add-method gf (make-a-method method-class + () lambda-list specializers + initargs doc :slot-name slot-name))))) + t) + ;; KLUDGE: this is maybe PCL bootstrap mechanism #6 or #7, invented + ;; by CSR in June 2007. Making the bootstrap sane is getting higher + ;; on the "TODO: URGENT" list. + (defun !fix-ensure-accessor-specializers () + (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)))) @@ -58,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. @@ -75,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)))) @@ -512,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)) + (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))