X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=7403d3a45d9c2fe1bb3d9d83d2599dc89ca6e781;hb=0a1374c92d909493e8c20744d08025a346069f42;hp=c4d7eba9d64884e2f28fde2afe97cddf38741955;hpb=9d67a20f91f72ec73847e283bcf9b2b4f74b1d25;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index c4d7eba..7403d3a 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -232,8 +232,7 @@ (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) @@ -388,8 +387,7 @@ 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)) (defun can-optimize-access (form required-parameters env) @@ -667,8 +665,21 @@ `(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+))) @@ -702,8 +713,9 @@ (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))))))) @@ -895,7 +907,8 @@ `(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. @@ -945,7 +958,7 @@ 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) @@ -988,20 +1001,26 @@ (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))) @@ -1009,8 +1028,8 @@ ;;; 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 nil) - (declare (ignore documentation real-body)) + (parse-body body) + (declare (ignore real-body documentation)) (let ((name-decl (get-declaration '%method-name declarations))) (and name-decl (destructuring-bind (name) name-decl @@ -1064,34 +1083,39 @@ (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) + (list (body-method-name body))) ; 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 + (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 @@ -1130,7 +1154,7 @@ (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)) @@ -1150,52 +1174,24 @@ (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)))))