Try this pasted by sjamaan on Tue Apr 15 21:06:23 2014

diff --git a/runtime.c b/runtime.c
index f68cd09..6750444 100644
--- a/runtime.c
+++ b/runtime.c
@@ -2847,6 +2847,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
 
     /* Mark items in forwarding table: */
     for(p = forwarding_table; *p != 0; p += 2) {
+      printf("reclaim p[1] = %p, p[0] = %p\n", p[1], p[0]);
       last = p[ 1 ];
       mark(&p[ 1 ]);
       C_block_header(p[ 0 ]) = C_block_header(last);
@@ -3349,6 +3350,7 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
 
   /* Mark items in forwarding table: */
   for(p = forwarding_table; *p != 0; p += 2) {
+    printf("RERECLAIM p[1] = %p, p[0] = %p\n", p[1], p[0]);
     last = p[ 1 ];
     remark(&p[ 1 ]);
     C_block_header(p[ 0 ]) = C_block_header(last);
[ permalink | raw ]

lolevel test output w/ debug info pasted by mario-goulart on Tue Apr 15 21:58:35 2014

[GC] level  1	gcs(minor)  0	gcs(major)  1
[GC] stack	0x00007fff9ffd3510	0xffffffff9ffd36b0	0x00007fffa00d3510
[GC]  from	0x00007f33e2ae5010	0x00007f33e2b1c768	0x00007f33e2b65010	0x0000000000037758
[GC]    to	0x00007f33e2b66010	0x00007f33e2b66010	0x00007f33e2be6010 
[GC] 0 locatives (from 32)
[GC] (old) fromspace: 	start=0x00007f33e2ae5010, 	limit=0x00007f33e2b65010
[GC] (old) tospace:   	start=0x00007f33e2b66010, 	limit=0x00007f33e2be6010
[GC] resized heap to 3145728 bytes
[GC] (new) fromspace: 	start=0x00007f33e19bd010, 	limit=0x00007f33e1b3d010
[GC] (new) tospace:   	start=0x00007f33e2a66010, 	limit=0x00007f33e2be6010
reclaim p[1] = 0x7f33e1a24a88, p[0] = 0x7f33e1a23d18
reclaim p[1] = 0x7f33e1a247f0, p[0] = 0x7f33e1a23e78
[GC] (old) fromspace: 	start=0x00007f33e19bd010, 	limit=0x00007f33e1b3d010
[GC] (old) tospace:   	start=0x00007f33e2a66010, 	limit=0x00007f33e2be6010
RERECLAIM p[1] = 0x7f33e2a66010, p[0] = 0x7f33e1a23d18
RERECLAIM p[1] = 0x7f33e2a66028, p[0] = 0x7f33e1a23e78
[GC] resized heap to 1572864 bytes
[GC] (new) fromspace: 	start=0x00007f33e16f9010, 	limit=0x00007f33e17b9010
[GC] (new) tospace:   	start=0x00000000025ecca0, 	limit=0x00000000026acca0
[GC] level  1	gcs(minor)  23	gcs(major)  2
[GC] stack	0x00007fff9ffd3510	0xffffffffa00d1f30	0x00007fffa00d3510
[GC]  from	0x00007f33e16f9010	0x00007f33e17432e8	0x00007f33e17b9010	0x000000000004a2d8
[GC]    to	0x00000000025ecca0	0x00000000025ecca0	0x00000000026acca0 
[GC] 0 locatives (from 32)
reclaim p[1] = 0x7fffa004c298, p[0] = 0x7f33e17278a8
[GC] level  1	gcs(minor)  1	gcs(major)  3
[GC] stack	0x00007fff9ffd3510	0xffffffffa0049c40	0x00007fffa00d3510
[GC]  from	0x00000000025ecca0	0x0000000002637cd0	0x00000000026acca0	0x000000000004b030
[GC]    to	0x00007f33e16f9010	0x00007f33e16f9010	0x00007f33e17b9010 
[GC] 0 locatives (from 32)

Error: unbound variable: foo

	Call history:

	<syntax>	  #<invalid forwarded object>
	<syntax>	  #<invalid forwarded object>
	<syntax>	  (##core#quote #<invalid forwarded object>)
	<syntax>	  #<invalid forwarded object>
	<eval>	  (mutate-procedure! #<invalid forwarded object> (lambda (#<invalid forwarded object>) (lambda #<inval......
	<syntax>	  (assert (not (eq? foo new-foo)))
	<syntax>	  (##core#let ((tmp139 (not (eq? foo new-foo)))) (##core#if (##core#check tmp139) tmp139 (##sys#error ...
	<syntax>	  (##core#begin (##core#if (##core#check tmp139) tmp139 (##sys#error "assertion failed" (##core#quote ...
	<syntax>	  (##core#if (##core#check tmp139) tmp139 (##sys#error "assertion failed" (##core#quote (not (eq? foo ......
	<syntax>	  (##core#check tmp139)
	<syntax>	  (##sys#error "assertion failed" (##core#quote (not (eq? foo new-foo))))
	<syntax>	  (##core#quote (not (eq? foo new-foo)))
	<syntax>	  (not (eq? foo new-foo))
	<syntax>	  (eq? foo new-foo)
	<eval>	  (not (eq? foo new-foo))
	<eval>	  (eq? foo new-foo)	<--
[ permalink | raw ]

Gotcha, you stupid bug! pasted by sjamaan on Wed Apr 16 08:43:41 2014

Looks like the problem occurs in C_rereclaim:

On my box at work, it doesn't fail:

peter@chewbacca% LD_LIBRARY_PATH=.. ../csi -n -include-path .. -s -:g -:hi120K lolevel-tests.scm
[GC] (old) fromspace:   start=0x000000000070e7c0,       limit=0x000000000071d7c0
[GC] (old) tospace:     start=0x000000000071d7d0,       limit=0x000000000072c7d0
[GC] resized heap to 2220032 bytes
[GC] (new) fromspace:   start=0x00007f19f9657010,       limit=0x00007f19f9766010
[GC] (new) tospace:     start=0x00007f19f8581010,       limit=0x00007f19f8690010
reclaim p[1] = 0x7fff19b28d70, p[0] = 0x7f19f96b1f28
reclaim p[1] = 0x7fff19b122b0, p[0] = 0x7fff19b80e60
[GC] level  1   gcs(minor)  24  gcs(major)  1
[GC] stack      0x00007fff19a84f20      0x0000000019b0fd00      0x00007fff19b84f20
[GC]  from      0x00007f19f8581010      0x00007f19f85cb418      0x00007f19f8690010      0x000000000004a408
[GC]    to      0x00007f19f9657010      0x00007f19f9657010      0x00007f19f9766010 
[GC] 0 locatives (from 32)
reclaim p[1] = 0x7fff19af3080, p[0] = 0x7f19f85afa08
[GC] level  1   gcs(minor)  1   gcs(major)  2
[GC] stack      0x00007fff19a84f20      0x0000000019af08f0      0x00007fff19b84f20
[GC]  from      0x00007f19f9657010      0x00007f19f96a1888      0x00007f19f9766010      0x000000000004a878
[GC]    to      0x00007f19f8581010      0x00007f19f8581010      0x00007f19f8690010 
[GC] 0 locatives (from 32)
[GC] level  1   gcs(minor)  4   gcs(major)  3
[GC] stack      0x00007fff19a84f20      0x0000000019a9c5f0      0x00007fff19b84f20
[GC]  from      0x00007f19f8581010      0x00007f19f85cbe28      0x00007f19f8690010      0x000000000004ae18
[GC]    to      0x00007f19f9657010      0x00007f19f9657010      0x00007f19f9766010 
[GC] 0 locatives (from 32)


Until you force a reallocation by tweaking the heap size:

peter@chewbacca% LD_LIBRARY_PATH=.. ../csi -n -include-path .. -s -:g -:hi420K lolevel-tests.scm
[GC] (old) fromspace:   start=0x00007fad210b0010,       limit=0x00007fad210e4810
[GC] (old) tospace:     start=0x00007fad2107b010,       limit=0x00007fad210af810
[GC] resized heap to 2527232 bytes
[GC] (new) fromspace:   start=0x00007fad20f46010,       limit=0x00007fad2107a810
[GC] (new) tospace:     start=0x00007fad1feda010,       limit=0x00007fad2000e810
reclaim p[1] = 0x7fff45818500, p[0] = 0x7fad20fa0ec0
reclaim p[1] = 0x7fff45801a40, p[0] = 0x7fff458705f0
[GC] (old) fromspace:   start=0x00007fad20f46010,       limit=0x00007fad2107a810
[GC] (old) tospace:     start=0x00007fad1feda010,       limit=0x00007fad2000e810
RERECLAIM p[1] = 0x7fad1feda010, p[0] = 0x7fad20fa0ec0
RERECLAIM p[1] = 0x7fad1feda028, p[0] = 0x7fff458705f0
[GC] resized heap to 1263616 bytes
[GC] (new) fromspace:   start=0x00007fad1fc3c010,       limit=0x00007fad1fcd6410
[GC] (new) tospace:     start=0x0000000000754f90,       limit=0x00000000007ef390
[GC] level  1   gcs(minor)  24  gcs(major)  1
[GC] stack      0x00007fff457746b0      0x00000000457ff490      0x00007fff458746b0
[GC]  from      0x00007fad1fc3c010      0x00007fad1fc86418      0x00007fad1fcd6410      0x000000000004a408
[GC]    to      0x0000000000754f90      0x0000000000754f90      0x00000000007ef390 
[GC] 0 locatives (from 32)
reclaim p[1] = 0x7fff457e2810, p[0] = 0x7fad1fc6aa08
[GC] level  1   gcs(minor)  1   gcs(major)  2
[GC] stack      0x00007fff457746b0      0x00000000457e0080      0x00007fff458746b0
[GC]  from      0x0000000000754f90      0x00000000007a00f0      0x00000000007ef390      0x000000000004b160
[GC]    to      0x00007fad1fc3c010      0x00007fad1fc3c010      0x00007fad1fcd6410 
[GC] 0 locatives (from 32)

Error: unbound variable: foo

        Call history:

        <syntax>          #<invalid forwarded object>
        <syntax>          #<invalid forwarded object>
        <syntax>          (##core#quote #<invalid forwarded object>)
        <syntax>          #<invalid forwarded object>
        <eval>    (mutate-procedure! #<invalid forwarded object> (lambda (#<invalid forwarded object>) (lambda #<inval......
        <syntax>          (assert (not (eq? foo new-foo)))
        <syntax>          (##core#let ((tmp139 (not (eq? foo new-foo)))) (##core#if (##core#check tmp139) tmp139 (##sys#error ...
        <syntax>          (##core#begin (##core#if (##core#check tmp139) tmp139 (##sys#error "assertion failed" (##core#quote ...
        <syntax>          (##core#if (##core#check tmp139) tmp139 (##sys#error "assertion failed" (##core#quote (not (eq? foo ......
        <syntax>          (##core#check tmp139)
        <syntax>          (##sys#error "assertion failed" (##core#quote (not (eq? foo new-foo))))
        <syntax>          (##core#quote (not (eq? foo new-foo)))
        <syntax>          (not (eq? foo new-foo))
        <syntax>          (eq? foo new-foo)
        <eval>    (not (eq? foo new-foo))
        <eval>    (eq? foo new-foo)     <--
[ permalink | raw ]

reduced testcase pasted by BUNNY351 on Wed Apr 16 13:30:40 2014

;;;; Unit lolevel testing

(require-extension lolevel)

(define (foo a b) (list a b))
(define tstvec (vector #f))
(define ev-tstvec (object-evict tstvec))
(object-release ev-tstvec)
(define some-foo '#(1 2 3))
(define some-bar '(1 2 3))
(object-become! (list (cons some-foo '(1 2 3)) (cons some-bar '#(1 2 3))))
(define new-foo (mutate-procedure! foo (lambda (new) (lambda args (cons 'hello (apply new args))))))
foo

; run this with:  bin/csi -n -s -:g -:hi420K x.scm
; interestingly, commenting out the "object-release" will make it work again...
[ permalink | raw ]

consistency check (sort of) added by BUNNY351 on Wed Apr 16 15:14:30 2014

diff --git a/chicken.h b/chicken.h
index 6dfefb9..ce725a4 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1771,6 +1771,7 @@ C_fctexport C_word C_vector(C_word **ptr, int n, ...);
 C_fctexport C_word C_structure(C_word **ptr, int n, ...);
 C_fctexport C_word C_fcall C_mutate_slot(C_word *slot, C_word val) C_regparm;
 C_fctexport C_word C_fcall C_mutate(C_word *slot, C_word val) C_regparm;
+C_fctexport C_word C_fcall  C_check_heap_consistency(C_word dummy) C_regparm;
 C_fctexport void C_fcall C_reclaim(void *trampoline, void *proc) C_regparm C_noret;
 C_fctexport void C_save_and_reclaim(void *trampoline, void *proc, int n, ...) C_noret;
 C_fctexport void C_fcall C_rereclaim2(C_uword size, int double_plus) C_regparm;
diff --git a/library.scm b/library.scm
index 59ddc36..961714c 100644
--- a/library.scm
+++ b/library.scm
@@ -5162,3 +5162,7 @@ EOF
       (loop (- len 1) (cdr input)))
      (else input))))
 
+
+;;;
+
+(define (##sys#check-heap-consistency) (##core#inline "C_check_heap_consistency" #f))
diff --git a/runtime.c b/runtime.c
index f68cd09..006b7af 100644
--- a/runtime.c
+++ b/runtime.c
@@ -3123,6 +3123,69 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
 }
 
 
+C_regparm C_word C_fcall C_check_heap_consistency(C_word dummy)
+{
+  C_word n, bytes, *p, x;
+  C_header h;
+  int i, f = 0;
+  C_SCHEME_BLOCK *bp = (C_SCHEME_BLOCK *)fromspace_start;
+
+  while((C_byte *)bp < C_fromspace_top) {
+    if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER) 
+      bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);
+
+    n = C_header_size(bp);
+    h = bp->header;
+    bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
+    p = bp->data;
+    i = 0;
+
+    if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
+      if(h & C_SPECIALBLOCK_BIT) {
+	--n;
+        ++i;
+	++p;
+      }
+
+      while(n--) {
+        x = *(p++);
+
+        if(!C_immediatep(x)) {
+          if((C_block_header(x) & C_GC_FORWARDING_BIT) != 0) {
+            if(!f) {
+              C_fputc('\n', C_stderr);
+              f = 1;
+            }
+
+            fprintf(C_stderr, C_text("Invalid forwarded object-pointer: [object=" UWORD_FORMAT_STRING
+                                     ", header=" UWORD_FORMAT_STRING
+                                     ": index=" UWORD_COUNT_FORMAT_STRING ", pointer=" UWORD_FORMAT_STRING "]\n"),
+                    (C_uword)bp, (C_uword)h, i, (C_uword)x);
+          }
+          else if(C_in_heapp(x) && !C_in_fromspacep(x)) {
+            if(!f) {
+              C_fputc('\n', C_stderr);
+              f = 1;
+            }
+
+            fprintf(C_stderr, C_text("Invalid non-heap object-pointer: [object=" UWORD_FORMAT_STRING
+                                     ", header=" UWORD_FORMAT_STRING
+                                     ": index=" UWORD_COUNT_FORMAT_STRING ", pointer=" UWORD_FORMAT_STRING "]\n"),
+                    (C_uword)bp, (C_uword)h, i, (C_uword)x);
+          }
+        }
+
+        ++i;
+      }
+    }
+
+    bp = (C_SCHEME_BLOCK *)((C_byte *)bp + C_align(bytes) + sizeof(C_header));
+  }
+
+  return C_mk_bool(f);
+}
+
+
 C_regparm void C_fcall mark_system_globals(void)
 {
   mark(&interrupt_hook_symbol);
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index 3a1dc70..4c41cbe 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -217,6 +217,7 @@
 (define ev-tstvec (object-evict tstvec))
 (assert (not (eq? tstvec ev-tstvec)))
 (assert (object-evicted? ev-tstvec))
+(set! ev-tstvec #f)
 (object-release ev-tstvec)
 
 ; object-evict-to-location
[ permalink | raw ]