flan/runtime/flan_rt.c

/* flan_rt — the milestone-2 host ABI.
 *
 * This is the whole of it: argv, stdout, exit, and four text conversions
 * (plan.org, Milestone-2 primitives). Keeping the list this short is what
 * makes the wasm32 target cheap, because a primitive is the only thing
 * implemented twice.
 *
 * Every function here takes and returns scalars or an out-pointer. Nothing
 * returns a struct by value: the emitted .ll would then have to agree with the
 * platform's struct-return ABI, which is exactly the kind of thing that works
 * on x86-64 and silently does not on wasm32.
 */

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

/* ── Conditions, spec-conditions.md ────────────────────────────────── */

/* A handler stack, and nothing more. signal walks it, calls every frame whose
 * type matches, and returns; a handler that returns normally leaves the
 * signalling function to carry on, and with an empty stack signal is a null
 * check. Nothing here transfers control — restart-case is what will, and it
 * needs a calling convention this does not.
 *
 * Frames are allocated by the caller, on its own stack: establishing a handler
 * is two stores and a push. The condition crosses as a pointer because a
 * condition is a struct and the handler runs while the signalling frame is
 * still alive, so there is nothing to copy.
 *
 * A type is a number rather than a pointer to anything, so that a module
 * compiled later against a running program agrees with it: see Check.type_id. */

typedef struct flan_handler {
  struct flan_handler *prev;
  uint32_t             type_id;
  void               (*fn)(void *condition, void *xfer);
} flan_handler;

static flan_handler *handlers;

void flan_handler_push(flan_handler *h) {
  h->prev = handlers;
  handlers = h;
}

void flan_handler_pop(flan_handler *h) {
  /* By frame, not by count: restoring what this frame displaced is correct
   * even if something below it got the stack out of step. */
  handlers = h->prev;
}

/* [xfer] is the signalling function's own end of the transfer channel
 * (spec-conditions.md §6), threaded through so that a handler invoking a
 * restart can write its target into it. That makes this C frame transparent to
 * a transfer, which it has to be: a handler is always reached through here, so
 * the rule that a transfer cannot cross a foreign frame would otherwise make
 * restart-case useless.
 *
 * A handler that transfers stops the walk. The remaining handlers are for a
 * signal that is still looking for someone; this one has been answered. */
void flan_signal(uint32_t type_id, void *condition, void *xfer) {
  for (flan_handler *h = handlers; h != NULL; h = h->prev)
    if (h->type_id == type_id) {
      h->fn(condition, xfer);
      if (*(void **)xfer != NULL) return;
    }
}

/* A restart stack, the same shape and for the same reasons. What a transfer
 * carries is the *address* of one of these frames, not a number: the frame is
 * allocated by the restart-case that offers it, on its own stack, so the
 * address is unique against every module a running program may later load and
 * against every re-entry of the same restart-case. §4's "innermost frame
 * offering the name" is then just the order of the walk. */

typedef struct flan_restart {
  struct flan_restart *prev;
  uint32_t             name_id;
  /* The name as written, beside the hash that matching uses. Matching never
   * needs it; a break loop does, because it has to show someone their choices
   * and nothing at run time can turn a hash back into a name. */
  const uint8_t       *name;
  int64_t              namelen;
} flan_restart;

static flan_restart *restarts;

void flan_restart_push(flan_restart *r) {
  r->prev = restarts;
  restarts = r;
}

void flan_restart_pop(flan_restart *r) { restarts = r->prev; }

/* What is on offer, innermost first — spec-conditions.md §4's walk, without
 * committing to anything. This is [compute-restarts]' data; today its only
 * caller is the break loop. */
int32_t flan_restart_count(void) {
  int32_t n = 0;
  for (flan_restart *r = restarts; r != NULL; r = r->prev) n++;
  return n;
}

const uint8_t *flan_restart_name(int32_t i, int64_t *len) {
  for (flan_restart *r = restarts; r != NULL; r = r->prev)
    if (i-- == 0) { *len = r->namelen; return r->name; }
  *len = 0;
  return NULL;
}

