X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=6a000b4a57c565e7ad9319470ab89885647000f1;hb=a7a4ca961ef0f587a2549bd9433eef7ddb845ab7;hp=76179ea459186df1fc1ba629ac9b6fb082eb852d;hpb=a8fa26a6e9804d3548f5bca9361a91345a689099;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 76179ea..6a000b4 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -24,600 +24,298 @@ ;;;; specification. (in-package "SB-PCL") - -(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))))) - -(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. + +(declaim (inline make-pv-table)) (defstruct (pv-table (:predicate pv-tablep) - (:constructor make-pv-table-internal - (slot-name-lists call-list)) - (:copier nil)) + (: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)) - -;;; 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 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) +;;; 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 *world-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 (* 2 (reduce #'+ snl + :key (lambda (slots) + (length (cdr slots)))))))))) + (sb-thread::with-spinlock (*pv-lock*) + (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))) -(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 use-standard-slot-access-p (class slot-name type) + (or (not (eq **boot-state** 'complete)) + (and (standard-class-p class) + (let ((slotd (find-slot-definition class slot-name))) + (and slotd + (slot-accessor-std-p slotd type)))))) + +(defun slot-missing-info (class slot-name) + (flet ((missing (operation) + (lambda (object) + (slot-missing class object slot-name operation)))) + (make-slot-info + :reader (missing 'slot-value) + :boundp (missing 'slot-boundp) + :writer (lambda (new-value object) + (slot-missing class object slot-name 'setf new-value))))) (defun compute-pv (slot-name-lists wrappers) - (unless (listp wrappers) (setq wrappers (list wrappers))) - (let* ((not-simple-p-cell (list nil)) - (elements - (gathering1 (collecting) - (iterate ((slot-names (list-elements 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)) - (gather1 - (when std-p - (compute-pv-slot slot-name wrapper class - class-slots not-simple-p-cell)))))))))) - (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)) + (let ((cell + (or (find-slot-cell wrapper slot-name) + (cons nil (slot-missing-info class slot-name))))) + (push (when (and std-p (use-standard-slot-access-p class slot-name 'all)) + (car cell)) + elements) + (push (or (cdr cell) + (bug "No SLOT-INFO for ~S in ~S" slot-name class)) + 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) - (free-cache cache)) - pv-cell)))) + (cache (or (pv-table-cache pv-table) + (setf (pv-table-cache pv-table) + (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) - (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))) - (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)) - (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 1)(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) - (setf (car 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 (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))) -(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))))))))))))) +;;; Sometimes we want to finalize if we can, but it's OK if +;;; we can't. +(defun try-finalize-inheritance (class) + (unless (typep class 'forward-referenced-class) + (when (every (lambda (super) + (or (eq super class) + (class-finalized-p super) + (try-finalize-inheritance super))) + (class-direct-superclasses class)) + (finalize-inheritance class) + t))) -(defun optimize-generic-function-call (form - required-parameters - env - slots - calls) - (declare (ignore required-parameters env slots calls)) - (or (and (eq (car form) 'make-instance) - (expand-make-instance-form form)) - form)) - (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 (variable-declaration '%variable-rebinding - var - env))) - (parameter-or-nil (car (memq (or rebound? var) - required-parameters)))) - (when parameter-or-nil - (let* ((class-name (caddr (variable-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 (and (symbolp var) (not (var-special-p var env))) + (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))) + (cond ((not (eq **boot-state** 'complete)) + (setq class nil)) + ((and class (not (class-finalized-p class))) + ;; The class itself is never forward-referenced + ;; here, but its superclasses may be. + (unless (try-finalize-inheritance class) + (when (boundp 'sb-c:*lexenv*) + (sb-c:compiler-notify + "~@" + class form)) + (setf class nil)))) + (when (and class-name (not (eq class-name t))) + (when (not (and class + (memq *the-class-structure-object* + (class-precedence-list class)))) + (aver 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 (safe-code-p env)))) + ;; 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 ((parameter-modified-p parameter-name env) + ;; ACCESSOR-SET-SLOT-VALUE doesn't do type-checking, + ;; so we need to use SAFE-SET-SLOT-VALUE. + (if (safe-code-p env) + `(safe-set-slot-value ,@(cdr form))) + `(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 ;;; the position of an entry in the alist corresponds to the ;;; argument's position in the lambda list. -(defun optimize-instance-access (slots - read/write - sparameter - slot-name - new-value) +(defun optimize-instance-access (slots read/write sparameter slot-name + new-value &optional safep) (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter))) - (if (and (eq *boot-state* 'complete) - (classp class) - (memq *the-class-structure-object* (class-precedence-list class))) - (let ((slotd (find-slot-definition class slot-name))) - (ecase read/write - (:read - `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) - (:write - `(setf (,(slot-definition-defstruct-accessor-symbol slotd) - ,parameter) - ,new-value)) - (:boundp - t))) - (let* ((parameter-entry (assq parameter slots)) - (slot-entry (assq slot-name (cdr parameter-entry))) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless parameter-entry - (error "internal error in slot optimization")) - (unless slot-entry - (setq slot-entry (list slot-name)) - (push slot-entry (cdr parameter-entry))) - (push pv-offset-form (cdr slot-entry)) - (ecase read/write - (:read - `(instance-read ,pv-offset-form ,parameter ,position - ',slot-name ',class)) - (:write - `(let ((.new-value. ,new-value)) - (instance-write ,pv-offset-form ,parameter ,position - ',slot-name ',class .new-value.))) - (:boundp - `(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 "internal error in slot optimization")) - (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 (variable-declaration '%variable-rebinding - form env))) - (parameter-or-nil (car (assq (or rebound? form) slots)))) - (when parameter-or-nil - (let* ((class-name (caddr (variable-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 (eval 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))))))))) + (parameter (if (consp sparameter) (car sparameter) sparameter))) + (if (and (eq **boot-state** 'complete) + (classp class) + (memq *the-class-structure-object* (class-precedence-list class))) + (let ((slotd (find-slot-definition class slot-name))) + (ecase read/write + (:read + `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter)) + (:write + `(setf (,(slot-definition-defstruct-accessor-symbol slotd) + ,parameter) + ,new-value)) + (:boundp + t))) + (let* ((parameter-entry (assq parameter slots)) + (slot-entry (assq slot-name (cdr parameter-entry))) + (position (posq parameter-entry slots)) + (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) + (unless parameter-entry + (bug "slot optimization bewilderment: O-I-A")) + (unless slot-entry + (setq slot-entry (list slot-name)) + (push slot-entry (cdr parameter-entry))) + (push pv-offset-form (cdr slot-entry)) + (ecase read/write + (:read + `(instance-read ,pv-offset-form ,parameter ,position + ',slot-name ',class)) + (:write + `(let ((.new-value. ,new-value)) + (instance-write ,pv-offset-form ,parameter ,position + ',slot-name ',class .new-value. ,safep))) + (:boundp + `(instance-boundp ,pv-offset-form ,parameter ,position + ',slot-name ',class))))))) (define-walker-template pv-offset) ; These forms get munged by mutate slots. (defmacro pv-offset (arg) arg) @@ -627,137 +325,188 @@ ;;; 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)))) - (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (let ((slotd (find-slot-definition class slot-name))) - (and slotd (classp (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)))) - (and (eq *boot-state* 'complete) - (standard-class-p class) - (not (eq class *the-class-t*)) ; shouldn't happen, though. - (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) - default - (let* ((index (gensym)) - (value index)) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (setq ,value (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (clos-slots-ref ,slots ,index)))) - ,@(when (or (null type) (eq type ':class)) - `((cons (cdr ,index)))) - (t +slot-unbound+))) - (if (eq ,value +slot-unbound+) - ,default - ,value)))))) + (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. + (let ((slotd (find-slot-definition class slot-name))) + (and slotd (eq :class (slot-definition-allocation slotd))))))) + +(defun constant-value-or-nil (form) + (and (constantp form) (constant-form-value form))) + +(defun slot-access-strategy (class slot-name type &optional conservative) + ;; CONSERVATIVE means we should assume custom access pattern even if + ;; there are no custom accessors defined if the metaclass is non-standard. + ;; + ;; This is needed because DEFCLASS generates accessor methods before possible + ;; SLOT-VALUE-USING-CLASS methods are defined, which causes them to take + ;; the slow path unless we make the conservative assumption here. + (if (eq **boot-state** 'complete) + (let (slotd) + (cond ((or + ;; Conditions, structures, and classes for which FIND-CLASS + ;; doesn't return them yet. + ;; FIXME: surely we can get faster accesses for structures? + (not (standard-class-p class)) + ;; Should not happen... (FIXME: assert instead?) + (eq class *the-class-t*) + (not (class-finalized-p class)) + ;; Strangeness... + (not (setf slotd (find-slot-definition class slot-name)))) + :accessor) + ((and (slot-accessor-std-p slotd type) + (or (not conservative) (eq *the-class-standard-class* (class-of class)))) + ;; The best case. + :standard) + (t + :custom))) + :standard)) + +;;;; SLOT-VALUE (defmacro instance-read (pv-offset parameter position slot-name class) - (if (skip-fast-slot-access-p class slot-name 'reader) - `(accessor-slot-value ,parameter ,slot-name) - `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-value ,parameter ,slot-name) - ,(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) - default - (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (setf (clos-slots-ref ,slots ,index) - ,new-value)))) - ,@(when (or (null type) (eq type ':class)) - `((cons (setf (cdr ,index) ,new-value)))) - (t ,default))))))) - -(defmacro instance-write (pv-offset - parameter - position - slot-name - class - new-value) - (if (skip-fast-slot-access-p class slot-name 'writer) - `(accessor-set-slot-value ,parameter ,slot-name ,new-value) - `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (accessor-set-slot-value ,parameter ,slot-name ,new-value) - ,(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-function-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) - default - (let* ((index (gensym))) - `(locally (declare #.*optimize-speed*) - (let ((,index (pvref ,pv ,pv-offset))) - (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (not (and ,slots - (eq (clos-slots-ref ,slots ,index) - +slot-unbound+)))))) - ,@(when (or (null type) (eq type ':class)) - `((cons (not (eq (cdr ,index) +slot-unbound+))))) - (t ,default))))))) + (ecase (slot-access-strategy (constant-value-or-nil class) + (constant-value-or-nil slot-name) + 'reader) + (:standard + `(instance-read-standard + .pv. ,(slot-vector-symbol position) + ,pv-offset (accessor-slot-value ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance))) + (:custom + `(instance-read-custom .pv. ,pv-offset ,parameter)) + (:accessor + `(accessor-slot-value ,parameter ,slot-name)))) + +(defmacro instance-read-standard (pv slots pv-offset default &optional kind) + (unless (member kind '(nil :instance :class)) + (error "illegal kind argument to ~S: ~S" 'instance-read-standard kind)) + (let* ((index (gensym)) + (value index)) + `(locally (declare #.*optimize-speed*) + (let ((,index (svref ,pv ,pv-offset)) + (,slots (truly-the simple-vector ,slots))) + (setq ,value (typecase ,index + ;; FIXME: the line marked by KLUDGE below (and + ;; the analogous spot in + ;; INSTANCE-WRITE-STANDARD) is there purely to + ;; suppress a type mismatch warning that + ;; propagates through to user code. + ;; Presumably SLOTS at this point can never + ;; actually be NIL, but the compiler seems to + ;; think it could, so we put this here to shut + ;; it up. (see also mail Rudi Schlatte + ;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30 + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum + (clos-slots-ref ,slots ,index)))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (cdr ,index)))) + (t + +slot-unbound+))) + (if (eq ,value +slot-unbound+) + ,default + ,value))))) + +(defmacro instance-read-custom (pv pv-offset parameter) + `(locally (declare #.*optimize-speed*) + (funcall (slot-info-reader (svref ,pv (1+ ,pv-offset))) ,parameter))) + +;;;; (SETF SLOT-VALUE) + +(defmacro instance-write (pv-offset parameter position slot-name class new-value + &optional check-type-p) + (ecase (slot-access-strategy (constant-value-or-nil class) + (constant-value-or-nil slot-name) + 'writer) + (:standard + `(instance-write-standard + .pv. ,(slot-vector-symbol position) + ,pv-offset ,new-value + ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form + ;; is executed (if it is executed). + (accessor-set-slot-value ,parameter ,slot-name .good-new-value.) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance) + ,check-type-p)) + (:custom + `(instance-write-custom .pv. ,pv-offset ,parameter ,new-value)) + (:accessor + (if check-type-p + ;; FIXME: We don't want this here. If it's _possible_ the fast path + ;; is applicable, we want to use it as well. + `(safe-set-slot-value ,parameter ,slot-name ,new-value) + `(accessor-set-slot-value ,parameter ,slot-name ,new-value))))) + +(defmacro instance-write-standard (pv slots pv-offset new-value default + &optional kind safep) + (unless (member kind '(nil :instance :class)) + (error "illegal kind argument to ~S: ~S" 'instance-write-standard kind)) + (let* ((index (gensym)) + (new-value-form + (if safep + `(let ((.typecheckfun. (slot-info-typecheck (svref ,pv (1+ ,pv-offset))))) + (declare (type (or function null) .typecheckfun.)) + (if .typecheckfun. + (funcall .typecheckfun. ,new-value) + ,new-value)) + new-value))) + `(locally (declare #.*optimize-speed*) + (let ((.good-new-value. ,new-value-form) + (,index (svref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum (and ,slots + (setf (clos-slots-ref ,slots ,index) + .good-new-value.))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (setf (cdr ,index) .good-new-value.)))) + (t ,default)))))) + +(defmacro instance-write-custom (pv pv-offset parameter new-value) + `(locally (declare #.*optimize-speed*) + (funcall (slot-info-writer (svref ,pv (1+ ,pv-offset))) ,new-value ,parameter))) + +;;;; SLOT-BOUNDP (defmacro instance-boundp (pv-offset parameter position slot-name class) - (if (skip-fast-slot-access-p class slot-name 'boundp) - `(accessor-slot-boundp ,parameter ,slot-name) - `(instance-boundp-internal .pv. ,(slot-vector-symbol position) - ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) - ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + (ecase (slot-access-strategy (constant-value-or-nil class) + (constant-value-or-nil slot-name) + 'boundp) + (:standard + `(instance-boundp-standard + .pv. ,(slot-vector-symbol position) + ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) + ,(if (generate-fast-class-slot-access-p class slot-name) + :class :instance))) + (:custom + `(instance-boundp-custom .pv. ,pv-offset ,parameter)) + (:accessor + `(accessor-slot-boundp ,parameter ,slot-name)))) + +(defmacro instance-boundp-standard (pv slots pv-offset default + &optional kind) + (unless (member kind '(nil :instance :class)) + (error "illegal kind argument to ~S: ~S" 'instance-boundp-standard kind)) + (let* ((index (gensym))) + `(locally (declare #.*optimize-speed*) + (let ((,index (svref ,pv ,pv-offset))) + (typecase ,index + ,@(when (or (null kind) (eq kind :instance)) + `((fixnum (not (and ,slots + (eq (clos-slots-ref ,slots ,index) + +slot-unbound+)))))) + ,@(when (or (null kind) (eq kind :class)) + `((cons (not (eq (cdr ,index) +slot-unbound+))))) + (t ,default)))))) + +(defmacro instance-boundp-custom (pv pv-offset parameter) + `(locally (declare #.*optimize-speed*) + (funcall (slot-info-boundp (svref ,pv (1+ ,pv-offset))) ,parameter))) ;;; This magic function has quite a job to do indeed. ;;; @@ -775,51 +524,28 @@ ;;; 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) + (mapcar (lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) + 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))) + (incf pv-offset) + (dolist (form (cdr slot-entry)) + (setf (cadr form) pv-offset)) + ;; Count one more for the slot we use for SLOT-INFO. + (incf pv-offset))) + sorted-slots)) (defun symbol-pkg-name (sym) (let ((pkg (symbol-package sym))) @@ -839,318 +565,323 @@ ;;; * faster code. (defun symbol-lessp (a b) (if (eq (symbol-package a) - (symbol-package b)) + (symbol-package b)) (string-lessp (symbol-name a) - (symbol-name b)) + (symbol-name b)) (string-lessp (symbol-pkg-name a) - (symbol-pkg-name b)))) + (symbol-pkg-name b)))) (defun symbol-or-cons-lessp (a b) (etypecase a (symbol (etypecase b - (symbol (symbol-lessp a b)) - (cons t))) + (symbol (symbol-lessp a b)) + (cons t))) (cons (etypecase b - (symbol nil) - (cons (if (eq (car a) (car b)) - (symbol-or-cons-lessp (cdr a) (cdr b)) - (symbol-or-cons-lessp (car a) (car b)))))))) + (symbol nil) + (cons (if (eq (car a) (car b)) + (symbol-or-cons-lessp (cdr a) (cdr b)) + (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) (mapcar (lambda (parameter-entry) - (cons (car parameter-entry) - (sort (cdr parameter-entry) ;slot entries - #'symbol-or-cons-lessp - :key #'car))) - slots)) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) + slots)) -(defun sort-calls (calls) - (sort calls #'symbol-or-cons-lessp :key #'car)) ;;;; 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) - &body body) - (with-gathering ((slot-vars (collecting)) - (pv-parameters (collecting))) - (iterate ((slots (list-elements slot-name-lists)) - (required-parameter (list-elements required-parameters)) - (i (interval :from 0))) - (when slots - (gather required-parameter pv-parameters) - (gather (slot-vector-symbol i) slot-vars))) - `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars) +(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 + for required-parameter in required-parameters + for i from 0 + do (when slots + (push required-parameter pv-parameters) + (push (slot-vector-symbol i) slot-vars))) + `(pv-binding1 (,pv-table-form + ,(nreverse pv-parameters) ,(nreverse slot-vars)) ,@body))) -(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) - &body body) - `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) - ,@body))) - -;;; This gets used only when the default MAKE-METHOD-LAMBDA is overridden. -(defmacro pv-env ((pv calls pv-table-symbol 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)) - -(defvar *non-variable-declarations* - ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I - ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If - ;; SBCL doesn't have 'em, VALUES should probably be removed from - ;; this list. - '(values %method-name %method-lambda-list - optimize ftype inline notinline)) - -(defvar *variable-declarations-with-argument* - '(%class - type)) - -(defvar *variable-declarations-without-argument* - '(ignore - ignorable special dynamic-extent - ;; FIXME: Possibly this entire list and variable could go away. - ;; If not, certainly we should remove all these built-in typenames - ;; from the list, and replace them with a test for "is it a type - ;; name?" (CLTL1 allowed only built-in type names as declarations, - ;; but ANSI CL allows any type name as a declaration.) - array atom base-char bignum bit bit-vector character compiled-function - complex cons double-float extended-char - fixnum float function hash-table integer - keyword list long-float nil null number package pathname random-state ratio - rational readtable sequence short-float signed-byte simple-array - simple-bit-vector simple-string simple-vector single-float standard-char - stream string symbol t unsigned-byte vector)) +(defmacro pv-binding1 ((pv-table-form pv-parameters slot-vars) + &body body) + `(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))) -(defun split-declarations (body args calls-next-method-p) +;;; This will only be visible in PV-ENV when the default MAKE-METHOD-LAMBDA is +;;; overridden. +(define-symbol-macro pv-env-environment overridden) + +(defmacro pv-env (&environment env + (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) + `(locally (declare (simple-vector .pv.)) + ,@forms) + `(let* ((.pv-table. ,pv-table-form) + (.pv. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))) + (declare ,(make-pv-type-declaration '.pv.)) + ,@forms))) + +(defun split-declarations (body args req-args cnm-p parameters-setqd) (let ((inner-decls nil) - (outer-decls nil) - decl) - (loop (when (null body) (return nil)) - (setq decl (car body)) - (unless (and (consp decl) - (eq (car decl) 'declare)) - (return nil)) - (dolist (form (cdr decl)) - (when (consp form) - (let ((declaration-name (car form))) - (if (member declaration-name *non-variable-declarations*) - (push `(declare ,form) outer-decls) - (let ((arg-p - (member declaration-name - *variable-declarations-with-argument*)) - (non-arg-p - (member declaration-name - *variable-declarations-without-argument*)) - (dname (list (pop form))) - (inners nil) (outers nil)) - (unless (or arg-p non-arg-p) - ;; FIXME: This warning, and perhaps the - ;; various *VARIABLE-DECLARATIONS-FOO* and/or - ;; *NON-VARIABLE-DECLARATIONS* variables, - ;; could probably go away now that we're not - ;; trying to be portable between different - ;; CLTL1 hosts the way PCL was. (Note that to - ;; do this right, we need to be able to handle - ;; user-defined (DECLAIM (DECLARATION FOO)) - ;; stuff.) - (warn "The declaration ~S is not understood by ~S.~@ - Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ - (Assuming it is a variable declaration without argument)." - declaration-name 'split-declarations - declaration-name - '*non-variable-declarations* - '*variable-declarations-with-argument* - '*variable-declarations-without-argument*) - (push declaration-name - *variable-declarations-without-argument*)) - (when arg-p - (setq dname (append dname (list (pop form))))) - (dolist (var form) - (if (member var args) - ;; Quietly remove IGNORE declarations on - ;; args when a next-method is involved, to - ;; prevent compiler warns about ignored - ;; args being read. - (unless (and calls-next-method-p - (eq (car dname) 'ignore)) - (push var outers)) - (push var inners))) - (when outers - (push `(declare (,@dname ,@outers)) outer-decls)) - (when inners - (push `(declare (,@dname ,@inners)) inner-decls))))))) - (setq body (cdr body))) + (outer-decls nil) + decl) + (loop + (when (null body) + (return nil)) + (setq decl (car body)) + (unless (and (consp decl) (eq (car decl) 'declare)) + (return nil)) + (dolist (form (cdr decl)) + (when (consp form) + (let* ((name (car form))) + (cond ((eq '%class name) + (push `(declare ,form) inner-decls)) + ((or (member name '(ignore ignorable special dynamic-extent type)) + (info :type :kind name)) + (let* ((inners nil) + (outers nil) + (tail (cdr form)) + (head (if (eq 'type name) + (list name (pop tail)) + (list name)))) + (dolist (var tail) + (if (member var args :test #'eq) + ;; Quietly remove IGNORE declarations on + ;; args when a next-method is involved, to + ;; prevent compiler warnings about ignored + ;; args being read. + (unless (and (eq 'ignore name) (member var req-args :test #'eq) (or cnm-p (member var parameters-setqd))) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@head ,@outers)) outer-decls)) + (when inners + (push `(declare (,@head ,@inners)) inner-decls)))) + (t + ;; All other declarations are not variable declarations, + ;; so they become outer declarations. + (push `(declare ,form) outer-decls)))))) + (setq body (cdr body))) (values outer-decls inner-decls body))) +;;; Convert a lambda expression containing a SB-PCL::%METHOD-NAME +;;; declaration (which is a naming style internal to PCL) into an +;;; SB-INT:NAMED-LAMBDA expression (which is a naming style used +;;; throughout SBCL, understood by the main compiler); or if there's +;;; no SB-PCL::%METHOD-NAME declaration, then just return the original +;;; lambda expression. +(defun name-method-lambda (method-lambda) + (let ((method-name *method-name*)) + (if method-name + `(named-lambda (slow-method ,@method-name) ,@(rest method-lambda)) + method-lambda))) + (defun make-method-initargs-form-internal (method-lambda initargs env) (declare (ignore env)) - (let (method-lambda-args lmf lmf-params) + (let (method-lambda-args + lmf ; becomes body of function + lmf-params) (if (not (and (= 3 (length method-lambda)) - (= 2 (length (setq method-lambda-args (cadr method-lambda)))) - (consp (setq lmf (third method-lambda))) - (eq 'simple-lexical-method-functions (car lmf)) - (eq (car method-lambda-args) - (cadr (setq lmf-params (cadr lmf)))) - (eq (cadr method-lambda-args) - (caddr lmf-params)))) - `(list* :function #',method-lambda - ',initargs) - (let* ((lambda-list (car lmf-params)) - (nreq 0)(restp nil)(args nil)) - (dolist (arg lambda-list) - (when (member arg '(&optional &rest &key)) - (setq restp t)(return nil)) - (when (eq arg '&aux) (return nil)) - (incf nreq)(push arg args)) - (setq args (nreverse args)) - (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) - (make-method-initargs-form-internal1 - initargs (cddr lmf) args lmf-params restp))))) + (= 2 (length (setq method-lambda-args (cadr method-lambda)))) + (consp (setq lmf (third method-lambda))) + (eq 'simple-lexical-method-functions (car lmf)) + (eq (car method-lambda-args) + (cadr (setq lmf-params (cadr lmf)))) + (eq (cadr method-lambda-args) + (caddr lmf-params)))) + `(list* :function ,(name-method-lambda method-lambda) + ',initargs) + (let* ((lambda-list (car lmf-params)) + (nreq 0) + (restp nil) + (args nil)) + (dolist (arg lambda-list) + (when (member arg '(&optional &rest &key)) + (setq restp t) + (return nil)) + (when (eq arg '&aux) + (return nil)) + (incf nreq) + (push arg args)) + (setq args (nreverse args)) + (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 :test #'eq) + (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) - (split-declarations - body req-args (getf (cdr lmf-params) :call-next-method-p)) - (let* ((rest-arg (when restp '.rest-arg.)) - (args+rest-arg (if restp - (append req-args (list rest-arg)) - req-args))) - `(list* :fast-function - (lambda (.pv-cell. .next-method-call. ,@args+rest-arg) - (declare (ignorable .pv-cell. .next-method-call.)) - ,@outer-decls - (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters) - &rest forms) - (declare (ignore pv-table-symbol pv-parameters)) - `(let ((,pv (car .pv-cell.)) - (,calls (cdr .pv-cell.))) - (declare ,(make-pv-type-declaration pv) - ,(make-calls-type-declaration calls)) - ,pv ,calls - ,@forms))) - (fast-lexical-method-functions - (,(car lmf-params) .next-method-call. ,req-args ,rest-arg - ,@(cdddr lmf-params)) - ,@inner-decls - ,@body))) - ',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) + (parameters-setqd (getf (cdr lmf-params) :parameters-setqd)) + (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 req-args call-next-method-p parameters-setqd) + (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 *method-name* 'named-lambda 'lambda) + ,@(when *method-name* + ;; function name + (list `(fast-method ,@*method-name*))) + ;; 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)) - (nreq (car arg-info)) - (restp (cdr 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))) - (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))))) - (let* ((fname (method-function-get fmf :name)) - (name `(,(or (get (car fname) 'method-sym) - (setf (get (car fname) 'method-sym) - (let ((str (symbol-name (car fname)))) - (if (string= "FAST-" str :end2 5) - (intern (subseq str 5) *pcl-package*) - (car fname))))) - ,@(cdr fname)))) - (set-function-name method-function name)) - (setf (method-function-get method-function :fast-function) fmf) + (lambda (method-args next-methods) + (let* ((pv (when pv-table + (get-pv method-args pv-table))) + (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)))) + ;; 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))) (defun pv-wrappers-from-pv-args (&rest args) - (let* ((nkeys (length args)) - (pv-wrappers (make-list nkeys)) - w - (w-t pv-wrappers)) - (dolist (arg args) - (setq w (wrapper-of arg)) - (unless (eq t (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P - (setq w (check-wrapper-validity arg))) - (setf (car w-t) w)) - (setq w-t (cdr w-t)) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers)) + (loop for arg in args + collect (valid-wrapper-of arg))) (defun pv-wrappers-from-all-args (pv-table args) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let* ((arg (car args)) - (w (wrapper-of arg))) - (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening. - (error "error in PV-WRAPPERS-FROM-ALL-ARGS")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq args (cdr args))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) + and arg in args + when snl + 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) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let ((w (car wrappers))) - (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening. - (error "error in PV-WRAPPERS-FROM-ALL-WRAPPERS")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq wrappers (cdr wrappers))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers + when snl + collect w))