Hi, Han-Wen Nienhuys <[EMAIL PROTECTED]> writes:
> Ludovic Courtès escreveu: > >> Not quite actually: the "hell = scm_malloc (...)" bit is still broken. > > ? I fixed it, added a ChangeLog and NEWS entry and a test case, and pushed it to 1.8. The simplest way to trigger a `go_to_hell ()' call is this: (define-class <foo> (<object>) (the-slot #:init-keyword #:value)) (define f (make <foo> #:value 2)) (define-class <foo> (<object>) (the-other-slot) (the-slot)) (slot-ref f 'the-slot) ;; -> via `TEST_CHANGE_CLASS ()' The test case is a variation on this, to make it likely to be hit by out-of-bound accesses to HELL. Thanks! Ludo'.
>From bb764c0e3c6969bc34154b9212eb0cd04b5f8f87 Mon Sep 17 00:00:00 2001 From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <[EMAIL PROTECTED]> Date: Tue, 19 Aug 2008 19:08:29 +0200 Subject: [PATCH] Complete fix of `hell' allocation in GOOPS. --- libguile/goops.c | 2 +- 1 files changed, 1 insertions(+), 1 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 8f298c5..c09932c 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2995,7 +2995,7 @@ scm_init_goops_builtins (void) list_of_no_method = scm_permanent_object (scm_list_1 (sym_no_method)); - hell = scm_calloc (hell_size * sizeof(scm_t_bits)); + hell = scm_calloc (hell_size * sizeof (*hell)); hell_mutex = scm_permanent_object (scm_make_mutex ()); create_basic_classes (); -- 1.5.6.2
>From 4a1db3a91ff5f2b8947d144f4ed3486d1960b34c Mon Sep 17 00:00:00 2001 From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <[EMAIL PROTECTED]> Date: Tue, 19 Aug 2008 19:13:39 +0200 Subject: [PATCH] Add ChangeLog and NEWS entry for the GOOPS `class-redefinition' memory corruption fix. --- NEWS | 1 + libguile/ChangeLog | 7 +++++++ 2 files changed, 8 insertions(+), 0 deletions(-) diff --git a/NEWS b/NEWS index fb5712a..c2bed17 100644 --- a/NEWS +++ b/NEWS @@ -57,6 +57,7 @@ This makes these internal functions technically not callable from application code. ** `guile-config link' now prints `-L$libdir' before `-lguile' +** Fix memory corruption involving GOOPS' `class-redefinition' ** Fix build issue on Tru64 and ia64-hp-hpux11.23 (`SCM_UNPACK' macro) ** Fix build issue on mips, mipsel, powerpc and ia64 (stack direction) ** Fix build issue on hppa2.0w-hp-hpux11.11 (`dirent64' and `readdir64_r') diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b4d3f87..15e6b4c 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2008-08-19 Han-Wen Nienhuys <[EMAIL PROTECTED]> + Ludovic Courtès <[EMAIL PROTECTED]> + + * goops.c (scm_init_goops_builtins, go_to_hell): Fix allocation + of `hell' by passing "hell_size * sizeof (*hell)" instead of + "hell_size" to `scm_malloc ()' and `scm_realloc ()'. + 2008-08-02 Neil Jerram <[EMAIL PROTECTED]> * numbers.c (scm_rationalize): Update docstring to match the -- 1.5.6.2
>From 82d8d6d9e8ac6a2c36534d6085cd3f96d6278856 Mon Sep 17 00:00:00 2001 From: =?utf-8?q?Ludovic=20Court=C3=A8s?= <[EMAIL PROTECTED]> Date: Wed, 20 Aug 2008 00:44:20 +0200 Subject: [PATCH] Add test case for the GOOPS `class-redefinition' memory corruption. --- test-suite/ChangeLog | 5 +++ test-suite/tests/goops.test | 75 +++++++++++++++++++++++++++++++++++++++++- 2 files changed, 78 insertions(+), 2 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 4c0d992..0d6b54c 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2008-08-19 Ludovic Courtès <[EMAIL PROTECTED]> + + * tests/goops.test (object update)[changing class, `hell' in + `goops.c' grows as expected]: New tests. + 2008-07-06 Ludovic Courtès <[EMAIL PROTECTED]> * standalone/test-asmobs, standalone/test-bad-identifiers, diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index e4c2df9..713132a 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -18,7 +18,8 @@ ;;;; Boston, MA 02110-1301 USA (define-module (test-suite test-goops) - #:use-module (test-suite lib)) + #:use-module (test-suite lib) + #:autoload (srfi srfi-1) (unfold)) (pass-if "GOOPS loads" (false-if-exception @@ -277,7 +278,77 @@ (y #:accessor y #:init-value 456) (z #:accessor z #:init-value 789)) (current-module)) - (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module)))) + (eval '(and (= (y foo) 456) (= (z foo) 789)) (current-module))) + + (pass-if "changing class" + (let* ((c1 (class () (the-slot #:init-keyword #:value))) + (c2 (class () (the-slot #:init-keyword #:value) + (the-other-slot #:init-value 888))) + (o1 (make c1 #:value 777))) + (and (is-a? o1 c1) + (not (is-a? o1 c2)) + (equal? (slot-ref o1 'the-slot) 777) + (let ((o2 (change-class o1 c2))) + (and (eq? o1 o2) + (is-a? o2 c2) + (not (is-a? o2 c1)) + (equal? (slot-ref o2 'the-slot) 777)))))) + + (pass-if "`hell' in `goops.c' grows as expected" + ;; This snippet yielded a segfault prior to the 2008-08-19 `goops.c' + ;; fix (i.e., Guile 1.8.5 and earlier). The root of the problem was + ;; that `go_to_hell ()' would not reallocate enough room for the `hell' + ;; array, leading to out-of-bounds accesses. + + (let* ((parent-class (class () + #:name '<class-that-will-be-redefined>)) + (classes + (unfold (lambda (i) (>= i 20)) + (lambda (i) + (make-class (list parent-class) + '((the-slot #:init-value #:value) + (the-other-slot)) + #:name (string->symbol + (string-append "<foo-to-redefine-" + (number->string i) + ">")))) + (lambda (i) + (+ 1 i)) + 0)) + (objects + (map (lambda (class) + (make class #:value 777)) + classes))) + + (define-method (change-class (foo parent-class) + (new <class>)) + ;; Called by `scm_change_object_class ()', via `purgatory ()'. + (if (null? classes) + (next-method) + (let ((class (car classes)) + (object (car objects))) + (set! classes (cdr classes)) + (set! objects (cdr objects)) + + ;; Redefine the class so that its instances are eventually + ;; passed to `scm_change_object_class ()'. This leads to + ;; nested `scm_change_object_class ()' calls, which increases + ;; the size of HELL and increments N_HELL. + (class-redefinition class + (make-class '() (class-slots class) + #:name (class-name class))) + + ;; Use `slot-ref' to trigger the `scm_change_object_class ()' + ;; and `go_to_hell ()' calls. + (slot-ref object 'the-slot) + + (next-method)))) + + + ;; Initiate the whole `change-class' chain. + (let* ((class (car classes)) + (object (change-class (car objects) class))) + (is-a? object class))))) (with-test-prefix "object comparison" (pass-if "default method" -- 1.5.6.2
