X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=3be7f774be1cc42f6edf9ee579dac791de2f9b14;hb=127fd3d2fb843c6bb7ad0763e143d81877e760e8;hp=0e816d0dddc4e99863503e1a9f1f4d12b77b409b;hpb=e3932d9a8cf3b8d2272cf75d1c40173af48747be;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 0e816d0..3be7f77 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -260,8 +260,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; 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. +;;; and corresponding slot indexes. + (defstruct (dfun-info (:constructor nil) (:copier nil)) (cache nil)) @@ -401,7 +401,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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))) + (cache (or cache (make-cache :key-count 1 :value nil :size 4))) (dfun-info (one-index-dfun-info type index cache))) (declare (type cache cache)) (values @@ -412,19 +412,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))) -(defun make-final-one-index-accessor-dfun (gf type index table) - (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) - (make-one-index-accessor-dfun gf type index cache))) - -(defun one-index-limit-fn (nlines) - (default-limit-fn nlines)) - (defun make-n-n-accessor-dfun (gf type &optional cache) (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))) + (cache (or cache (make-cache :key-count 1 :value t :size 2))) (dfun-info (n-n-dfun-info type cache))) (declare (type cache cache)) (values @@ -434,13 +427,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))) -(defun make-final-n-n-accessor-dfun (gf type table) - (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) - (make-n-n-accessor-dfun gf type cache))) - -(defun n-n-accessors-limit-fn (nlines) - (default-limit-fn nlines)) - (defun make-checking-dfun (generic-function function &optional cache) (unless cache (when (use-caching-dfun-p generic-function) @@ -457,7 +443,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 function) nil dfun-info)) - (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value nil :size 2))) (dfun-info (checking-dfun-info function cache))) (values (funcall (get-dfun-constructor 'emit-checking metatypes applyp) @@ -468,8 +454,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))))) -(defun make-final-checking-dfun (generic-function function - classes-list new-class) +(defun make-final-checking-dfun (generic-function function classes-list new-class) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp nkeys)) @@ -477,9 +462,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function nil classes-list new-class))) (make-checking-dfun generic-function function cache))))) (defun use-default-method-only-dfun-p (generic-function) @@ -500,9 +484,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function))))) - -(defun checking-limit-fn (nlines) - (default-limit-fn nlines)) (defun make-caching-dfun (generic-function &optional cache) (unless cache @@ -515,7 +496,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) (dfun-info (caching-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) @@ -526,14 +507,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) - (let ((cache (make-final-ordinary-dfun-internal - generic-function t #'caching-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function t classes-list new-class))) (make-caching-dfun generic-function cache))) -(defun caching-limit-fn (nlines) - (default-limit-fn nlines)) - (defun insure-caching-dfun (gf) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info gf) @@ -590,8 +567,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) (dfun-info (constant-value-dfun-info cache))) + (declare (type cache cache)) (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) cache @@ -601,15 +579,24 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) - (let ((cache (make-final-ordinary-dfun-internal - generic-function :constant-value #'caching-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function :constant-value classes-list new-class))) (make-constant-value-dfun generic-function cache))) +(defun gf-has-method-with-nonstandard-specializer-p (gf) + (let ((methods (generic-function-methods gf))) + (dolist (method methods nil) + (unless (every (lambda (s) (standard-specializer-p s)) + (method-specializers method)) + (return t))))) + (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) (unless (or caching-p - (gf-requires-emf-keyword-checks gf)) + (gf-requires-emf-keyword-checks gf) + ;; DISPATCH-DFUN-COST will error if it encounters a + ;; method with a non-standard specializer. + (gf-has-method-with-nonstandard-specializer-p gf)) ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than @@ -692,18 +679,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) (dfun-update gf #'make-dispatch-dfun))) -(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))) - table) - cache)) - -(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn - classes-list new-class) +(defun make-final-ordinary-dfun-cache + (generic-function valuep classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (new-class (and new-class @@ -714,8 +691,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 new-class)) (cache (if new-class (copy-cache (gf-dfun-cache generic-function)) - (get-cache nkeys (not (null valuep)) limit-fn 4)))) - (make-emf-cache generic-function valuep cache classes-list new-class))) + (make-cache :key-count nkeys :value (not (null valuep)) + :size 4)))) + (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) @@ -851,8 +829,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ((use-caching-dfun-p gf) (dfun-update gf #'make-caching-dfun)) (t - (dfun-update - gf #'make-checking-dfun + (dfun-update gf #'make-checking-dfun ;; nemf is suitable only for caching, have to do this: (cache-miss-values gf args 'checking)))))) @@ -861,6 +838,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (make-final-dfun-internal gf classes-list) (set-dfun gf dfun cache info))) +;;; FIXME: What is this? (defvar *new-class* nil) (defun final-accessor-dfun-type (gf) @@ -912,10 +890,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (w1 (class-wrapper second))) (make-two-class-accessor-dfun gf type w0 w1 all-index))) ((or (integerp all-index) (consp all-index)) - (make-final-one-index-accessor-dfun - gf type all-index table)) + (let ((cache (hash-table-to-cache table :value nil :key-count 1))) + (make-one-index-accessor-dfun gf type all-index cache))) (no-class-slots-p - (make-final-n-n-accessor-dfun gf type table)) + (let ((cache (hash-table-to-cache table :value t :key-count 1))) + (make-n-n-accessor-dfun gf type cache))) (t (make-final-caching-dfun gf classes-list new-class))) (make-final-caching-dfun gf classes-list new-class))))) @@ -951,6 +930,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t (make-final-caching-dfun gf classes-list new-class))))) +(defvar *pcl-misc-random-state* (make-random-state)) (defun accessor-miss (gf new object dfun-info) (let* ((ostate (type-of dfun-info)) @@ -990,7 +970,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((ncache (fill-cache cache wrappers nindex))) (unless (eq ncache cache) (funcall update-fn ncache))))) - (cond ((null ntype) (caching)) ((or invalidp @@ -1035,6 +1014,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) ((eq oemf nemf) + ;; The cache of a checking dfun doesn't hold any values, + ;; so this NIL appears to be just a dummy-value we use in + ;; order to insert the wrappers into the cache. (let ((ncache (fill-cache cache wrappers nil))) (unless (eq ncache cache) (dfun-update generic-function #'make-checking-dfun @@ -1060,9 +1042,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (typecase emf (constant-fast-method-call (constant-fast-method-call-value emf)) - (constant-method-call (constant-method-call-value emf)) - (t (bug "~S with non-constant EMF ~S" - 'constant-value-miss emf)))) + (constant-method-call + (constant-method-call-value emf)) + (t + (bug "~S with non-constant EMF ~S" 'constant-value-miss emf)))) (ncache (fill-cache ocache wrappers value))) (unless (eq ncache ocache) (dfun-update generic-function @@ -1433,9 +1416,17 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t specl2))) (class-eq (case (car type2) (eql specl2) + ;; FIXME: This says that all CLASS-EQ + ;; specializers are equally specific, which + ;; is fair enough because only one CLASS-EQ + ;; specializer can ever be appliable. If + ;; ORDER-SPECIALIZERS should only ever be + ;; called on specializers from applicable + ;; methods, we could replace this with a BUG. (class-eq nil) (class type1))) (eql (case (car type2) + ;; similarly. (eql nil) (t specl1)))))))) @@ -1673,7 +1664,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 all-applicable-p (all-sorted-p t) function-p) - (if (null methods) + (if (null methods) (if function-p (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) @@ -1738,17 +1729,50 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (defun update-dfun (generic-function &optional dfun cache info) - (let* ((early-p (early-gf-p 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-function generic-function dfun) - (let ((gf-name (if early-p - (!early-gf-name generic-function) - (generic-function-name generic-function)))) - (set-fun-name generic-function gf-name) - dfun)))) + (let ((early-p (early-gf-p generic-function))) + (flet ((update () + ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can + ;; access it, and so that it's there for eg. future cache updates. + (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-function generic-function dfun) + (let ((gf-name (if early-p + (!early-gf-name generic-function) + (generic-function-name generic-function)))) + (set-fun-name generic-function gf-name) + dfun)))) + ;; This needs to be atomic per generic function, consider: + ;; 1. T1 sets dfun-state to S1 and computes discr. fun using S1 + ;; 2. T2 sets dfun-state to S2 and computes discr. fun using S2 + ;; 3. T2 sets fin + ;; 4. T1 sets fin + ;; Oops: now dfun-state and fin don't match! Since just calling + ;; a generic can cause the dispatch function to be updated we + ;; need a lock here. + ;; + ;; We need to accept recursion, because PCL is nasty and twisty, + ;; and we need to disable interrupts because it would be bad if + ;; we updated the DFUN-STATE but not the dispatch function. + ;; + ;; This is sufficient, because all the other calls to SET-DFUN + ;; are part of this same code path (done while the lock is held), + ;; which we AVER. + ;; + ;; FIXME: When our mutexes are smart about the need to wake up + ;; sleepers we can put a mutex here instead -- but in the meantime + ;; we use a spinlock to avoid a syscall for every dfun update. + ;; + ;; KLUDGE: No need to lock during bootstrap. + (if early-p + (update) + (let ((lock (gf-lock generic-function))) + ;; FIXME: GF-LOCK is a generic function... Are there cases + ;; where we can end up in a metacircular loop here? In + ;; case there are, better fetch it while interrupts are + ;; still enabled... + (sb-thread::call-with-recursive-system-spinlock #'update lock)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) @@ -1758,7 +1782,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; 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*))) @@ -1821,7 +1844,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (format t "~% ~S~%" (caddr type+count+sizes))) *dfun-count*) (values)) -|# +||# (defun gfs-of-type (type) (unless (consp type) (setq type (list type)))