flan/lib/dynload_stubs.c

/* 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 <caml/threads.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);
}

/* ── The agent, when it is in this same process ─────────────────────── */

/* [flan dev] builds one binary that is the compiled program and holds this
 * compiler, so a request to the agent need not leave the address space. The
 * two ends still meet at one line of text and one answer — that is
 * vendor/agent/flan_agent.c's [handle_line], and this is a call to it.
 *
 * Weak, because the same [flan] binary that builds a merged program does not
 * itself contain an agent: the launcher, [flan reload], the two-process daemon
 * and every test link no flan_agent.o, and there the symbol is null. So "is
 * there an agent in this process" is answered by the linker rather than by a
 * flag that could disagree with reality, and [None] here is what makes
 * lib/dev.ml fall back to the socket.
 *
 * The runtime system is released across the call. A delivery does a [dlopen],
 * which is milliseconds of relocation and the loader lock, and holding OCaml's
 * lock through it stalls every other OCaml thread for no reason — docs/DISCUSS.md
 * §14's third cost, in the one place this lane creates it. Nothing the agent
 * does touches an OCaml value, so there is nothing to keep alive across it. */
extern char *flan_agent_request(const char *line, uint64_t *len)
    __attribute__((weak));
extern void flan_agent_request_free(char *p) __attribute__((weak));

CAMLprim value flan_agent_direct(value line) {
  CAMLparam1(line);
  CAMLlocal2(s, r);
  char    *out;
  uint64_t n = 0;
  if (flan_agent_request == NULL) CAMLreturn(Val_int(0)); /* None */
  {
    /* Copied out first: [String_val] points into the OCaml heap, which may
       move once the runtime system is released. */
    size_t k = caml_string_length(line);
    char  *copy = malloc(k + 1);
    if (copy == NULL) caml_failwith("out of memory asking the agent");
    memcpy(copy, String_val(line), k);
    copy[k] = '\0';
    caml_release_runtime_system();
    out = flan_agent_request(copy, &n);
    caml_acquire_runtime_system();
    free(copy);
  }
  s = caml_alloc_initialized_string((mlsize_t)n, out == NULL ? "" : out);
  if (out != NULL && flan_agent_request_free != NULL)
    flan_agent_request_free(out);
  r = caml_alloc_some(s);
  CAMLreturn(r);
}