;;;; specification.
(in-package "SB-PCL")
+
+;;;; 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
-(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)
- (: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))
-
-;;; 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)
- (make-pv-table-internal slot-name-lists call-list))
+ (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))
-
-;;; Entries in this are lists of (table . pv-offset-list).
-(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
-
-(defun intern-pv-table (&key slot-name-lists call-list)
- (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)))
- (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 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*)))
- (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)
+;;; 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))
+
+;;; Used for interning PV-TABLES, keyed by the SLOT-NAME-LISTS
+;;; used.
+(defvar *pv-tables* (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)
+ (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)
(setq wrappers (list wrappers)))
(let (elements)
- (dolist (slot-names slot-name-lists
- (make-permutation-vector (nreverse elements)))
+ (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))))
+ (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)))))))
-
-(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))
+ 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)
(make-cache :key-count (- (length slot-name-lists)
(if hitp
value
(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)))
+ (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-cell)))))
+ pv)))))
(defun make-pv-type-declaration (var)
`(type simple-vector ,var))
-
-(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)
- (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 pv-offset-list)
- (declare (ignore pv-offset-list))
- (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-cell)
- (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 (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
(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)))))
+ (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))
;;; 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))))
+ slots)))
+ (mapcar (lambda (r+snl)
+ (when (or (car r+snl) (cdr r+snl))
+ r+snl))
+ slot-name-lists))))
-(defun mutate-slots-and-calls (slots calls)
+(defun mutate-slots (slots)
(let ((sorted-slots (sort-slots slots))
- (sorted-calls (sort-calls (cdr calls)))
(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.
do (when slots
(push required-parameter pv-parameters)
(push (slot-vector-symbol i) slot-vars)))
- `(pv-binding1 (.pv. .calls. ,pv-table-form
+ `(pv-binding1 (,pv-table-form
,(nreverse pv-parameters) ,(nreverse slot-vars))
,@body)))
-(defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars)
+(defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars)
&body body)
- `(pv-env (,pv ,calls ,pv-table-form ,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)))
(define-symbol-macro pv-env-environment overridden)
(defmacro pv-env (&environment env
- (pv calls pv-table-form pv-parameters)
+ (pv-table-form pv-parameters)
&rest 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)
+ `(locally ,@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
+ (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters)))
+ (declare ,(make-pv-type-declaration '.pv.))
,@forms)))
(defvar *non-var-declarations*
;; function name
(list (cons 'fast-method (body-method-name body))))
;; The lambda-list of the FMF
- (.pv-cell. .next-method-call. ,@fmf-lambda-list)
+ (.pv. .next-method-call. ,@fmf-lambda-list)
;; body of the function
- (declare (ignorable .pv-cell. .next-method-call.)
+ (declare (ignorable .pv. .next-method-call.)
(disable-package-locks pv-env-environment))
,@outer-decls
(symbol-macrolet ((pv-env-environment default))
(defun method-function-from-fast-function (fmf plist)
(declare (type function fmf))
(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)))
+ (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)
- (let* ((pv-cell (when pv-table
- (get-pv-cell 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)))))
- (apply fmf pv-cell nmc method-args))))
+ (apply fmf pv nmc method-args))))
;; FIXME: this looks dangerous.
(let* ((fname (%fun-name fmf)))
(when (and fname (eq (car fname) 'fast-method))
;;; 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))
+ (pv (fast-method-call-pv fmc))
(arg-info (fast-method-call-arg-info fmc))
(nreq (car arg-info))
(restp (cdr arg-info)))
(method-function nm)
nm)
:call-method-args (list nms)))))
- (apply fmf pv-cell nmc method-args)))))
+ (apply fmf pv nmc method-args)))))
-(defun get-pv-cell (method-args pv-table)
+(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))))
(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