runtime: caml_startup_pooled function added

9 files changed, 120 insertions, 49 deletions

diff --git a/asmrun/startup.c b/asmrun/startup.c
index 7abec8d11b..9a67b95c2a 100644
--- a/asmrun/startup.c
+++ b/asmrun/startup.c
@@ -100,12 +100,12 @@ extern void caml_install_invalid_parameter_handler();
 
 #endif
 
-value caml_startup_exn(char **argv)
+value caml_startup_common(char **argv, int pooling)
 {
   char * exe_name, * proc_self_exe;
   char tos;
 
-  if (!caml_startup_aux())
+  if (!caml_startup_aux(pooling))
     return Val_unit;
 
 #ifdef WITH_SPACETIME
@@ -147,16 +147,31 @@ value caml_startup_exn(char **argv)
   return caml_start_program();
 }
 
+value caml_startup_exn(char **argv)
+{
+  return caml_startup_common(argv, /* pooling */ 0);
+}
+
 void caml_startup(char **argv)
 {
   value res = caml_startup_exn(argv);
-
-  if (Is_exception_result(res)) {
+  if (Is_exception_result(res))
     caml_fatal_uncaught_exception(Extract_exception(res));
-  }
 }
 
 void caml_main(char **argv)
 {
   caml_startup(argv);
 }
+
+value caml_startup_pooled_exn(char **argv)
+{
+  return caml_startup_common(argv, /* pooling */ 1);
+}
+
+void caml_startup_pooled(char **argv)
+{
+  value res = caml_startup_pooled_exn(argv);
+  if (Is_exception_result(res))
+    caml_fatal_uncaught_exception(Extract_exception(res));
+}
diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml
index 8f82fc96d0..bf01ba1d66 100644
--- a/bytecomp/bytelink.ml
+++ b/bytecomp/bytelink.ml
@@ -460,11 +460,7 @@ let link_bytecode_as_c ppf tolink outfile =
 \nextern \"C\" {\
 \n#endif\
 \n#include <caml/mlvalues.h>\
-\nCAMLextern void caml_startup_code(\
-\n           code_t code, asize_t code_size,\
-\n           char *data, asize_t data_size,\
-\n           char *section_table, asize_t section_table_size,\
-\n           char **argv);\n";
+\n#include <caml/startup.h>\n";
     output_string outchan "static int caml_code[] = {\n";
     Symtable.init();
     clear_crc_interfaces ();
@@ -499,13 +495,34 @@ let link_bytecode_as_c ppf tolink outfile =
 \n  caml_startup_code(caml_code, sizeof(caml_code),\
 \n                    caml_data, sizeof(caml_data),\
 \n                    caml_sections, sizeof(caml_sections),\
+\n                    /* pooling */ 0,\
 \n                    argv);\
 \n}\
+\n\
 \nvalue caml_startup_exn(char ** argv)\
 \n{\
 \n  return caml_startup_code_exn(caml_code, sizeof(caml_code),\
 \n                               caml_data, sizeof(caml_data),\
 \n                               caml_sections, sizeof(caml_sections),\
+\n                               /* pooling */ 0,\
+\n                               argv);\
+\n}\
+\n\
+\nvoid caml_startup_pooled(char ** argv)\
+\n{\
+\n  caml_startup_code(caml_code, sizeof(caml_code),\
+\n                    caml_data, sizeof(caml_data),\
+\n                    caml_sections, sizeof(caml_sections),\
+\n                    /* pooling */ 1,\
+\n                    argv);\
+\n}\
+\n\
+\nvalue caml_startup_pooled_exn(char ** argv)\
+\n{\
+\n  return caml_startup_code_exn(caml_code, sizeof(caml_code),\
+\n                               caml_data, sizeof(caml_data),\
+\n                               caml_sections, sizeof(caml_sections),\
+\n                               /* pooling */ 1,\
 \n                               argv);\
 \n}\
 \n#ifdef __cplusplus\
diff --git a/byterun/caml/callback.h b/byterun/caml/callback.h
index 814d651944..cbc2ccea7a 100644
--- a/byterun/caml/callback.h
+++ b/byterun/caml/callback.h
@@ -50,6 +50,8 @@ CAMLextern void caml_iterate_named_values(caml_named_action f);
 CAMLextern void caml_main (char ** argv);
 CAMLextern void caml_startup (char ** argv);
 CAMLextern value caml_startup_exn (char ** argv);
+CAMLextern void caml_startup_pooled (char ** argv);
+CAMLextern value caml_startup_pooled_exn (char ** argv);
 CAMLextern void caml_shutdown (void);
 
 CAMLextern int caml_callback_depth;
