X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=2fa4b85e40f1f00b2543420f2926375b249a79c6;hb=1540c1c1d517c58fa9a41629beb65cdce7dfafb6;hp=9aef26daaac3af87d6f4ecd142a7855b286861ec;hpb=ee90e535c985f697c71d839083aed16710f846fd;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 9aef26d..2fa4b85 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)) @@ -63,63 +55,47 @@ ;;; used. (defvar *pv-tables* (make-hash-table :test 'equal)) -;;; Indexes PV-TABLES by indivisual slot names used. -(defvar *pv-tables-by-slots* (make-hash-table :test 'equal)) - -;;; ...and one lock to rule them. Spinlock because for certain (rare) +;;; ...and one lock to rule them. Lock because for certain (rare) ;;; cases this lock might be grabbed in the course of method dispatch -;;; -- and mostly this is already under the *big-compiler-lock*. +;;; -- and mostly this is already under the *world-lock* (defvar *pv-lock* - (sb-thread::make-spinlock :name "pv table index lock")) + (sb-thread:make-mutex :name "pv table index lock")) (defun intern-pv-table (&key slot-name-lists) - (let ((new-p nil)) - (flet ((intern-slot-names (slot-names) - (or (gethash slot-names *slot-name-lists*) - (setf (gethash slot-names *slot-name-lists*) slot-names))) - (%intern-pv-table (snl) - (or (gethash snl *pv-tables*) - (setf (gethash snl *pv-tables*) - (progn - (setq new-p t) - (make-pv-table :slot-name-lists snl)))))) - (sb-thread::with-spinlock (*pv-lock*) - (let ((pv-table - (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))) - (when new-p - (let ((pv-index 0)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (pushnew pv-table (gethash slot-name *pv-tables-by-slots*)) - (incf pv-index))) - (setf (pv-table-pv-size pv-table) pv-index))) - pv-table))))) - -(defun map-pv-table-references-of (slot-name function) - (dolist (table (sb-thread::with-spinlock (*pv-lock*) - (gethash slot-name *pv-tables-by-slots*))) - (funcall function table))) + (flet ((intern-slot-names (slot-names) + ;; FIXME: NIL at the head of the list is a remnant from + ;; old purged code, that hasn't been quite cleaned up yet. + ;; ...but as long as we assume it is there, we may as well + ;; assert it. + (aver (not (car slot-names))) + (or (gethash slot-names *slot-name-lists*) + (setf (gethash slot-names *slot-name-lists*) slot-names))) + (%intern-pv-table (snl) + (or (gethash snl *pv-tables*) + (setf (gethash snl *pv-tables*) + (make-pv-table :slot-name-lists snl + :pv-size (* 2 (reduce #'+ snl + :key (lambda (slots) + (length (cdr slots)))))))))) + (sb-thread:with-mutex (*pv-lock*) + (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))) -(defun optimize-slot-value-by-class-p (class slot-name type) - (or (not (eq *boot-state* 'complete)) - (let ((slotd (find-slot-definition class slot-name))) - (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 use-standard-slot-access-p (class slot-name type) + (or (not (eq **boot-state** 'complete)) + (and (standard-class-p class) + (let ((slotd (find-slot-definition class slot-name))) + (and slotd + (slot-accessor-std-p slotd type)))))) + +(defun slot-missing-info (class slot-name) + (flet ((missing (operation) + (lambda (object) + (slot-missing class object slot-name operation)))) + (make-slot-info + :reader (missing 'slot-value) + :boundp (missing 'slot-boundp) + :writer (lambda (new-value object) + (slot-missing class object slot-name 'setf new-value))))) (defun compute-pv (slot-name-lists wrappers) (unless (listp wrappers) @@ -129,13 +105,17 @@ (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) - nil) - elements))))) + (let ((cell + (or (find-slot-cell wrapper slot-name) + (cons nil (slot-missing-info class slot-name))))) + (push (when (and std-p (use-standard-slot-access-p class slot-name 'all)) + (car cell)) + elements) + (push (or (cdr cell) + (bug "No SLOT-INFO for ~S in ~S" slot-name class)) + elements)))))) (let* ((n (length elements)) (pv (make-array n))) (loop for i from (1- n) downto 0 @@ -163,109 +143,62 @@ (defun make-pv-type-declaration (var) `(type simple-vector ,var)) - -(defvar *pv-table-cache-update-info* nil) - -(defun update-pv-table-cache-info (class) - (let ((slot-names-for-pv-table-update nil) - (new-icui nil)) - (dolist (icu *pv-table-cache-update-info*) - (if (eq (car icu) class) - (pushnew (cdr icu) slot-names-for-pv-table-update) - (push icu new-icui))) - (setq *pv-table-cache-update-info* new-icui) - (when slot-names-for-pv-table-update - (update-all-pv-table-caches class slot-names-for-pv-table-update)))) - -(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) - nil))) - slot-names)) - (pv-tables nil)) - (dolist (slot-name slot-names) - (map-pv-table-references-of - slot-name - (lambda (pv-table) - (pushnew pv-table pv-tables)))) - (dolist (pv-table pv-tables) - (let* ((cache (pv-table-cache pv-table)) - (slot-name-lists (pv-table-slot-name-lists pv-table)) - (pv-size (pv-table-pv-size pv-table)) - (pv-map (make-array pv-size :initial-element nil))) - (let ((map-index 0) (param-index 0)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (let ((a (assoc slot-name new-values))) - (setf (svref pv-map map-index) - (and a (cons param-index (cdr a))))) - (incf map-index)) - (incf param-index))) - (when cache - (map-cache (lambda (wrappers pv) - (update-slots-in-pv wrappers pv - cwrapper pv-size pv-map)) - cache)))))) - -(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) - (if (atom wrappers) - (when (eq cwrapper wrappers) - (dotimes-fixnum (i pv-size) - (let ((map (svref pv-map i))) - (when map - (aver (= (car map) 0)) - (setf (svref pv i) (cdr map)))))) - (when (memq cwrapper wrappers) - (let ((param 0)) - (dolist (wrapper wrappers) - (when (eq wrapper cwrapper) - (dotimes-fixnum (i pv-size) - (let ((map (svref pv-map i))) - (when (and map (= (car map) param)) - (setf (svref pv i) (cdr map)))))) - (incf param)))))) +;;; Sometimes we want to finalize if we can, but it's OK if +;;; we can't. +(defun try-finalize-inheritance (class) + (unless (typep class 'forward-referenced-class) + (when (every (lambda (super) + (or (eq super class) + (class-finalized-p super) + (try-finalize-inheritance super))) + (class-direct-superclasses class)) + (finalize-inheritance class) + t))) + (defun can-optimize-access (form required-parameters env) (destructuring-bind (op var-form slot-name-form &optional new-value) form - (let ((type (ecase op - (slot-value 'reader) - (set-slot-value 'writer) - (slot-boundp 'boundp))) - (var (extract-the var-form)) - (slot-name (constant-form-value slot-name-form env))) - (when (symbolp var) - (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env))) - (parameter-or-nil (car (memq (or rebound? var) - required-parameters)))) - (when parameter-or-nil - (let* ((class-name (caddr (var-declaration '%class - parameter-or-nil - env))) - (class (find-class class-name nil))) - (when (or (not (eq *boot-state* 'complete)) - (and class (not (class-finalized-p class)))) - (setq class nil)) - (when (and class-name (not (eq class-name t))) - (when (or (null type) - (not (and class - (memq *the-class-structure-object* - (class-precedence-list class)))) - (optimize-slot-value-by-class-p class slot-name type)) - (values (cons parameter-or-nil (or class class-name)) - slot-name - new-value)))))))))) + (let ((type (ecase op + (slot-value 'reader) + (set-slot-value 'writer) + (slot-boundp 'boundp))) + (var (extract-the var-form)) + (slot-name (constant-form-value slot-name-form env))) + (when (and (symbolp var) (not (var-special-p var env))) + (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env))) + (parameter-or-nil (car (memq (or rebound? var) + required-parameters)))) + (when parameter-or-nil + (let* ((class-name (caddr (var-declaration '%class + parameter-or-nil + env))) + (class (find-class class-name nil))) + (cond ((not (eq **boot-state** 'complete)) + (setq class nil)) + ((and class (not (class-finalized-p class))) + ;; The class itself is never forward-referenced + ;; here, but its superclasses may be. + (unless (try-finalize-inheritance class) + (when (boundp 'sb-c:*lexenv*) + (sb-c:compiler-notify + "~@" + class form)) + (setf class nil)))) + (when (and class-name (not (eq class-name t))) + (when (not (and class + (memq *the-class-structure-object* + (class-precedence-list class)))) + (aver type) + (values (cons parameter-or-nil (or class class-name)) + slot-name + new-value)))))))))) ;;; Check whether the binding of the named variable is modified in the ;;; method body. (defun parameter-modified-p (parameter-name env) - (let ((modified-variables (macroexpand '%parameter-binding-modified env))) + (let ((modified-variables (%macroexpand '%parameter-binding-modified env))) (memq parameter-name modified-variables))) (defun optimize-slot-value (form slots required-parameters env) @@ -275,24 +208,24 @@ (let ((optimized-form (optimize-instance-access slots :read sparameter slot-name nil))) - ;; We don't return the optimized form directly, since there's - ;; still a chance that we'll find out later on that the - ;; optimization should not have been done, for example due to - ;; the walker encountering a SETQ on SPARAMETER later on in - ;; the body [ see for example clos.impure.lisp test with :name - ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer - ;; the decision until the compiler macroexpands - ;; OPTIMIZED-SLOT-VALUE. - ;; - ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at - ;; this point (instead of when expanding - ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of - ;; SLOTS. If that mutation isn't done during the walking, - ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING - ;; form around the body, and compilation will fail. -- JES, - ;; 2006-09-18 - `(optimized-slot-value ,form ,(car sparameter) ,optimized-form)) - `(accessor-slot-value ,@(cdr form))))) + ;; We don't return the optimized form directly, since there's + ;; still a chance that we'll find out later on that the + ;; optimization should not have been done, for example due to + ;; the walker encountering a SETQ on SPARAMETER later on in + ;; the body [ see for example clos.impure.lisp test with :name + ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer + ;; the decision until the compiler macroexpands + ;; OPTIMIZED-SLOT-VALUE. + ;; + ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at + ;; this point (instead of when expanding + ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of + ;; SLOTS. If that mutation isn't done during the walking, + ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING + ;; form around the body, and compilation will fail. -- JES, + ;; 2006-09-18 + `(optimized-slot-value ,form ,(car sparameter) ,optimized-form)) + `(accessor-slot-value ,@(cdr form))))) (defmacro optimized-slot-value (form parameter-name optimized-form &environment env) @@ -308,21 +241,19 @@ (if sparameter (let ((optimized-form (optimize-instance-access slots :write sparameter - slot-name new-value))) + slot-name new-value (safe-code-p env)))) ;; See OPTIMIZE-SLOT-VALUE `(optimized-set-slot-value ,form ,(car sparameter) ,optimized-form)) `(accessor-set-slot-value ,@(cdr form))))) (defmacro optimized-set-slot-value (form parameter-name optimized-form &environment env) - (cond ((safe-code-p env) - ;; Don't optimize slot value setting in safe code, since the - ;; optimized version will fail to catch some type errors - ;; (for example when a subclass declares a tighter type for - ;; the slot than a superclass). - `(safe-set-slot-value ,@(cdr form))) - ((parameter-modified-p parameter-name env) - `(accessor-set-slot-value ,@(cdr form))) + (cond ((parameter-modified-p parameter-name env) + ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking, + ;; so we need to use SAFE-SET-SLOT-VALUE. + (if (safe-code-p env) + `(safe-set-slot-value ,@(cdr form))) + `(accessor-set-slot-value ,@(cdr form))) (t optimized-form))) @@ -347,14 +278,11 @@ ;;; of a required parameter to the function. The alist is in order, so ;;; the position of an entry in the alist corresponds to the ;;; argument's position in the lambda list. -(defun optimize-instance-access (slots - read/write - sparameter - slot-name - new-value) +(defun optimize-instance-access (slots read/write sparameter slot-name + new-value &optional safep) (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) (parameter (if (consp sparameter) (car sparameter) sparameter))) - (if (and (eq *boot-state* 'complete) + (if (and (eq **boot-state** 'complete) (classp class) (memq *the-class-structure-object* (class-precedence-list class))) (let ((slotd (find-slot-definition class slot-name))) @@ -384,7 +312,7 @@ (:write `(let ((.new-value. ,new-value)) (instance-write ,pv-offset-form ,parameter ,position - ',slot-name ',class .new-value.))) + ',slot-name ',class .new-value. ,safep))) (:boundp `(instance-boundp ,pv-offset-form ,parameter ,position ',slot-name ',class))))))) @@ -400,122 +328,185 @@ (let ((class (and (constantp class-form) (constant-form-value class-form))) (slot-name (and (constantp slot-name-form) (constant-form-value slot-name-form)))) - (and (eq *boot-state* 'complete) + (and (eq **boot-state** 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) (and slotd (eq :class (slot-definition-allocation slotd))))))) -(defun skip-fast-slot-access-p (class-form slot-name-form type) - (let ((class (and (constantp class-form) (constant-form-value class-form))) - (slot-name (and (constantp slot-name-form) - (constant-form-value slot-name-form)))) - (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - ;; FIXME: Is this really right? "Don't skip if there is - ;; no slot definition." - (let ((slotd (find-slot-definition class slot-name))) - (and slotd - (not (slot-accessor-std-p slotd type))))))) - -(defmacro instance-read-internal (pv slots pv-offset default &optional kind) - (unless (member kind '(nil :instance :class :default)) - (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind)) - (if (eq kind :default) - default - (let* ((index (gensym)) - (value index)) - `(locally (declare #.*optimize-speed*) - (let ((,index (svref ,pv ,pv-offset))) - (setq ,value (typecase ,index - ;; FIXME: the line marked by KLUDGE below - ;; (and the analogous spot in - ;; INSTANCE-WRITE-INTERNAL) is there purely - ;; to suppress a type mismatch warning that - ;; propagates through to user code. - ;; Presumably SLOTS at this point can never - ;; actually be NIL, but the compiler seems - ;; to think it could, so we put this here - ;; to shut it up. (see also mail Rudi - ;; Schlatte sbcl-devel 2003-09-21) -- CSR, - ;; 2003-11-30 - ,@(when (or (null kind) (eq kind :instance)) - `((fixnum - (and ,slots ; KLUDGE - (clos-slots-ref ,slots ,index))))) - ,@(when (or (null kind) (eq kind :class)) - `((cons (cdr ,index)))) - (t +slot-unbound+))) - (if (eq ,value +slot-unbound+) - ,default - ,value)))))) +(defun constant-value-or-nil (form) + (and (constantp form) (constant-form-value form))) + +(defun slot-access-strategy (class slot-name type &optional conservative) + ;; CONSERVATIVE means we should assume custom access pattern even if + ;; there are no custom accessors defined if the metaclass is non-standard. + ;; + ;; This is needed because DEFCLASS generates accessor methods before possible + ;; SLOT-VALUE-USING-CLASS methods are defined, which causes them to take + ;; the slow path unless we make the conservative assumption here. + (if (eq **boot-state** 'complete) + (let (slotd) + (cond ((or + ;; Conditions, structures, and classes for which FIND-CLASS + ;; doesn't return them yet. + ;; FIXME: surely we can get faster accesses for structures? + (not (standard-class-p class)) + ;; Should not happen... (FIXME: assert instead?) + (eq class *the-class-t*) + (not (class-finalized-p class)) + ;; Strangeness... + (not (setf slotd (find-slot-definition class slot-name)))) + :accessor) + ((and (slot-accessor-std-p slotd type) + (or (not conservative) (eq *the-class-standard-class* (class-of class)))) + ;; The best case. + :standard) + (t + :custom))) + :standard)) + +;;;; SLOT-VALUE (defmacro instance-read (pv-offset parameter position slot-name class) - (if (skip-fast-slot-access-p class slot-name 'reader) - `(accessor-slot-value ,parameter ,slot-name) - `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-value ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) - -(defmacro instance-write-internal (pv slots pv-offset new-value default - &optional kind) - (unless (member kind '(nil :instance :class :default)) - (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind)) - (if (eq kind :default) - default - (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (svref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null kind) (eq kind :instance)) - `((fixnum (and ,slots - (setf (clos-slots-ref ,slots ,index) - ,new-value))))) - ,@(when (or (null kind) (eq kind :class)) - `((cons (setf (cdr ,index) ,new-value)))) - (t ,default))))))) - -(defmacro instance-write (pv-offset - parameter - position - slot-name - class - new-value) - (if (skip-fast-slot-access-p class slot-name 'writer) - `(accessor-set-slot-value ,parameter ,slot-name ,new-value) - `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (accessor-set-slot-value ,parameter ,slot-name ,new-value) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) - -(defmacro instance-boundp-internal (pv slots pv-offset default - &optional kind) - (unless (member kind '(nil :instance :class :default)) - (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind)) - (if (eq kind :default) - default - (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (svref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null kind) (eq kind :instance)) - `((fixnum (not (and ,slots - (eq (clos-slots-ref ,slots ,index) - +slot-unbound+)))))) - ,@(when (or (null kind) (eq kind :class)) - `((cons (not (eq (cdr ,index) +slot-unbound+))))) - (t ,default))))))) + (ecase (slot-access-strategy (constant-value-or-nil class) + (constant-value-or-nil slot-name) + 'reader) + (:standard + `(instance-read-standard + .pv. ,(slot-vector-symbol position) + ,pv-offset (accessor-slot-value ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance))) + (:custom + `(instance-read-custom .pv. ,pv-offset ,parameter)) + (:accessor + `(accessor-slot-value ,parameter ,slot-name)))) + +(defmacro instance-read-standard (pv slots pv-offset default &optional kind) + (unless (member kind '(nil :instance :class)) + (error "illegal kind argument to ~S: ~S" 'instance-read-standard kind)) + (let* ((index (gensym)) + (value index)) + `(locally (declare #.*optimize-speed*) + (let ((,index (svref ,pv ,pv-offset)) + (,slots (truly-the simple-vector ,slots))) + (setq ,value (typecase ,index + ;; FIXME: the line marked by KLUDGE below (and + ;; the analogous spot in + ;; INSTANCE-WRITE-STANDARD) is there purely to + ;; suppress a type mismatch warning that + ;; propagates through to user code. + ;; Presumably SLOTS at this point can never + ;; actually be NIL, but the compiler seems to + ;; think it could, so we put this here to shut + ;; it up. (see also mail Rudi Schlatte + ;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30 + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum + (clos-slots-ref ,slots ,index)))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (cdr ,index)))) + (t + +slot-unbound+))) + (if (eq ,value +slot-unbound+) + ,default + ,value))))) + +(defmacro instance-read-custom (pv pv-offset parameter) + `(locally (declare #.*optimize-speed*) + (funcall (slot-info-reader (svref ,pv (1+ ,pv-offset))) ,parameter))) + +;;;; (SETF SLOT-VALUE) + +(defmacro instance-write (pv-offset parameter position slot-name class new-value + &optional check-type-p) + (ecase (slot-access-strategy (constant-value-or-nil class) + (constant-value-or-nil slot-name) + 'writer) + (:standard + `(instance-write-standard + .pv. ,(slot-vector-symbol position) + ,pv-offset ,new-value + ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form + ;; is executed (if it is executed). + (accessor-set-slot-value ,parameter ,slot-name .good-new-value.) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance) + ,check-type-p)) + (:custom + `(instance-write-custom .pv. ,pv-offset ,parameter ,new-value)) + (:accessor + (if check-type-p + ;; FIXME: We don't want this here. If it's _possible_ the fast path + ;; is applicable, we want to use it as well. + `(safe-set-slot-value ,parameter ,slot-name ,new-value) + `(accessor-set-slot-value ,parameter ,slot-name ,new-value))))) + +(defmacro instance-write-standard (pv slots pv-offset new-value default + &optional kind safep) + (unless (member kind '(nil :instance :class)) + (error "illegal kind argument to ~S: ~S" 'instance-write-standard kind)) + (let* ((index (gensym)) + (new-value-form + (if safep + `(let ((.typecheckfun. (slot-info-typecheck (svref ,pv (1+ ,pv-offset))))) + (declare (type (or function null) .typecheckfun.)) + (if .typecheckfun. + (funcall .typecheckfun. ,new-value) + ,new-value)) + new-value))) + `(locally (declare #.*optimize-speed*) + (let ((.good-new-value. ,new-value-form) + (,index (svref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum (and ,slots + (setf (clos-slots-ref ,slots ,index) + .good-new-value.))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (setf (cdr ,index) .good-new-value.)))) + (t ,default)))))) + +(defmacro instance-write-custom (pv pv-offset parameter new-value) + `(locally (declare #.*optimize-speed*) + (funcall (slot-info-writer (svref ,pv (1+ ,pv-offset))) ,new-value ,parameter))) + +;;;; SLOT-BOUNDP (defmacro instance-boundp (pv-offset parameter position slot-name class) - (if (skip-fast-slot-access-p class slot-name 'boundp) - `(accessor-slot-boundp ,parameter ,slot-name) - `(instance-boundp-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - :class :instance)))) + (ecase (slot-access-strategy (constant-value-or-nil class) + (constant-value-or-nil slot-name) + 'boundp) + (:standard + `(instance-boundp-standard + .pv. ,(slot-vector-symbol position) + ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance))) + (:custom + `(instance-boundp-custom .pv. ,pv-offset ,parameter)) + (:accessor + `(accessor-slot-boundp ,parameter ,slot-name)))) + +(defmacro instance-boundp-standard (pv slots pv-offset default + &optional kind) + (unless (member kind '(nil :instance :class)) + (error "illegal kind argument to ~S: ~S" 'instance-boundp-standard kind)) + (let* ((index (gensym))) + `(locally (declare #.*optimize-speed*) + (let ((,index (svref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum (not (and ,slots + (eq (clos-slots-ref ,slots ,index) + +slot-unbound+)))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (not (eq (cdr ,index) +slot-unbound+))))) + (t ,default)))))) + +(defmacro instance-boundp-custom (pv pv-offset parameter) + `(locally (declare #.*optimize-speed*) + (funcall (slot-info-boundp (svref ,pv (1+ ,pv-offset))) ,parameter))) ;;; This magic function has quite a job to do indeed. ;;; @@ -551,7 +542,9 @@ (dolist (slot-entry (cdr parameter-entry)) (incf pv-offset) (dolist (form (cdr slot-entry)) - (setf (cadr form) pv-offset)))) + (setf (cadr form) pv-offset)) + ;; Count one more for the slot we use for SLOT-INFO. + (incf pv-offset))) sorted-slots)) (defun symbol-pkg-name (sym) @@ -634,123 +627,58 @@ ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT ;; symbol-macrolet. (if (eq (macroexpand 'pv-env-environment env) 'default) - `(locally ,@forms) + `(locally (declare (simple-vector .pv.)) + ,@forms) `(let* ((.pv-table. ,pv-table-form) (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))) (declare ,(make-pv-type-declaration '.pv.)) ,@forms))) -(defvar *non-var-declarations* - ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I - ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If - ;; SBCL doesn't have 'em, VALUES should probably be removed from - ;; this list. - '(values - %method-name - %method-lambda-list - optimize - ftype - muffle-conditions - inline - notinline)) - -(defvar *var-declarations-with-arg* - '(%class - type)) - -(defvar *var-declarations-without-arg* - '(ignore - ignorable special dynamic-extent - ;; FIXME: Possibly this entire list and variable could go away. - ;; If not, certainly we should remove all these built-in typenames - ;; from the list, and replace them with a test for "is it a type - ;; name?" (CLTL1 allowed only built-in type names as declarations, - ;; but ANSI CL allows any type name as a declaration.) - array atom base-char bignum bit bit-vector character compiled-function - complex cons double-float extended-char - fixnum float function hash-table integer - keyword list long-float nil null number package pathname random-state ratio - rational readtable sequence short-float signed-byte simple-array - simple-bit-vector simple-string simple-vector single-float standard-char - stream string symbol t unsigned-byte vector)) - -(defun split-declarations (body args maybe-reads-params-p) +(defun split-declarations (body args req-args cnm-p parameters-setqd) (let ((inner-decls nil) (outer-decls nil) decl) - (loop (when (null body) (return nil)) - (setq decl (car body)) - (unless (and (consp decl) - (eq (car decl) 'declare)) - (return nil)) - (dolist (form (cdr decl)) - (when (consp form) - (let ((declaration-name (car form))) - (if (member declaration-name *non-var-declarations*) - (push `(declare ,form) outer-decls) - (let ((arg-p - (member declaration-name - *var-declarations-with-arg*)) - (non-arg-p - (member declaration-name - *var-declarations-without-arg*)) - (dname (list (pop form))) - (inners nil) (outers nil)) - (unless (or arg-p non-arg-p) - ;; FIXME: This warning, and perhaps the - ;; various *VAR-DECLARATIONS-FOO* and/or - ;; *NON-VAR-DECLARATIONS* variables, - ;; could probably go away now that we're not - ;; trying to be portable between different - ;; CLTL1 hosts the way PCL was. (Note that to - ;; do this right, we need to be able to handle - ;; user-defined (DECLAIM (DECLARATION FOO)) - ;; stuff.) - (warn "The declaration ~S is not understood by ~S.~@ - Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ - (Assuming it is a variable declaration without argument)." - declaration-name 'split-declarations - declaration-name - '*non-var-declarations* - '*var-declarations-with-arg* - '*var-declarations-without-arg*) - (push declaration-name *var-declarations-without-arg*)) - (when arg-p - (setq dname (append dname (list (pop form))))) - (case (car dname) - (%class (push `(declare (,@dname ,@form)) inner-decls)) - (t - (dolist (var form) - (if (member var args) - ;; Quietly remove IGNORE declarations - ;; on args when a next-method is - ;; involved, to prevent compiler - ;; warnings about ignored args being - ;; read. - (unless (and maybe-reads-params-p - (eq (car dname) 'ignore)) - (push var outers)) - (push var inners))) - (when outers - (push `(declare (,@dname ,@outers)) outer-decls)) - (when inners - (push - `(declare (,@dname ,@inners)) - inner-decls))))))))) - (setq body (cdr body))) + (loop + (when (null body) + (return nil)) + (setq decl (car body)) + (unless (and (consp decl) (eq (car decl) 'declare)) + (return nil)) + (dolist (form (cdr decl)) + (when (consp form) + (let* ((name (car form))) + (cond ((eq '%class name) + (push `(declare ,form) inner-decls)) + ((or (member name '(ignore ignorable special dynamic-extent type)) + (info :type :kind name)) + (let* ((inners nil) + (outers nil) + (tail (cdr form)) + (head (if (eq 'type name) + (list name (pop tail)) + (list name)))) + (dolist (var tail) + (if (member var args :test #'eq) + ;; Quietly remove IGNORE declarations on + ;; args when a next-method is involved, to + ;; prevent compiler warnings about ignored + ;; args being read. + (unless (and (eq 'ignore name) + (member var req-args :test #'eq) + (or cnm-p (member var parameters-setqd))) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@head ,@outers)) outer-decls)) + (when inners + (push `(declare (,@head ,@inners)) inner-decls)))) + (t + ;; All other declarations are not variable declarations, + ;; so they become outer declarations. + (push `(declare ,form) outer-decls)))))) + (setq body (cdr body))) (values outer-decls inner-decls body))) -;;; Pull a name out of the %METHOD-NAME declaration in the function -;;; body given, or return NIL if no %METHOD-NAME declaration is found. -(defun body-method-name (body) - (multiple-value-bind (real-body declarations documentation) - (parse-body body) - (declare (ignore real-body documentation)) - (let ((name-decl (get-declaration '%method-name declarations))) - (and name-decl - (destructuring-bind (name) name-decl - name))))) - ;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME ;;; declaration (which is a naming style internal to PCL) into an ;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used @@ -758,9 +686,9 @@ ;;; no SB-PCL::%METHOD-NAME declaration, then just return the original ;;; lambda expression. (defun name-method-lambda (method-lambda) - (let ((method-name (body-method-name (cddr method-lambda)))) + (let ((method-name *method-name*)) (if method-name - `(named-lambda (slow-method ,method-name) ,(rest method-lambda)) + `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda)) method-lambda))) (defun make-method-initargs-form-internal (method-lambda initargs env) @@ -799,7 +727,7 @@ ;; Given a valid lambda list, extract the parameter names. (loop for x in lambda-list with res = nil - do (unless (member x lambda-list-keywords) + do (unless (member x lambda-list-keywords :test #'eq) (if (consp x) (let ((name (car x))) (if (consp name) @@ -824,7 +752,7 @@ (outer-parameters req-args) ;; The lambda-list used by BIND-ARGS (bind-list lambda-list) - (setq-p (getf (cdr lmf-params) :setq-p)) + (parameters-setqd (getf (cdr lmf-params) :parameters-setqd)) (auxp (member '&aux bind-list)) (call-next-method-p (getf (cdr lmf-params) :call-next-method-p))) ;; Try to use the normal function call machinery instead of BIND-ARGS @@ -849,7 +777,7 @@ bind-list req-args)) (multiple-value-bind (outer-decls inner-decls body-sans-decls) (split-declarations - body outer-parameters (or call-next-method-p setq-p)) + body outer-parameters req-args call-next-method-p parameters-setqd) (let* ((rest-arg (when restp '.rest-arg.)) (fmf-lambda-list (if rest-arg @@ -859,10 +787,10 @@ lambda-list)))) `(list* :function - (let* ((fmf (,(if (body-method-name body) 'named-lambda 'lambda) - ,@(when (body-method-name body) + (let* ((fmf (,(if *method-name* 'named-lambda 'lambda) + ,@(when *method-name* ;; function name - (list (cons 'fast-method (body-method-name body)))) + (list `(fast-method ,@*method-name*))) ;; The lambda-list of the FMF (.pv. .next-method-call. ,@fmf-lambda-list) ;; body of the function @@ -944,25 +872,18 @@ (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) (defun pv-wrappers-from-pv-args (&rest args) - (let (wrappers) - (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers))) - (let ((wrapper (wrapper-of arg))) - (push (if (invalid-wrapper-p wrapper) - (check-wrapper-validity wrapper) - wrapper) - wrappers))))) + (loop for arg in args + collect (valid-wrapper-of arg))) (defun pv-wrappers-from-all-args (pv-table args) - (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args + (loop for snl in (pv-table-slot-name-lists pv-table) + and arg in args when snl - collect (wrapper-of arg) into wrappers - finally (return (if (cdr wrappers) wrappers (car wrappers))))) + collect (valid-wrapper-of arg))) ;;; Return the subset of WRAPPERS which is used in the cache ;;; of PV-TABLE. (defun pv-wrappers-from-all-wrappers (pv-table wrappers) (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers when snl - collect w into result - finally (return (if (cdr result) result (car result))))) - + collect w))