From c18409446e31bde55e9572b460914ef57fce007d Mon Sep 17 00:00:00 2001
From: Xavier Leroy <xavier.leroy@college-de-france.fr>
Date: Sun, 7 Jun 2020 17:37:12 +0200
Subject: [PATCH] extern.c: use new closure representation to marshal closures

We know where the code pointers, closure info words and infix headers are,
and can output them directly.

Currently activated in no-naked-pointers mode only, but would work in
the other mode as well.
---
 runtime/extern.c | 62 ++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 55 insertions(+), 7 deletions(-)

diff --git a/runtime/extern.c b/runtime/extern.c
index 8df7573a2..d287d5716 100644
--- a/runtime/extern.c
+++ b/runtime/extern.c
@@ -653,6 +653,32 @@ static void extern_code_pointer(char * codeptr)
   }
 }
 
+/* Marshaling the non-environment part of closures */
+
+Caml_inline mlsize_t extern_closure_up_to_env(value v)
+{
+  mlsize_t startenv, i;
+  value info;
+
+  startenv = Start_env_closinfo(Closinfo_val(v));
+  i = 0;
+  do {
+    /* The infix header */
+    if (i > 0) extern_int(Long_val(Field(v, i++)));
+    /* The default entry point */
+    extern_code_pointer((char *) Field(v, i++));
+    /* The closure info. */
+    info = Field(v, i++);
+    extern_int(Long_val(info));
+    /* The direct entry point if arity is neither 0 nor 1 */
+    if (Arity_closinfo(info) != 0 && Arity_closinfo(info) != 1) {
+      extern_code_pointer((char *) Field(v, i++));
+    }
+  } while (i < startenv);
+  CAMLassert(i == startenv);
+  return startenv;
+}
+
 /* Marshal the given value in the output buffer */
 
 int caml_extern_allow_out_of_heap = 0;
@@ -669,9 +695,15 @@ static void extern_rec(value v)
   while(1) {
   if (Is_long(v)) {
     extern_int(Long_val(v));
-    goto next_item;
   }
-  if (Is_in_value_area(v) || caml_extern_allow_out_of_heap) {
+#ifndef NO_NAKED_POINTERS
+  else if (! (Is_in_value_area(v) || caml_extern_allow_out_of_heap)) {
+    /* Naked pointer outside the heap: try to marshal it as a code pointer,
+       otherwise fail. */
+    extern_code_pointer((char *) v);
+  }
+#endif
+  else {
     header_t hd = Hd_val(v);
     tag_t tag = Tag_hd(hd);
     mlsize_t sz = Wosize_hd(hd);
@@ -747,6 +779,27 @@ static void extern_rec(value v)
       extern_record_location(v, h);
       break;
     }
+#ifdef NO_NAKED_POINTERS
+    case Closure_tag: {
+      mlsize_t i;
+      extern_header(sz, tag);
+      size_32 += 1 + sz;
+      size_64 += 1 + sz;
+      extern_record_location(v, h);
+      i = extern_closure_up_to_env(v);
+      if (i >= sz) goto next_item;
+      /* Remember that we still have to serialize fields i + 1 ... sz - 1 */
+      if (i < sz - 1) {
+        sp++;
+        if (sp >= extern_stack_limit) sp = extern_resize_stack(sp);
+        sp->v = &Field(v, i + 1);
+        sp->count = sz - i - 1;
+      }
+      /* Continue serialization with the first environment field */
+      v = Field(v, i);
+      continue;
+    }
+#endif
     default: {
       extern_header(sz, tag);
       size_32 += 1 + sz;
@@ -765,11 +818,6 @@ static void extern_rec(value v)
     }
     }
   }
-  else {
-    /* Naked pointer outside the heap: try to marshal it as a code pointer,
-       otherwise fail. */
-    extern_code_pointer((char *) v);
-  }
   next_item:
     /* Pop one more item to marshal, if any */
     if (sp == extern_stack) {