(pv-cell (cons pv calls))
(new-cache (fill-cache cache pv-wrappers pv-cell)))
(unless (eq new-cache cache)
- (setf (pv-table-cache pv-table) new-cache)
- (free-cache cache))
+ (setf (pv-table-cache pv-table) new-cache))
pv-cell))))
(defun make-pv-type-declaration (var)
slots
calls)
(declare (ignore required-parameters env slots calls))
- (or (and (eq (car form) 'make-instance)
- (expand-make-instance-form form))
+ (or ; (optimize-reader ...)?
form))
\f
(defun can-optimize-access (form required-parameters env)
(standard-class-p class)
(not (eq class *the-class-t*)) ; shouldn't happen, though.
(let ((slotd (find-slot-definition class slot-name)))
- (and slotd (classp (slot-definition-allocation slotd)))))))
+ (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) (eval class-form)))
`(locally (declare #.*optimize-speed*)
(let ((,index (pvref ,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 type) (eq type :instance))
- `((fixnum (clos-slots-ref ,slots ,index))))
+ `((fixnum
+ (and ,slots ; KLUDGE
+ (clos-slots-ref ,slots ,index)))))
,@(when (or (null type) (eq type :class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type :instance))
- `((fixnum (setf (clos-slots-ref ,slots ,index)
- ,new-value))))
+ `((fixnum (and ,slots
+ (setf (clos-slots-ref ,slots ,index)
+ ,new-value)))))
,@(when (or (null type) (eq type :class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
`(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
(let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
slot-vars pv-parameters))
- ,@body)))
+ (declare (ignorable ,@(mapcar #'identity slot-vars)))
+ ,@body)))
;;; This gets used only when the default MAKE-METHOD-LAMBDA is
;;; overridden.
simple-bit-vector simple-string simple-vector single-float standard-char
stream string symbol t unsigned-byte vector))
-(defun split-declarations (body args calls-next-method-p)
+(defun split-declarations (body args maybe-reads-params-p)
(let ((inner-decls nil)
(outer-decls nil)
decl)
(push declaration-name *var-declarations-without-arg*))
(when arg-p
(setq dname (append dname (list (pop form)))))
- (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 calls-next-method-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)))))))
+ (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)))
(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 (documentation declarations real-body)
- (extract-declarations body nil)
- (declare (ignore documentation real-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
(defun name-method-lambda (method-lambda)
(let ((method-name (body-method-name (cddr method-lambda))))
(if method-name
- `(named-lambda ,method-name ,(rest method-lambda))
+ `(named-lambda (method ,method-name) ,(rest method-lambda))
method-lambda)))
(defun make-method-initargs-form-internal (method-lambda initargs env)
(initargs body req-args lmf-params restp)
(multiple-value-bind (outer-decls inner-decls body-sans-decls)
(split-declarations
- body req-args (getf (cdr lmf-params) :call-next-method-p))
+ body req-args (or (getf (cdr lmf-params) :call-next-method-p)
+ (getf (cdr lmf-params) :setq-p)))
(let* ((rest-arg (when restp '.rest-arg.))
(args+rest-arg (if restp
(append req-args (list rest-arg))
req-args)))
`(list*
:fast-function
- (named-lambda
- ,(or (body-method-name body) '.method.) ; function name
- (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
- ;; body of the function
- (declare (ignorable .pv-cell. .next-method-call.))
- ,@outer-decls
- (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
- &rest forms)
- (declare (ignore pv-table-symbol
- pv-parameters))
- `(let ((,pv (car .pv-cell.))
- (,calls (cdr .pv-cell.)))
- (declare ,(make-pv-type-declaration pv)
- ,(make-calls-type-declaration calls))
- ,pv ,calls
- ,@forms)))
- (fast-lexical-method-functions
- (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
- ,@(cdddr lmf-params))
- ,@inner-decls
- ,@body-sans-decls)))
+ (,(if (body-method-name body) 'named-lambda 'lambda)
+ ,@(when (body-method-name body)
+ ;; function name
+ (list (cons 'fast-method (body-method-name body))))
+ (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
+ ;; body of the function
+ (declare (ignorable .pv-cell. .next-method-call.))
+ ,@outer-decls
+ (declare (disable-package-locks pv-env))
+ (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+ &rest forms)
+ (declare (ignore pv-table-symbol
+ pv-parameters))
+ (declare (enable-package-locks pv-env))
+ `(let ((,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv)
+ ,(make-calls-type-declaration calls))
+ ,pv ,calls
+ ,@forms)))
+ (declare (enable-package-locks pv-env))
+ (fast-lexical-method-functions
+ (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+ ,@(cdddr lmf-params))
+ ,@inner-decls
+ ,@body-sans-decls)))
',initargs))))
;;; Use arrays and hash tables and the fngen stuff to make this much
(setf (get (car fname) 'method-sym)
(let ((str (symbol-name (car fname))))
(if (string= "FAST-" str :end2 5)
- (intern (subseq str 5) *pcl-package*)
+ (format-symbol *pcl-package* (subseq str 5))
(car fname)))))
,@(cdr fname))))
(set-fun-name method-function name))
(pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
(defun pv-wrappers-from-pv-args (&rest args)
- (let* ((nkeys (length args))
- (pv-wrappers (make-list nkeys))
- w
- (w-t pv-wrappers))
- (dolist (arg args)
- (setq w (wrapper-of arg))
- (when (invalid-wrapper-p w)
- (setq w (check-wrapper-validity arg)))
- (setf (car w-t) w))
- (setq w-t (cdr w-t))
- (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
- pv-wrappers))
+ (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)))))
(defun pv-wrappers-from-all-args (pv-table args)
- (let ((nkeys 0)
- (slot-name-lists (pv-table-slot-name-lists pv-table)))
- (dolist (sn slot-name-lists)
- (when sn (incf nkeys)))
- (let* ((pv-wrappers (make-list nkeys))
- (pv-w-t pv-wrappers))
- (dolist (sn slot-name-lists)
- (when sn
- (let* ((arg (car args))
- (w (wrapper-of arg)))
- (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
- (error "error in PV-WRAPPERS-FROM-ALL-ARGS"))
- (setf (car pv-w-t) w)
- (setq pv-w-t (cdr pv-w-t))))
- (setq args (cdr args)))
- (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
- pv-wrappers)))
+ (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)))))
+;;; Return the subset of WRAPPERS which is used in the cache
+;;; of PV-TABLE.
(defun pv-wrappers-from-all-wrappers (pv-table wrappers)
- (let ((nkeys 0)
- (slot-name-lists (pv-table-slot-name-lists pv-table)))
- (dolist (sn slot-name-lists)
- (when sn (incf nkeys)))
- (let* ((pv-wrappers (make-list nkeys))
- (pv-w-t pv-wrappers))
- (dolist (sn slot-name-lists)
- (when sn
- (let ((w (car wrappers)))
- (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
- (error "error in PV-WRAPPERS-FROM-ALL-WRAPPERS"))
- (setf (car pv-w-t) w)
- (setq pv-w-t (cdr pv-w-t))))
- (setq wrappers (cdr wrappers)))
- (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
- pv-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)))))
projects / sbcl.git / blobdiff