void *flan_find_restart(uint32_t name_id) {
  for (flan_restart *r = restarts; r != NULL; r = r->prev)
    if (r->name_id == name_id) return r;
  return NULL;
}

/* The i'th frame itself, innermost first — the same walk as
 * [flan_restart_name] and the other half of it. A break loop that offers
 * someone a *list* has to be able to take the entry they picked, and §4's
 * by-name lookup cannot express "the second retry": it takes the first frame
 * offering the name, by definition, so a shadowed restart is on every list
 * and reachable from none of them. Identifying a restart positionally is the
 * only thing that fixes that, and it is why SBCL does the same.
 *
 * The address is the currency: a transfer carries the frame's address, so a
 * caller that holds one from before is holding the same frame the walk found,
 * whatever the walk finds today. */
void *flan_restart_frame(int32_t i) {
  for (flan_restart *r = restarts; r != NULL; r = r->prev)
    if (i-- == 0) return r;
  return NULL;
}

/* Aim the transfer channel at a frame obtained earlier. The same store
 * [flan_break_resume] makes and the same one an invoke-restart makes — this
 * only spells it without a lookup, for a caller that did its looking up when
 * the stack was worth reading. */
void flan_restart_take(void *frame, void *xfer) { *(void **)xfer = frame; }

/* [T] and string are both ptr+len — see Emit.ll. */
typedef struct { const uint8_t *ptr; int64_t len; } flan_slice;

static int    rt_argc;
static char **rt_argv;
static flan_slice *rt_args;   /* argv as [string], built once, never freed */

void flan_rt_init(int32_t argc, char **argv) {
  rt_argc = (int)argc;
  rt_argv = argv;
  /* Line buffered even when stdout is a file or a pipe, where the C default is
   * a 4K block. A Flan program can run for minutes with a REPL attached to it,
   * and output that only appears when it exits is output nobody can use. It is
   * also what makes a program's progress observable to a test that is driving
   * it. The cost is one write per line instead of per 4K. */
  setvbuf(stdout, NULL, _IOLBF, 0);
}

void flan_argv(flan_slice *out) {
  if (rt_args == NULL && rt_argc > 0) {
    rt_args = (flan_slice *)malloc(sizeof(flan_slice) * (size_t)rt_argc);
    for (int i = 0; i < rt_argc; i++) {
      rt_args[i].ptr = (const uint8_t *)rt_argv[i];
      rt_args[i].len = (int64_t)strlen(rt_argv[i]);
    }
  }
  out->ptr = (const uint8_t *)rt_args;
  out->len = (int64_t)rt_argc;
}

void flan_write_stdout(const uint8_t *p, int64_t n) {
  if (n > 0) fwrite(p, 1, (size_t)n, stdout);
}

void flan_exit(int32_t status) {
  fflush(stdout);
  exit((int)status);
}

/* The conversions are *text*: bytes->f64 parses "12.5", f64->bytes renders it.
 * calc-me's tokenizer needs the first, the prelude's printers the second. */

#define SCRATCH 64
static char scratch[SCRATCH];   /* rendered text lives here until the next call */

/* snprintf returns what it *would* have written, not what it did. The three
 * shims below hand the result back as a slice, so taking that number at face
 * value would publish a length past the end of the buffer and every reader of
 * that slice would run off it. No format here can reach 64 — %g is at most 13
 * characters and %lld at most 20 — so this clamp cannot fire today; it is here
 * because the distance between "cannot fire" and "reads off the end of a
 * static buffer" is one format string, and nothing else in the file says so.
 * Found by reading, under a sanitizer sweep that could not have found it:
 * nothing in the corpus prints a number long enough. */
static int64_t fit(int n) {
  if (n < 0) return 0;
  return n < SCRATCH ? (int64_t)n : (int64_t)(SCRATCH - 1);
}

