Merge pull request #10217 from damiendoligez/fix-9853

fix for #9853

Changes

@@ -76,6 +76,9 @@ Working version
   to the debugger via a socket.
   (Antonin Décimo, review by Xavier Leroy)
 
+- #10217: Fix a segfault in a corner case of compaction (reported in #9853)
+  (Damien Doligez, report by Sadiq Jaffer, review by Stephen Dolan)
+
 - #10250, #10266: Dynamically allocate alternate signal stacks to
    accommodate changes in Glibc 2.34.
   (Xavier Leroy, reports by Tomasz Kłoczko and R.W.M. Jones, review by Anil

runtime/compact.c

@@ -39,7 +39,8 @@ extern void caml_shrink_heap (char *);              /* memory.c */
 
    We use the GC's color bits in the following way:
 
-   - White words are headers of live blocks.
+   - White words are headers of live blocks except for 0, which is a
+     fragment.
    - Blue words are headers of free blocks.
    - Black words are headers of out-of-heap "blocks".
    - Gray words are the encoding of pointers in inverted lists.
@@ -122,11 +123,9 @@ static char *compact_allocate (mlsize_t size)
 {
   char *chunk, *adr;
 
-  while (Chunk_size (compact_fl) - Chunk_alloc (compact_fl) <= Bhsize_wosize (3)
-         && Chunk_size (Chunk_next (compact_fl))
-            - Chunk_alloc (Chunk_next (compact_fl))
-            <= Bhsize_wosize (3)){
+  while (Chunk_size(compact_fl) - Chunk_alloc(compact_fl) < Bhsize_wosize(1)){
     compact_fl = Chunk_next (compact_fl);
+    CAMLassert (compact_fl != NULL);
   }
   chunk = compact_fl;
   while (Chunk_size (chunk) - Chunk_alloc (chunk) < size){
@@ -242,7 +241,7 @@ static void do_compaction (intnat new_allocation_policy)
 
         CAMLassert (!Is_black_hd (h));
         CAMLassert (!Is_gray_hd (h));
-        if (Is_white_hd (h)){
+        if (h != 0 && Is_white_hd (h)){
           word q;
           tag_t t;
           char *newadr;
@@ -304,13 +303,13 @@ static void do_compaction (intnat new_allocation_policy)
       chend = ch + Chunk_size (ch);
       while ((char *) p < chend){
         word q = *p;
-        if (Color_hd (q) == Caml_white){
+        if (q != 0 && Is_white_hd (q)){
           size_t sz = Bhsize_hd (q);
           char *newadr = compact_allocate (sz);
           memmove (newadr, p, sz);
           p += Wsize_bsize (sz);
         }else{
-          CAMLassert (Color_hd (q) == Caml_blue);
+          CAMLassert (q == 0 || Is_blue_hd (q));
           p += Whsize_hd (q);
         }
       }

testsuite/tests/regression/pr9853/compaction_corner_case.ml

@@ -0,0 +1,10 @@
+(* TEST *)
+
+(* Compaction crash when there is only one heap chunk and it is fully used. *)
+let c = ref []
+
+let () =
+  for i = 0 to 25000 do
+    c := 0 :: !c;
+    Gc.compact ()
+  done