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();
}

/* 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();
}

/* ── Allocators, spec-memory.md ────────────────────────────────────────
 *
 * One type-erased procedure plus an opaque data pointer, which is Odin's
 * shape (base/runtime/core.odin, Allocator_Proc), and every operation takes
 * size and align as parameters because the only place the concrete type is
 * known is the call site.
 *
 * A Flan `Allocator` value is a *pointer* to one of these, not a copy of it.
 * That is forced by two things in the spec and is not a convenience: the
 * capability set has to be readable at run time from wherever a container
 * landed, and `free-all` bumps an epoch that every container made from the
 * allocator has to observe. A copied-by-value allocator would give each copy
 * its own epoch and the dev trap would never fire.
 *
 * Nothing here returns a struct by value, per the file header.
 */

enum {
  FLAN_ALLOC_ALLOC    = 0,
  FLAN_ALLOC_RESIZE   = 1,
  FLAN_ALLOC_FREE     = 2,
  FLAN_ALLOC_FREE_ALL = 3
};

/* The capability set. Odin reads its own back through the procedure
 * (Query_Features returning an Allocator_Mode_Set); a field is the same
 * information without the round trip, and `can-free` is the one that is
 * load-bearing — spec-memory.md refuses a drop-carrying container against an
 * allocator that lacks it. */
enum {
  FLAN_CAN_ALLOC    = 1u << 0,
  FLAN_CAN_RESIZE   = 1u << 1,
  FLAN_CAN_FREE     = 1u << 2,
  FLAN_CAN_FREE_ALL = 1u << 3
};

typedef struct flan_allocator flan_allocator;

/* Returns NULL on failure and never reports failure any other way. The
 * condition, the restart and the message are all the compiler's job; this
 * layer says yes or no. */
typedef void *(*flan_alloc_proc)(flan_allocator *a, int32_t mode, void *p,
                                 int64_t old_size, int64_t size, int64_t align);

struct flan_allocator {
  flan_alloc_proc proc;
  void           *data;
  uint32_t        caps;
  /* Bumped on every free-all. A container records it and traps if it moved:
   * spec-memory.md, "Dev builds detect a released region". Separate from the
   * per-Vec generation word, which answers a different question. */
  uint64_t        epoch;
  /* Dev accounting for the general-purpose tier: "did you forget to free" is
   * an allocator-tier question and this is the allocator's answer. */
  int64_t         live_blocks;
  int64_t         live_bytes;
};

/* -- The heap allocator: malloc, realloc, free. ---------------------- */

static void *flan_heap_proc(flan_allocator *a, int32_t mode, void *p,
                            int64_t old_size, int64_t size, int64_t align) {
  switch (mode) {
  case FLAN_ALLOC_ALLOC: {
    void *q = NULL;
    size_t al, sz;
    if (size <= 0) return NULL;
    al = (size_t)(align < (int64_t)sizeof(void *) ? (int64_t)sizeof(void *) : align);
    sz = (size_t)size;
    /* aligned_alloc requires a size that is a multiple of the alignment. */
    if (sz % al) sz += al - (sz % al);
    q = aligned_alloc(al, sz);
    if (q) { a->live_blocks++; a->live_bytes += size; }
    return q;
  }
  case FLAN_ALLOC_RESIZE: {
    /* aligned_alloc has no realloc, so growth is a new block and a copy. The
     * caller passes old_size for exactly this reason, and it is the one
     * number a wrong answer here would read off the end of. */
    void *q = flan_heap_proc(a, FLAN_ALLOC_ALLOC, NULL, 0, size, align);
    if (!q) return NULL;
    if (p && old_size > 0)
      memcpy(q, p, (size_t)(old_size < size ? old_size : size));
    if (p) { free(p); a->live_blocks--; a->live_bytes -= old_size; }
    return q;
  }
  case FLAN_ALLOC_FREE:
    if (p) { free(p); a->live_blocks--; a->live_bytes -= old_size; }
    return NULL;
  case FLAN_ALLOC_FREE_ALL:
  default:
    return NULL;
  }
}

