;;;; to each such (GF . ARGS) tuple inside a method body, and use this
;;;; to cache effective method functions.
\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
(declaim (inline make-pv-table))
(defstruct (pv-table (:predicate pv-tablep)
(:copier nil))
;;; used.
(defvar *pv-tables* (make-hash-table :test 'equal))
-;;; 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*.
(sb-thread::make-spinlock :name "pv table index lock"))
(defun intern-pv-table (&key slot-name-lists)
- (let ((new-p nil))
- (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))))))
- (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)))
+ (flet ((intern-slot-names (slot-names)
+ ;; FIXME: NIL at the head of the list is a remnant from
+ ;; old purged code, that hasn't been quite cleaned up yet.
+ ;; ...but as long as we assume it is there, we may as well
+ ;; assert it.
+ (aver (not (car 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*)
+ (make-pv-table :slot-name-lists snl
+ :pv-size (reduce #'+ snl
+ :key (lambda (slots)
+ (length (cdr slots)))))))))
+ (sb-thread::with-spinlock (*pv-lock*)
+ (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
\f
(defun optimize-slot-value-by-class-p (class slot-name type)
(or (not (eq *boot-state* 'complete))
(and slotd
(slot-accessor-std-p slotd type)))))
-(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)
- (assq slot-name class-slots)))
- (when (consp slot-name)
- (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 (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)
(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))))
+ (class (wrapper-class* wrapper)))
(dolist (slot-name (cdr slot-names))
(push (if std-p
- (compute-pv-slot slot-name wrapper class class-slots)
+ (compute-pv-slot slot-name wrapper class)
nil)
elements)))))
(let* ((n (length elements))
(defun make-pv-type-declaration (var)
`(type simple-vector ,var))
-
-(defvar *pv-table-cache-update-info* nil)
-
-(defun update-pv-table-cache-info (class)
- (let ((slot-names-for-pv-table-update nil)
- (new-icui nil))
- (dolist (icu *pv-table-cache-update-info*)
- (if (eq (car icu) class)
- (pushnew (cdr icu) slot-names-for-pv-table-update)
- (push icu new-icui)))
- (setq *pv-table-cache-update-info* new-icui)
- (when slot-names-for-pv-table-update
- (update-all-pv-table-caches class slot-names-for-pv-table-update))))
-
-(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)))
- (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
- slot-name
- (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 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)))
- (setf (svref pv-map map-index)
- (and a (cons param-index (cdr a)))))
- (incf map-index))
- (incf param-index)))
- (when cache
- (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 (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)
(destructuring-bind (op var-form slot-name-form &optional new-value) form
(pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
(defun pv-wrappers-from-pv-args (&rest args)
- (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)))))
+ (loop for arg in args
+ collect (valid-wrapper-of arg)))
(defun pv-wrappers-from-all-args (pv-table args)
- (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
+ (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)))))
+ collect (valid-wrapper-of arg)))
;;; Return the subset of WRAPPERS which is used in the cache
;;; of PV-TABLE.
(defun pv-wrappers-from-all-wrappers (pv-table 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)))))
-
+ collect w))
projects / sbcl.git / blobdiff