From 96a67b487909638cc0cb91114b6babf94b4bc1a7 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 20 Apr 2006 14:25:44 +0000 Subject: [PATCH] 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 --- NEWS | 4 ++++ src/pcl/cache.lisp | 14 +++++++---- src/pcl/methods.lisp | 25 +++++++++---------- tests/mop-14.impure-cload.lisp | 52 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 79 insertions(+), 18 deletions(-) create mode 100644 tests/mop-14.impure-cload.lisp diff --git a/NEWS b/NEWS index 22a5a9a..cfb3cfd 100644 --- a/NEWS +++ b/NEWS @@ -37,6 +37,10 @@ changes in sbcl-0.9.12 relative to sbcl-0.9.11: appropriate float range (reported by John Wiseman) * bug fix: MAKE-LOAD-FORM-SAVING-SLOTS accepts en empty slot name list. + * bug fix: precomputing cache entries for generic functions with + some subclasses of specializers as yet invalid does not attempt to + fill a cache line with a negative offset. (reported by Levente + Mészároz) * improvements to DOCUMENTATION for TYPE and STRUCTURE doc-types: allow condition class objects as arguments to DOCUMENTATION and (SETF DOCUMENTATION); only find and set documentation for diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 34c148f..4b0fbc4 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -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) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index 3358df9..9f43c63 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -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))) diff --git a/tests/mop-14.impure-cload.lisp b/tests/mop-14.impure-cload.lisp new file mode 100644 index 0000000..e2af7fc --- /dev/null +++ b/tests/mop-14.impure-cload.lisp @@ -0,0 +1,52 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +;;; this file attempts to test the computation of final discriminating +;;; functions for slot-valuish generic functions in the presence of +;;; large hierarchies of slot definitions with a forward-referenced +;;; superclass. (This used to fail in cache-filling code: see reports +;;; from Levente Mészáros sbcl-devel 2006-04-19) + +(defpackage :dc + (:use + #:cl + #:sb-mop)) + +(in-package :dc) + +(defclass dwim-slot-definition + (standard-slot-definition) + ()) + +(defclass dwim-direct-slot-definition + (standard-direct-slot-definition dwim-slot-definition) + ()) + +(defclass dwim-effective-slot-definition + (extra-effective-slot-definition + standard-effective-slot-definition dwim-slot-definition) + ()) +(defclass dwim-attribute-slot-definition + (dwim-slot-definition) + ()) + +(defclass dwim-attribute-effective-slot-definition + (dwim-effective-slot-definition dwim-attribute-slot-definition) + ()) + +(defclass dwim-attribute-direct-slot-definition + (dwim-direct-slot-definition dwim-attribute-slot-definition) + ()) + +(defclass extra-effective-slot-definition () + ()) diff --git a/version.lisp-expr b/version.lisp-expr index 442dd50..727d7c1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.11.42" +"0.9.11.43" -- 1.7.10.4