static flan_allocator flan_heap = {
  flan_heap_proc, NULL,
  FLAN_CAN_ALLOC | FLAN_CAN_RESIZE | FLAN_CAN_FREE,
  0, 0, 0
};

/* -- The arena: one fixed backing buffer and a bump offset. ----------
 *
 * `free-all` is retain-capacity: offset = 0, the pages stay. That is an
 * announced amendment to spec-memory.md's operation table (see BUILT.md) and
 * it is what Odin's arena_free_all already does in effect. Handing the pages
 * back is `arena-destroy`, a separate operation, because a frame arena reset
 * every frame must not return memory only to ask for it again.
 *
 * The epoch is bumped either way: the pages are the same but every container
 * made before the reset is invalid, which is the whole point of the trap. */

typedef struct flan_arena {
  uint8_t *base;
  int64_t  cap;
  int64_t  offset;
  int64_t  peak;
} flan_arena;

static int64_t flan_align_up(int64_t x, int64_t a) {
  if (a <= 1) return x;
  return (x + a - 1) / a * a;
}

static void *flan_arena_proc(flan_allocator *a, int32_t mode, void *p,
                             int64_t old_size, int64_t size, int64_t align) {
  flan_arena *ar = (flan_arena *)a->data;
  switch (mode) {
  case FLAN_ALLOC_ALLOC: {
    int64_t start, end;
    if (size <= 0) return NULL;
    if (align < 1) align = 1;
    start = flan_align_up(ar->offset, align);
    end = start + size;
    if (end > ar->cap || end < start) return NULL;   /* exhausted, or overflow */
    ar->offset = end;
    if (end > ar->peak) ar->peak = end;
    a->live_blocks++;
    a->live_bytes += size;
    return ar->base + start;
  }
  case FLAN_ALLOC_RESIZE: {
    void *q;
    /* Growing the most recent block in place is the one case worth special
     * casing: a Vec that is the only thing pushing into a frame arena grows
     * without copying, which is the common shape. */
    if (p && (uint8_t *)p + old_size == ar->base + ar->offset) {
      int64_t end = (int64_t)((uint8_t *)p - ar->base) + size;
      if (end > ar->cap || end < 0) return NULL;
      ar->offset = end;
      if (end > ar->peak) ar->peak = end;
      a->live_bytes += size - old_size;
      return p;
    }
    q = flan_arena_proc(a, FLAN_ALLOC_ALLOC, NULL, 0, size, align);
    if (!q) return NULL;
    if (p && old_size > 0)
      memcpy(q, p, (size_t)(old_size < size ? old_size : size));
    return q;                       /* the old block is not reclaimable */
  }
  case FLAN_ALLOC_FREE:
    return NULL;                    /* refused by the capability set above */
  case FLAN_ALLOC_FREE_ALL:
    ar->offset = 0;
    a->live_blocks = 0;
    a->live_bytes = 0;
    return NULL;
  default:
    return NULL;
  }
}

/* -- The context, spec-memory.md's context/allocator and context/temp ----
 *
 * A dynamic variable with save and restore, not an extra parameter on every
 * signature. The spec calls it part of the calling convention; taking that
 * literally would touch every function signature, the FFI shim, the dev
 * trampolines and the reload ABI, for the same observable behaviour. The
 * literal reading is deferred and BUILT.md says so.
 *
 * There are no threads in Flan, so a plain global is the whole of it. */

static flan_allocator *flan_ctx_alloc = &flan_heap;
static flan_allocator *flan_ctx_tmp = NULL;

flan_allocator *flan_arena_new(int64_t cap);

flan_allocator *flan_context_allocator(void) { return flan_ctx_alloc; }

/* The default temp arena, made on first use. 1 MiB: big enough that the
 * per-frame tier does not fail on a toy program, small enough that a program
 * which never touches it has not paid for a heap. */
#define FLAN_TEMP_DEFAULT (1 << 20)

