Allow marshalling to work outside of the heap (#623)

5 files changed, 57 insertions, 9 deletions

diff --git a/byterun/caml/intext.h b/byterun/caml/intext.h
index 3deaf3a062..32aef50520 100644
--- a/byterun/caml/intext.h
+++ b/byterun/caml/intext.h
@@ -125,6 +125,17 @@ CAMLextern intnat caml_output_value_to_block(value v, value flags,
 /* <private> */
 value caml_input_val (struct channel * chan);
   /* Read a structured value from the channel [chan]. */
+
+extern value caml_input_value_to_outside_heap (value channel);
+  /* As for [caml_input_value], but the value is unmarshalled into
+     malloc blocks that are not added to the heap.  Not for the
+     casual user. */
+
+extern int caml_extern_allow_out_of_heap;
+  /* Permit the marshaller to traverse structures that look like OCaml
+     values but do not live in the OCaml heap. */
+
+extern value caml_output_value(value vchan, value v, value flags);
 /* </private> */
 
 CAMLextern value caml_input_val_from_string (value str, intnat ofs);
diff --git a/byterun/caml/memory.h b/byterun/caml/memory.h
index 9a1287c65e..de417e0467 100644
--- a/byterun/caml/memory.h
+++ b/byterun/caml/memory.h
@@ -49,6 +49,7 @@ CAMLextern void * caml_stat_resize (void *, asize_t);     /* Size in bytes. */
 CAMLextern int caml_init_alloc_for_heap (void);
 CAMLextern char *caml_alloc_for_heap (asize_t request);   /* Size in bytes. */
 CAMLextern void caml_free_for_heap (char *mem);
+CAMLextern void caml_disown_for_heap (char *mem);
 CAMLextern int caml_add_to_heap (char *mem);
 CAMLextern color_t caml_allocation_color (void *hp);
 
diff --git a/byterun/extern.c b/byterun/extern.c
index 221e206df3..f110dff2ac 100644
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -383,6 +383,8 @@ static void writecode64(int code, intnat val)
 
 /* Marshal the given value in the output buffer */
 
+int caml_extern_allow_out_of_heap = 0;
+
 static void extern_rec(value v)
 {
   struct code_fragment * cf;
@@ -409,7 +411,7 @@ static void extern_rec(value v)
       writecode32(CODE_INT32, n);
     goto next_item;
   }
-  if (Is_in_value_area(v)) {
+  if (Is_in_value_area(v) || caml_extern_allow_out_of_heap) {
     header_t hd = Hd_val(v);
     tag_t tag = Tag_hd(hd);
     mlsize_t sz = Wosize_hd(hd);
diff --git a/byterun/intern.c b/byterun/intern.c
index 96196ff2de..1d66c8f30d 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -554,7 +554,8 @@ static void intern_rec(value *dest)
   intern_free_stack();
 }
 
-static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
+static void intern_alloc(mlsize_t whsize, mlsize_t num_objects,
+      int outside_heap)
 {
   mlsize_t wosize;
 
@@ -564,7 +565,7 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
     return;
   }
   wosize = Wosize_whsize(whsize);
-  if (wosize > Max_wosize) {
+  if (wosize > Max_wosize || outside_heap) {
     /* Round desired size up to next page */
     asize_t request =
       ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
@@ -573,7 +574,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects)
       intern_cleanup();
       caml_raise_out_of_memory();
     }
-    intern_color = caml_allocation_color(intern_extra_block);
+    intern_color =
+      outside_heap ? Caml_black : caml_allocation_color(intern_extra_block);
     intern_dest = (header_t *) intern_extra_block;
     Assert (intern_block == 0);
   } else {
@@ -686,7 +688,7 @@ static void caml_parse_header(char * fun_name,
 
 /* Reading from a channel */
 
-value caml_input_val(struct channel *chan)
+static value caml_input_val_core(struct channel *chan, int outside_heap)
 {
   char header[32];
   struct marshal_header h;
@@ -718,15 +720,26 @@ value caml_input_val(struct channel *chan)
   }
   /* Initialize global state */
   intern_init(block, block);
-  intern_alloc(h.whsize, h.num_objects);
+  intern_alloc(h.whsize, h.num_objects, outside_heap);
   /* Fill it in */
   intern_rec(&res);
-  intern_add_to_heap(h.whsize);
+  if (!outside_heap) {
+    intern_add_to_heap(h.whsize);
+  } else {
+    caml_disown_for_heap(intern_extra_block);
+    intern_extra_block = NULL;
+    intern_block = 0;
+  }
   /* Free everything */
   intern_cleanup();
   return caml_check_urgent_gc(res);
 }
 
+value caml_input_val(struct channel* chan)
+{
+  return caml_input_val_core(chan, 0);
+}
+
 CAMLprim value caml_input_value(value vchan)
 {
   CAMLparam1 (vchan);
@@ -741,6 +754,18 @@ CAMLprim value caml_input_value(value vchan)
 
 /* Reading from memory-resident blocks */
 
+CAMLprim value caml_input_value_to_outside_heap(value vchan)
+{
+  CAMLparam1 (vchan);
+  struct channel * chan = Channel(vchan);
+  CAMLlocal1 (res);
+
+  Lock(chan);
+  res = caml_input_val_core(chan, 1);
+  Unlock(chan);
+  CAMLreturn (res);
+}
+
 CAMLexport value caml_input_val_from_string(value str, intnat ofs)
 {
   CAMLparam1 (str);
@@ -753,7 +778,7 @@ CAMLexport value caml_input_val_from_string(value str, intnat ofs)
   if (ofs + h.header_len + h.data_len > caml_string_length(str))
     caml_failwith("input_val_from_string: bad length");
   /* Allocate result */
-  intern_alloc(h.whsize, h.num_objects);
+  intern_alloc(h.whsize, h.num_objects, 0);
   intern_src = &Byte_u(str, ofs + h.header_len); /* If a GC occurred */
   /* Fill it in */
   intern_rec(&obj);
@@ -772,7 +797,7 @@ static value input_val_from_block(struct marshal_header * h)
 {
   value obj;
   /* Allocate result */
-  intern_alloc(h->whsize, h->num_objects);
+  intern_alloc(h->whsize, h->num_objects, 0);
   /* Fill it in */
   intern_rec(&obj);
   intern_add_to_heap(h->whsize);
diff --git a/byterun/memory.c b/byterun/memory.c
index 4b52b82004..c4467532cf 100644
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -284,6 +284,15 @@ char *caml_alloc_for_heap (asize_t request)
   }
 }
 
+/* Use this function if a block allocated with [caml_alloc_for_heap] is
+   not actually going to be added to the heap.  The caller is responsible
+   for freeing it. */
+void caml_disown_for_heap (char* mem)
+{
+  /* Currently a no-op. */
+  mem = mem;
+}
+
 /* Use this function to free a block allocated with [caml_alloc_for_heap]
    if you don't add it with [caml_add_to_heap].
 */