;;; ...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"))
(or (gethash snl *pv-tables*)
(setf (gethash snl *pv-tables*)
(make-pv-table :slot-name-lists snl
- :pv-size (reduce #'+ snl
- :key (lambda (slots)
- (length (cdr slots)))))))))
+ :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
(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)))
(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)))
;;; 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)
+ 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)))))))
:class :instance))))
(defmacro instance-write-internal (pv slots pv-offset new-value default
- &optional kind)
+ &optional kind safep)
(unless (member kind '(nil :instance :class))
(error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
- (let* ((index (gensym)))
+ (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 ((,index (svref ,pv ,pv-offset)))
+ (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)
- ,new-value)))))
+ .good-new-value.)))))
,@(when (or (null kind) (eq kind :class))
- `((cons (setf (cdr ,index) ,new-value))))
+ `((cons (setf (cdr ,index) .good-new-value.))))
(t ,default))))))
-(defmacro instance-write (pv-offset parameter position slot-name class
- new-value)
+(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)
(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)
projects / sbcl.git / blobdiff