From: Christophe R. <cr...@us...> - 2006-04-20 14:25:56
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28934/src/pcl Modified Files: cache.lisp methods.lisp Log Message: 0.9.11.43: Fix bug reported by Levente Meszaros sbcl-devel 2004-04-19: cache filling with negative offset. ... when precomputing cache contents, don't include classes with invalid wrappers. ... irony of ironies: I'm pretty sure that there's a bug lurking somewhere else in any case, because the problem was being exhibited in the computation of a cache for SLOT-BOUNDP-USING-CLASS, which doesn't (or shouldn't) use a cacheing dfun, but instead has its own specialized dfun which basically calls the boundp function from the slot definition. Hmm... ... comments and minor tidying in cache.lisp Index: cache.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/cache.lisp,v retrieving revision 1.37 retrieving revision 1.38 diff -u -d -r1.37 -r1.38 --- cache.lisp 2 Dec 2005 14:30:13 -0000 1.37 +++ cache.lisp 20 Apr 2006 14:25:45 -0000 1.38 @@ -943,7 +943,7 @@ (defun fill-cache (cache wrappers value) ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check.. - (assert wrappers) + (aver wrappers) (or (fill-cache-p nil cache wrappers value) (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*)) @@ -982,10 +982,7 @@ (defun probe-cache (cache wrappers &optional default limit-fn) ;;(declare (values value)) - (unless wrappers - ;; FIXME: This and another earlier test on a WRAPPERS arg can - ;; be compact assertoids. - (error "WRAPPERS arg is NIL!")) + (aver wrappers) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) (limit (funcall (or limit-fn (limit-fn)) (nlines)))) @@ -1041,6 +1038,13 @@ (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) (primary (location-line location))) (declare (fixnum location primary)) + ;; FIXME: I tried (aver (> location 0)) and (aver (not + ;; (location-reserved-p location))) here, on the basis that + ;; particularly passing a LOCATION of 0 for a cache with more + ;; than one key would cause PRIMARY to be -1. However, the + ;; AVERs triggered during the bootstrap, and removing them + ;; didn't cause anything to break, so I've left them removed. + ;; I'm still confused as to what is right. -- CSR, 2006-04-20 (multiple-value-bind (free emptyp) (find-free-cache-line primary cache wrappers) (when (or forcep emptyp) Index: methods.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v retrieving revision 1.54 retrieving revision 1.55 diff -u -d -r1.54 -r1.55 --- methods.lisp 27 Mar 2006 08:13:07 -0000 1.54 +++ methods.lisp 20 Apr 2006 14:25:45 -0000 1.55 @@ -951,18 +951,19 @@ (set-structure-svuc-method type method))))))) (defun mec-all-classes-internal (spec precompute-p) - (cons (specializer-class spec) - (and (classp spec) - precompute-p - (not (or (eq spec *the-class-t*) - (eq spec *the-class-slot-object*) - (eq spec *the-class-standard-object*) - (eq spec *the-class-structure-object*))) - (let ((sc (class-direct-subclasses spec))) - (when sc - (mapcan (lambda (class) - (mec-all-classes-internal class precompute-p)) - sc)))))) + (unless (invalid-wrapper-p (class-wrapper (specializer-class spec))) + (cons (specializer-class spec) + (and (classp spec) + precompute-p + (not (or (eq spec *the-class-t*) + (eq spec *the-class-slot-object*) + (eq spec *the-class-standard-object*) + (eq spec *the-class-structure-object*))) + (let ((sc (class-direct-subclasses spec))) + (when sc + (mapcan (lambda (class) + (mec-all-classes-internal class precompute-p)) + sc))))))) (defun mec-all-classes (spec precompute-p) (let ((classes (mec-all-classes-internal spec precompute-p))) |