(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*))
(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 (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)))))
\f
;;; When all the methods of a generic function are automatically
;;; generated reader or writer methods a number of special
(defun accessor-miss-function (gf dfun-info)
(ecase (dfun-info-accessor-type dfun-info)
- (reader
+ ((reader boundp)
(lambda (arg)
(accessor-miss gf nil arg dfun-info)))
(writer
#-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
\f
(defun make-one-class-accessor-dfun (gf type wrapper index)
- (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
+ (let ((emit (ecase type
+ (reader 'emit-one-class-reader)
+ (boundp 'emit-one-class-boundp)
+ (writer 'emit-one-class-writer)))
(dfun-info (one-class-dfun-info type index wrapper)))
(values
(funcall (get-dfun-constructor emit (consp index))
dfun-info)))
(defun make-two-class-accessor-dfun (gf type w0 w1 index)
- (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
+ (let ((emit (ecase type
+ (reader 'emit-two-class-reader)
+ (boundp 'emit-two-class-boundp)
+ (writer 'emit-two-class-writer)))
(dfun-info (two-class-dfun-info type index w0 w1)))
(values
(funcall (get-dfun-constructor emit (consp index))
;;; std accessors same index dfun
(defun make-one-index-accessor-dfun (gf type index &optional cache)
- (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
+ (let* ((emit (ecase type
+ (reader 'emit-one-index-readers)
+ (boundp 'emit-one-index-boundps)
+ (writer 'emit-one-index-writers)))
(cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
(dfun-info (one-index-dfun-info type index cache)))
(declare (type cache cache))
(default-limit-fn nlines))
(defun make-n-n-accessor-dfun (gf type &optional cache)
- (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
+ (let* ((emit (ecase type
+ (reader 'emit-n-n-readers)
+ (boundp 'emit-n-n-boundps)
+ (writer 'emit-n-n-writers)))
(cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
(dfun-info (n-n-dfun-info type cache)))
(declare (type cache cache))
(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)
(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)
(let ((fmf (if (listp method)
(third method)
(method-fast-function method))))
- (method-function-get fmf ':slot-name-lists)))
+ (method-function-get fmf :slot-name-lists)))
;; KLUDGE: As of sbcl-0.6.4, it's very important for
;; efficiency to know the type of the sequence argument to
;; quantifiers (SOME/NOTANY/etc.) at compile time, but
(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)))
(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)))
(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)))
(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))
(cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
(type 'accessor)
(t 'checking)))
- (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
- (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
- ,@body))
- (invoke-emf ,nemf ,args)))
+ (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
+ (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
+ ,@body))
+ ;; Create a FAST-INSTANCE-BOUNDP structure instance for a cached
+ ;; SLOT-BOUNDP so that INVOKE-EMF does the right thing, that is,
+ ;; does not signal a SLOT-UNBOUND error for a boundp test.
+ ,@(if type
+ ;; FIXME: could the NEMF not be a CONS (for :CLASS-allocated
+ ;; slots?)
+ `((if (and (eq ,type 'boundp) (integerp ,nemf))
+ (invoke-emf (make-fast-instance-boundp :index ,nemf) ,args)
+ (invoke-emf ,nemf ,args)))
+ `((invoke-emf ,nemf ,args)))))
;;; The dynamically adaptive method lookup algorithm is implemented is
;;; implemented as a kind of state machine. The kinds of
(let* ((class (class-of instance))
(class-name (!bootstrap-get-slot 'class class 'name)))
(!bootstrap-get-slot class-name instance slot-name))))
+ (boundp #'(sb-kernel:instance-lambda (instance)
+ (let* ((class (class-of instance))
+ (class-name (!bootstrap-get-slot 'class class 'name)))
+ (not (eq +slot-unbound+
+ (!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)))
(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-boundp-method*
+ (early-method-class method))
+ (standard-boundp-method-p method)))
+ methods)
+ 'boundp)
+ ((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))
(let* ((ostate (type-of dfun-info))
(otype (dfun-info-accessor-type dfun-info))
oindex ow0 ow1 cache
- (args (ecase otype ; The congruence rules ensure
- (reader (list object)) ; that this is safe despite not
- (writer (list new object))))) ; knowing the new type yet.
+ (args (ecase otype
+ ;; The congruence rules ensure that this is safe
+ ;; despite not knowing the new type yet.
+ ((reader boundp) (list object))
+ (writer (list new object)))))
(dfun-miss (gf args wrappers invalidp nemf ntype nindex)
;; The following lexical functions change the state of the
(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))
;;; in the object argument.
(defun cache-miss-values (gf args state)
(multiple-value-bind (nreq applyp metatypes nkeys arg-info)
- (get-generic-function-info gf)
+ (get-generic-fun-info gf)
(declare (ignore nreq applyp nkeys))
(with-dfun-wrappers (args metatypes)
(dfun-wrappers invalid-wrapper-p wrappers classes types)
(declare (ignore gf))
(let* ((accessor-type (gf-info-simple-accessor-type arg-info))
(accessor-class (case accessor-type
- (reader (car classes))
- (writer (cadr classes))
- (boundp (car classes)))))
+ ((reader boundp) (car classes))
+ (writer (cadr classes)))))
(accessor-values-internal accessor-type accessor-class methods)))
(defun accessor-values1 (gf accessor-type accessor-class)
(let* ((type `(class-eq ,accessor-class))
- (types (if (eq accessor-type 'writer) `(t ,type) `(,type)))
+ (types (ecase accessor-type
+ ((reader boundp) `(,type))
+ (writer `(t ,type))))
(methods (compute-applicable-methods-using-types gf types)))
(accessor-values-internal accessor-type accessor-class methods)))
(let* ((specializers (if (consp method)
(early-method-specializers method t)
(method-specializers method)))
- (specl (if (eq type 'reader)
- (car specializers)
- (cadr specializers)))
+ (specl (ecase type
+ ((reader boundp) (car specializers))
+ (writer (cadr specializers))))
(specl-cpl (if early-p
(early-class-precedence-list specl)
(and (class-finalized-p specl)
(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)))
(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)
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*)
(or dfun (make-initial-dfun generic-function))
(compute-discriminating-function generic-function))))
(set-funcallable-instance-fun generic-function dfun)
- (set-function-name generic-function gf-name)
+ (set-fun-name generic-function gf-name)
(when (and ocache (not (eq ocache cache))) (free-cache ocache))
dfun)))
\f
(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