Merge pull request #283 from mlasson/trunk

Fix memory leaks in intern.c when OOM is raised

Changes

@@ -315,6 +315,8 @@ Bug fixes:
   (whitequark)
 - GPR#280: Fix stdlib dependencies for .p.cmx (Pierre Chambart,
   Mark Shinwell)
+- GPR#283: Fix memory leaks in intern.c when OOM is raised
+  (Marc Lasson, review by Alain Frisch)
 
 Features wishes:
 - PR#4714: List.cons

byterun/array.c

@@ -12,7 +12,6 @@
 /***********************************************************************/
 
 /* Operations on arrays */
-
 #include <string.h>
 #include "caml/alloc.h"
 #include "caml/fail.h"
@@ -391,8 +390,17 @@ CAMLprim value caml_array_concat(value al)
     lengths = static_lengths;
   } else {
     arrays = caml_stat_alloc(n * sizeof(value));
-    offsets = caml_stat_alloc(n * sizeof(intnat));
-    lengths = caml_stat_alloc(n * sizeof(value));
+    offsets = malloc(n * sizeof(intnat));
+    if (offsets == NULL) {
+      caml_stat_free(arrays);
+      caml_raise_out_of_memory();
+    }
+    lengths = malloc(n * sizeof(value));
+    if (lengths == NULL) {
+      caml_stat_free(offsets);
+      caml_stat_free(arrays);
+      caml_raise_out_of_memory();
+    }
   }
   /* Build the parameters to caml_array_gather */
   for (i = 0, l = al; l != Val_int(0); l = Field(l, 1), i++) {

byterun/caml/memory.h

@@ -34,6 +34,7 @@ extern "C" {
 
 
 CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t);
+CAMLextern value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t);
 CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t);
 CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz);
 CAMLextern void caml_free_dependent_memory (mlsize_t bsz);

byterun/intern.c

@@ -37,24 +37,20 @@
 static unsigned char * intern_src;
 /* Reading pointer in block holding input data. */
 
-static unsigned char * intern_input;
-/* Pointer to beginning of block holding input data.
-   Meaningful only if intern_input_malloced = 1. */
-
-static int intern_input_malloced;
-/* 1 if intern_input was allocated by caml_stat_alloc()
-   and needs caml_stat_free() on error, 0 otherwise. */
+static unsigned char * intern_input = NULL;
+/* Pointer to beginning of block holding input data,
+   if non-NULL this pointer will be freed by the cleanup function. */
 
 static header_t * intern_dest;
 /* Writing pointer in destination block */
 
-static char * intern_extra_block;
+static char * intern_extra_block = NULL;
 /* If non-NULL, point to new heap chunk allocated with caml_alloc_for_heap. */
 
 static asize_t obj_counter;
 /* Count how many objects seen so far */
 
-static value * intern_obj_table;
+static value * intern_obj_table = NULL;
 /* The pointers to objects already seen */
 
 static unsigned int intern_color;
@@ -64,7 +60,7 @@ static header_t intern_header;
 /* Original header of the destination block.
    Meaningful only if intern_extra_block is NULL. */
 
-static value intern_block;
+static value intern_block = 0;
 /* Point to the heap block allocated as destination block.
    Meaningful only if intern_extra_block is NULL. */
 
@@ -138,16 +134,35 @@ static inline void readblock(void * dest, intnat len)
   intern_src += len;
 }
 
