;;;; specification.
(in-package "SB-PCL")
-\f
-(defmacro instance-slot-index (wrapper slot-name)
- `(let ((pos 0))
- (declare (fixnum pos))
- (block loop
- (dolist (sn (wrapper-instance-slots-layout ,wrapper))
- (when (eq ,slot-name sn) (return-from loop pos))
- (incf pos)))))
-\f
-(defun pv-cache-limit-fn (nlines)
- (default-limit-fn nlines))
+;;;; Up to 1.0.9.24 SBCL used to have a sketched out implementation
+;;;; for optimizing GF calls inside method bodies using a PV approach,
+;;;; inherited from the original PCL. This was never completed, and
+;;;; was removed at that point to make the code easier to understand
+;;;; -- but:
+;;;;
+;;;; FIXME: It would be possible to optimize GF calls inside method
+;;;; bodies using permutation vectors: if all the arguments to the
+;;;; GF are specializers parameters, we can assign a permutation index
+;;;; to each such (GF . ARGS) tuple inside a method body, and use this
+;;;; to cache effective method functions.
+\f
+(declaim (inline make-pv-table))
(defstruct (pv-table (:predicate pv-tablep)
- (:constructor make-pv-table-internal
- (slot-name-lists call-list))
(:copier nil))
(cache nil :type (or cache null))
(pv-size 0 :type fixnum)
- (slot-name-lists nil :type list)
- (call-list nil :type list))
-
-#-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)
-
-(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))
+ (slot-name-lists nil :type list))
(defun make-pv-table-type-declaration (var)
`(type pv-table ,var))
-(defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
-(defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
+;;; Used for interning parts of SLOT-NAME-LISTS, as part of
+;;; PV-TABLE interning -- just to save space.
+(defvar *slot-name-lists* (make-hash-table :test 'equal))
-;;; Entries in this are lists of (table . pv-offset-list).
-(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
+;;; Used for interning PV-TABLES, keyed by the SLOT-NAME-LISTS
+;;; used.
+(defvar *pv-tables* (make-hash-table :test 'equal))
-(defun intern-pv-table (&key slot-name-lists call-list)
+;;; Indexes PV-TABLES by indivisual slot names used.
+(defvar *pv-tables-by-slots* (make-hash-table :test 'equal))
+
+;;; ...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*.
+(defvar *pv-lock*
+ (sb-thread::make-spinlock :name "pv table index lock"))
+
+(defun intern-pv-table (&key slot-name-lists)
(let ((new-p nil))
- (flet ((inner (x)
- (or (gethash x *slot-name-lists-inner*)
- (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
- (outer (x)
- (or (gethash x *slot-name-lists-outer*)
- (setf (gethash x *slot-name-lists-outer*)
- (let ((snl (copy-list (cdr x)))
- (cl (car x)))
+ (flet ((intern-slot-names (slot-names)
+ (or (gethash slot-names *slot-name-lists*)
+ (setf (gethash slot-names *slot-name-lists*) slot-names)))
+ (%intern-pv-table (snl)
+ (or (gethash snl *pv-tables*)
+ (setf (gethash snl *pv-tables*)
+ (progn
(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))))
-
-(defun note-pv-table-reference (ref pv-offset pv-table)
- (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
- (when (listp entry)
- (let ((table-entry (assq pv-table entry)))
- (when (and (null table-entry)
- (> (length entry) 8))
- (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
- (dolist (table-entry entry)
- (setf (gethash (car table-entry) new-table-table)
- (cdr table-entry)))
- (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
- (when (listp entry)
- (if (null table-entry)
- (let ((new (cons pv-table pv-offset)))
- (if (consp entry)
- (push new (cdr entry))
- (setf (gethash ref *pv-key-to-pv-table-table*)
- (list new))))
- (push pv-offset (cdr table-entry)))
- (return-from note-pv-table-reference nil))))
- (let ((list (gethash pv-table entry)))
- (if (consp list)
- (push pv-offset (cdr list))
- (setf (gethash pv-table entry) (list pv-offset)))))
- nil)
-
-(defun map-pv-table-references-of (ref function)
- (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
- (if (listp entry)
- (dolist (table+pv-offset-list entry)
- (funcall function
- (car table+pv-offset-list)
- (cdr table+pv-offset-list)))
- (maphash function entry)))
- ref)
+ (make-pv-table :slot-name-lists snl))))))
+ (sb-thread::with-spinlock (*pv-lock*)
+ (let ((pv-table
+ (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))
+ (when new-p
+ (let ((pv-index 0))
+ (dolist (slot-name-list slot-name-lists)
+ (dolist (slot-name (cdr slot-name-list))
+ (pushnew pv-table (gethash slot-name *pv-tables-by-slots*))
+ (incf pv-index)))
+ (setf (pv-table-pv-size pv-table) pv-index)))
+ pv-table)))))
+
+(defun map-pv-table-references-of (slot-name function)
+ (dolist (table (sb-thread::with-spinlock (*pv-lock*)
+ (gethash slot-name *pv-tables-by-slots*)))
+ (funcall function table)))
\f
-(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)
- (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))))
- (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)))))))
+(defun compute-pv-slot (slot-name wrapper class)
+ (when (optimize-slot-value-by-class-p class slot-name 'all)
+ (car (find-slot-cell wrapper slot-name))))
(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)))))))
-
-(defun compute-calls (call-list wrappers)
- (declare (ignore call-list wrappers))
- #||
- (map 'vector
- (lambda (call)
- (compute-emf-from-wrappers call wrappers))
- call-list)
- ||#
- '#())
-
-#|| ; Need to finish this, then write the maintenance functions.
-(defun compute-emf-from-wrappers (call wrappers)
- (when call
- (destructuring-bind (gf-name nreq restp arg-info) call
- (if (eq gf-name 'make-instance)
- (error "should not get here") ; there is another mechanism for this.
- (lambda (&rest args)
- (if (not (eq *boot-state* 'complete))
- (apply (gdefinition gf-name) args)
- (let* ((gf (gdefinition gf-name))
- (arg-info (arg-info-reader gf))
- (classes '?)
- (types '?)
- (emf (cache-miss-values-internal gf arg-info
- wrappers classes types
- 'caching)))
- (update-all-pv-tables call wrappers emf)
- (invoke-emf emf args))))))))
-||#
-
-(defun make-permutation-vector (indexes)
- (make-array (length indexes) :initial-contents indexes))
+ (unless (listp wrappers)
+ (setq wrappers (list wrappers)))
+ (let (elements)
+ (dolist (slot-names slot-name-lists)
+ (when slot-names
+ (let* ((wrapper (pop 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)
+ elements)))))
+ (let* ((n (length elements))
+ (pv (make-array n)))
+ (loop for i from (1- n) downto 0
+ do (setf (svref pv i) (pop elements)))
+ pv)))
(defun pv-table-lookup (pv-table pv-wrappers)
(let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
- (call-list (pv-table-call-list pv-table))
(cache (or (pv-table-cache pv-table)
(setf (pv-table-cache pv-table)
- (get-cache (- (length slot-name-lists)
- (count nil slot-name-lists))
- t
- #'pv-cache-limit-fn
- 2)))))
- (or (probe-cache cache pv-wrappers)
- (let* ((pv (compute-pv slot-name-lists pv-wrappers))
- (calls (compute-calls call-list pv-wrappers))
- (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))
- pv-cell))))
+ (make-cache :key-count (- (length slot-name-lists)
+ (count nil slot-name-lists))
+ :value t
+ :size 2)))))
+ (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers)
+ (if hitp
+ value
+ (let* ((pv (compute-pv slot-name-lists pv-wrappers))
+ (new-cache (fill-cache cache pv-wrappers pv)))
+ ;; This is safe: if another thread races us here the loser just
+ ;; misses the next time as well.
+ (unless (eq new-cache cache)
+ (setf (pv-table-cache pv-table) new-cache))
+ pv)))))
(defun make-pv-type-declaration (var)
`(type simple-vector ,var))
-(defvar *empty-pv* #())
-
-(defmacro pvref (pv index)
- `(svref ,pv ,index))
-
-(defmacro copy-pv (pv)
- `(copy-seq ,pv))
-
-(defun make-calls-type-declaration (var)
- `(type simple-vector ,var))
-
-(defmacro callsref (calls index)
- `(svref ,calls ,index))
-
(defvar *pv-table-cache-update-info* nil)
(defun update-pv-table-cache-info (class)
(defun update-all-pv-table-caches (class slot-names)
(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)
+ nil)))
+ slot-names))
(pv-tables nil))
(dolist (slot-name slot-names)
(map-pv-table-references-of
slot-name
- (lambda (pv-table pv-offset-list)
- (declare (ignore pv-offset-list))
+ (lambda (pv-table)
(pushnew pv-table pv-tables))))
(dolist (pv-table pv-tables)
(let* ((cache (pv-table-cache pv-table))
(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)))
(incf map-index))
(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)))
+ (map-cache (lambda (wrappers pv)
+ (update-slots-in-pv wrappers pv
+ 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)))
-\f
-(defun maybe-expand-accessor-form (form required-parameters slots env)
- (let* ((fname (car form))
- #||(len (length form))||#
- (gf (if (symbolp fname)
- (unencapsulated-fdefinition fname)
- (gdefinition fname))))
- (macrolet ((maybe-optimize-reader ()
- `(let ((parameter
- (can-optimize-access1 (cadr form)
- required-parameters env)))
- (when parameter
- (optimize-reader slots parameter gf-name form))))
- (maybe-optimize-writer ()
- `(let ((parameter
- (can-optimize-access1 (caddr form)
- required-parameters env)))
- (when parameter
- (optimize-writer slots parameter gf-name form)))))
- (unless (and (consp (cadr form))
- (eq 'instance-accessor-parameter (caadr form)))
- (when (and (eq *boot-state* 'complete)
- (generic-function-p gf))
- (let ((methods (generic-function-methods gf)))
- (when methods
- (let* ((gf-name (generic-function-name gf))
- (arg-info (gf-arg-info gf))
- (metatypes (arg-info-metatypes arg-info))
- (nreq (length metatypes))
- (applyp (arg-info-applyp arg-info)))
- (when (null applyp)
- (cond ((= nreq 1)
- (when (some #'standard-reader-method-p methods)
- (maybe-optimize-reader)))
- ((and (= nreq 2)
- (consp gf-name)
- (eq (car gf-name) 'setf))
- (when (some #'standard-writer-method-p methods)
- (maybe-optimize-writer)))))))))))))
-
-(defun optimize-generic-function-call (form
- required-parameters
- env
- slots
- calls)
- (declare (ignore required-parameters env slots calls))
- (or ; (optimize-reader ...)?
- form))
+ (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 (svref 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 (svref pv i) (cdr map))))))
+ (incf param))))))
\f
(defun can-optimize-access (form required-parameters env)
- (let ((type (ecase (car form)
- (slot-value 'reader)
- (set-slot-value 'writer)
- (slot-boundp 'boundp)))
- (var (cadr form))
- (slot-name (eval (caddr form)))) ; known to be constant
- (can-optimize-access1 var required-parameters env type slot-name)))
-
-;;; FIXME: This looks like an internal helper function for
-;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called
-;;; bare from several places in the code. Perhaps the two functions
-;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and
-;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
-;;; args instead of optional ones, too.
-(defun can-optimize-access1 (var required-parameters env
- &optional type slot-name)
- (when (and (consp var) (eq 'the (car var)))
- ;; FIXME: We should assert list of length 3 here. Or maybe we
- ;; should just define EXTRACT-THE, replace the whole
- ;; (WHEN ..)
- ;; form with
- ;; (AWHEN (EXTRACT-THE VAR)
- ;; (SETF VAR IT))
- ;; and then use EXTRACT-THE similarly to clean up the other tests
- ;; against 'THE scattered through the PCL code.
- (setq var (caddr var)))
- (when (symbolp var)
- (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
- (parameter-or-nil (car (memq (or rebound? var)
- required-parameters))))
- (when parameter-or-nil
- (let* ((class-name (caddr (var-declaration '%class
- parameter-or-nil
- env)))
- (class (find-class class-name nil)))
- (when (or (not (eq *boot-state* 'complete))
- (and class (not (class-finalized-p class))))
- (setq class nil))
- (when (and class-name (not (eq class-name t)))
- (when (or (null type)
- (not (and class
- (memq *the-class-structure-object*
- (class-precedence-list class))))
- (optimize-slot-value-by-class-p class slot-name type))
- (cons parameter-or-nil (or class class-name)))))))))
-
-(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)))
- `(accessor-slot-value ,@(cdr 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)))
- `(accessor-set-slot-value ,@(cdr 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)))
- `(accessor-slot-boundp ,@(cdr form))))
-
-(defun optimize-reader (slots sparameter gf-name form)
- (if sparameter
- (optimize-accessor-call slots :read sparameter gf-name nil)
- form))
-
-(defun optimize-writer (slots sparameter gf-name form)
- (if sparameter
- (destructuring-bind (ignore1 ignore2 new-value) form
- (declare (ignore ignore1 ignore2))
- (optimize-accessor-call slots :write sparameter gf-name new-value))
- form))
+ (destructuring-bind (op var-form slot-name-form &optional new-value) form
+ (let ((type (ecase op
+ (slot-value 'reader)
+ (set-slot-value 'writer)
+ (slot-boundp 'boundp)))
+ (var (extract-the var-form))
+ (slot-name (constant-form-value slot-name-form env)))
+ (when (symbolp var)
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
+ (parameter-or-nil (car (memq (or rebound? var)
+ required-parameters))))
+ (when parameter-or-nil
+ (let* ((class-name (caddr (var-declaration '%class
+ parameter-or-nil
+ env)))
+ (class (find-class class-name nil)))
+ (when (or (not (eq *boot-state* 'complete))
+ (and class (not (class-finalized-p class))))
+ (setq class nil))
+ (when (and class-name (not (eq class-name t)))
+ (when (or (null type)
+ (not (and class
+ (memq *the-class-structure-object*
+ (class-precedence-list class))))
+ (optimize-slot-value-by-class-p class slot-name type))
+ (values (cons parameter-or-nil (or class class-name))
+ slot-name
+ new-value))))))))))
+
+;;; 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 (form slots required-parameters env)
+ (multiple-value-bind (sparameter slot-name)
+ (can-optimize-access form required-parameters env)
+ (if sparameter
+ (let ((optimized-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 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 (form slots required-parameters env)
+ (multiple-value-bind (sparameter slot-name new-value)
+ (can-optimize-access form required-parameters env)
+ (if sparameter
+ (let ((optimized-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)
+ (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)))
+ (t
+ optimized-form)))
+
+(defun optimize-slot-boundp (form slots required-parameters env)
+ (multiple-value-bind (sparameter slot-name)
+ (can-optimize-access form required-parameters env)
+ (if sparameter
+ (let ((optimized-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))
;;; The SLOTS argument is an alist, the CAR of each entry is the name
;;; of a required parameter to the function. The alist is in order, so
`(instance-boundp ,pv-offset-form ,parameter ,position
',slot-name ',class)))))))
-(defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
- (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
- (parameter (if (consp sparameter) (car sparameter) sparameter))
- (parameter-entry (assq parameter slots))
- (name (case read/write
- (:read `(reader ,gf-name))
- (:write `(writer ,gf-name))))
- (slot-entry (assoc name (cdr parameter-entry) :test #'equal))
- (position (posq parameter-entry slots))
- (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
- (unless parameter-entry
- (error "slot optimization bewilderment: O-A-C"))
- (unless slot-entry
- (setq slot-entry (list name))
- (push slot-entry (cdr parameter-entry)))
- (push pv-offset-form (cdr slot-entry))
- (ecase read/write
- (:read
- `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
- (:write
- `(let ((.new-value. ,new-value))
- (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
- .new-value.))))))
-
-(defvar *unspecific-arg* '..unspecific-arg..)
-
-(defun optimize-gf-call-internal (form slots env)
- (when (and (consp form)
- (eq (car form) 'the))
- (setq form (caddr form)))
- (or (and (symbolp form)
- (let* ((rebound? (caddr (var-declaration '%variable-rebinding
- form
- env)))
- (parameter-or-nil (car (assq (or rebound? form) slots))))
- (when parameter-or-nil
- (let* ((class-name (caddr (var-declaration 'class
- parameter-or-nil
- env))))
- (when (and class-name (not (eq class-name t)))
- (position parameter-or-nil slots :key #'car))))))
- (if (constantp form)
- (let ((form (constant-form-value form)))
- (if (symbolp form)
- form
- *unspecific-arg*))
- *unspecific-arg*)))
-
-(defun optimize-gf-call (slots calls gf-call-form nreq restp env)
- (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work
- (let* ((args (cdr gf-call-form))
- (all-args-p (eq (car gf-call-form) 'make-instance))
- (non-required-args (nthcdr nreq args))
- (required-args (ldiff args non-required-args))
- (call-spec (list (car gf-call-form) nreq restp
- (mapcar (lambda (form)
- (optimize-gf-call-internal form slots env))
- (if all-args-p
- args
- required-args))))
- (call-entry (assoc call-spec calls :test #'equal))
- (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
- (unless (some #'integerp
- (let ((spec-args (cdr call-spec)))
- (if all-args-p
- (ldiff spec-args (nthcdr nreq spec-args))
- spec-args)))
- (return-from optimize-gf-call nil))
- (unless call-entry
- (setq call-entry (list call-spec))
- (push call-entry (cdr calls)))
- (push pv-offset-form (cdr call-entry))
- (if (eq (car call-spec) 'make-instance)
- `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
- `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
- (invoke-effective-method-function .emf. ,restp
- ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
-
(define-walker-template pv-offset) ; These forms get munged by mutate slots.
(defmacro pv-offset (arg) arg)
(define-walker-template instance-accessor-parameter)
(and (eq *boot-state* 'complete)
(standard-class-p class)
(not (eq class *the-class-t*)) ; shouldn't happen, though.
+ ;; FIXME: Is this really right? "Don't skip if there is
+ ;; no slot definition."
(let ((slotd (find-slot-definition class slot-name)))
- (and slotd (skip-optimize-slot-value-by-class-p class
- slot-name
- type))))))
-
-(defun skip-optimize-slot-value-by-class-p (class slot-name type)
- (let ((slotd (find-slot-definition class slot-name)))
- (and slotd
- (eq *boot-state* 'complete)
- (not (slot-accessor-std-p slotd type)))))
-
-(defmacro instance-read-internal (pv slots pv-offset default &optional type)
- (unless (member type '(nil :instance :class :default))
- (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
- (if (eq type :default)
+ (and slotd
+ (not (slot-accessor-std-p slotd type)))))))
+
+(defmacro instance-read-internal (pv slots pv-offset default &optional kind)
+ (unless (member kind '(nil :instance :class :default))
+ (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind))
+ (if (eq kind :default)
default
(let* ((index (gensym))
(value index))
`(locally (declare #.*optimize-speed*)
- (let ((,index (pvref ,pv ,pv-offset)))
+ (let ((,index (svref ,pv ,pv-offset)))
(setq ,value (typecase ,index
;; FIXME: the line marked by KLUDGE below
;; (and the analogous spot in
;; 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))
+ ,@(when (or (null kind) (eq kind :instance))
`((fixnum
(and ,slots ; KLUDGE
(clos-slots-ref ,slots ,index)))))
- ,@(when (or (null type) (eq type :class))
+ ,@(when (or (null kind) (eq kind :class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(if (eq ,value +slot-unbound+)
,(if (generate-fast-class-slot-access-p class slot-name)
:class :instance))))
-(defmacro instance-reader (pv-offset parameter position gf-name class)
- (declare (ignore class))
- `(instance-read-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset
- (,gf-name (instance-accessor-parameter ,parameter))
- :instance))
-
(defmacro instance-write-internal (pv slots pv-offset new-value default
- &optional type)
- (unless (member type '(nil :instance :class :default))
- (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
- (if (eq type :default)
+ &optional kind)
+ (unless (member kind '(nil :instance :class :default))
+ (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
+ (if (eq kind :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
- (let ((,index (pvref ,pv ,pv-offset)))
+ (let ((,index (svref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type :instance))
+ ,@(when (or (null kind) (eq kind :instance))
`((fixnum (and ,slots
(setf (clos-slots-ref ,slots ,index)
,new-value)))))
- ,@(when (or (null type) (eq type :class))
+ ,@(when (or (null kind) (eq kind :class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
,(if (generate-fast-class-slot-access-p class slot-name)
:class :instance))))
-(defmacro instance-writer (pv-offset
- parameter
- position
- gf-name
- class
- new-value)
- (declare (ignore class))
- `(instance-write-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset ,new-value
- (,(if (consp gf-name)
- (get-setf-fun-name gf-name)
- gf-name)
- (instance-accessor-parameter ,parameter)
- ,new-value)
- :instance))
-
(defmacro instance-boundp-internal (pv slots pv-offset default
- &optional type)
- (unless (member type '(nil :instance :class :default))
- (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
- (if (eq type :default)
+ &optional kind)
+ (unless (member kind '(nil :instance :class :default))
+ (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind))
+ (if (eq kind :default)
default
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
- (let ((,index (pvref ,pv ,pv-offset)))
+ (let ((,index (svref ,pv ,pv-offset)))
(typecase ,index
- ,@(when (or (null type) (eq type :instance))
+ ,@(when (or (null kind) (eq kind :instance))
`((fixnum (not (and ,slots
(eq (clos-slots-ref ,slots ,index)
+slot-unbound+))))))
- ,@(when (or (null type) (eq type :class))
+ ,@(when (or (null kind) (eq kind :class))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default)))))))
;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to
;;; having fewer PV's floating around. Even if the gain is only
;;; modest, it costs nothing.
-(defun slot-name-lists-from-slots (slots calls)
- (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
+(defun slot-name-lists-from-slots (slots)
+ (let ((slots (mutate-slots slots)))
(let* ((slot-name-lists
(mapcar (lambda (parameter-entry)
(cons nil (mapcar #'car (cdr parameter-entry))))
- slots))
- (call-list
- (mapcar #'car calls)))
- (dolist (call call-list)
- (dolist (arg (cdr call))
- (when (integerp arg)
- (setf (car (nth arg slot-name-lists)) t))))
- (setq slot-name-lists (mapcar (lambda (r+snl)
- (when (or (car r+snl) (cdr r+snl))
- r+snl))
- slot-name-lists))
- (let ((cvt (apply #'vector
- (let ((i -1))
- (mapcar (lambda (r+snl)
- (when r+snl (incf i)))
- slot-name-lists)))))
- (setq call-list (mapcar (lambda (call)
- (cons (car call)
- (mapcar (lambda (arg)
- (if (integerp arg)
- (svref cvt arg)
- arg))
- (cdr call))))
- call-list)))
- (values slot-name-lists call-list))))
-
-(defun mutate-slots-and-calls (slots calls)
+ slots)))
+ (mapcar (lambda (r+snl)
+ (when (or (car r+snl) (cdr r+snl))
+ r+snl))
+ slot-name-lists))))
+
+(defun mutate-slots (slots)
(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)
(dolist (form (cdr slot-entry))
(setf (cadr form) pv-offset))))
- (dolist (call-entry sorted-calls)
- (incf pv-offset)
- (dolist (form (cdr call-entry))
- (setf (cadr form) pv-offset)))
- (values sorted-slots sorted-calls)))
+ sorted-slots))
(defun symbol-pkg-name (sym)
(let ((pkg (symbol-package sym)))
:key #'car)))
slots))
-(defun sort-calls (calls)
- (sort calls #'symbol-or-cons-lessp :key #'car))
\f
;;;; This needs to work in terms of metatypes and also needs to work
;;;; for automatically generated reader and writer functions.
;;;; 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
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-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-table-form pv-parameters slot-vars)
&body body)
- `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
+ `(pv-env (,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-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)
+ `(locally ,@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
%method-lambda-list
optimize
ftype
+ muffle-conditions
inline
notinline))
(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)))))
+(defun lambda-list-parameter-names (lambda-list)
+ ;; 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)
+ (if (consp x)
+ (let ((name (car x)))
+ (if (consp name)
+ ;; ... ((:BAR FOO) 1)
+ (push (second name) res)
+ ;; ... (FOO 1)
+ (push name res))
+ ;; ... (... 1 FOO-P)
+ (let ((name-p (cddr x)))
+ (when name-p
+ (push (car name-p) res))))
+ ;; ... FOO
+ (push x res)))
+ finally (return res)))
+
(defun make-method-initargs-form-internal1
(initargs body req-args lmf-params restp)
- (multiple-value-bind (outer-decls inner-decls body-sans-decls)
- (split-declarations
- 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
- (,(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 (;; If :PV-TABLE-SYMBOL isn't in the plist, the PV-ENV
- ;; macro defined here will never get expanded. To
- ;; speed up compilation of CLOS code, don't emit it
- ;; in the first place.
- ,@(when (getf (cdr lmf-params) :pv-env-p)
- `((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))))
+ (let* (;; The lambda-list of the method, minus specifiers
+ (lambda-list (car lmf-params))
+ ;; Names of the parameters that will be in the outermost lambda-list
+ ;; (and whose bound declarations thus need to be in OUTER-DECLS).
+ (outer-parameters req-args)
+ ;; The lambda-list used by BIND-ARGS
+ (bind-list lambda-list)
+ (setq-p (getf (cdr lmf-params) :setq-p))
+ (auxp (member '&aux bind-list))
+ (call-next-method-p (getf (cdr lmf-params) :call-next-method-p)))
+ ;; Try to use the normal function call machinery instead of BIND-ARGS
+ ;; binding the arguments, unless:
+ (unless (or ;; If all arguments are required, BIND-ARGS will be a no-op
+ ;; in any case.
+ (and (not restp) (not auxp))
+ ;; CALL-NEXT-METHOD wants to use BIND-ARGS, and needs a
+ ;; list of all non-required arguments.
+ call-next-method-p)
+ (setf ;; We don't want a binding for .REST-ARG.
+ restp nil
+ ;; Get all the parameters for declaration parsing
+ outer-parameters (lambda-list-parameter-names lambda-list)
+ ;; Ensure that BIND-ARGS won't do anything (since
+ ;; BIND-LIST won't contain any non-required parameters,
+ ;; and REQ-ARGS will be of an equal length). We still want
+ ;; to pass BIND-LIST to FAST-LEXICAL-METHOD-FUNCTIONS so
+ ;; that BIND-FAST-LEXICAL-METHOD-FUNCTIONS can take care
+ ;; of rebinding SETQd required arguments around the method
+ ;; body.
+ bind-list req-args))
+ (multiple-value-bind (outer-decls inner-decls body-sans-decls)
+ (split-declarations
+ body outer-parameters (or call-next-method-p setq-p))
+ (let* ((rest-arg (when restp
+ '.rest-arg.))
+ (fmf-lambda-list (if rest-arg
+ (append req-args (list '&rest rest-arg))
+ (if call-next-method-p
+ req-args
+ lambda-list))))
+ `(list*
+ :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))))
+ ;; The lambda-list of the FMF
+ (.pv. .next-method-call. ,@fmf-lambda-list)
+ ;; body of the function
+ (declare (ignorable .pv. .next-method-call.)
+ (disable-package-locks pv-env-environment))
+ ,@outer-decls
+ (symbol-macrolet ((pv-env-environment default))
+ (fast-lexical-method-functions
+ (,bind-list .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
;;; better. It doesn't really matter, though, because a function
;;; 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)
+ (snl (getf plist :slot-name-lists))
+ (pv-table (when snl
+ (intern-pv-table :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)))
+ (let* ((pv (when pv-table
+ (get-pv method-args pv-table)))
(nm (car next-methods))
(nms (cdr next-methods))
(nmc (when 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)))))
- (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)
+ (apply fmf pv nmc method-args))))
+ ;; 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 (fast-method-call-pv 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)))))
+ (apply fmf pv nmc method-args)))))
+
+(defun get-pv (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)))
when snl
collect w into result
finally (return (if (cdr result) result (car result)))))
+
projects / sbcl.git / blobdiff