X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=4d81f4bd8a37ce873af241a596489248363b04fd;hb=3d9d3088982414ca5617caf62bd37b4fecac29b6;hp=c133d4fb4a1866bed08c4080c46e79ec20eee946;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index c133d4f..4d81f4b 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 @@ -668,7 +688,7 @@ And so, we are saved. (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) @@ -704,11 +724,17 @@ And so, we are saved. (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 +788,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 +828,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 +857,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 +1002,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 +1041,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 +1108,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) @@ -1437,7 +1473,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 +1538,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)