+static void intern_init(void * src, void * input)
+{
+  /* This is asserted at the beginning of demarshaling primitives.
+     If it fails, it probably means that an exception was raised
+     without calling intern_cleanup() during the previous demarshaling. */
+  Assert (intern_input == NULL && intern_obj_table == NULL \
+     && intern_extra_block == NULL && intern_block == 0);
+  intern_src = src;
+  intern_input = input;
+}
+
 static void intern_cleanup(void)
 {
-  if (intern_input_malloced) caml_stat_free(intern_input);
-  if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
+  if (intern_input != NULL) {
+     caml_stat_free(intern_input);
+     intern_input = NULL;
+  }
+  if (intern_obj_table != NULL) {
+    caml_stat_free(intern_obj_table);
+    intern_obj_table = NULL;
+  }
   if (intern_extra_block != NULL) {
     /* free newly allocated heap chunk */
     caml_free_for_heap(intern_extra_block);
+    intern_extra_block = NULL;
   } else if (intern_block != 0) {
     /* restore original header for heap block, otherwise GC is confused */
     Hd_val(intern_block) = intern_header;
+    intern_block = 0;
   }
   /* free the recursion stack */
   intern_free_stack();
@@ -549,9 +564,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
   mlsize_t wosize;
 
   if (whsize == 0) {
-    intern_obj_table = NULL;
-    intern_extra_block = NULL;
-    intern_block = 0;
+    Assert (intern_extra_block == NULL && intern_block == 0
+         && intern_obj_table == NULL);
     return;
   }
   wosize = Wosize_whsize(whsize);
@@ -560,37 +574,50 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
     asize_t request =
       ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
     intern_extra_block = caml_alloc_for_heap(request);
-    if (intern_extra_block == NULL) caml_raise_out_of_memory();
+    if (intern_extra_block == NULL) {
+      intern_cleanup();
+      caml_raise_out_of_memory();
+    }
     intern_color = caml_allocation_color(intern_extra_block);
     intern_dest = (header_t *) intern_extra_block;
+    Assert (intern_block == 0);
   } else {
     /* this is a specialised version of caml_alloc from alloc.c */
     if (wosize == 0){
       intern_block = Atom (String_tag);
     }else if (wosize <= Max_young_wosize){
       intern_block = caml_alloc_small (wosize, String_tag);
     }else{
-      intern_block = caml_alloc_shr (wosize, String_tag);
+      intern_block = caml_alloc_shr_no_raise (wosize, String_tag);
       /* do not do the urgent_gc check here because it might darken
          intern_block into gray and break the Assert 3 lines down */
+      if (intern_block == 0) {
+        intern_cleanup();
+        caml_raise_out_of_memory();
+      }
     }
     intern_header = Hd_val(intern_block);
     intern_color = Color_hd(intern_header);
     Assert (intern_color == Caml_white || intern_color == Caml_black);
     intern_dest = (header_t *) Hp_val(intern_block);
-    intern_extra_block = NULL;
+    Assert (intern_extra_block == NULL);
   }
   obj_counter = 0;
-  if (num_objects > 0)
-    intern_obj_table = (value *) caml_stat_alloc(num_objects * sizeof(value));
-  else
-    intern_obj_table = NULL;
+  if (num_objects > 0) {
+    intern_obj_table = (value *) malloc(num_objects * sizeof(value));
+    if (intern_obj_table == NULL) {
+      intern_cleanup();
+      caml_raise_out_of_memory();
+    }
+  } else
+    Assert(intern_obj_table == NULL);
 }
 
 static void intern_add_to_heap(mlsize_t whsize)
 {
   /* Add new heap chunk to heap if needed */
   if (intern_extra_block != NULL) {
+    Assert(intern_block == 0);
     /* If heap chunk not filled totally, build free block at end */
     asize_t request =
       ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
@@ -604,6 +631,9 @@ static void intern_add_to_heap(mlsize_t whsize)
     caml_allocated_words +=
       Wsize_bsize ((char *) intern_dest - intern_extra_block);
     caml_add_to_heap(intern_extra_block);
+    intern_extra_block = NULL; // To prevent intern_cleanup freeing it
+  } else {
+    intern_block = 0; // To prevent intern_cleanup rewriting its header
   }
 }
 
@@ -692,16 +722,14 @@ value caml_input_val(struct channel *chan)
     caml_stat_free(block);
     caml_failwith("input_value: truncated object");
   }
-  intern_input = (unsigned char *) block;
-  intern_input_malloced = 1;
-  intern_src = intern_input;
+  /* Initialize global state */
+  intern_init(block, block);
   intern_alloc(h.whsize, h.num_objects);
   /* Fill it in */
   intern_rec(&res);
   intern_add_to_heap(h.whsize);
   /* Free everything */
-  caml_stat_free(intern_input);
-  if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
+  intern_cleanup();
   return caml_check_urgent_gc(res);
 }
 
