Experiments with DW_OP_call*, DW_OP_implicit_pointer, etc.

extern_standalone/extern_standalone_check_big.ml

@@ -0,0 +1,12 @@
+(* Reads the output of extern_standalone_test_big.c back with
+   Marshal.from_channel and checks it against the expected list.
+
+   Usage:  ocaml extern_standalone_check_big.ml actual_big.bin *)
+
+let ic = open_in_bin Sys.argv.(1)
+
+let () =
+  let expected = List.init 10000 (fun i -> "item" ^ string_of_int i) in
+  let v : string list = Marshal.from_channel ic in
+  if v <> expected then (prerr_endline "big mismatch"; exit 1);
+  print_endline "big readback OK"

extern_standalone/extern_standalone_check_readback.ml

@@ -0,0 +1,43 @@
+(* Reads the output of extern_standalone_test.c back with
+   Marshal.from_channel and checks each value, proving the standalone
+   output is consumable by the real OCaml runtime.
+
+   Usage:  ocaml extern_standalone_check_readback.ml actual.bin *)
+
+let ic = open_in_bin Sys.argv.(1)
+
+type t = A of int | B of int | C of int | D of string
+
+let idx = ref 0
+
+let check : 'a. 'a -> unit = fun expected ->
+  incr idx;
+  let v = Marshal.from_channel ic in
+  if v <> expected then begin
+    Printf.eprintf "value %d mismatch\n" !idx;
+    exit 1
+  end
+
+let () =
+  check 42;
+  let pair = (1, 2) in
+  check pair;
+  check "hello";
+  check (pair, pair);
+  check 3.14;
+  check [| 1.5; 2.5; 3.5 |];
+  check [1; 2; 3];
+  check "";
+  check (-5);
+  check (-1000);
+  check 100000;
+  check (1 lsl 40);
+  check (String.make 100 'x');
+  check (String.make 300 'y');
+  check (D "payload");
+  check ([||] : int array);
+  check ([1; 2; 3], "mid", 2.25);
+  (match input_char ic with
+   | exception End_of_file -> ()
+   | _ -> prerr_endline "trailing data"; exit 1);
+  print_endline "readback OK"

extern_standalone/extern_standalone_compare.py

@@ -0,0 +1,31 @@
+"""Compare two files of concatenated marshal blobs (e.g. the output of
+extern_standalone_test.c against that of
+extern_standalone_gen_expected.ml), ignoring the header field at offset
+12 of each blob (size in words when read on a 32-bit platform), which
+extern_standalone.c writes as 0.
+
+Usage:  python3 extern_standalone_compare.py actual.bin expected.bin
+"""
+import sys
+
+def blobs(path):
+    data = open(path, 'rb').read()
+    i, out = 0, []
+    while i < len(data):
+        magic = int.from_bytes(data[i:i+4], 'big')
+        assert magic == 0x8495A6BE, f"unexpected magic {magic:#x} at {i}"
+        datalen = int.from_bytes(data[i+4:i+8], 'big')
+        out.append(bytearray(data[i:i+20+datalen]))
+        i += 20 + datalen
+    assert i == len(data)
+    return out
+
+a, b = blobs(sys.argv[1]), blobs(sys.argv[2])
+assert len(a) == len(b), f"blob counts differ: {len(a)} vs {len(b)}"
+for n, (x, y) in enumerate(zip(a, b)):
+    x[12:16] = b'\0\0\0\0'
+    y[12:16] = b'\0\0\0\0'
+    if x != y:
+        print(f"blob {n} differs")
+        sys.exit(1)
+print(f"OK: {len(a)} blobs identical modulo the 32-bit size field")

extern_standalone/extern_standalone_gen_expected.ml

@@ -0,0 +1,35 @@
+(* Generates the expected marshalled bytes for extern_standalone_test.c,
+   using the real Marshal module.  Values must match, in order, those in
+   extern_standalone_test.c.
+
+   Usage:  ocaml extern_standalone_gen_expected.ml expected.bin
+   then compare against the test output with
+   extern_standalone_compare.py. *)
+
+let out = open_out_bin Sys.argv.(1)
+
+let dump v = output_string out (Marshal.to_string v [])
+
+(* [D _] is the fourth non-constant constructor, so it has tag 3 *)
+type t = A of int | B of int | C of int | D of string
+
+let () =
+  dump 42;
+  let pair = (1, 2) in
+  dump pair;
+  dump "hello";
+  dump (pair, pair);
+  dump 3.14;
+  dump [| 1.5; 2.5; 3.5 |];
+  dump [1; 2; 3];
+  dump "";
+  dump (-5);
+  dump (-1000);
+  dump 100000;
+  dump (1 lsl 40);
+  dump (String.make 100 'x');
+  dump (String.make 300 'y');
+  dump (D "payload");
+  dump [||];
+  dump ([1; 2; 3], "mid", 2.25);
+  close_out out

