X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=902a89e2e3e2a7779c29cc009983415232858ebb;hb=447477e72bd4fe54e678a28bdcc4a2802797d6ed;hp=a3c2970f79a2b3043eb997bf7251e6dc533e314c;hpb=665eea819b61f87f401ff0a9ff82f6cbdcc5c636;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index a3c2970..902a89e 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -85,7 +85,7 @@ (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) (when new-p - (let ((pv-index 1)) + (let ((pv-index 0)) (dolist (slot-name-list slot-name-lists) (dolist (slot-name (cdr slot-name-list)) (note-pv-table-reference slot-name pv-index pv-table) @@ -132,60 +132,43 @@ (maphash function entry))) ref) -(defvar *pvs* (make-hash-table :test 'equal)) - (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 class-slot-p-cell) +(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) - (let ((cell (assq slot-name class-slots))) - (when cell - (setf (car class-slot-p-cell) t) - cell)))) + (assq slot-name class-slots))) (when (consp slot-name) - (dolist (type '(reader writer) nil) - (when (eq (car slot-name) type) - (return - (let* ((gf-name (cadr slot-name)) - (gf (gdefinition gf-name)) - (location (when (eq *boot-state* 'complete) - (accessor-values1 gf type class)))) - (when (consp location) - (setf (car class-slot-p-cell) t)) - location))))))) + (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 compute-pv (slot-name-lists wrappers) - (unless (listp wrappers) (setq wrappers (list wrappers))) - (let* ((not-simple-p-cell (list nil)) - (elements - (let ((elements nil)) - (dolist (slot-names slot-name-lists) - (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)))) - (dolist (slot-name (cdr slot-names)) - ;; Original PCL code had this idiom. why not: - ;; - ;; (WHEN STD-P - ;; (PUSH ...)) ? - (push (when std-p - (compute-pv-slot slot-name wrapper class - class-slots not-simple-p-cell)) - elements))))) - (nreverse elements)))) - (if (car not-simple-p-cell) - (make-permutation-vector (cons t elements)) - (or (gethash elements *pvs*) - (setf (gethash elements *pvs*) - (make-permutation-vector (cons nil elements))))))) + (unless (listp wrappers) + (setq wrappers (list wrappers))) + (let (elements) + (dolist (slot-names slot-name-lists + (make-permutation-vector (nreverse elements))) + (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)))) + (dolist (slot-name (cdr slot-names)) + (push (if std-p + (compute-pv-slot slot-name wrapper class class-slots) + nil) + elements))))))) (defun compute-calls (call-list wrappers) (declare (ignore call-list wrappers)) @@ -271,14 +254,14 @@ (let* ((cwrapper (class-wrapper class)) (std-p (typep cwrapper 'wrapper)) (class-slots (and std-p (wrapper-class-slots cwrapper))) - (class-slot-p-cell (list nil)) - (new-values (mapcar (lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) - slot-names)) + (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 @@ -291,7 +274,7 @@ (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 1) (param-index 0)) + (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))) @@ -301,48 +284,27 @@ (incf param-index))) (when cache (map-cache (lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map)) cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) - (if (not (if (atom wrappers) - (eq cwrapper wrappers) - (dolist (wrapper wrappers nil) - (when (eq wrapper cwrapper) - (return t))))) - pv - (let* ((old-intern-p (listp (pvref pv 0))) - (new-pv (if old-intern-p - (copy-pv pv) - pv)) - (new-intern-p t)) - (if (atom wrappers) - (dotimes-fixnum (i pv-size) - (when (consp (let ((map (svref pv-map i))) - (if map - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil))) - (let ((param 0)) - (dolist (wrapper wrappers) - (when (eq wrapper cwrapper) - (dotimes-fixnum (i pv-size) - (when (consp (let ((map (svref pv-map i))) - (if (and map (= (car map) param)) - (setf (pvref new-pv i) (cdr map)) - (pvref new-pv i)))) - (setq new-intern-p nil)))) - (incf param)))) - (when new-intern-p - (setq new-pv (let ((list-pv (coerce pv 'list))) - (or (gethash (cdr list-pv) *pvs*) - (setf (gethash (cdr list-pv) *pvs*) - (if old-intern-p - new-pv - (make-permutation-vector list-pv))))))) - new-pv))) + (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 (pvref 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 (pvref pv i) (cdr map)))))) + (incf param)))))) (defun maybe-expand-accessor-form (form required-parameters slots env) (let* ((fname (car form)) @@ -439,55 +401,109 @@ (optimize-slot-value-by-class-p class slot-name type)) (cons parameter-or-nil (or class class-name))))))))) +;;; 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))) + (memq parameter-name modified-variables))) + (defun optimize-slot-value (slots sparameter form) (if sparameter - (destructuring-bind (ignore1 ignore2 slot-name-form) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots :read sparameter slot-name nil))) + (let ((optimized-form + (destructuring-bind (ignore1 ignore2 slot-name-form) form + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-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 while 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) + ;; Either use OPTIMIZED-FORM or fall back to the safe + ;; ACCESSOR-SLOT-VALUE. + (if (parameter-modified-p parameter-name env) + `(accessor-slot-value ,@(cdr form)) + optimized-form)) + (defun optimize-set-slot-value (slots sparameter form) (if sparameter - (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form - (declare (ignore ignore1 ignore2)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :write - sparameter - slot-name - new-value))) + (let ((optimized-form + (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form + (declare (ignore ignore1 ignore2)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :write + sparameter + slot-name + new-value))))) + ;; 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) + (if (parameter-modified-p parameter-name env) + `(accessor-set-slot-value ,@(cdr form)) + optimized-form)) + (defun optimize-slot-boundp (slots sparameter form) (if sparameter - (destructuring-bind - ;; FIXME: In CMU CL ca. 19991205, this binding list had a - ;; fourth element in it, NEW-VALUE. It's hard to see how - ;; that could possibly be right, since SLOT-BOUNDP has no - ;; NEW-VALUE. Since it was causing a failure in building PCL - ;; for SBCL, so I changed it to match the definition of - ;; SLOT-BOUNDP (and also to match the list used in the - ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded - ;; out by this, since this is old code which has worked for - ;; ages to build PCL for CMU CL, so it's hard to see why it - ;; should need a patch like this in order to build PCL for - ;; SBCL. I'd like to return to this and find a test case - ;; which exercises this function both in CMU CL, to see - ;; whether it's really a previously-unexercised bug or - ;; whether I've misunderstood something (and, presumably, - ;; patched it wrong). - (slot-boundp-symbol instance slot-name-form) - form - (declare (ignore slot-boundp-symbol instance)) - (let ((slot-name (eval slot-name-form))) - (optimize-instance-access slots - :boundp - sparameter - slot-name - nil))) + (let ((optimized-form + (destructuring-bind + ;; FIXME: In CMU CL ca. 19991205, this binding list + ;; had a fourth element in it, NEW-VALUE. It's hard + ;; to see how that could possibly be right, since + ;; SLOT-BOUNDP has no NEW-VALUE. Since it was + ;; causing a failure in building PCL for SBCL, so I + ;; changed it to match the definition of + ;; SLOT-BOUNDP (and also to match the list used in + ;; the similar OPTIMIZE-SLOT-VALUE, + ;; above). However, I'm weirded out by this, since + ;; this is old code which has worked for ages to + ;; build PCL for CMU CL, so it's hard to see why it + ;; should need a patch like this in order to build + ;; PCL for SBCL. I'd like to return to this and + ;; find a test case which exercises this function + ;; both in CMU CL, to see whether it's really a + ;; previously-unexercised bug or whether I've + ;; misunderstood something (and, presumably, + ;; patched it wrong). + (slot-boundp-symbol instance slot-name-form) + form + (declare (ignore slot-boundp-symbol instance)) + (let ((slot-name (eval slot-name-form))) + (optimize-instance-access slots + :boundp + sparameter + slot-name + nil))))) + ;; See OPTIMIZE-SLOT-VALUE + `(optimized-slot-boundp ,form ,(car sparameter) ,optimized-form)) `(accessor-slot-boundp ,@(cdr form)))) +(defmacro optimized-slot-boundp (form parameter-name optimized-form + &environment env) + (if (parameter-modified-p parameter-name env) + `(accessor-slot-boundp ,@(cdr form)) + optimized-form)) + (defun optimize-reader (slots sparameter gf-name form) (if sparameter (optimize-accessor-call slots :read sparameter gf-name nil) @@ -830,7 +846,7 @@ (defun mutate-slots-and-calls (slots calls) (let ((sorted-slots (sort-slots slots)) (sorted-calls (sort-calls (cdr calls))) - (pv-offset 0)) ; index 0 is for info + (pv-offset -1)) (dolist (parameter-entry sorted-slots) (dolist (slot-entry (cdr parameter-entry)) (incf pv-offset) @@ -893,7 +909,7 @@ ;;;; Automatically generated reader and writer functions use this ;;;; stuff too. -(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) +(defmacro pv-binding ((required-parameters slot-name-lists pv-table-form) &body body) (let (slot-vars pv-parameters) (loop for slots in slot-name-lists @@ -902,13 +918,13 @@ do (when slots (push required-parameter pv-parameters) (push (slot-vector-symbol i) slot-vars))) - `(pv-binding1 (.pv. .calls. ,pv-table-symbol + `(pv-binding1 (.pv. .calls. ,pv-table-form ,(nreverse pv-parameters) ,(nreverse slot-vars)) ,@body))) -(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) +(defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars) &body body) - `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) + `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters) (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) slot-vars pv-parameters)) (declare (ignorable ,@(mapcar #'identity slot-vars))) @@ -919,7 +935,7 @@ (define-symbol-macro pv-env-environment overridden) (defmacro pv-env (&environment env - (pv calls pv-table-symbol pv-parameters) + (pv calls pv-table-form pv-parameters) &rest forms) ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT ;; symbol-macrolet. @@ -930,17 +946,14 @@ ,(make-calls-type-declaration calls)) ,pv ,calls ,@forms) - `(locally - ,@(when (symbolp pv-table-symbol) - `((declare (special ,pv-table-symbol)))) - (let* ((.pv-table. ,pv-table-symbol) - (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) - (,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv)) - (declare ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms)))) + `(let* ((.pv-table. ,pv-table-form) + (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)) + (,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv)) + (declare ,(make-calls-type-declaration calls)) + ,pv ,calls + ,@forms))) (defvar *non-var-declarations* ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I @@ -1092,7 +1105,7 @@ (incf nreq) (push arg args)) (setq args (nreverse args)) - (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) + (setf (getf (getf initargs 'plist) :arg-info) (cons nreq restp)) (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) @@ -1107,22 +1120,26 @@ (append req-args (list rest-arg)) req-args))) `(list* - :fast-function - (,(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.) - (disable-package-locks pv-env-environment)) - ,@outer-decls - (symbol-macrolet ((pv-env-environment default)) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body-sans-decls))) + :function + (let* ((fmf (,(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.) + (disable-package-locks pv-env-environment)) + ,@outer-decls + (symbol-macrolet ((pv-env-environment default)) + (fast-lexical-method-functions + (,(car lmf-params) .next-method-call. ,req-args ,rest-arg + ,@(cdddr lmf-params)) + ,@inner-decls + ,@body-sans-decls)))) + (mf (%make-method-function fmf nil))) + (set-funcallable-instance-function + mf (method-function-from-fast-function fmf ',(getf initargs 'plist))) + mf) ',initargs)))) ;;; Use arrays and hash tables and the fngen stuff to make this much @@ -1130,19 +1147,20 @@ ;;; returned by this will get called only when the user explicitly ;;; funcalls a result of method-function. BUT, this is needed to make ;;; early methods work. -(defun method-function-from-fast-function (fmf) +(defun method-function-from-fast-function (fmf plist) (declare (type function fmf)) - (let* ((method-function nil) (pv-table nil) - (arg-info (method-function-get fmf :arg-info)) + (let* ((method-function nil) + (calls (getf plist :call-list)) + (snl (getf plist :slot-name-lists)) + (pv-table (when (or calls snl) + (intern-pv-table :call-list calls :slot-name-lists snl))) + (arg-info (getf plist :arg-info)) (nreq (car arg-info)) (restp (cdr arg-info))) (setq method-function (lambda (method-args next-methods) - (unless pv-table - (setq pv-table (method-function-pv-table fmf))) (let* ((pv-cell (when pv-table - (get-method-function-pv-cell - method-function method-args pv-table))) + (get-pv-cell method-args pv-table))) (nm (car next-methods)) (nms (cdr next-methods)) (nmc (when nm @@ -1156,20 +1174,41 @@ (args (ldiff method-args rest))) (apply fmf pv-cell nmc (nconc args (list rest)))) (apply fmf pv-cell nmc method-args))))) - (let* ((fname (method-function-get fmf :name)) - (name (cons 'slow-method (cdr fname)))) - (set-fun-name method-function name)) - (setf (method-function-get method-function :fast-function) fmf) + ;; FIXME: this looks dangerous. + (let* ((fname (%fun-name fmf))) + (when (and fname (eq (car fname) 'fast-method)) + (set-fun-name method-function (cons 'slow-method (cdr fname))))) method-function)) -(defun get-method-function-pv-cell (method-function - method-args - &optional pv-table) - (let ((pv-table (or pv-table (method-function-pv-table method-function)))) - (when pv-table - (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) - (when pv-wrappers - (pv-table-lookup pv-table pv-wrappers)))))) +;;; this is similar to the above, only not quite. Only called when +;;; the MOP is heavily involved. Not quite parallel to +;;; METHOD-FUNCTION-FROM-FAST-METHOD-FUNCTION, because we can close +;;; over the actual PV-CELL in this case. +(defun method-function-from-fast-method-call (fmc) + (let* ((fmf (fast-method-call-function fmc)) + (pv-cell (fast-method-call-pv-cell fmc)) + (arg-info (fast-method-call-arg-info fmc)) + (nreq (car arg-info)) + (restp (cdr arg-info))) + (lambda (method-args next-methods) + (let* ((nm (car next-methods)) + (nms (cdr next-methods)) + (nmc (when nm + (make-method-call + :function (if (std-instance-p nm) + (method-function nm) + nm) + :call-method-args (list nms))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args)))))) + +(defun get-pv-cell (method-args pv-table) + (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args))) + (when pv-wrappers + (pv-table-lookup pv-table pv-wrappers)))) (defun pv-table-lookup-pv-args (pv-table &rest pv-parameters) (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))