;;;; to each such (GF . ARGS) tuple inside a method body, and use this
;;;; to cache effective method functions.
\f
-(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)))))
-\f
(declaim (inline make-pv-table))
(defstruct (pv-table (:predicate pv-tablep)
(:copier nil))
;;; 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)))))
\f
-(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)
(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
(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))))))
\f
+;;; 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
+ "~@<Cannot optimize slot access, inheritance of ~S is not ~
+ yet finaliable due to forward-referenced superclasses:~
+ ~% ~S~:@>"
+ 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)
(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)
(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)))
;;; 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)))
(: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)))))))
(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.
;;;
(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)
;; 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
;;; 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)
;; 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)
(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
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
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
(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))
projects / sbcl.git / blobdiff