(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 (symbol-function generator) args)
+ (apply (fdefinition generator) args)
(or (cadr args-entry)
(multiple-value-bind (new not-best-p)
(apply (symbol-function generator) args)
(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)
(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
- (make-top-level-form `(precompile-dfun-constructor
- ,(car generator-entry))
- '(:load-toplevel)
- `(load-precompiled-dfun-constructor
- ',(car generator-entry)
- ',(car args-entry)
- ',system
- ,(apply (symbol-function (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)))))
\f
-;;; 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
;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)
(defun accessor-miss-function (gf dfun-info)
(ecase (dfun-info-accessor-type dfun-info)
(reader
- #'(lambda (arg)
- (declare (pcl-fast-call))
- (accessor-miss gf nil arg dfun-info)))
+ (lambda (arg)
+ (accessor-miss gf nil arg dfun-info)))
(writer
- #'(lambda (new arg)
- (declare (pcl-fast-call))
- (accessor-miss gf new arg dfun-info)))))
+ (lambda (new arg)
+ (accessor-miss gf new arg dfun-info)))))
#-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
\f
(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)
(funcall (get-dfun-constructor 'emit-checking metatypes applyp)
cache
function
- #'(lambda (&rest args)
- (declare (pcl-fast-call))
- (checking-miss generic-function args dfun-info)))
+ (lambda (&rest args)
+ (checking-miss generic-function args dfun-info)))
cache
dfun-info)))))
(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
(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)
(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)))
(values
(funcall (get-dfun-constructor 'emit-caching metatypes applyp)
cache
- #'(lambda (&rest args)
- (declare (pcl-fast-call))
- (caching-miss generic-function args dfun-info)))
+ (lambda (&rest args)
+ (caching-miss generic-function args dfun-info)))
cache
dfun-info))))
(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
(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)))
(values
(funcall (get-dfun-constructor 'emit-constant-value metatypes)
cache
- #'(lambda (&rest args)
- (declare (pcl-fast-call))
- (constant-value-miss generic-function args dfun-info)))
+ (lambda (&rest args)
+ (constant-value-miss generic-function args dfun-info)))
cache
dfun-info))))
(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)
(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))
(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)
(ecase type
(reader #'(sb-kernel:instance-lambda (instance)
(let* ((class (class-of instance))
- (class-name (bootstrap-get-slot 'class class 'name)))
- (bootstrap-get-slot class-name instance slot-name))))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (!bootstrap-get-slot class-name instance slot-name))))
(writer #'(sb-kernel:instance-lambda (new-value instance)
(let* ((class (class-of instance))
- (class-name (bootstrap-get-slot 'class class 'name)))
- (bootstrap-set-slot class-name instance slot-name new-value)))))))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (!bootstrap-set-slot class-name instance slot-name new-value)))))))
(defun initial-dfun (gf args)
(dfun-miss (gf args wrappers invalidp nemf ntype nindex)
(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))))
(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))
(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))
(dfun-update generic-function
#'make-constant-value-dfun ncache))))))))
\f
-;;; 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.
;;;
;;; <function> The compiled effective method function for this set of
;;; arguments.
;;; 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))
(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))))
(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)))
(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
(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)))
(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)
(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)))
(defun order-specializers (specl1 specl2 index compare-classes-function)
(let ((type1 (if (eq *boot-state* 'complete)
(specializer-type specl1)
- (bootstrap-get-slot 'specializer specl1 'type)))
+ (!bootstrap-get-slot 'specializer specl1 'type)))
(type2 (if (eq *boot-state* 'complete)
(specializer-type specl2)
- (bootstrap-get-slot 'specializer specl2 'type))))
+ (!bootstrap-get-slot 'specializer specl2 'type))))
(cond ((eq specl1 specl2)
nil)
((atom type1)
(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)
(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)
(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))
(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)
(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))
'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)
(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*)
(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))
(defun update-dfun (generic-function &optional dfun cache info)
(let* ((early-p (early-gf-p generic-function))
(gf-name (if early-p
- (early-gf-name generic-function)
+ (!early-gf-name generic-function)
(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)))
\f
(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*)))
(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))
(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))
projects / sbcl.git / blobdiff