PR#5757: GC compaction bug (crash)

git-svn-id: http://caml.inria.fr/svn/ocaml/version/4.00@12910 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Changes

@@ -12,6 +12,7 @@ Bug fixes:
 - PR#5735: %apply and %revapply not first class citizens
 - PR#5738: first class module patterns not handled by ocamldep
 - PR#5742: missing bound checks in Array.sub
+- PR#5757: GC compaction bug (crash)
 
 
 OCaml 4.00.0:

VERSION

@@ -1,4 +1,4 @@
-4.00.1+dev2_2012-08-06
+4.00.1+dev3_2012-09-08
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

byterun/compact.c

@@ -331,7 +331,7 @@ static void do_compaction (void)
         word q = *p;
         if (Color_hd (q) == Caml_white){
           size_t sz = Bhsize_hd (q);
-          char *newadr = compact_allocate (sz);  Assert (newadr <= (char *)p);
+          char *newadr = compact_allocate (sz);
           memmove (newadr, p, sz);
           p += Wsize_bsize (sz);
         }else{
@@ -384,7 +384,8 @@ static void do_compaction (void)
     while (ch != NULL){
       if (Chunk_size (ch) > Chunk_alloc (ch)){
         caml_make_free_blocks ((value *) (ch + Chunk_alloc (ch)),
-                               Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1);
+                               Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1,
+                               Caml_white);
       }
       ch = Chunk_next (ch);
     }
@@ -397,7 +398,7 @@ uintnat caml_percent_max;  /* used in gc_ctrl.c and memory.c */
 
 void caml_compact_heap (void)
 {
-  uintnat target_size, live;
+  uintnat target_words, target_size, live;
 
   do_compaction ();
   /* Compaction may fail to shrink the heap to a reasonable size
@@ -414,26 +415,33 @@ void caml_compact_heap (void)
      See PR#5389
   */
   /* We compute:
-     freewords = caml_fl_cur_size          (exact)
-     heapsize = caml_heap_size             (exact)
-     live = heap_size - freewords
-     target_size = live * (1 + caml_percent_free / 100)
-                 = live / 100 * (100 + caml_percent_free)
-     We add 1 to live/100 to make sure it isn't 0.
+     freewords = caml_fl_cur_size                  (exact)
+     heapwords = Wsize_bsize (caml_heap_size)      (exact)
+     live = heapwords - freewords
+     wanted = caml_percent_free * (live / 100 + 1) (same as in do_compaction)
+     target_words = live + wanted
+     We add one page to make sure a small difference in counting sizes
+     won't make [do_compaction] keep the second block (and break all sorts
+     of invariants).
 
      We recompact if target_size < heap_size / 2
   */
-  live = caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size);
-  target_size = (live / 100 + 1) * (100 + caml_percent_free);
-  target_size = caml_round_heap_chunk_size (target_size);
+  live = Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size;
+  target_words = live + caml_percent_free * (live / 100 + 1)
+                 + Wsize_bsize (Page_size);
+  target_size = caml_round_heap_chunk_size (Bsize_wsize (target_words));
   if (target_size < caml_stat_heap_size / 2){
     char *chunk;
 
-    /* round it up to a page size */
+    caml_gc_message (0x10, "Recompacting heap (target=%luk)\n",
+                     target_size / 1024);
+
     chunk = caml_alloc_for_heap (target_size);
     if (chunk == NULL) return;
+    /* PR#5757: we need to make the new blocks blue, or they won't be
+       recognized as free by the recompaction. */
     caml_make_free_blocks ((value *) chunk,
-                           Wsize_bsize (Chunk_size (chunk)), 0);
+                           Wsize_bsize (Chunk_size (chunk)), 0, Caml_blue);
     if (caml_page_table_add (In_heap, chunk, chunk + Chunk_size (chunk)) != 0){
       caml_free_for_heap (chunk);
       return;
@@ -448,6 +456,7 @@ void caml_compact_heap (void)
     do_compaction ();
     Assert (caml_stat_heap_chunks == 1);
     Assert (Chunk_next (caml_heap_start) == NULL);
+    Assert (caml_stat_heap_size == Chunk_size (chunk));
   }
 }
 

byterun/freelist.c

@@ -509,8 +509,11 @@ void caml_fl_add_blocks (char *bp)
    p: pointer to the first word of the block
    size: size of the block (in words)
    do_merge: 1 -> do merge; 0 -> do not merge
+   color: which color to give to the pieces; if [do_merge] is 1, this
+          is overridden by the merge code, but we have historically used
+          [Caml_white].
 */
-void caml_make_free_blocks (value *p, mlsize_t size, int do_merge)
+void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color)
 {
   mlsize_t sz;
 
@@ -520,7 +523,7 @@ void caml_make_free_blocks (value *p, mlsize_t size, int do_merge)
     }else{
       sz = size;
     }
-    *(header_t *)p = Make_header (Wosize_whsize (sz), 0, Caml_white);
+    *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color);
     if (do_merge) caml_fl_merge_block (Bp_hp (p));
     size -= sz;
     p += sz;

byterun/freelist.h

@@ -29,7 +29,7 @@ void caml_fl_init_merge (void);
 void caml_fl_reset (void);
 char *caml_fl_merge_block (char *);
 void caml_fl_add_blocks (char *);
-void caml_make_free_blocks (value *, mlsize_t, int);
+void caml_make_free_blocks (value *, mlsize_t, int, int);
 void caml_set_allocation_policy (uintnat);
 
 

byterun/intern.c

@@ -558,7 +558,7 @@ static void intern_add_to_heap(mlsize_t whsize)
     Assert(intern_dest <= end_extra_block);
     if (intern_dest < end_extra_block){
       caml_make_free_blocks ((value *) intern_dest,
-                             end_extra_block - intern_dest, 0);
+                             end_extra_block - intern_dest, 0, Caml_white);
     }
     caml_allocated_words +=
       Wsize_bsize ((char *) intern_dest - intern_extra_block);

byterun/major_gc.c

@@ -496,7 +496,7 @@ void caml_init_major_heap (asize_t heap_size)
 
   caml_fl_init_merge ();
   caml_make_free_blocks ((value *) caml_heap_start,
-                         Wsize_bsize (caml_stat_heap_size), 1);
+                         Wsize_bsize (caml_stat_heap_size), 1, Caml_white);
   caml_gc_phase = Phase_idle;
   gray_vals_size = 2048;
   gray_vals = (value *) malloc (gray_vals_size * sizeof (value));

byterun/memory.c

@@ -318,7 +318,7 @@ static char *expand_heap (mlsize_t request)
   }
   remain = malloc_request;
   prev = hp = mem;
-  /* XXX find a way to do this with a call to caml_make_free_blocks */
+  /* FIXME find a way to do this with a call to caml_make_free_blocks */
   while (Wosize_bhsize (remain) > Max_wosize){
     Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue);
 #ifdef DEBUG

testsuite/tests/regression/pr5757/Makefile

@@ -0,0 +1,4 @@
+MAIN_MODULE=pr5757
+
+include ../../../makefiles/Makefile.one
+include ../../../makefiles/Makefile.common

testsuite/tests/regression/pr5757/pr5757.ml

@@ -0,0 +1,5 @@
+Random.init 3;;
+for i = 0 to 100_000 do
+  ignore (String.create (Random.int 1_000_000))
+done;;
+Printf.printf "hello world\n";;

testsuite/tests/regression/pr5757/pr5757.reference

@@ -0,0 +1 @@
+hello world