/* The length is clamped below *and* above. Above is obvious and was always
 * here. Below was not, and it was the real one: a slice's length is a signed
 * 64-bit count, (slice s 2 1) computes 2 - 1 - 2 = -1, and `(size_t)n` on a
 * negative n is 18446744073709551615, which is not less than 511, so k became
 * 511 and the memcpy read 511 bytes from wherever the slice pointed. A checked
 * build traps on the reversed slice before it gets here; an unchecked one does
 * not, and every other (ptr, len) entry point in this file — flan_write_stdout,
 * flan_escape_bytes, flan_dev_emit — already guards the negative case. These
 * two were the exceptions. */
static size_t clamp_len(int64_t n, size_t cap) {
  if (n <= 0) return 0;
  return (uint64_t)n < (uint64_t)cap ? (size_t)n : cap;
}

double flan_bytes_to_f64(const uint8_t *p, int64_t n) {
  char buf[512];
  size_t k = clamp_len(n, sizeof buf - 1);
  memcpy(buf, p, k);
  buf[k] = '\0';
  return strtod(buf, NULL);
}

int64_t flan_bytes_to_i64(const uint8_t *p, int64_t n) {
  char buf[64];
  size_t k = clamp_len(n, sizeof buf - 1);
  memcpy(buf, p, k);
  buf[k] = '\0';
  return (int64_t)strtoll(buf, NULL, 10);
}

/* %g so that 3.5 prints as "3.5" and not "3.500000" — calc-me's expected
 * output is a table of exact strings. */
void flan_f64_to_bytes(double x, flan_slice *out) {
  int n = snprintf(scratch, SCRATCH, "%g", x);
  out->ptr = (const uint8_t *)scratch;
  out->len = fit(n);
}

void flan_i64_to_bytes(int64_t x, flan_slice *out) {
  int n = snprintf(scratch, SCRATCH, "%lld", (long long)x);
  out->ptr = (const uint8_t *)scratch;
  out->len = fit(n);
}

/* u64 is not i64 with a flag: 0xFFFFFFFFFFFFFFFF is 18446744073709551615 and
 * not -1, and routing it through the signed printer is the only way println
 * could disagree with the REPL about a value both can hold. Hence a second
 * shim rather than a cast at the call site. */
void flan_u64_to_bytes(uint64_t x, flan_slice *out) {
  int n = snprintf(scratch, SCRATCH, "%llu", (unsigned long long)x);
  out->ptr = (const uint8_t *)scratch;
  out->len = fit(n);
}

/* A string *inside* a printed structure, quoted and escaped, so that the run
 * of bytes can be told from the punctuation around it — (S {:name "a b"}) has
 * two fields if the quotes are missing and one if they are there.
 *
 * This is the same escape table as flan_dev_emit_str in flan_dev.c, and
 * deliberately so: the REPL and println must not disagree about what a struct
 * looks like. It cannot be the *same function* because the dev one streams
 * into the result buffer and this one has to hand back a slice; if either
 * table changes, change both.
 *
 * Its own buffer, not `scratch`: escaping is the one conversion whose output
 * is not a bounded handful of characters. Over-long input is truncated with an
 * ellipsis rather than silently cut, because a value that prints as a shorter
 * value is the failure nobody notices. */
#define ESCAPE_MAX 1024
static char escaped[ESCAPE_MAX];

