Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv26821/src/pcl
Modified Files:
boot.lisp cache.lisp dfun.lisp dlisp.lisp methods.lisp
std-class.lisp vector.lisp
Removed Files:
dlisp2.lisp
Log Message:
1.0.6.3: thread and interrupt safe CLOS cache
* New cache implementation. While the patch appears to modify
src/pcl/cache.lisp, it is really a wholesale reimplementation.
-- Use compare-and-swap to provide atomicity where necessary.
-- Layouts are write-once, but cached values can be replaced
atomically.
-- Expanding the cache (or dropping invalidated and incomplete
entries) copies the cache.
-- Use ..EMPTY.. as a sentinel value to denote unused cache line
slot.
-- Cache index zero is no longer special.
-- Maximum cache size is limited to avoid ridiculously huge caches.
-- API changes in the cache code: MAKE-CACHE replaces GET-CACHE.
PROBE-CACHE now returns a primary indicating a hit or a miss,
and returns the probed value as the second return value.
* Move remaining non-cache related code from cache.lisp.
* Delete unused closure-based dispatch code (src/pcl/dlisp2.lisp). If
we want to support a compilerless build at some future date this
code can be always resurrected from the CVS -- or better yet, can
be re-implemented.
* Delete MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN, inlining it to the
call-sites for easier understanding. (Yes, there is such a thing as
too much abstraction.)
Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.133
retrieving revision 1.134
diff -u -d -r1.133 -r1.134
--- boot.lisp 10 May 2007 16:00:55 -0000 1.133
+++ boot.lisp 28 May 2007 18:52:26 -0000 1.134
@@ -2009,8 +2009,6 @@
(setf (gf-dfun-state generic-function) new-value)))
(defun set-dfun (gf &optional dfun cache info)
- (when cache
- (setf (cache-owner cache) gf))
(let ((new-state (if (and dfun (or cache info))
(list* dfun cache info)
dfun)))
Index: cache.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/cache.lisp,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- cache.lisp 28 May 2007 15:16:24 -0000 1.50
+++ cache.lisp 28 May 2007 18:52:26 -0000 1.51
@@ -23,826 +23,423 @@
;;;; warranty about the software, its performance or its conformity to any
;;;; specification.
-(in-package "SB-PCL")
-
-;;; Ye olde CMUCL comment follows, but it seems likely that the paper
-;;; that would be inserted would resemble Kiczales and Rodruigez,
-;;; Efficient Method Dispatch in PCL, ACM 1990. Some of the details
-;;; changed between that paper and "May Day PCL" of 1992; some other
-;;; details have changed since, but reading that paper gives the broad
-;;; idea.
[...1188 lines suppressed...]
+ ;; Copy layouts.
+ (loop for offset from 0 below key-count do
+ (setf (svref copy (+ index offset)) (pop layouts)))
+ ;; Update probe depth.
+ (let ((distance (/ (- index primary) line-size)))
+ (setf depth (max depth (if (minusp distance)
+ ;; account for wrap-around
+ (+ distance size)
+ distance))))))
+ :next
+ (setf index (next-cache-index mask index line-size))
+ (unless (zerop index)
+ (go :copy)))
+ (%make-cache :vector copy
+ :depth depth
+ :key-count (cache-key-count cache)
+ :line-size line-size
+ :value valuep
+ :mask (cache-mask cache)
+ :limit (cache-limit cache))))
Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -d -r1.56 -r1.57
--- dfun.lisp 11 May 2007 11:55:43 -0000 1.56
+++ dfun.lisp 28 May 2007 18:52:26 -0000 1.57
@@ -401,7 +401,7 @@
(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 @@
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 @@
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 @@
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 @@
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 @@
(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 @@
(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 @@
(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 @@
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 @@
(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,9 +579,8 @@
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)
@@ -702,18 +679,8 @@
(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
@@ -724,8 +691,9 @@
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* ())
@@ -861,8 +829,7 @@
((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))))))
@@ -871,6 +838,7 @@
(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)
@@ -922,10 +890,11 @@
(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)))))
@@ -961,6 +930,7 @@
(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))
@@ -1000,7 +970,6 @@
(let ((ncache (fill-cache cache wrappers nindex)))
(unless (eq ncache cache)
(funcall update-fn ncache)))))
-
(cond ((null ntype)
(caching))
((or invalidp
@@ -1045,6 +1014,9 @@
(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
@@ -1070,9 +1042,10 @@
(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
@@ -1749,6 +1722,8 @@
(defun update-dfun (generic-function &optional dfun cache info)
(let* ((early-p (early-gf-p generic-function)))
+ ;; FIXME: How atomic wrt. SET-FUNCALLABLE-INSTANCE-FUN does
+ ;; this need to be?
(set-dfun generic-function dfun cache info)
(let ((dfun (if early-p
(or dfun (make-initial-dfun generic-function))
Index: dlisp.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dlisp.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- dlisp.lisp 28 May 2007 15:16:24 -0000 1.24
+++ dlisp.lisp 28 May 2007 18:52:26 -0000 1.25
@@ -23,6 +23,7 @@
(in-package "SB-PCL")
+
;;;; some support stuff for getting a hold of symbols that we need when
;;;; building the discriminator codes. It's OK for these to be interned
;;;; symbols because we don't capture any user code in the scope in which
@@ -246,7 +247,7 @@
(fsc-instance-wrapper ,instance)))))
(block access
(when (and wrapper
- (/= (layout-clos-hash wrapper) 0)
+ (not (zerop (layout-clos-hash wrapper)))
,@(if (eql 1 1-or-2-class)
`((eq wrapper wrapper-0))
`((or (eq wrapper wrapper-0)
@@ -383,147 +384,12 @@
(error "Every metatype is T."))
`(prog ()
(return
- (let ((cache-vector (cache-vector ,cache-var))
- (mask (cache-mask ,cache-var))
- (size (cache-size ,cache-var))
- (overflow (cache-overflow ,cache-var))
- ,@wrapper-bindings)
- (declare (fixnum size mask))
- ,(emit-cache-lookup wrapper-vars miss-tag value-var)
+ (let ,wrapper-bindings
+ ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var)
,hit-form))
,miss-tag
(return ,miss-form))))
-(defun emit-cache-lookup (wrapper-vars miss-tag value-reg)
- (cond ((cdr wrapper-vars)
- (emit-greater-than-1-dlap wrapper-vars miss-tag value-reg))
- (value-reg
- (emit-1-t-dlap (car wrapper-vars) miss-tag value-reg))
- (t
- (emit-1-nil-dlap (car wrapper-vars) miss-tag))))
-
-(defun emit-1-nil-dlap (wrapper miss-label)
- `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
- miss-label))
- (location primary))
- (declare (fixnum primary location))
- (block search
- (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
- (return-from search nil))
- (setq location (the fixnum (+ location 1)))
- (when (= location size)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (when (eq (car entry) ,wrapper)
- (return-from search nil)))
- (go ,miss-label))))))
-
-(defmacro get-cache-vector-lock-count (cache-vector)
- `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
- (unless (typep lock-count 'fixnum)
- (error "My cache got freed somehow."))
- (the fixnum lock-count)))
-
-(defun emit-1-t-dlap (wrapper miss-label value)
- `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
- miss-label))
- (initial-lock-count (get-cache-vector-lock-count cache-vector)))
- (declare (fixnum primary initial-lock-count))
- (let ((location primary))
- (declare (fixnum location))
- (block search
- (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
- (setq ,value (cache-vector-ref cache-vector (1+ location)))
- (return-from search nil))
- (setq location (the fixnum (+ location 2)))
- (when (= location size)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (when (eq (car entry) ,wrapper)
- (setq ,value (cdr entry))
- (return-from search nil)))
- (go ,miss-label))))
- (unless (= initial-lock-count
- (get-cache-vector-lock-count cache-vector))
- (go ,miss-label)))))
-
-(defun emit-greater-than-1-dlap (wrappers miss-label value)
- (declare (type list wrappers))
- (let ((cache-line-size (compute-line-size (+ (length wrappers)
- (if value 1 0)))))
- `(let ((primary 0)
- (size-1 (the fixnum (- size 1))))
- (declare (fixnum primary size-1))
- ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
- (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
- (declare (fixnum initial-lock-count))
- (let ((location primary)
- (next-location 0))
- (declare (fixnum location next-location))
- (block search
- (loop (setq next-location
- (the fixnum (+ location ,cache-line-size)))
- (when (and ,@(mapcar
- (lambda (wrapper)
- `(eq ,wrapper
- (cache-vector-ref
- cache-vector
- (setq location
- (the fixnum (+ location 1))))))
- wrappers))
- ,@(when value
- `((setq location (the fixnum (+ location 1)))
- (setq ,value (cache-vector-ref cache-vector
- location))))
- (return-from search nil))
- (setq location next-location)
- (when (= location size-1)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (let ((entry-wrappers (car entry)))
- (when (and ,@(mapcar (lambda (wrapper)
- `(eq ,wrapper
- (pop entry-wrappers)))
- wrappers))
- ,@(when value
- `((setq ,value (cdr entry))))
- (return-from search nil))))
- (go ,miss-label))))
- (unless (= initial-lock-count
- (get-cache-vector-lock-count cache-vector))
- (go ,miss-label)))))))
-
-(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
- `(let ((wrapper-cache-no (layout-clos-hash ,wrapper)))
- (declare (fixnum wrapper-cache-no))
- (when (zerop wrapper-cache-no) (go ,miss-label))
- ,(let ((form `(logand mask wrapper-cache-no)))
- `(the fixnum ,form))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
- (declare (type list wrappers))
- ;; This returns 1 less that the actual location.
- `(progn
- ,@(let ((adds 0) (len (length wrappers)))
- (declare (fixnum adds len))
- (mapcar (lambda (wrapper)
- `(let ((wrapper-cache-no (layout-clos-hash ,wrapper)))
- (declare (fixnum wrapper-cache-no))
- (when (zerop wrapper-cache-no) (go ,miss-label))
- (setq primary (the fixnum (+ primary wrapper-cache-no)))
- ,@(progn
- (incf adds)
- (when (or (zerop (mod adds
- wrapper-cache-number-adds-ok))
- (eql adds len))
- `((setq primary
- ,(let ((form `(logand primary mask)))
- `(the fixnum ,form))))))))
- wrappers))))
-
;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
;;; CMU/SBCL approach of using funcallable instances, that branch may
;;; run on non-pcl instances (structures). The result will be the
@@ -531,7 +397,7 @@
;;; "slots" will be whatever the first slot is, but will be ignored.
;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
;;; as well as PCL fins.
-(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
+(defun emit-fetch-wrapper (metatype argument miss-tag &optional slot)
(ecase metatype
((standard-instance)
`(cond ((std-instance-p ,argument)
@@ -541,7 +407,7 @@
,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
(fsc-instance-wrapper ,argument))
(t
- (go ,miss-label))))
+ (go ,miss-tag))))
;; Sep92 PCL used to distinguish between some of these cases (and
;; spuriously exclude others). Since in SBCL
;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
Index: methods.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v
retrieving revision 1.69
retrieving revision 1.70
diff -u -d -r1.69 -r1.70
--- methods.lisp 11 May 2007 11:55:43 -0000 1.69
+++ methods.lisp 28 May 2007 18:52:26 -0000 1.70
@@ -965,14 +965,12 @@
(nkeys (arg-info-nkeys arg-info))
(metatypes (arg-info-metatypes arg-info))
(wrappers (unless (eq nkeys 1) (make-list nkeys)))
- (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
- (default '(default)))
+ (precompute-p (gf-precompute-dfun-and-emf-p arg-info)))
(flet ((add-class-list (classes)
(when (or (null new-class) (memq new-class classes))
(let ((%wrappers (get-wrappers-from-classes
nkeys wrappers classes metatypes)))
- (when (and %wrappers
- (eq default (probe-cache cache %wrappers default)))
+ (when (and %wrappers (not (probe-cache cache %wrappers)))
(let ((value (cond ((eq valuep t)
(sdfun-for-caching generic-function
classes))
@@ -1541,6 +1539,10 @@
((gf-precompute-dfun-and-emf-p arg-info)
(multiple-value-bind (dfun cache info)
(make-final-dfun-internal gf)
+ ;; FIXME: What does the next comment mean? Presumably it
+ ;; refers to the age-old implementation where cache vectors
+ ;; where cached resources? Also, the first thing UPDATE-DFUN
+ ;; does it SET-DFUN, so do we really need it here?
(set-dfun gf dfun cache info) ; lest the cache be freed twice
(update-dfun gf dfun cache info))))))
Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.108
retrieving revision 1.109
diff -u -d -r1.108 -r1.109
--- std-class.lisp 7 Apr 2007 13:58:57 -0000 1.108
+++ std-class.lisp 28 May 2007 18:52:26 -0000 1.109
@@ -856,7 +856,7 @@
(setf slots eslotds
(wrapper-instance-slots-layout nwrapper) nlayout
(wrapper-class-slots nwrapper) nwrapper-class-slots
- (wrapper-no-of-instance-slots nwrapper) nslots
+ (layout-length nwrapper) nslots
wrapper nwrapper)
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
@@ -1230,7 +1230,7 @@
;; good style. There has to be a better way! -- CSR,
;; 2002-10-29
(eq (layout-invalid owrapper) t))
- (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+ (let ((nwrapper (make-wrapper (layout-length owrapper)
class)))
(setf (wrapper-instance-slots-layout nwrapper)
(wrapper-instance-slots-layout owrapper))
@@ -1257,7 +1257,7 @@
;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism.
(defmethod make-instances-obsolete ((class std-class))
(let* ((owrapper (class-wrapper class))
- (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+ (nwrapper (make-wrapper (layout-length owrapper)
class)))
(unless (class-finalized-p class)
(if (class-has-a-forward-referenced-superclass-p class)
Index: vector.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/vector.lisp,v
retrieving revision 1.49
retrieving revision 1.50
diff -u -d -r1.49 -r1.50
--- vector.lisp 11 Apr 2007 20:57:13 -0000 1.49
+++ vector.lisp 28 May 2007 18:52:26 -0000 1.50
@@ -33,9 +33,6 @@
(when (eq ,slot-name sn) (return-from loop pos))
(incf pos)))))
-(defun pv-cache-limit-fn (nlines)
- (default-limit-fn nlines))
-
(defstruct (pv-table (:predicate pv-tablep)
(:constructor make-pv-table-internal
(slot-name-lists call-list))
@@ -208,19 +205,22 @@
(call-list (pv-table-call-list pv-table))
(cache (or (pv-table-cache pv-table)
(setf (pv-table-cache pv-table)
- (get-cache (- (length slot-name-lists)
- (count nil slot-name-lists))
- t
- #'pv-cache-limit-fn
- 2)))))
- (or (probe-cache cache pv-wrappers)
- (let* ((pv (compute-pv slot-name-lists pv-wrappers))
- (calls (compute-calls call-list pv-wrappers))
- (pv-cell (cons pv calls))
- (new-cache (fill-cache cache pv-wrappers pv-cell)))
- (unless (eq new-cache cache)
- (setf (pv-table-cache pv-table) new-cache))
- pv-cell))))
+ (make-cache :key-count (- (length slot-name-lists)
+ (count nil slot-name-lists))
+ :value t
+ :size 2)))))
+ (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers)
+ (if hitp
+ value
+ (let* ((pv (compute-pv slot-name-lists pv-wrappers))
+ (calls (compute-calls call-list pv-wrappers))
+ (pv-cell (cons pv calls))
+ (new-cache (fill-cache cache pv-wrappers pv-cell)))
+ ;; This is safe: if another thread races us here the loser just
+ ;; misses the next time as well.
+ (unless (eq new-cache cache)
+ (setf (pv-table-cache pv-table) new-cache))
+ pv-cell)))))
(defun make-pv-type-declaration (var)
`(type simple-vector ,var))
--- dlisp2.lisp DELETED ---
|