flan_allocator *flan_context_temp(void) {
  if (!flan_ctx_tmp) flan_ctx_tmp = flan_arena_new(FLAN_TEMP_DEFAULT);
  return flan_ctx_tmp;
}

/* Returns the previous one, which is what with-allocator restores — on the
 * normal path and on the transfer path both. */
flan_allocator *flan_context_set(flan_allocator *a) {
  flan_allocator *prev = flan_ctx_alloc;
  if (a) flan_ctx_alloc = a;
  return prev;
}

void flan_context_restore(flan_allocator *a) {
  if (a) flan_ctx_alloc = a;
}

flan_allocator *flan_arena_new(int64_t cap) {
  flan_allocator *a;
  flan_arena *ar;
  if (cap <= 0) cap = FLAN_TEMP_DEFAULT;
  a = (flan_allocator *)calloc(1, sizeof *a);
  ar = (flan_arena *)calloc(1, sizeof *ar);
  if (!a || !ar) { free(a); free(ar); return NULL; }
  ar->base = (uint8_t *)malloc((size_t)cap);
  if (!ar->base) { free(a); free(ar); return NULL; }
  ar->cap = cap;
  a->proc = flan_arena_proc;
  a->data = ar;
  /* No FLAN_CAN_FREE: an arena cannot release one block, which is Odin's
   * answer too (allocators.odin returns Mode_Not_Implemented for .Free). */
  a->caps = FLAN_CAN_ALLOC | FLAN_CAN_RESIZE | FLAN_CAN_FREE_ALL;
  return a;
}

void flan_arena_destroy(flan_allocator *a) {
  flan_arena *ar;
  if (!a || a->proc != flan_arena_proc) return;
  ar = (flan_arena *)a->data;
  if (a == flan_ctx_alloc) flan_ctx_alloc = &flan_heap;
  if (a == flan_ctx_tmp) flan_ctx_tmp = NULL;
  a->epoch++;
  free(ar->base);
  free(ar);
  free(a);
}

flan_allocator *flan_heap_allocator(void) { return &flan_heap; }

int8_t flan_alloc_can_free(flan_allocator *a) {
  return (int8_t)(a && (a->caps & FLAN_CAN_FREE) ? 1 : 0);
}

int8_t flan_alloc_can_free_all(flan_allocator *a) {
  return (int8_t)(a && (a->caps & FLAN_CAN_FREE_ALL) ? 1 : 0);
}

int64_t flan_alloc_epoch(flan_allocator *a) {
  return a ? (int64_t)a->epoch : 0;
}

int64_t flan_alloc_live_blocks(flan_allocator *a) {
  return a ? a->live_blocks : 0;
}

_Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen);
_Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen);

/* free-all on an allocator that does not offer it is a trap, not a silent
 * no-op: "I released the region" and "I leaked the region" must not be the
 * same program text. */
void flan_alloc_free_all(flan_allocator *a, const uint8_t *loc, int64_t loclen) {
  /* A null allocator is a zeroed [defvar] nobody assigned yet. Silently doing
   * nothing would make "I released the region" and "I never made one" the same
   * program text, which is the thing this trap exists to prevent. */
  if (!a) flan_null_alloc_fail(loc, loclen);
  if (!(a->caps & FLAN_CAN_FREE_ALL)) flan_free_all_fail(loc, loclen);
  a->proc(a, FLAN_ALLOC_FREE_ALL, NULL, 0, 0, 0);
  a->epoch++;
}

_Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen) {
  fflush(stdout);
  fprintf(stderr,
          "%.*s: this allocator is null — a zeroed Allocator was never given "
          "one\n",
          (int)loclen, (const char *)loc);
  rt_die();
}

_Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen) {
  fflush(stdout);
  fprintf(stderr,
          "%.*s: this allocator does not offer free-all — it has no region to "
          "release, and releasing nothing is not the same as releasing "
          "everything\n",
          (int)loclen, (const char *)loc);
  rt_die();
}