extern_standalone/extern_standalone_gen_expected_big.ml

@@ -0,0 +1,11 @@
+(* Generates the expected marshalled bytes for
+   extern_standalone_test_big.c, using the real Marshal module.
+
+   Usage:  ocaml extern_standalone_gen_expected_big.ml expected_big.bin *)
+
+let out = open_out_bin Sys.argv.(1)
+
+let () =
+  let l = List.init 10000 (fun i -> "item" ^ string_of_int i) in
+  output_string out (Marshal.to_string l []);
+  close_out out

extern_standalone/extern_standalone_test.c

@@ -0,0 +1,219 @@
+/* Test harness for extern_standalone.c (and for extern_standalone.cpp,
+   by linking this file against the C++ build instead).
+
+   Build:  cc -std=c11 -Wall -Wextra extern_standalone.c \
+               extern_standalone_test.c -o test_extern
+
+   Constructs OCaml values by hand (native-code OxCaml representation)
+   and marshals them, writing the concatenated results to the file given
+   as argv[1]; then exercises the error paths, which are self-checking.
+   The dumped values are intended to be compared against the output of
+   extern_standalone_gen_expected.ml (the same values marshalled by the
+   real Marshal module) using extern_standalone_compare.py: they match
+   byte-for-byte except for the 32-bit size field at bytes 12-15 of each
+   marshal header, which is written as 0 here.  Reading the output back
+   with extern_standalone_check_readback.ml must also yield the original
+   values.  See extern_standalone_test_big.c for a stress test. */
+
+#include <stdint.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+typedef intptr_t intnat;
+typedef uintptr_t uintnat;
+typedef intnat value;
+
+typedef enum {
+  CAML_EXTERN_OK = 0,
+  CAML_EXTERN_ERROR_OUT_OF_MEMORY = 1,
+  CAML_EXTERN_ERROR_INVALID_ARGUMENT = 2
+} caml_extern_error;
+
+extern caml_extern_error caml_output_value_to_malloc(value v, char ** buf,
+                                                     intnat * len);
+extern const char * caml_extern_error_message(void);
+
+/* Value construction.  Header: 8 reserved bits (zero here), 46 size bits,
+   2 colour bits (NOT_MARKABLE), 8 tag bits. */
+
+#define TAG_CLOSURE 247
+#define TAG_ABSTRACT 251
+#define TAG_STRING 252
+#define TAG_DOUBLE 253
+#define TAG_DOUBLE_ARRAY 254
+#define TAG_CUSTOM 255
+
+static value mk_long(long n) { return ((value) n << 1) | 1; }
+
+static value mk_block(unsigned tag, size_t wosize)
+{
+  uintnat * p = malloc((wosize + 1) * sizeof(value));
+  if (p == NULL) abort();
+  p[0] = ((uintnat) wosize << 10) | (3u << 8) | tag;
+  return (value) (p + 1);
+}
+
+static void set_field(value b, size_t i, value f)
+{
+  ((value *) b)[i] = f;
+}
+
+static value mk_string(const char * str)
+{
+  size_t len = strlen(str);
+  size_t wosize = (len + sizeof(value)) / sizeof(value);
+  size_t bosize = wosize * sizeof(value);
+  value b = mk_block(TAG_STRING, wosize);
+  char * data = (char *) b;
+  memset(data, 0, bosize);
+  memcpy(data, str, len);
+  data[bosize - 1] = (char) (bosize - 1 - len);
+  return b;
+}
+
+static value mk_double(double d)
+{
+  value b = mk_block(TAG_DOUBLE, 1);
+  memcpy((void *) b, &d, 8);
+  return b;
+}
+
+static value mk_double_array(const double * d, size_t n)
+{
+  value b = mk_block(TAG_DOUBLE_ARRAY, n);
+  memcpy((void *) b, d, n * 8);
+  return b;
+}
+
+static value mk_list(const long * elts, size_t n)
+{
+  value l = mk_long(0);              /* [] */
+  for (size_t i = n; i > 0; i--) {
+    value cell = mk_block(0, 2);
+    set_field(cell, 0, mk_long(elts[i - 1]));
+    set_field(cell, 1, l);
+    l = cell;
+  }
+  return l;
+}
+
+static FILE * out;
+
+static void dump(value v)
+{
+  char * buf;
+  intnat len;
+  caml_extern_error err = caml_output_value_to_malloc(v, &buf, &len);
+  if (err != CAML_EXTERN_OK) {
+    fprintf(stderr, "unexpected error %d: %s\n", (int) err,
+            caml_extern_error_message());
+    exit(2);
+  }
+  fwrite(buf, 1, len, out);
+  free(buf);
+}
+
+int main(int argc, char ** argv)
+{
+  if (argc != 2) { fprintf(stderr, "usage: %s OUTFILE\n", argv[0]); return 2; }
+  out = fopen(argv[1], "wb");
+  if (out == NULL) { perror("fopen"); return 2; }
+
+  /* Same values, in the same order, as gen_expected.ml */
+  dump(mk_long(42));
+
+  value pair = mk_block(0, 2);
+  set_field(pair, 0, mk_long(1));
+  set_field(pair, 1, mk_long(2));
+  dump(pair);
+
+  dump(mk_string("hello"));
+
+  value shared = mk_block(0, 2);
+  set_field(shared, 0, pair);
+  set_field(shared, 1, pair);
+  dump(shared);
+
+  dump(mk_double(3.14));
+
+  double floats[3] = { 1.5, 2.5, 3.5 };
+  dump(mk_double_array(floats, 3));
+
+  long ints[3] = { 1, 2, 3 };
+  dump(mk_list(ints, 3));
+
+  dump(mk_string(""));
+  dump(mk_long(-5));
+  dump(mk_long(-1000));
+  dump(mk_long(100000));
+  dump(mk_long(1L << 40));
+
+  char buf100[101], buf300[301];
+  memset(buf100, 'x', 100); buf100[100] = '\0';
+  memset(buf300, 'y', 300); buf300[300] = '\0';
+  dump(mk_string(buf100));
+  dump(mk_string(buf300));
+
+  /* A variant with a non-zero tag and an atom (empty block) */
+  value variant = mk_block(3, 1);
+  set_field(variant, 0, mk_string("payload"));
+  dump(variant);
+  dump(mk_block(0, 0));
+
+  /* Nested structure exercising the extern stack */
+  value nested = mk_block(0, 3);
+  set_field(nested, 0, mk_list(ints, 3));
+  set_field(nested, 1, mk_string("mid"));
+  set_field(nested, 2, mk_double(2.25));
+  dump(nested);
+
+  fclose(out);
+
+  /* Error paths, not compared against the OCaml output */
+
+  caml_extern_error err;
+
+  value abstract = mk_block(TAG_ABSTRACT, 1);
+  set_field(abstract, 0, mk_long(0));
+  char * buf;
+  intnat len;
+  err = caml_output_value_to_malloc(abstract, &buf, &len);
+  if (err != CAML_EXTERN_ERROR_INVALID_ARGUMENT
+      || strcmp(caml_extern_error_message(),
+                "output_value: abstract value (Abstract)") != 0) {
+    fprintf(stderr, "expected abstract error, got %d: %s\n", (int) err,
+            caml_extern_error_message());
+    return 2;
+  }
+
+  /* Custom blocks are now rejected */
+  value custom = mk_block(TAG_CUSTOM, 2);
+  set_field(custom, 0, (value) &main);   /* would be the ops pointer */
+  set_field(custom, 1, mk_long(0));
+  err = caml_output_value_to_malloc(custom, &buf, &len);
+  if (err != CAML_EXTERN_ERROR_INVALID_ARGUMENT
+      || strcmp(caml_extern_error_message(),
+                "output_value: abstract value (Custom)") != 0) {
+    fprintf(stderr, "expected custom error, got %d: %s\n", (int) err,
+            caml_extern_error_message());
+    return 2;
+  }
+
+  /* Closures are always rejected */
+  value closure = mk_block(TAG_CLOSURE, 3);
+  set_field(closure, 0, (value) &main);
+  set_field(closure, 1, (value) ((1ULL << 56) + (1ULL << 55) + (2 << 1) + 1));
+  set_field(closure, 2, mk_long(7));
+  err = caml_output_value_to_malloc(closure, &buf, &len);
+  if (err != CAML_EXTERN_ERROR_INVALID_ARGUMENT
+      || strcmp(caml_extern_error_message(),
+                "output_value: functional value") != 0) {
+    fprintf(stderr, "expected functional-value error, got %d: %s\n",
+            (int) err, caml_extern_error_message());
+    return 2;
+  }
+
+  printf("error-path tests passed\n");
+  return 0;
+}