GOOPS memory corruption in `go_to_hell ()'

[Ludovic Courtès]

Hi,

Han-Wen Nienhuys <address@hidden> 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?= <address@hidden>
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?= <address@hidden>
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  <address@hidden>
+           Ludovic Courtès  <address@hidden>
+
+       * 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  <address@hidden>
 
        * 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?= <address@hidden>
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  <address@hidden>
+
+       * tests/goops.test (object update)[changing class, `hell' in
+       `goops.c' grows as expected]: New tests.
+
 2008-07-06  Ludovic Courtès  <address@hidden>
 
        * 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