Index: byterun/intern.c
===================================================================
--- byterun/intern.c	(revision 12905)
+++ byterun/intern.c	(working copy)
@@ -558,7 +558,7 @@
     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);
Index: byterun/memory.c
===================================================================
--- byterun/memory.c	(revision 12905)
+++ byterun/memory.c	(working copy)
@@ -318,7 +318,7 @@
   }
   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
Index: byterun/freelist.c
===================================================================
--- byterun/freelist.c	(revision 12905)
+++ byterun/freelist.c	(working copy)
@@ -509,8 +509,11 @@
    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 @@
     }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;
Index: byterun/freelist.h
===================================================================
--- byterun/freelist.h	(revision 12905)
+++ byterun/freelist.h	(working copy)
@@ -29,7 +29,7 @@
 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);
 
 
Index: byterun/compact.c
===================================================================
--- byterun/compact.c	(revision 12905)
+++ byterun/compact.c	(working copy)
@@ -331,7 +331,7 @@
         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 @@
     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 @@
 
 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 @@
      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 @@
     do_compaction ();
     Assert (caml_stat_heap_chunks == 1);
     Assert (Chunk_next (caml_heap_start) == NULL);
+    Assert (caml_stat_heap_size == Chunk_size (chunk));
   }
 }
 
Index: byterun/major_gc.c
===================================================================
--- byterun/major_gc.c	(revision 12905)
+++ byterun/major_gc.c	(working copy)
@@ -496,7 +496,7 @@
 
   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));

Property changes on: testsuite/tests/regression/pr5757
___________________________________________________________________
Added: svn:ignore
   + *.o
*.a
*.so
*.obj

*.cm[ioxat]
*.cmx[as]
*.cmti
*.annot

*.result
*.byte
*.native
program
program.exe

.depend
.depend.nt
.DS_Store



Index: testsuite/tests/regression/pr5757/pr5757.ml
===================================================================
--- testsuite/tests/regression/pr5757/pr5757.ml	(revision 0)
+++ testsuite/tests/regression/pr5757/pr5757.ml	(revision 0)
@@ -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";;
Index: testsuite/tests/regression/pr5757/pr5757.reference
===================================================================
--- testsuite/tests/regression/pr5757/pr5757.reference	(revision 0)
+++ testsuite/tests/regression/pr5757/pr5757.reference	(revision 0)
@@ -0,0 +1 @@
+hello world
Index: testsuite/tests/regression/pr5757/Makefile
===================================================================
--- testsuite/tests/regression/pr5757/Makefile	(revision 0)
+++ testsuite/tests/regression/pr5757/Makefile	(revision 0)
@@ -0,0 +1,4 @@
+MAIN_MODULE=pr5757
+
+include ../../../makefiles/Makefile.one
+include ../../../makefiles/Makefile.common