X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=106708db9aee2bce6d7d2aff3bc5a299f3554589;hb=2deca07b781acdf0214dacf5a7444756dfba6928;hp=c133d4fb4a1866bed08c4080c46e79ec20eee946;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index c133d4f..106708d 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -302,7 +302,7 @@ And so, we are saved. (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 @@ -312,7 +312,10 @@ And so, we are saved. #-sb-fluid (declaim (sb-ext:freeze-type dfun-info)) (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)) @@ -322,7 +325,10 @@ And so, we are saved. 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)) @@ -333,7 +339,10 @@ And so, we are saved. ;;; 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)) @@ -353,7 +362,10 @@ And so, we are saved. (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)) @@ -378,7 +390,7 @@ 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) (let ((dfun-info (default-method-only-dfun-info))) @@ -412,7 +424,7 @@ 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))) @@ -421,7 +433,7 @@ And so, we are saved. (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 @@ -445,7 +457,7 @@ And so, we are saved. (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))) @@ -468,7 +480,7 @@ 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))) @@ -478,7 +490,7 @@ And so, we are saved. (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 @@ -505,7 +517,7 @@ And so, we are saved. (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))) @@ -616,8 +628,7 @@ And so, we are saved. (maphash (lambda (classes value) (setq cache (fill-cache cache (class-wrapper classes) - value - t))) + value))) table) cache)) @@ -647,10 +658,19 @@ And so, we are saved. (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 @@ -666,49 +686,75 @@ And so, we are saved. (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) +(defun finalize-specializers (gf) + (let ((all-finalized t)) + (dolist (method (generic-function-methods gf)) + (dolist (specializer (method-specializers method)) + (when (and (classp specializer) + (not (class-finalized-p specializer))) + (if (class-has-a-forward-referenced-superclass-p specializer) + (setq all-finalized nil) + (finalize-inheritance specializer))))) + all-finalized)) + (defun make-initial-dfun (gf) (let ((initial-dfun - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) - (if (and (eq *boot-state* 'complete) - (compute-applicable-methods-emf-std-p gf)) - (let* ((caching-p (use-caching-dfun-p gf)) - (classes-list (precompute-effective-methods - gf caching-p - (not *lazy-dfun-compute-p*)))) - (if *lazy-dfun-compute-p* - (cond ((use-dispatch-dfun-p gf caching-p) - (values initial-dfun - nil - (initial-dispatch-dfun-info))) - (caching-p - (insure-caching-dfun gf) - (values initial-dfun nil (initial-dfun-info))) - (t - (values initial-dfun nil (initial-dfun-info)))) - (make-final-dfun-internal gf classes-list))) - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (type nil)) - (if (and (gf-precompute-dfun-and-emf-p arg-info) - (setq type (final-accessor-dfun-type gf))) - (if *early-p* - (values (make-early-accessor gf type) nil nil) - (make-final-accessor-dfun gf type)) - (values initial-dfun nil (initial-dfun-info))))) + (cond + ((and (eq *boot-state* 'complete) + (not (finalize-specializers gf))) + (values initial-dfun nil (initial-dfun-info))) + ((and (eq *boot-state* 'complete) + (compute-applicable-methods-emf-std-p gf)) + (let* ((caching-p (use-caching-dfun-p gf)) + ;; KLUDGE: the only effect of this (when + ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) + ;; is to signal an error when we try to add methods + ;; with the wrong qualifiers to a generic function. + (classes-list (precompute-effective-methods + gf caching-p + (not *lazy-dfun-compute-p*)))) + (if *lazy-dfun-compute-p* + (cond ((use-dispatch-dfun-p gf caching-p) + (values initial-dfun + nil + (initial-dispatch-dfun-info))) + (caching-p + (insure-caching-dfun gf) + (values initial-dfun nil (initial-dfun-info))) + (t + (values initial-dfun nil (initial-dfun-info)))) + (make-final-dfun-internal gf classes-list)))) + (t + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (initial-dfun-info)))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) (let* ((methods (early-gf-methods gf)) (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type - (reader #'(sb-kernel:instance-lambda (instance) + (reader #'(instance-lambda (instance) (let* ((class (class-of instance)) (class-name (!bootstrap-get-slot 'class class 'name))) (!bootstrap-get-slot class-name instance slot-name)))) - (writer #'(sb-kernel:instance-lambda (new-value instance) + (boundp #'(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 #'(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))))))) @@ -762,6 +808,13 @@ And so, we are saved. 'reader) ((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))) @@ -795,7 +848,7 @@ And so, we are saved. specls all-same-p) (cond ((null methods) (values - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) @@ -824,9 +877,11 @@ And so, we are saved. (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 @@ -967,7 +1022,7 @@ And so, we are saved. ;;; 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) @@ -1006,14 +1061,15 @@ And so, we are saved. (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))) @@ -1072,9 +1128,9 @@ And so, we are saved. (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) @@ -1270,6 +1326,12 @@ And so, we are saved. (mapcar (lambda (x) (position x lambda-list)) argument-precedence-order))) +(defun cpl-or-nil (class) + (if (eq *boot-state* 'complete) + (when (class-finalized-p class) + (class-precedence-list class)) + (early-class-precedence-list class))) + (defun saut-and (specl type) (let ((applicable nil) (possibly-applicable t)) @@ -1293,8 +1355,8 @@ And so, we are saved. (defun saut-not-class (specl ntype) (let* ((class (type-class specl)) - (cpl (class-precedence-list class))) - (not (memq (cadr ntype) cpl)))) + (cpl (cpl-or-nil class))) + (not (memq (cadr ntype) cpl)))) (defun saut-not-prototype (specl ntype) (let* ((class (case (car specl) @@ -1302,8 +1364,8 @@ And so, we are saved. (class-eq (cadr specl)) (prototype (cadr specl)) (class (cadr specl)))) - (cpl (class-precedence-list class))) - (not (memq (cadr ntype) cpl)))) + (cpl (cpl-or-nil class))) + (not (memq (cadr ntype) cpl)))) (defun saut-not-class-eq (specl ntype) (let ((class (case (car specl) @@ -1317,9 +1379,7 @@ And so, we are saved. (t t))) (defun class-applicable-using-class-p (specl type) - (let ((pred (memq specl (if (eq *boot-state* 'complete) - (class-precedence-list type) - (early-class-precedence-list type))))) + (let ((pred (memq specl (cpl-or-nil type)))) (values pred (or pred (if (not *in-precompute-effective-methods-p*) @@ -1341,7 +1401,7 @@ And so, we are saved. (class (class-applicable-using-class-p (cadr specl) (cadr type))) (t (values nil (let ((class (type-class specl))) (memq (cadr type) - (class-precedence-list class))))))) + (cpl-or-nil class))))))) (defun saut-class-eq (specl type) (if (eq (car specl) 'eql) @@ -1351,11 +1411,7 @@ And so, we are saved. (eq (cadr specl) (cadr type))) (class (or (eq (cadr specl) (cadr type)) - (memq (cadr specl) - (if (eq *boot-state* 'complete) - (class-precedence-list (cadr type)) - (early-class-precedence-list - (cadr type))))))))) + (memq (cadr specl) (cpl-or-nil (cadr type)))))))) (values pred pred)))) (defun saut-prototype (specl type) @@ -1368,10 +1424,7 @@ And so, we are saved. (class-eq (eq (cadr specl) (class-of (cadr type)))) (class (memq (cadr specl) (let ((class (class-of (cadr type)))) - (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list - class)))))))) + (cpl-or-nil class))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) @@ -1437,7 +1490,7 @@ And so, we are saved. (if function-p (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (apply #'no-applicable-method gf args))) (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) @@ -1502,15 +1555,13 @@ And so, we are saved. (let* ((early-p (early-gf-p generic-function)) (gf-name (if early-p (!early-gf-name generic-function) - (generic-function-name generic-function))) - (ocache (gf-dfun-cache generic-function))) + (generic-function-name 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)))) - (set-funcallable-instance-fun generic-function dfun) + (set-funcallable-instance-function generic-function dfun) (set-fun-name generic-function gf-name) - (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) (defvar *dfun-count* nil)