void flan_escape_bytes(const uint8_t *p, int64_t n, flan_slice *out) {
  size_t len = n < 0 ? 0 : (size_t)n;
  size_t w = 0;
  int cut = 0;
  /* The guard reserves 9 bytes, and all 9 are spoken for: 4 for the longest
   * single escape (\xNN), 3 for the ellipsis, 1 for the closing quote, 1
   * spare. So the loop never writes a partial escape and the three writes
   * after it never need a bound of their own. Swept over every length to 1300
   * against \x01, '"', '\\' and 'a': the worst output is 1021 of 1024. If the
   * escape table ever grows a longer form, this 9 grows with it. */
  escaped[w++] = '"';
  for (size_t i = 0; i < len; i++) {
    if (w + 5 + 4 >= ESCAPE_MAX) { cut = 1; break; }
    unsigned char c = p[i];
    switch (c) {
      case '"':  escaped[w++] = '\\'; escaped[w++] = '"';  break;
      case '\\': escaped[w++] = '\\'; escaped[w++] = '\\'; break;
      case '\n': escaped[w++] = '\\'; escaped[w++] = 'n';  break;
      case '\t': escaped[w++] = '\\'; escaped[w++] = 't';  break;
      case '\r': escaped[w++] = '\\'; escaped[w++] = 'r';  break;
      default:
        if (c < 0x20) {
          w += (size_t)snprintf(escaped + w, 5, "\\x%02x", c);
        } else {
          escaped[w++] = (char)c;
        }
    }
  }
  if (cut) { escaped[w++] = '.'; escaped[w++] = '.'; escaped[w++] = '.'; }
  escaped[w++] = '"';
  out->ptr = (const uint8_t *)escaped;
  out->len = (int64_t)w;
}

/* Bounds failures. The emitted code branches here and then falls off the end
 * with `unreachable`, so these must not return — the same explicit shape as
 * every other non-local exit, which is what keeps wasm32 free of unwinding.
 *
 * The location is passed as ptr+len because that is what a Flan string already
 * is; nothing here allocates. Exit 134 is abort()'s status without abort()'s
 * signal, so the same assertion should hold once wasm32 builds.
 *
 * stdout is flushed *before* the message: stderr is unbuffered and a
 * redirected stdout is not, so without this the error appears above the output
 * that led to it. */

static _Noreturn void rt_die(void) {
  fflush(stdout);
  fflush(stderr);
  exit(134);
}

_Noreturn void flan_bounds_fail(const uint8_t *loc, int64_t loclen,
                                int64_t idx, int64_t len) {
  fflush(stdout);
  fprintf(stderr, "%.*s: index %lld is out of bounds for length %lld\n",
          (int)loclen, (const char *)loc, (long long)idx, (long long)len);
  rt_die();
}

/* §2's diverging variant: the same walk, but a handler that returns normally
 * has not answered it. Only a transfer gets past here — the caller's guard
 * sees the channel and forwards it — so with nothing transferring the program
 * stops. In a dev build this is where the break loop will go; until it exists,
 * stopping is all there is, and it says which condition it was.
 *
 * [flan_signal] is not reused with a flag because the two differ in what they
 * do when the walk ends, which is the whole of §1 against §2. */
/* The dev-build break loop, spec-conditions.md §2. A hook rather than a direct
 * call because the loop lives in the *agent*, which is an optional package, and
 * this file is the release runtime — it must not depend on something a program
 * may not have imported. A program with no agent leaves this NULL and dies the
 * way it always did.
 *
 * The hook may resume by writing a restart into the transfer channel, which is
 * the same channel an invoke-restart writes and reaches the same guard. So
 * choosing a restart from the break loop and choosing one from a handler are
 * the same act, lowered the same way. */
void (*flan_break_hook)(const uint8_t *name, int64_t namelen, void *condition,
                        void *xfer);

/* Must agree with Check.type_id, byte for byte, or a name typed at the break
 * loop matches nothing. FNV-1a over the name, 32 bits. */
static uint32_t flan_name_id(const uint8_t *s, int64_t n) {
  uint32_t h = 0x811c9dc5u;
  for (int64_t i = 0; i < n; i++) {
    h ^= (uint32_t)s[i];
    h *= 0x01000193u;
  }
  return h;
}

/* What the break loop calls to resume: look a restart up by the name someone
 * typed and aim the channel at it. 0 if no frame offers it, and then the loop
 * says so rather than resuming into nothing. */
