/* Loading a compiled macro into the compiler's own process.
 *
 * NEXT.md's expander design: there is no interpreter, so running a macro means
 * compiling it and dlopening it. The reload primitive does exactly this
 * already, but its host is a running Flan program written in C; here the host
 * is the OCaml compiler, which has no dlopen of its own -- Dynlink loads
 * OCaml, not ELF. So the boundary needs stubs, and this is all of them.
 *
 * Two rules shape what is here:
 *
 *   - Nothing but pointers and scalars crosses. A Flan `string`/slice is
 *     {ptr,len} and a `Form` is {i32, [2 x i64]}, and LLVM's calling
 *     convention for an aggregate passed or returned *by value* in hand-written
 *     IR is not promised to be clang's C ABI for the equivalent struct. The
 *     unions lane verified memory layout, so memory is the agreement we have:
 *     every macro is reached through a thunk taking (ptr,i64,ptr,ptr) and
 *     writing its result through the out pointer.
 *
 *   - The macro module is self-contained: it links the runtime in and has no
 *     undefined Flan symbols, so the OCaml executable needs no -rdynamic and
 *     nothing in it has to be exported.
 *
 * The peek/poke family is how the marshaller writes a Form image into memory
 * the macro can read. OCaml cannot address raw memory, so the bytes are laid
 * out from here one field at a time.
 */

#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/fail.h>

#include <dlfcn.h>
#include <stdlib.h>
#include <string.h>
#include <stdint.h>

CAMLprim value flan_dl_open(value path) {
  CAMLparam1(path);
  void *h = dlopen(String_val(path), RTLD_NOW | RTLD_LOCAL);
  if (!h) caml_failwith(dlerror());
  CAMLreturn(caml_copy_nativeint((intnat)h));
}

CAMLprim value flan_dl_sym(value handle, value name) {
  CAMLparam2(handle, name);
  void *p = dlsym((void *)Nativeint_val(handle), String_val(name));
  if (!p) caml_failwith(dlerror());
  CAMLreturn(caml_copy_nativeint((intnat)p));
}

CAMLprim value flan_dl_close(value handle) {
  dlclose((void *)Nativeint_val(handle));
  return Val_unit;
}

/* The one call shape a macro is reached through. See the thunk Emit writes. */
typedef void (*flan_macro_fn)(void *args, int64_t n, void *out, void *xfer);

CAMLprim value flan_macro_call(value fn, value args, value n, value out) {
  CAMLparam4(fn, args, n, out);
  /* The transfer channel every Flan signature carries (spec-conditions.md,
     section 6). A macro that signals a condition with nothing above it to
     handle it aborts inside the compiler, which is loud rather than silent;
     the channel still has to be a real, zeroed slot. */
  int64_t xfer[4] = { 0, 0, 0, 0 };
  ((flan_macro_fn)Nativeint_val(fn))((void *)Nativeint_val(args),
                                     Int64_val(n),
                                     (void *)Nativeint_val(out), xfer);
  CAMLreturn(Val_unit);
}

CAMLprim value flan_mem_alloc(value n) {
  CAMLparam1(n);
  /* Zeroed, because ZII is the language's rule and an unwritten Form field
     must read as the zero of its type rather than as whatever malloc had. */
  void *p = calloc((size_t)Long_val(n), 1);
  if (!p) caml_failwith("out of memory laying out a macro's arguments");
  CAMLreturn(caml_copy_nativeint((intnat)p));
}

CAMLprim value flan_mem_free(value p) {
  free((void *)Nativeint_val(p));
  return Val_unit;
}

CAMLprim value flan_poke_i32(value p, value off, value x) {
  int32_t v = (int32_t)Int32_val(x);
  memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 4);
  return Val_unit;
}

CAMLprim value flan_poke_i64(value p, value off, value x) {
  int64_t v = Int64_val(x);
  memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8);
  return Val_unit;
}

CAMLprim value flan_poke_f64(value p, value off, value x) {
  double v = Double_val(x);
  memcpy((char *)Nativeint_val(p) + Long_val(off), &v, 8);
  return Val_unit;
}

CAMLprim value flan_poke_ptr(value p, value off, value q) {
  void *v = (void *)Nativeint_val(q);
  memcpy((char *)Nativeint_val(p) + Long_val(off), &v, sizeof v);
  return Val_unit;
}

CAMLprim value flan_poke_bytes(value p, value off, value s) {
  memcpy((char *)Nativeint_val(p) + Long_val(off), String_val(s),
         caml_string_length(s));
  return Val_unit;
}

CAMLprim value flan_peek_i32(value p, value off) {
  int32_t v;
  memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 4);
  return caml_copy_int32(v);
}

CAMLprim value flan_peek_i64(value p, value off) {
  int64_t v;
  memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8);
  return caml_copy_int64(v);
}

CAMLprim value flan_peek_f64(value p, value off) {
  double v;
  memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), 8);
  return caml_copy_double(v);
}

CAMLprim value flan_peek_ptr(value p, value off) {
  void *v;
  memcpy(&v, (char *)Nativeint_val(p) + Long_val(off), sizeof v);
  return caml_copy_nativeint((intnat)v);
}

CAMLprim value flan_peek_bytes(value p, value off, value n) {
  CAMLparam3(p, off, n);
  CAMLlocal1(s);
  s = caml_alloc_string((mlsize_t)Long_val(n));
  memcpy((char *)Bytes_val(s), (char *)Nativeint_val(p) + Long_val(off),
         (size_t)Long_val(n));
  CAMLreturn(s);
}