@@ -725,8 +753,8 @@ CAMLexport value caml_input_val_from_string(value str, intnat ofs)
   CAMLlocal1 (obj);
   struct marshal_header h;
 
-  intern_src = &Byte_u(str, ofs);
-  intern_input_malloced = 0;
+  /* Initialize global state */
+  intern_init(&Byte_u(str, ofs), NULL);
   caml_parse_header("input_val_from_string", &h);
   if (ofs + h.header_len + h.data_len > caml_string_length(str))
     caml_failwith("input_val_from_string: bad length");
@@ -737,7 +765,7 @@ CAMLexport value caml_input_val_from_string(value str, intnat ofs)
   intern_rec(&obj);
   intern_add_to_heap(h.whsize);
   /* Free everything */
-  if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
+  intern_cleanup();
   CAMLreturn (caml_check_urgent_gc(obj));
 }
 
@@ -755,39 +783,32 @@ static value input_val_from_block(struct marshal_header * h)
   intern_rec(&obj);
   intern_add_to_heap(h->whsize);
   /* Free internal data structures */
-  if (intern_obj_table != NULL) caml_stat_free(intern_obj_table);
+  intern_cleanup();
   return caml_check_urgent_gc(obj);
 }
 
 CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs)
 {
   struct marshal_header h;
-  value obj;
 
-  intern_input = (unsigned char *) data;
-  intern_src = intern_input + ofs;
-  intern_input_malloced = 1;
+  intern_init(data + ofs, data);
+
   caml_parse_header("input_value_from_malloc", &h);
-  obj = input_val_from_block(&h);
-  /* Free the input */
-  caml_stat_free(intern_input);
-  return obj;
+
+  return input_val_from_block(&h);
 }
 
 /* [len] is a number of bytes */
 CAMLexport value caml_input_value_from_block(char * data, intnat len)
 {
   struct marshal_header h;
-  value obj;
 
-  intern_input = (unsigned char *) data;
-  intern_src = intern_input;
-  intern_input_malloced = 0;
+  /* Initialize global state */
+  intern_init(data, NULL);
   caml_parse_header("input_value_from_block", &h);
   if (h.header_len + h.data_len > len)
     caml_failwith("input_val_from_block: bad length");
-  obj = input_val_from_block(&h);
-  return obj;
+  return input_val_from_block(&h);
 }
 
 /* [ofs] is a [value] that represents a number of bytes
@@ -804,7 +825,6 @@ CAMLprim value caml_marshal_data_size(value buff, value ofs)
   uintnat data_len;
 
   intern_src = &Byte_u(buff, Long_val(ofs));
-  intern_input_malloced = 0;
   magic = read32u();
   switch(magic) {
   case Intext_magic_number_small:

byterun/memory.c

@@ -405,7 +405,8 @@ color_t caml_allocation_color (void *hp)
   }
 }
 
-CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
+static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag,
+                                        int raise_oom)
 {
   header_t *hp;
   value *new_block;
@@ -415,10 +416,14 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
   if (hp == NULL){
     new_block = expand_heap (wosize);
     if (new_block == NULL) {
-      if (caml_in_minor_collection)
-        caml_fatal_error ("Fatal error: out of memory.\n");
-      else
-        caml_raise_out_of_memory ();
+      if (raise_oom) {
+        if (caml_in_minor_collection)
+          caml_fatal_error ("Fatal error: out of memory.\n");
+        else
+          caml_raise_out_of_memory ();
+      } else {
+        return 0;
+      }
     }
     caml_fl_add_blocks ((value) new_block);
     hp = caml_fl_allocate (wosize);
@@ -452,6 +457,16 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
   return Val_hp (hp);
 }
 
+CAMLexport value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t tag)
+{
+  return caml_alloc_shr_aux(wosize, tag, 0);
+}
+
+CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
+{
+  return caml_alloc_shr_aux(wosize, tag, 1);
+}
+
 /* Dependent memory is all memory blocks allocated out of the heap
    that depend on the GC (and finalizers) for deallocation.
    For the GC to take dependent memory into account when computing