X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=0b7e01b3bbe979d1b29838f579774acee4945f32;hb=29a9ccc860532b32c566aec095f570e999a9c52c;hp=95c2c3abc92de444b37ddcb7bf32d55669368a0c;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 95c2c3a..0b7e01b 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -103,16 +103,16 @@ And so, we are saved. (when (and *raise-metatypes-to-class-p* (member generator '(emit-checking emit-caching emit-in-checking-cache-p emit-constant-value))) - (setq args (cons (mapcar #'(lambda (mt) - (if (eq mt 't) - mt - 'class)) + (setq args (cons (mapcar (lambda (mt) + (if (eq mt t) + mt + 'class)) (car args)) (cdr args)))) (let* ((generator-entry (assq generator *dfun-constructors*)) (args-entry (assoc args (cdr generator-entry) :test #'equal))) (if (null *enable-dfun-constructor-caching*) - (apply (name-get-fdefinition generator) args) + (apply (fdefinition generator) args) (or (cadr args-entry) (multiple-value-bind (new not-best-p) (apply (symbol-function generator) args) @@ -137,10 +137,12 @@ And so, we are saved. (metatypes (car args)) (gfs (when dfun-type (gfs-of-type dfun-type)))) (dolist (gf gfs) - (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf))) + (when (and (equal metatypes + (arg-info-metatypes (gf-arg-info gf))) (let ((gf-name (generic-function-name gf))) (and (not (eq gf-name 'slot-value-using-class)) - (not (equal gf-name '(setf slot-value-using-class))) + (not (equal gf-name + '(setf slot-value-using-class))) (not (eq gf-name 'slot-boundp-using-class))))) (update-dfun gf))) (setf (second args-entry) constructor) @@ -154,75 +156,77 @@ And so, we are saved. (defmacro precompile-dfun-constructors (&optional system) (let ((*precompiling-lap* t)) `(progn - ,@(gathering1 (collecting) + ,@(let (collect) (dolist (generator-entry *dfun-constructors*) (dolist (args-entry (cdr generator-entry)) (when (or (null (caddr args-entry)) (eq (caddr args-entry) system)) (when system (setf (caddr args-entry) system)) - (gather1 - `(load-precompiled-dfun-constructor - ',(car generator-entry) - ',(car args-entry) - ',system - ,(apply (name-get-fdefinition (car generator-entry)) - (car args-entry))))))))))) + (push `(load-precompiled-dfun-constructor + ',(car generator-entry) + ',(car args-entry) + ',system + ,(apply (fdefinition (car generator-entry)) + (car args-entry))) + collect)))) + (nreverse collect))))) -;;; When all the methods of a generic function are automatically generated -;;; reader or writer methods a number of special optimizations are possible. -;;; These are important because of the large number of generic functions of -;;; this type. +;;; When all the methods of a generic function are automatically +;;; generated reader or writer methods a number of special +;;; optimizations are possible. These are important because of the +;;; large number of generic functions of this type. ;;; ;;; There are a number of cases: ;;; ;;; ONE-CLASS-ACCESSOR -;;; In this case, the accessor generic function has only been called -;;; with one class of argument. There is no cache vector, the wrapper -;;; of the one class, and the slot index are stored directly as closure -;;; variables of the discriminating function. This case can convert to -;;; either of the next kind. +;;; In this case, the accessor generic function has only been +;;; called with one class of argument. There is no cache vector, +;;; the wrapper of the one class, and the slot index are stored +;;; directly as closure variables of the discriminating function. +;;; This case can convert to either of the next kind. ;;; ;;; TWO-CLASS-ACCESSOR -;;; Like above, but two classes. This is common enough to do specially. -;;; There is no cache vector. The two classes are stored a separate -;;; closure variables. +;;; Like above, but two classes. This is common enough to do +;;; specially. There is no cache vector. The two classes are +;;; stored a separate closure variables. ;;; ;;; ONE-INDEX-ACCESSOR -;;; In this case, the accessor generic function has seen more than one -;;; class of argument, but the index of the slot is the same for all -;;; the classes that have been seen. A cache vector is used to store -;;; the wrappers that have been seen, the slot index is stored directly -;;; as a closure variable of the discriminating function. This case -;;; can convert to the next kind. +;;; In this case, the accessor generic function has seen more than +;;; one class of argument, but the index of the slot is the same +;;; for all the classes that have been seen. A cache vector is +;;; used to store the wrappers that have been seen, the slot index +;;; is stored directly as a closure variable of the discriminating +;;; function. This case can convert to the next kind. ;;; ;;; N-N-ACCESSOR -;;; This is the most general case. In this case, the accessor generic -;;; function has seen more than one class of argument and more than one -;;; slot index. A cache vector stores the wrappers and corresponding -;;; slot indexes. Because each cache line is more than one element -;;; long, a cache lock count is used. -(defstruct (dfun-info (:constructor nil)) +;;; This is the most general case. In this case, the accessor +;;; generic function has seen more than one class of argument and +;;; more than one slot index. A cache vector stores the wrappers +;;; and corresponding slot indexes. Because each cache line is +;;; more than one element long, a cache lock count is used. +(defstruct (dfun-info (:constructor nil) + (:copier nil)) (cache nil)) -(defstruct (no-methods - (:constructor no-methods-dfun-info ()) - (:include dfun-info))) +(defstruct (no-methods (:constructor no-methods-dfun-info ()) + (:include dfun-info) + (:copier nil))) -(defstruct (initial - (:constructor initial-dfun-info ()) - (:include dfun-info))) +(defstruct (initial (:constructor initial-dfun-info ()) + (:include dfun-info) + (:copier nil))) -(defstruct (initial-dispatch - (:constructor initial-dispatch-dfun-info ()) - (:include dfun-info))) +(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) + (:include dfun-info) + (:copier nil))) -(defstruct (dispatch - (:constructor dispatch-dfun-info ()) - (:include dfun-info))) +(defstruct (dispatch (:constructor dispatch-dfun-info ()) + (:include dfun-info) + (:copier nil))) -(defstruct (default-method-only - (:constructor default-method-only-dfun-info ()) - (:include dfun-info))) +(defstruct (default-method-only (:constructor default-method-only-dfun-info ()) + (:include dfun-info) + (:copier nil))) ;without caching: ; dispatch one-class two-class default-method-only @@ -232,62 +236,64 @@ And so, we are saved. ;accessor: ; one-class two-class one-index n-n -(defstruct (accessor-dfun-info - (:constructor nil) - (:include dfun-info)) +(defstruct (accessor-dfun-info (:constructor nil) + (:include dfun-info) + (:copier nil)) accessor-type) ; (member reader writer) (defmacro dfun-info-accessor-type (di) `(accessor-dfun-info-accessor-type ,di)) -(defstruct (one-index-dfun-info - (:constructor nil) - (:include accessor-dfun-info)) +(defstruct (one-index-dfun-info (:constructor nil) + (:include accessor-dfun-info) + (:copier nil)) index) (defmacro dfun-info-index (di) `(one-index-dfun-info-index ,di)) -(defstruct (n-n - (:constructor n-n-dfun-info (accessor-type cache)) - (:include accessor-dfun-info))) +(defstruct (n-n (:constructor n-n-dfun-info (accessor-type cache)) + (:include accessor-dfun-info) + (:copier nil))) -(defstruct (one-class - (:constructor one-class-dfun-info (accessor-type index wrapper0)) - (:include one-index-dfun-info)) +(defstruct (one-class (:constructor one-class-dfun-info + (accessor-type index wrapper0)) + (:include one-index-dfun-info) + (:copier nil)) wrapper0) (defmacro dfun-info-wrapper0 (di) `(one-class-wrapper0 ,di)) -(defstruct (two-class - (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1)) - (:include one-class)) +(defstruct (two-class (:constructor two-class-dfun-info + (accessor-type index wrapper0 wrapper1)) + (:include one-class) + (:copier nil)) wrapper1) (defmacro dfun-info-wrapper1 (di) `(two-class-wrapper1 ,di)) -(defstruct (one-index - (:constructor one-index-dfun-info - (accessor-type index cache)) - (:include one-index-dfun-info))) +(defstruct (one-index (:constructor one-index-dfun-info + (accessor-type index cache)) + (:include one-index-dfun-info) + (:copier nil))) -(defstruct (checking - (:constructor checking-dfun-info (function cache)) - (:include dfun-info)) +(defstruct (checking (:constructor checking-dfun-info (function cache)) + (:include dfun-info) + (:copier nil)) function) (defmacro dfun-info-function (di) `(checking-function ,di)) -(defstruct (caching - (:constructor caching-dfun-info (cache)) - (:include dfun-info))) +(defstruct (caching (:constructor caching-dfun-info (cache)) + (:include dfun-info) + (:copier nil))) -(defstruct (constant-value - (:constructor constant-value-dfun-info (cache)) - (:include dfun-info))) +(defstruct (constant-value (:constructor constant-value-dfun-info (cache)) + (:include dfun-info) + (:copier nil))) (defmacro dfun-update (generic-function function &rest args) `(multiple-value-bind (dfun cache info) @@ -372,9 +378,9 @@ And so, we are saved. (when (use-dispatch-dfun-p generic-function) (return-from make-checking-dfun (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) - (get-generic-function-info generic-function) + (get-generic-fun-info generic-function) (declare (ignore nreq)) - (if (every #'(lambda (mt) (eq mt 't)) metatypes) + (if (every (lambda (mt) (eq mt t)) metatypes) (let ((dfun-info (default-method-only-dfun-info))) (values (funcall (get-dfun-constructor 'emit-default-only metatypes applyp) @@ -395,9 +401,9 @@ And so, we are saved. (defun make-final-checking-dfun (generic-function function classes-list new-class) (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function)))) - (if (every #'(lambda (mt) (eq mt 't)) metatypes) - (values #'(lambda (&rest args) - (invoke-emf function args)) + (if (every (lambda (mt) (eq mt t)) metatypes) + (values (lambda (&rest args) + (invoke-emf function args)) nil (default-method-only-dfun-info)) (let ((cache (make-final-ordinary-dfun-internal generic-function nil #'checking-limit-fn @@ -406,9 +412,9 @@ And so, we are saved. (defun use-default-method-only-dfun-p (generic-function) (multiple-value-bind (nreq applyp metatypes nkeys) - (get-generic-function-info generic-function) + (get-generic-fun-info generic-function) (declare (ignore nreq applyp nkeys)) - (every #'(lambda (mt) (eq mt 't)) metatypes))) + (every (lambda (mt) (eq mt t)) metatypes))) (defun use-caching-dfun-p (generic-function) (some (lambda (method) @@ -433,11 +439,13 @@ And so, we are saved. (defun make-caching-dfun (generic-function &optional cache) (unless cache (when (use-constant-value-dfun-p generic-function) - (return-from make-caching-dfun (make-constant-value-dfun generic-function))) + (return-from make-caching-dfun + (make-constant-value-dfun generic-function))) (when (use-dispatch-dfun-p generic-function) - (return-from make-caching-dfun (make-dispatch-dfun generic-function)))) + (return-from make-caching-dfun + (make-dispatch-dfun generic-function)))) (multiple-value-bind (nreq applyp metatypes nkeys) - (get-generic-function-info generic-function) + (get-generic-fun-info generic-function) (declare (ignore nreq)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) (dfun-info (caching-dfun-info cache))) @@ -460,17 +468,17 @@ And so, we are saved. (defun insure-caching-dfun (gf) (multiple-value-bind (nreq applyp metatypes nkeys) - (get-generic-function-info gf) + (get-generic-fun-info gf) (declare (ignore nreq nkeys)) (when (and metatypes (not (null (car metatypes))) (dolist (mt metatypes nil) - (unless (eq mt 't) (return t)))) + (unless (eq mt t) (return t)))) (get-dfun-constructor 'emit-caching metatypes applyp)))) (defun use-constant-value-dfun-p (gf &optional boolean-values-p) (multiple-value-bind (nreq applyp metatypes nkeys) - (get-generic-function-info gf) + (get-generic-fun-info gf) (declare (ignore nreq metatypes nkeys)) (let* ((early-p (early-gf-p gf)) (methods (if early-p @@ -480,24 +488,24 @@ And so, we are saved. (and (null applyp) (or (not (eq *boot-state* 'complete)) (compute-applicable-methods-emf-std-p gf)) - (notany #'(lambda (method) - (or (and (eq *boot-state* 'complete) - (some #'eql-specializer-p - (method-specializers method))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) - :constant-value default))) - (if boolean-values-p - (not (or (eq value 't) (eq value nil))) - (eq value default))))) + (notany (lambda (method) + (or (and (eq *boot-state* 'complete) + (some #'eql-specializer-p + (method-specializers method))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (if boolean-values-p + (not (or (eq value t) (eq value nil))) + (eq value default))))) methods))))) (defun make-constant-value-dfun (generic-function &optional cache) (multiple-value-bind (nreq applyp metatypes nkeys) - (get-generic-function-info generic-function) + (get-generic-fun-info generic-function) (declare (ignore nreq applyp)) (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) (dfun-info (constant-value-dfun-info cache))) @@ -536,57 +544,33 @@ And so, we are saved. (defparameter *structure-typep-cost* 1) (defparameter *built-in-typep-cost* 0) -;;; The execution time of this version is exponential to some function -;;; of number of gf methods and argument lists. It was taking -;;; literally hours to load the presentation methods from the -;;; cl-http w3p kit. -#+nil -(defun dispatch-dfun-cost (gf) - (generate-discrimination-net-internal - gf (generic-function-methods gf) nil - #'(lambda (methods known-types) - (declare (ignore methods known-types)) - 0) - #'(lambda (position type true-value false-value) - (declare (ignore position)) - (+ (max true-value false-value) - (if (eq 'class (car type)) - (let ((cpl (class-precedence-list (class-of (cadr type))))) - (cond((memq *the-class-built-in-class* cpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* cpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0))) - #'identity)) - -;;; This version is from the pcl found in the gcl-2.1 distribution. -;;; Someone added a cost limit so as to keep the execution time controlled +;;; According to comments in the original CMU CL version of PCL, +;;; the cost LIMIT is important to cut off exponential growth for +;;; large numbers of gf methods and argument lists. (defun dispatch-dfun-cost (gf &optional limit) (generate-discrimination-net-internal gf (generic-function-methods gf) nil - #'(lambda (methods known-types) - (declare (ignore methods known-types)) - 0) - #'(lambda (position type true-value false-value) - (declare (ignore position)) - (let* ((type-test-cost - (if (eq 'class (car type)) - (let* ((metaclass (class-of (cadr type))) - (mcpl (class-precedence-list metaclass))) - (cond ((memq *the-class-built-in-class* mcpl) - *built-in-typep-cost*) - ((memq *the-class-structure-class* mcpl) - *structure-typep-cost*) - (t - *non-built-in-typep-cost*))) - 0)) - (max-cost-so-far - (+ (max true-value false-value) type-test-cost))) - (when (and limit (<= limit max-cost-so-far)) - (return-from dispatch-dfun-cost max-cost-so-far)) - max-cost-so-far)) + (lambda (methods known-types) + (declare (ignore methods known-types)) + 0) + (lambda (position type true-value false-value) + (declare (ignore position)) + (let* ((type-test-cost + (if (eq 'class (car type)) + (let* ((metaclass (class-of (cadr type))) + (mcpl (class-precedence-list metaclass))) + (cond ((memq *the-class-built-in-class* mcpl) + *built-in-typep-cost*) + ((memq *the-class-structure-class* mcpl) + *structure-typep-cost*) + (t + *non-built-in-typep-cost*))) + 0)) + (max-cost-so-far + (+ (max true-value false-value) type-test-cost))) + (when (and limit (<= limit max-cost-so-far)) + (return-from dispatch-dfun-cost max-cost-so-far)) + max-cost-so-far)) #'identity)) (defparameter *cache-lookup-cost* 1) @@ -629,11 +613,11 @@ And so, we are saved. (defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) (let ((cache (or cache (get-cache nkeys valuep limit-fn (+ (hash-table-count table) 3))))) - (maphash #'(lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value - t))) + (maphash (lambda (classes value) + (setq cache (fill-cache cache + (class-wrapper classes) + value + t))) table) cache)) @@ -669,16 +653,16 @@ And so, we are saved. (invoke-emf ,nemf ,args))) ;;; The dynamically adaptive method lookup algorithm is implemented is -;;; implemented as a kind of state machine. The kinds of discriminating -;;; function is the state, the various kinds of reasons for a cache miss -;;; are the state transitions. +;;; implemented as a kind of state machine. The kinds of +;;; discriminating function is the state, the various kinds of reasons +;;; for a cache miss are the state transitions. ;;; -;;; The code which implements the transitions is all in the miss handlers -;;; for each kind of dfun. Those appear here. +;;; The code which implements the transitions is all in the miss +;;; handlers for each kind of dfun. Those appear here. ;;; -;;; Note that within the states that cache, there are dfun updates which -;;; simply select a new cache or cache field. Those are not considered -;;; as state transitions. +;;; Note that within the states that cache, there are dfun updates +;;; which simply select a new cache or cache field. Those are not +;;; considered as state transitions. (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) @@ -769,18 +753,18 @@ And so, we are saved. (let ((methods (if (early-gf-p gf) (early-gf-methods gf) (generic-function-methods gf)))) - (cond ((every #'(lambda (method) - (if (consp method) - (eq *the-class-standard-reader-method* - (early-method-class method)) - (standard-reader-method-p method))) + (cond ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-reader-method* + (early-method-class method)) + (standard-reader-method-p method))) methods) 'reader) - ((every #'(lambda (method) - (if (consp method) - (eq *the-class-standard-writer-method* - (early-method-class method)) - (standard-writer-method-p method))) + ((every (lambda (method) + (if (consp method) + (eq *the-class-standard-writer-method* + (early-method-class method)) + (standard-writer-method-p method))) methods) 'writer)))) @@ -817,14 +801,14 @@ And so, we are saved. (no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) (make-final-accessor-dfun gf type classes-list new-class)) - ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*)) + ((and (not (and (every (lambda (specl) (eq specl *the-class-t*)) (setq specls (method-specializers (car methods)))) (setq all-same-p - (every #'(lambda (method) - (and (equal specls - (method-specializers - method)))) + (every (lambda (method) + (and (equal specls + (method-specializers + method)))) methods)))) (use-constant-value-dfun-p gf)) (make-final-constant-value-dfun gf classes-list new-class)) @@ -904,8 +888,8 @@ And so, we are saved. (setq oindex (dfun-info-index dfun-info)) (setq cache (dfun-info-cache dfun-info)) (if (eql nindex oindex) - (do-fill #'(lambda (ncache) - (one-index nindex ncache))) + (do-fill (lambda (ncache) + (one-index nindex ncache))) (n-n))) (n-n (setq cache (dfun-info-cache dfun-info)) @@ -951,8 +935,8 @@ And so, we are saved. (dfun-update generic-function #'make-constant-value-dfun ncache)))))))) -;;; Given a generic function and a set of arguments to that generic function, -;;; returns a mess of values. +;;; Given a generic function and a set of arguments to that generic +;;; function, return a mess of values. ;;; ;;; The compiled effective method function for this set of ;;; arguments. @@ -982,23 +966,19 @@ And so, we are saved. ;;; an :instance slot, this is the index number of that slot ;;; in the object argument. (defun cache-miss-values (gf args state) - (if (null (if (early-gf-p gf) - (early-gf-methods gf) - (generic-function-methods gf))) - (apply #'no-applicable-method gf args) - (multiple-value-bind (nreq applyp metatypes nkeys arg-info) - (get-generic-function-info gf) - (declare (ignore nreq applyp nkeys)) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p wrappers classes types) - (error "The function ~S requires at least ~D arguments" - gf (length metatypes)) - (multiple-value-bind (emf methods accessor-type index) - (cache-miss-values-internal gf arg-info wrappers classes types state) - (values emf methods - dfun-wrappers - invalid-wrapper-p - accessor-type index)))))) + (multiple-value-bind (nreq applyp metatypes nkeys arg-info) + (get-generic-fun-info gf) + (declare (ignore nreq applyp nkeys)) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p wrappers classes types) + (error-need-at-least-n-args gf (length metatypes)) + (multiple-value-bind (emf methods accessor-type index) + (cache-miss-values-internal + gf arg-info wrappers classes types state) + (values emf methods + dfun-wrappers + invalid-wrapper-p + accessor-type index))))) (defun cache-miss-values-internal (gf arg-info wrappers classes types state) (let* ((for-accessor-p (eq state 'accessor)) @@ -1011,7 +991,8 @@ And so, we are saved. (compute-applicable-methods-using-classes gf classes)) (let ((emf (if (or cam-std-p all-applicable-and-sorted-p) (function-funcall (get-secondary-dispatch-function1 - gf methods types nil (and for-cache-p wrappers) + gf methods types nil (and for-cache-p + wrappers) all-applicable-and-sorted-p) nil (and for-cache-p wrappers)) (default-secondary-dispatch-function gf)))) @@ -1050,8 +1031,10 @@ And so, we are saved. (early-method-standard-accessor-slot-name meth)) (and (member *the-class-std-object* (if early-p - (early-class-precedence-list accessor-class) - (class-precedence-list accessor-class))) + (early-class-precedence-list + accessor-class) + (class-precedence-list + accessor-class))) (if early-p (not (eq *the-class-standard-method* (early-method-class meth))) @@ -1062,7 +1045,8 @@ And so, we are saved. (slotd (and accessor-class (if early-p (dolist (slot (early-class-slotds accessor-class) nil) - (when (eql slot-name (early-slot-definition-name slot)) + (when (eql slot-name + (early-slot-definition-name slot)) (return slot))) (find-slot-definition accessor-class slot-name))))) (when (and slotd @@ -1098,44 +1082,45 @@ And so, we are saved. (so-p (member *the-class-std-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) - (early-method-standard-accessor-slot-name method)) + (early-method-standard-accessor-slot-name + method)) (accessor-method-slot-name method)))) (when (or (null specl-cpl) (member *the-class-structure-object* specl-cpl)) (return-from make-accessor-table nil)) - (maphash #'(lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-std-object* cpl)) - (or early-p - (slot-accessor-std-p slotd type))) - (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) + (maphash (lambda (class slotd) + (let ((cpl (if early-p + (early-class-precedence-list class) + (class-precedence-list class)))) + (when (memq specl cpl) + (unless (and (or so-p + (member *the-class-std-object* cpl)) + (or early-p + (slot-accessor-std-p slotd type))) + (return-from make-accessor-table nil)) + (push (cons specl slotd) (gethash class table))))) (gethash slot-name *name->class->slotd-table*)))) - (maphash #'(lambda (class specl+slotd-list) - (dolist (sclass (if early-p - (early-class-precedence-list class) - (class-precedence-list class)) - (error "This can't happen")) - (let ((a (assq sclass specl+slotd-list))) - (when a - (let* ((slotd (cdr a)) - (index (if early-p - (early-slot-definition-location slotd) - (slot-definition-location slotd)))) - (unless index (return-from make-accessor-table nil)) - (setf (gethash class table) index) - (when (consp index) (setq no-class-slots-p nil)) - (setq all-index (if (or (null all-index) - (eql all-index index)) - index t)) - (incf size) - (cond ((= size 1) (setq first class)) - ((= size 2) (setq second class))) - (return nil)))))) + (maphash (lambda (class specl+slotd-list) + (dolist (sclass (if early-p + (early-class-precedence-list class) + (class-precedence-list class)) + (error "This can't happen.")) + (let ((a (assq sclass specl+slotd-list))) + (when a + (let* ((slotd (cdr a)) + (index (if early-p + (early-slot-definition-location slotd) + (slot-definition-location slotd)))) + (unless index (return-from make-accessor-table nil)) + (setf (gethash class table) index) + (when (consp index) (setq no-class-slots-p nil)) + (setq all-index (if (or (null all-index) + (eql all-index index)) + index t)) + (incf size) + (cond ((= size 1) (setq first class)) + ((= size 2) (setq second class))) + (return nil)))))) table) (values table all-index first second size no-class-slots-p))) @@ -1161,8 +1146,10 @@ And so, we are saved. (unless applicable-p (setq definite-p nil)) (push method possibly-applicable-methods)))) (let ((precedence (arg-info-precedence (if (early-gf-p generic-function) - (early-gf-arg-info generic-function) - (gf-arg-info generic-function))))) + (early-gf-arg-info + generic-function) + (gf-arg-info + generic-function))))) (values (sort-applicable-methods precedence (nreverse possibly-applicable-methods) types) @@ -1171,22 +1158,24 @@ And so, we are saved. (defun sort-applicable-methods (precedence methods types) (sort-methods methods precedence - #'(lambda (class1 class2 index) - (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list class)))) - (if (memq class2 (memq class1 cpl)) - class1 class2))))) + (lambda (class1 class2 index) + (let* ((class (type-class (nth index types))) + (cpl (if (eq *boot-state* 'complete) + (class-precedence-list class) + (early-class-precedence-list class)))) + (if (memq class2 (memq class1 cpl)) + class1 class2))))) (defun sort-methods (methods precedence compare-classes-function) (flet ((sorter (method1 method2) (dolist (index precedence) (let* ((specl1 (nth index (if (listp method1) - (early-method-specializers method1 t) + (early-method-specializers method1 + t) (method-specializers method1)))) (specl2 (nth index (if (listp method2) - (early-method-specializers method2 t) + (early-method-specializers method2 + t) (method-specializers method2)))) (order (order-specializers specl1 specl2 index compare-classes-function))) @@ -1210,10 +1199,12 @@ And so, we are saved. (t (case (car type1) (class (case (car type2) - (class (funcall compare-classes-function specl1 specl2 index)) + (class (funcall compare-classes-function + specl1 specl2 index)) (t specl2))) (prototype (case (car type2) - (class (funcall compare-classes-function specl1 specl2 index)) + (class (funcall compare-classes-function + specl1 specl2 index)) (t specl2))) (class-eq (case (car type2) (eql specl2) @@ -1244,7 +1235,10 @@ And so, we are saved. (list class2 class1 t) (let ((name1 (class-name class1)) (name2 (class-name class2))) - (if (and name1 name2 (symbolp name1) (symbolp name2) + (if (and name1 + name2 + (symbolp name1) + (symbolp name2) (string< (symbol-name name1) (symbol-name name2))) (list class1 class2 t) @@ -1252,7 +1246,9 @@ And so, we are saved. (push choice choices)) (car choice)))) (loop (funcall function - (sort-methods methods precedence #'compare-classes-function)) + (sort-methods methods + precedence + #'compare-classes-function)) (unless (dolist (c choices nil) (unless (third c) (rotatef (car c) (cadr c)) @@ -1358,12 +1354,13 @@ And so, we are saved. (memq (cadr specl) (if (eq *boot-state* 'complete) (class-precedence-list (cadr type)) - (early-class-precedence-list (cadr type))))))))) + (early-class-precedence-list + (cadr type))))))))) (values pred pred)))) (defun saut-prototype (specl type) (declare (ignore specl type)) - (values nil nil)) ; fix this someday + (values nil nil)) ; XXX original PCL comment: fix this someday (defun saut-eql (specl type) (let ((pred (case (car specl) @@ -1373,16 +1370,17 @@ And so, we are saved. (let ((class (class-of (cadr type)))) (if (eq *boot-state* 'complete) (class-precedence-list class) - (early-class-precedence-list class)))))))) + (early-class-precedence-list + class)))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) (setq specl (type-from-specializer specl)) - (when (eq specl 't) + (when (eq specl t) (return-from specializer-applicable-using-type-p (values t t))) - ;; This is used by c-a-m-u-t and generate-discrimination-net-internal, + ;; This is used by C-A-M-U-T and GENERATE-DISCRIMINATION-NET-INTERNAL, ;; and has only what they need. - (if (or (atom type) (eq (car type) 't)) + (if (or (atom type) (eq (car type) t)) (values nil t) (case (car type) (and (saut-and specl type)) @@ -1395,7 +1393,7 @@ And so, we are saved. 'specializer-applicable-using-type-p type))))) -(defun map-all-classes (function &optional (root 't)) +(defun map-all-classes (function &optional (root t)) (let ((braid-p (or (eq *boot-state* 'braid) (eq *boot-state* 'complete)))) (labels ((do-class (class) @@ -1429,19 +1427,22 @@ And so, we are saved. (not (methods-contain-eql-specializer-p methods))) method-alist wrappers)) -(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p - &optional all-applicable-p - (all-sorted-p t) function-p) +(defun get-secondary-dispatch-function1 (gf methods types method-alist-p + wrappers-p + &optional + all-applicable-p + (all-sorted-p t) + function-p) (if (null methods) (if function-p - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(sb-kernel:instance-lambda (&rest args) - (apply #'no-applicable-method gf args))) - #'(lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(lambda (&rest args) - (apply #'no-applicable-method gf args)))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + #'(sb-kernel:instance-lambda (&rest args) + (apply #'no-applicable-method gf args))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (apply #'no-applicable-method gf args)))) (let* ((key (car methods)) (ht-value (or (gethash key *effective-method-table*) (setf (gethash key *effective-method-table*) @@ -1463,20 +1464,24 @@ And so, we are saved. (push (cons akey value) (cdr ht-value)) value))))))) -(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p - all-applicable-p all-sorted-p function-p) +(defun get-secondary-dispatch-function2 (gf methods types method-alist-p + wrappers-p all-applicable-p + all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) (if (eq *boot-state* 'complete) (let* ((combin (generic-function-method-combination gf)) (effective (compute-effective-method gf combin methods))) - (make-effective-method-function1 gf effective method-alist-p wrappers-p)) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p)) (let ((effective (standard-compute-effective-method gf nil methods))) - (make-effective-method-function1 gf effective method-alist-p wrappers-p))) + (make-effective-method-function1 gf effective method-alist-p + wrappers-p))) (let ((net (generate-discrimination-net gf methods types all-sorted-p))) (compute-secondary-dispatch-function1 gf net function-p)))) -(defun get-effective-method-function (gf methods &optional method-alist wrappers) +(defun get-effective-method-function (gf methods + &optional method-alist wrappers) (function-funcall (get-secondary-dispatch-function1 gf methods nil (not (null method-alist)) (not (null wrappers)) @@ -1500,16 +1505,11 @@ And so, we are saved. (generic-function-name generic-function))) (ocache (gf-dfun-cache generic-function))) (set-dfun generic-function dfun cache info) - (let* ((dfun (if early-p - (or dfun (make-initial-dfun generic-function)) - (compute-discriminating-function generic-function))) - (info (gf-dfun-info generic-function))) - (unless (eq 'default-method-only (type-of info)) - (setq dfun (doctor-dfun-for-the-debugger - generic-function - dfun))) - (set-funcallable-instance-function generic-function dfun) - (set-function-name generic-function gf-name) + (let ((dfun (if early-p + (or dfun (make-initial-dfun generic-function)) + (compute-discriminating-function generic-function)))) + (set-funcallable-instance-fun generic-function dfun) + (set-fun-name generic-function gf-name) (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) @@ -1517,6 +1517,11 @@ And so, we are saved. (defvar *dfun-list* nil) (defvar *minimum-cache-size-to-list*) +;;; These functions aren't used in SBCL, or documented anywhere that +;;; I'm aware of, but they look like they might be useful for +;;; debugging or performance tweaking or something, so I've just +;;; commented them out instead of deleting them. -- WHN 2001-03-28 +#| (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (a (assq sym *dfun-list*))) @@ -1545,7 +1550,7 @@ And so, we are saved. (defun list-large-caches (&optional (*minimum-cache-size-to-list* 130)) (setq *dfun-list* nil) (map-all-generic-functions #'list-large-cache) - (setq *dfun-list* (sort dfun-list #'< :key #'car)) + (setq *dfun-list* (sort *dfun-list* #'< :key #'car)) (mapc #'print *dfun-list*) (values)) @@ -1564,26 +1569,28 @@ And so, we are saved. (incf (cdr b)))))) (defun count-all-dfuns () - (setq *dfun-count* (mapcar #'(lambda (type) (list type 0 nil)) + (setq *dfun-count* (mapcar (lambda (type) (list type 0 nil)) '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY ONE-INDEX N-N CHECKING CACHING DISPATCH))) (map-all-generic-functions #'count-dfun) - (mapc #'(lambda (type+count+sizes) - (setf (third type+count+sizes) - (sort (third type+count+sizes) #'< :key #'car))) + (mapc (lambda (type+count+sizes) + (setf (third type+count+sizes) + (sort (third type+count+sizes) #'< :key #'car))) *dfun-count*) - (mapc #'(lambda (type+count+sizes) - (format t "~&There are ~D dfuns of type ~S." - (cadr type+count+sizes) (car type+count+sizes)) - (format t "~% ~S~%" (caddr type+count+sizes))) + (mapc (lambda (type+count+sizes) + (format t "~&There are ~W dfuns of type ~S." + (cadr type+count+sizes) (car type+count+sizes)) + (format t "~% ~S~%" (caddr type+count+sizes))) *dfun-count*) (values)) +|# (defun gfs-of-type (type) (unless (consp type) (setq type (list type))) (let ((gf-list nil)) - (map-all-generic-functions #'(lambda (gf) - (when (memq (type-of (gf-dfun-info gf)) type) - (push gf gf-list)))) + (map-all-generic-functions (lambda (gf) + (when (memq (type-of (gf-dfun-info gf)) + type) + (push gf gf-list)))) gf-list))