diff --git a/byterun/caml/memory.h b/byterun/caml/memory.h
index 645ca8b089..b9c9426c24 100644
--- a/byterun/caml/memory.h
+++ b/byterun/caml/memory.h
@@ -78,11 +78,19 @@ typedef void* caml_stat_block;
 
 /* The pool must be initialized with a call to [caml_stat_create_pool]
    before it is possible to use any of the [caml_stat_*] functions below.
+
+   If the pool is not initialized, [caml_stat_*] functions will still work in
+   backward compatibility mode, becoming thin wrappers around [malloc] family
+   of functions. In this case, calling [caml_stat_destroy_pool] will not free
+   the claimed heap memory, resulting in leaks.
 */
 CAMLextern void caml_stat_create_pool(void);
 
 /* [caml_stat_destroy_pool] frees all the heap memory claimed by the pool.
-   None of the [caml_stat_*] functions below can be used after that.
+
+   Once the pool is destroyed, [caml_stat_*] functions will continue to work
+   in backward compatibility mode, becoming thin wrappers around [malloc]
+   family of functions.
 */
 CAMLextern void caml_stat_destroy_pool(void);
 
diff --git a/byterun/caml/startup.h b/byterun/caml/startup.h
index 0c38dac0f1..9dc2ea4185 100644
--- a/byterun/caml/startup.h
+++ b/byterun/caml/startup.h
@@ -27,12 +27,14 @@ CAMLextern void caml_startup_code(
            code_t code, asize_t code_size,
            char *data, asize_t data_size,
            char *section_table, asize_t section_table_size,
+           int pooling,
            char **argv);
 
 CAMLextern value caml_startup_code_exn(
   code_t code, asize_t code_size,
   char *data, asize_t data_size,
   char *section_table, asize_t section_table_size,
+  int pooling,
   char **argv);
 
 enum { FILE_NOT_FOUND = -1, BAD_BYTECODE  = -2 };
diff --git a/byterun/caml/startup_aux.h b/byterun/caml/startup_aux.h
index 80ff2e0926..8c30c5f5fc 100644
--- a/byterun/caml/startup_aux.h
+++ b/byterun/caml/startup_aux.h
@@ -34,8 +34,9 @@ extern uintnat caml_trace_level;
 extern void caml_parse_ocamlrunparam (void);
 
 /* Common entry point to caml_startup.
-   Returns 0 if the runtime is already initialized. */
-extern int caml_startup_aux (void);
+   Returns 0 if the runtime is already initialized.
+   If [pooling] is 0, [caml_stat_*] functions will not be backed by a pool. */
+extern int caml_startup_aux (int pooling);
 
 #endif /* CAML_INTERNALS */
 
diff --git a/byterun/memory.c b/byterun/memory.c
index 7198c94ab0..ff4f511c83 100644
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -736,12 +736,17 @@ static struct pool_block *pool = NULL;
 /* Returns a pointer to the block header, given a pointer to "data" */
 static struct pool_block* get_pool_block(caml_stat_block b)
 {
-  if (b == NULL) return NULL;
-  struct pool_block *pb = (struct pool_block*)(((char*)b) - SIZEOF_POOL_BLOCK);
+  if (b == NULL)
+    return NULL;
+
+  else {
+    struct pool_block *pb =
+      (struct pool_block*)(((char*)b) - SIZEOF_POOL_BLOCK);
 #ifdef DEBUG
-  Assert(pb->magic == Debug_pool_magic);
+    Assert(pb->magic == Debug_pool_magic);
 #endif
-  return pb;
+    return pb;
+  }
 }
 
 CAMLexport void caml_stat_create_pool(void)
@@ -767,6 +772,7 @@ CAMLexport void caml_stat_destroy_pool(void)
       free(pool);
       pool = next;
     }
+    pool = NULL;
   }
 }
 
