;;; 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)
;;; 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"))
(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-spinlock (*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))
(and slotd
(slot-accessor-std-p slotd type)))))
-(defun compute-pv-slot (slot-name wrapper class)
+(defun compute-slot-location-for-pv (slot-name wrapper class)
(when (optimize-slot-value-by-class-p class slot-name 'all)
(car (find-slot-cell wrapper slot-name))))
+(defun compute-slot-typecheckfun-for-pv (slot-name wrapper class)
+ (when (optimize-slot-value-by-class-p class slot-name 'all)
+ (cadr (find-slot-cell wrapper slot-name))))
+
(defun compute-pv (slot-name-lists wrappers)
(unless (listp wrappers)
(setq wrappers (list wrappers)))
(std-p (typep wrapper 'wrapper))
(class (wrapper-class* wrapper)))
(dolist (slot-name (cdr slot-names))
- (push (if std-p
- (compute-pv-slot slot-name wrapper class)
- nil)
+ (push (when std-p
+ (compute-slot-location-for-pv slot-name wrapper class))
+ elements)
+ (push (when std-p
+ (compute-slot-typecheckfun-for-pv slot-name wrapper class))
elements)))))
(let* ((n (length elements))
(pv (make-array n)))
(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))
- (new-values
- (mapcar
- (lambda (slot-name)
- (cons slot-name
- (if std-p
- (compute-pv-slot slot-name cwrapper class)
- 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
(defun can-optimize-access (form required-parameters env)
(destructuring-bind (op var-form slot-name-form &optional new-value) form
(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)
(: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)))))))
(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))
+ (unless (member kind '(nil :instance :class))
(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))))))
+ (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)))))
(defmacro instance-read (pv-offset parameter position slot-name class)
(if (skip-fast-slot-access-p class slot-name 'reader)
:class :instance))))
(defmacro instance-write-internal (pv slots pv-offset new-value default
- &optional kind)
- (unless (member kind '(nil :instance :class :default))
+ &optional kind safep)
+ (unless (member kind '(nil :instance :class))
(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)
+ (let* ((index (gensym))
+ (new-value-form
+ (if safep
+ `(let ((.typecheckfun. (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 (pv-offset parameter position slot-name class new-value
+ &optional check-type-p)
(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)
+ (if check-type-p
+ ;; FIXME: We don't want this here. If it's _possible_ the fast path
+ ;; is applicable, we wan to use it as well.
+ `(safe-set-slot-value ,parameter ,slot-name ,new-value)
+ `(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)
+ ;; 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))))
+ :class :instance)
+ ,check-type-p)))
(defmacro instance-boundp-internal (pv slots pv-offset default
- &optional kind)
- (unless (member kind '(nil :instance :class :default))
+ &optional kind)
+ (unless (member kind '(nil :instance :class))
(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)))))))
+ (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 (pv-offset parameter position slot-name class)
(if (skip-fast-slot-access-p class slot-name 'boundp)
(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 typecheckfun.
+ (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)
(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) maybe-reads-params-p)
+ (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
;; 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)
(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