int32_t flan_break_resume(const uint8_t *name, int64_t namelen, void *xfer) {
  void *r = flan_find_restart(flan_name_id(name, namelen));
  if (r == NULL) return 0;
  *(void **)xfer = r;
  return 1;
}

void flan_error(uint32_t type_id, void *condition, void *xfer,
                const uint8_t *name, int64_t namelen) {
  flan_signal(type_id, condition, xfer);
  if (*(void **)xfer != NULL) return;
  /* Nothing handled it. In a dev build that is a place to stand, not the end
   * of the program — which is the whole of §2 and the reason it is worth
   * having. */
  if (flan_break_hook != NULL) {
    flan_break_hook(name, namelen, condition, xfer);
    if (*(void **)xfer != NULL) return;
  }
  fflush(stdout);
  fprintf(stderr, "unhandled %.*s\n", (int)namelen, (const char *)name);
  rt_die();
}

/* Nothing on the restart stack offers the name. It is reported where the
 * invoke was, because that is the only place that knows what was asked for;
 * there is nowhere to resume, so there is nothing else to do. */
_Noreturn void flan_restart_fail(const uint8_t *loc, int64_t loclen,
                                 const uint8_t *name, int64_t namelen) {
  fflush(stdout);
  fprintf(stderr, "%.*s: no restart named %.*s is active\n",
          (int)loclen, (const char *)loc, (int)namelen, (const char *)name);
  rt_die();
}

/* The frame the name found does not take these arguments — spec-conditions.md
 * §3's run-time check. It has to be at run time: a restart is resolved on a
 * dynamic stack, so the invoke site cannot see what it will find, and the
 * frame cannot see who will find it. What each end knows is its own parameter
 * list, so the message is both of them side by side. */
_Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen,
                                      const uint8_t *name, int64_t namelen,
                                      const uint8_t *want, int64_t wantlen,
                                      const uint8_t *got, int64_t gotlen) {
  fflush(stdout);
  fprintf(stderr, "%.*s: restart %.*s takes %.*s, given %.*s\n",
          (int)loclen, (const char *)loc, (int)namelen, (const char *)name,
          (int)wantlen, (const char *)want, (int)gotlen, (const char *)got);
  rt_die();
}

/* A clause with parameters was reached by a transfer that filled none of them
 * in. No [invoke-restart] can do that — it writes the arguments before it aims
 * the channel — so this is the other way a transfer starts: the break loop,
 * which today takes a restart by position and has no way to supply a value.
 * Refused at the clause rather than run on a buffer nobody wrote. */
_Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen,
                                    const uint8_t *name, int64_t namelen,
                                    const uint8_t *want, int64_t wantlen) {
  fflush(stdout);
  fprintf(stderr,
          "%.*s: restart %.*s takes %.*s, and whatever took it supplied no "
          "arguments — a restart with parameters cannot be taken from the "
          "break loop yet\n",
          (int)loclen, (const char *)loc, (int)namelen, (const char *)name,
          (int)wantlen, (const char *)want);
  rt_die();
}

/* Something a defer called invoked a restart. A defer is the cleanup a
 * transfer runs on its way out (§5), so a transfer starting there would leave
 * this frame's defers half run with two targets and no way to choose. The
 * lexical case is refused by the checker; this is the one that reaches a
 * function through a call, where nothing static could see it. */
_Noreturn void flan_transfer_fail(const uint8_t *loc, int64_t loclen) {
  fflush(stdout);
  fprintf(stderr,
          "%.*s: a defer invoked a restart, which a defer may not do — it is "
          "the cleanup a transfer runs on its way out\n",
          (int)loclen, (const char *)loc);
  rt_die();
}

_Noreturn void flan_slice_fail(const uint8_t *loc, int64_t loclen,
                               int64_t lo, int64_t hi, int64_t len) {
  fflush(stdout);
  fprintf(stderr, "%.*s: slice [%lld %lld) is out of bounds for length %lld\n",
          (int)loclen, (const char *)loc, (long long)lo, (long long)hi,
          (long long)len);
  rt_die();
}