X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=902a89e2e3e2a7779c29cc009983415232858ebb;hb=447477e72bd4fe54e678a28bdcc4a2802797d6ed;hp=7c307f0d0242699592ab074883f808d316fc1f7a;hpb=81ce38f2e03e4f569d7a95bb18efb25bb16fc269;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 7c307f0..902a89e 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -47,15 +47,18 @@ #-sb-fluid (declaim (sb-ext:freeze-type pv-table)) -(defvar *initial-pv-table* (make-pv-table-internal nil nil)) - -; help new slot-value-using-class methods affect fast iv access -(defvar *all-pv-table-list* nil) +;;; FIXME: The comment below seem to indicate that this was intended +;;; to be actually used, however, it isn't anymore, and was commented +;;; out at 0.9.13.47. Also removed was code in MAKE-PV-TABLE that +;;; pushed each new PV-TABLE onto this list. --NS 2006-06-18 +;;; +;;; help new slot-value-using-class methods affect fast iv access +;;; +;;; (defvar *all-pv-table-list* nil) +(declaim (inline make-pv-table)) (defun make-pv-table (&key slot-name-lists call-list) - (let ((pv-table (make-pv-table-internal slot-name-lists call-list))) - (push pv-table *all-pv-table-list*) - pv-table)) + (make-pv-table-internal slot-name-lists call-list)) (defun make-pv-table-type-declaration (var) `(type pv-table ,var)) @@ -79,18 +82,19 @@ (setq new-p t) (make-pv-table :slot-name-lists snl :call-list cl)))))) - (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists))))) - (when new-p - (let ((pv-index 1)) - (dolist (slot-name-list slot-name-lists) - (dolist (slot-name (cdr slot-name-list)) - (note-pv-table-reference slot-name pv-index pv-table) - (incf pv-index))) - (dolist (gf-call call-list) - (note-pv-table-reference gf-call pv-index pv-table) - (incf pv-index)) - (setf (pv-table-pv-size pv-table) pv-index))) - pv-table)))) + (let ((pv-table + (outer (mapcar #'inner (cons call-list slot-name-lists))))) + (when new-p + (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) + (incf pv-index))) + (dolist (gf-call call-list) + (note-pv-table-reference gf-call pv-index pv-table) + (incf pv-index)) + (setf (pv-table-pv-size pv-table) pv-index))) + pv-table)))) (defun note-pv-table-reference (ref pv-offset pv-table) (let ((entry (gethash ref *pv-key-to-pv-table-table*))) @@ -128,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)) @@ -238,8 +225,6 @@ (defun make-pv-type-declaration (var) `(type simple-vector ,var)) -(defvar *empty-pv* #()) - (defmacro pvref (pv index) `(svref ,pv ,index)) @@ -269,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 @@ -289,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))) @@ -299,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)) @@ -437,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) @@ -586,7 +604,7 @@ (when (and class-name (not (eq class-name t))) (position parameter-or-nil slots :key #'car)))))) (if (constantp form) - (let ((form (eval form))) + (let ((form (constant-form-value form))) (if (symbolp form) form *unspecific-arg*)) @@ -630,8 +648,9 @@ ;;; It is safe for these two functions to be wrong. They just try to ;;; guess what the most likely case will be. (defun generate-fast-class-slot-access-p (class-form slot-name-form) - (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (let ((class (and (constantp class-form) (constant-form-value class-form))) + (slot-name (and (constantp slot-name-form) + (constant-form-value slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. @@ -639,8 +658,9 @@ (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))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (let ((class (and (constantp class-form) (constant-form-value class-form))) + (slot-name (and (constantp slot-name-form) + (constant-form-value slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. @@ -826,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) @@ -889,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 @@ -898,32 +918,42 @@ 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))) ,@body))) -;;; This gets used only when the default MAKE-METHOD-LAMBDA is +;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is ;;; overridden. -(defmacro pv-env ((pv calls pv-table-symbol pv-parameters) +(define-symbol-macro pv-env-environment overridden) + +(defmacro pv-env (&environment env + (pv calls pv-table-form pv-parameters) &rest forms) - `(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)) - ,@(when (symbolp pv-table-symbol) - `((declare (special ,pv-table-symbol)))) - ,pv ,calls - ,@forms)) + ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT + ;; symbol-macrolet. + (if (eq (macroexpand 'pv-env-environment env) 'default) + `(let ((,pv (car .pv-cell.)) + (,calls (cdr .pv-cell.))) + (declare ,(make-pv-type-declaration pv) + ,(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 @@ -1075,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))))) @@ -1090,33 +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.)) - ,@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))) + :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 @@ -1124,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 @@ -1150,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)))