@@ -811,20 +817,25 @@ CAMLexport void* caml_stat_alloc_aligned(asize_t sz, int modulo,
 /* [sz] is a number of bytes */
 CAMLexport caml_stat_block caml_stat_alloc_noexc(asize_t sz)
 {
-  struct pool_block *pb = malloc(sz + SIZEOF_POOL_BLOCK);
-  if (pb == NULL) return NULL;
+  /* Backward compatibility mode */
+  if (pool == NULL)
+    return malloc(sz);
+  else {
+    struct pool_block *pb = malloc(sz + SIZEOF_POOL_BLOCK);
+    if (pb == NULL) return NULL;
 #ifdef DEBUG
-  memset(&(pb->data), Debug_uninit_stat, sz);
-  pb->magic = Debug_pool_magic;
+    memset(&(pb->data), Debug_uninit_stat, sz);
+    pb->magic = Debug_pool_magic;
 #endif
 
-  /* Linking the block into the ring */
-  pb->next = pool->next;
-  pb->prev = pool;
-  pool->next->prev = pb;
-  pool->next = pb;
+    /* Linking the block into the ring */
+    pb->next = pool->next;
+    pb->prev = pool;
+    pool->next->prev = pb;
+    pool->next = pb;
 
-  return &(pb->data);
+    return &(pb->data);
+  }
 }
 
 /* [sz] is a number of bytes */
@@ -839,28 +850,38 @@ CAMLexport caml_stat_block caml_stat_alloc(asize_t sz)
 
 CAMLexport void caml_stat_free(caml_stat_block b)
 {
-  struct pool_block *pb = get_pool_block(b);
-  if (pb == NULL) return;
+  /* Backward compatibility mode */
+  if (pool == NULL)
+    free(b);
+  else {
+    struct pool_block *pb = get_pool_block(b);
+    if (pb == NULL) return;
 
-  /* Unlinking the block from the ring */
-  pb->prev->next = pb->next;
-  pb->next->prev = pb->prev;
+    /* Unlinking the block from the ring */
+    pb->prev->next = pb->next;
+    pb->next->prev = pb->prev;
 
-  free(pb);
+    free(pb);
+  }
 }
 
 /* [sz] is a number of bytes */
 CAMLexport caml_stat_block caml_stat_resize_noexc(caml_stat_block b, asize_t sz)
 {
-  struct pool_block *pb = get_pool_block(b);
-  struct pool_block *pb_new = realloc(pb, sz + SIZEOF_POOL_BLOCK);
-  if (pb_new == NULL) return NULL;
+  /* Backward compatibility mode */
+  if (pool == NULL)
+    return realloc(b, sz);
+  else {
+    struct pool_block *pb = get_pool_block(b);
+    struct pool_block *pb_new = realloc(pb, sz + SIZEOF_POOL_BLOCK);
+    if (pb_new == NULL) return NULL;
 
-  /* Relinking the new block into the ring in place of the old one */
-  pb_new->prev->next = pb_new;
-  pb_new->next->prev = pb_new;
+    /* Relinking the new block into the ring in place of the old one */
+    pb_new->prev->next = pb_new;
+    pb_new->next->prev = pb_new;
 
-  return &(pb_new->data);
+    return &(pb_new->data);
+  }
 }
 
 /* [sz] is a number of bytes */
@@ -877,10 +898,12 @@ CAMLexport caml_stat_block caml_stat_calloc_noexc(asize_t num, asize_t sz)
 {
   /* todo: an overflow check is desirable here */
   sz *= num;
-  caml_stat_block result = caml_stat_alloc_noexc(sz);
-  if (result != NULL)
-    memset(result, 0, sz);
-  return result;
+  {
+    caml_stat_block result = caml_stat_alloc_noexc(sz);
+    if (result != NULL)
+      memset(result, 0, sz);
+    return result;
+  }
 }
 
 CAMLexport caml_stat_string caml_stat_strdup_noexc(const char *s)
diff --git a/byterun/startup.c b/byterun/startup.c
index e2e2531a99..80e55f0a7a 100644
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -286,7 +286,7 @@ CAMLexport void caml_main(char **argv)
 
   caml_ensure_spacetime_dot_o_is_included++;
 
-  if (!caml_startup_aux())
+  if (!caml_startup_aux(/* pooling */ 0))
     return;
 
   /* Machine-dependent initialization of the floating-point hardware
@@ -403,12 +403,13 @@ CAMLexport value caml_startup_code_exn(
            code_t code, asize_t code_size,
            char *data, asize_t data_size,
            char *section_table, asize_t section_table_size,
+           int pooling,
            char **argv)
 {
   char * cds_file;
   char * exe_name;
 
-  if (!caml_startup_aux())
+  if (!caml_startup_aux(pooling))
     return Val_unit;
 
   caml_init_ieee_floats();
@@ -473,13 +474,14 @@ CAMLexport void caml_startup_code(
            code_t code, asize_t code_size,
            char *data, asize_t data_size,
            char *section_table, asize_t section_table_size,
+           int pooling,
            char **argv)
 {
   value res;
 
   res = caml_startup_code_exn(code, code_size, data, data_size,
                               section_table, section_table_size,
-                              argv);
+                              pooling, argv);
   if (Is_exception_result(res)) {
     caml_exn_bucket = Extract_exception(res);
     if (caml_debugger_in_use) {
diff --git a/byterun/startup_aux.c b/byterun/startup_aux.c
index 2b15a52507..6fe2aca811 100644
--- a/byterun/startup_aux.c
+++ b/byterun/startup_aux.c
@@ -117,7 +117,7 @@ static int startup_count = 0;
 static int shutdown_happened = 0;
 
 
-int caml_startup_aux(void)
+int caml_startup_aux(int pooling)
 {
   if (shutdown_happened == 1)
     caml_fatal_error("Fatal error: caml_startup was called after the runtime "
@@ -129,7 +129,8 @@ int caml_startup_aux(void)
   if (startup_count > 1)
     return 0;
 
-  caml_stat_create_pool();
+  if (pooling)
+    caml_stat_create_pool();
 
   return 1;
 }