From: Christophe Rhodes Date: Fri, 6 Nov 2009 21:12:16 +0000 (+0000) Subject: 1.0.32.12: Fix slot-value on specialized parameters in SVUC methods X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=95591ed483dbb8c0846c129953acac1554f28809;p=sbcl.git 1.0.32.12: Fix slot-value on specialized parameters in SVUC methods The slot accessors' functions were being computed too early, requiring a wrapper (for the PV optimization) when none was available. The fix delays the computation by the usual trick of installing a closure that will perform the slot accessor computation on demand. Include a correct MOP test for this (slightly hard because of constraints about order of instantiation: see lp #473699, reported by Lars Rune Nodstal). --- diff --git a/NEWS b/NEWS index 830a6e4..ff126ad 100644 --- a/NEWS +++ b/NEWS @@ -1,7 +1,7 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.0.32: * improvement: support O_LARGEFILE access to files larger than 2GB on - x86-64/linux. (thanks to Daniel Janus) + x86-64/linux. (thanks to Daniel Janus; launchpad bug #453080) * new feature: SB-INTROSPECT:WHO-SPECIALIZES-DIRECTLY to get a list of definitions for methods specializing on the passed class itself. * new feature: SB-INTROSPECT:WHO-SPECIALIZES-GENERALLY to get a list of @@ -9,11 +9,18 @@ changes relative to sbcl-1.0.32: subclasses of it. * fixes and improvements related to external formats: ** fix a typo preventing conversion of strings into octet vectors - in the latin-2 encoding. (reported by Attila Lendvai) + in the latin-2 encoding. (reported by Attila Lendvai; launchpad bug + #471689) + * bug fix: uses of slot accessors on specialized method parameters within + the bodies of SLOT-VALUE-USING-CLASS methods no longer triggers a type + error while finalizing the class. This fix may cause classes with slot + accessors to be finalized later than previously. (reported by Lars Rune + Nøstdal; launchpad bug #473699) * bug fix: restore buildability on the MIPS platform. (regression from 1.0.30.38, reported by Samium Gromoff) * bug fix: inspecting closures is less likely to fail with a type error. - * bug fix: no timer starvation when setting the system clock back + * bug fix: no timer starvation when setting the system clock back. + (launchpad bug #460283) changes in sbcl-1.0.32 relative to sbcl-1.0.31: * optimization: faster FIND and POSITION on strings of unknown element type diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index b5d0e58..c7869ec 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -69,8 +69,8 @@ (the fixnum (logand (the fixnum (lognot mask)) flags))))) value) -(defmethod initialize-internal-slot-functions ((slotd - effective-slot-definition)) +(defmethod initialize-internal-slot-functions + ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) (class (slot-value slotd '%class))) (dolist (type '(reader writer boundp)) @@ -79,6 +79,33 @@ (writer '(setf slot-value-using-class)) (boundp 'slot-boundp-using-class))) (gf (gdefinition gf-name))) + ;; KLUDGE: this logic is cut'n'pasted from + ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is + ;; only called later, because it does things that can't be + ;; computed this early in class finalization; however, we need + ;; this bit as early as possible. -- CSR, 2009-11-05 + (setf (slot-accessor-std-p slotd type) + (let* ((std-method (standard-svuc-method type)) + (str-method (structure-svuc-method type)) + (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) + (types (if (eq type 'writer) `(t ,@types1) types1)) + (methods (compute-applicable-methods-using-types gf types))) + (null (cdr methods)))) + (setf (slot-accessor-function slotd type) + (lambda (&rest args) + ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P + ;; work here (see KLUDGE comment above). + (let ((fun (compute-slot-accessor-info slotd type gf))) + (apply fun args)))))))) + +(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition)) + (let* ((name (slot-value slotd 'name))) + (dolist (type '(reader writer boundp)) + (let* ((gf-name (ecase type + (reader 'slot-value-using-class) + (writer '(setf slot-value-using-class)) + (boundp 'slot-boundp-using-class))) + (gf (gdefinition gf-name))) (compute-slot-accessor-info slotd type gf))))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: @@ -98,10 +125,7 @@ (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd '%class)) - (old-slotd (when (class-finalized-p class) - (find-slot-definition class name))) - (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) + (class (slot-value slotd '%class))) (multiple-value-bind (function std-p) (if (eq **boot-state** 'complete) (get-accessor-method-function gf type class slotd) @@ -615,7 +639,7 @@ (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) - (mapc #'initialize-internal-slot-functions eslotds) + (mapc #'finalize-internal-slot-functions eslotds) eslotds)) (defmethod shared-initialize :after @@ -1095,7 +1119,7 @@ (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) - (mapc #'initialize-internal-slot-functions eslotds) + (mapc #'finalize-internal-slot-functions eslotds) eslotds)) (defmethod compute-effective-slot-definition ((class slot-class) name dslotds) diff --git a/tests/mop-29.impure.lisp b/tests/mop-29.impure.lisp new file mode 100644 index 0000000..71b2d1d --- /dev/null +++ b/tests/mop-29.impure.lisp @@ -0,0 +1,60 @@ +;;;; 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. + +;;; a test that metaclasses can be instantiated even if there are +;;; applicable methods for SLOT-VALUE-USING-CLASS with specialized +;;; arguments that invoke slot readers. (Previously the PV +;;; optimization for slot readers caused the new class's wrapper and +;;; effective slot definitions to be available during class +;;; finalization) + +(load "assertoid.lisp") + +(defpackage "MOP-29" + (:use "CL" "SB-MOP")) + +(in-package "MOP-29") + +(defclass my-class (standard-class) + ()) +(defmethod validate-superclass ((class my-class) (super-class standard-class)) + t) +(defvar *foo*) +;;; the specialization of OBJECT here triggers the PV optimization; +;;; with an unspecialized argument, the SLOT-VALUE is not optimized. +(defmethod slot-value-using-class + ((class my-class) (object standard-object) eslotd) + (if *foo* + (setf (slot-value object 'id) 42) + (call-next-method))) +(defclass my-object () + ((id :type integer :reader id-of)) + (:metaclass my-class)) + +;;; the first patch failed on code like this, because the STD-P field +;;; of the accessor information was also computed lazily, but it is +;;; needed in order to real with accessor cache misses. +(defun test-global-accessors () + (let ((object (make-instance 'my-object))) + (setf (slot-value object 'id) 13) + (let ((*foo* nil)) + (assert (= (id-of object) 13)) + (assert (= (slot-value object 'id) 13))) + (let ((*foo* t)) + (assert (= (id-of object) 42)) + (assert (= (slot-value object 'id) 42))) + (let ((*foo* nil)) + (assert (= (id-of object) 42)) + (assert (= (slot-value object 'id) 42))))) +(compile 'test-global-accessors) +(test-global-accessors) diff --git a/version.lisp-expr b/version.lisp-expr index 6498578..6c2e42a 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".) -"1.0.32.11" +"1.0.32.12"