flan/runtime/flan_dyn_stub.c

/* flan_dyn_stub — a standing-in implementation of the flan_dyn.h ABI.
 *
 * THE MERGE REPLACES THIS FILE WITH runtime/flan_dyn.c. It exists so that the
 * compiler side of dynamic-by-default can be built and run against the fixed
 * ABI before the real runtime lands; the real one is being written in parallel
 * against the same header, and flan_dyn.h is the contract the two are diffed
 * against.
 *
 * What it is not: it mallocs and never frees, it collects nothing, and
 * flan_dyn_root_push / flan_dyn_root_pop record their arguments and do nothing
 * with them. That last point matters for anyone reading a passing test here —
 * root emission is *not* exercised by this file. A program with entirely wrong
 * root discipline passes every test that runs against this stub. The check
 * that does bite is the one over the emitted IR, counting pushes against pops
 * per function; see the acceptance tests.
 *
 * The representation is the simplest thing that satisfies the header's rule
 * that the word is opaque: every value is a pointer to a heap cell, including
 * the small ones. The real runtime will not do this.
 */

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

/* The compiler carries this file as one string with flan_dyn.h pasted in front
 * of it (lib/dune), and in that form there is no header on disk to find. The
 * probe keeps the file compilable both ways: standalone against the real
 * header, and concatenated, where the declarations are already above. The
 * header's own include guard makes the two agree. */
#if defined(__has_include)
#  if __has_include("flan_dyn.h")
#    include "flan_dyn.h"
#  endif
#endif

/* flan_rt.c's own [rt_trap] is static, so this mirrors it rather than calling
 * it: print the sentence, offer the name to the dev daemon's hook, and leave
 * with flan_rt's exit code so that a dyn trap is indistinguishable from any
 * other trap to whoever is watching. The hook is flan_rt.c's global, and a
 * program links both files. */
extern void (*flan_trap_hook)(const uint8_t *name, int64_t namelen);

static _Noreturn void dyn_trap(const char *name, const char *sentence) {
  fflush(stdout);
  fprintf(stderr, "%s\n", sentence);
  fflush(stderr);
  if (flan_trap_hook != NULL)
    flan_trap_hook((const uint8_t *)name, (int64_t)strlen(name));
  _exit(134);
}

enum tag { T_NIL, T_I64, T_F64, T_BOOL, T_STR, T_VEC };

typedef struct cell {
  enum tag tag;
  union {
    int64_t i;
    double  f;
    int32_t b;
    struct { uint8_t *ptr; int64_t len; } s;
    struct { struct cell **items; int64_t len, cap; } v;
  } u;
} cell;

static cell *alloc(enum tag t) {
  cell *c = calloc(1, sizeof *c);
  if (c == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate");
  c->tag = t;
  return c;
}

static cell *as(flan_dyn d) { return (cell *)(uintptr_t)d; }
static flan_dyn word(cell *c) { return (flan_dyn)(uintptr_t)c; }

/* ── Construction ──────────────────────────────────────────────────── */

flan_dyn flan_dyn_nil(void) { return word(alloc(T_NIL)); }

flan_dyn flan_dyn_from_i64(int64_t v) {
  cell *c = alloc(T_I64); c->u.i = v; return word(c);
}

flan_dyn flan_dyn_from_f64(double v) {
  cell *c = alloc(T_F64); c->u.f = v; return word(c);
}

flan_dyn flan_dyn_from_bool(int32_t v) {
  cell *c = alloc(T_BOOL); c->u.b = (v != 0); return word(c);
}

flan_dyn flan_dyn_from_bytes(const uint8_t *ptr, int64_t len) {
  cell *c = alloc(T_STR);
  c->u.s.ptr = malloc((size_t)len + 1);
  if (c->u.s.ptr == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate");
  if (len > 0) memcpy(c->u.s.ptr, ptr, (size_t)len);
  c->u.s.ptr[len] = 0;
  c->u.s.len = len;
  return word(c);
}

flan_dyn flan_dyn_vec_new(void) {
  cell *c = alloc(T_VEC);
  c->u.v.cap = 8;
  c->u.v.items = calloc((size_t)c->u.v.cap, sizeof(cell *));
  if (c->u.v.items == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate");
  return word(c);
}

/* ── Arithmetic ────────────────────────────────────────────────────── */

/* Two numbers promote to f64 when either is one, which is the rule a reader
 * expects of a dynamic language and is not the rule the typed language uses.
 * The typed language has no implicit widening at all; here there is no
 * annotation to have been written, so refusing would leave (+ 1 2.5) with no
 * spelling that works. */
static int numeric(cell *c) { return c->tag == T_I64 || c->tag == T_F64; }
static double as_f(cell *c) { return c->tag == T_I64 ? (double)c->u.i : c->u.f; }

static flan_dyn arith(flan_dyn a, flan_dyn b, char op) {
  cell *x = as(a), *y = as(b);
  if (!numeric(x) || !numeric(y)) dyn_trap("DynArithType", "this arithmetic needs two numbers, and one of the two values is not one");
  if (x->tag == T_I64 && y->tag == T_I64) {
    int64_t p = x->u.i, q = y->u.i, r = 0;
    switch (op) {
      case '+': r = p + q; break;
      case '-': r = p - q; break;
      case '*': r = p * q; break;
      case '/': if (q == 0) dyn_trap("DivideByZero", "division by zero"); r = p / q; break;
      case '%': if (q == 0) dyn_trap("DivideByZero", "division by zero"); r = p % q; break;
    }
    return flan_dyn_from_i64(r);
  }
  {
    double p = as_f(x), q = as_f(y), r = 0;
    switch (op) {
      case '+': r = p + q; break;
      case '-': r = p - q; break;
      case '*': r = p * q; break;
      case '/': r = p / q; break;
      /* fmod without math.h, to keep the stub's link line as short as the
       * real runtime's is meant to be. */
      case '%': r = p - q * (double)(int64_t)(p / q); break;
    }
    return flan_dyn_from_f64(r);
  }
}

flan_dyn flan_dyn_add(flan_dyn a, flan_dyn b) { return arith(a, b, '+'); }
flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b) { return arith(a, b, '-'); }
flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b) { return arith(a, b, '*'); }
flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b) { return arith(a, b, '/'); }
flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b) { return arith(a, b, '%'); }

/* ── Ordering and equality ─────────────────────────────────────────── */

static int cmp(flan_dyn a, flan_dyn b) {
  cell *x = as(a), *y = as(b);
  if (x->tag == T_STR && y->tag == T_STR) {
    int64_t n = x->u.s.len < y->u.s.len ? x->u.s.len : y->u.s.len;
    int r = memcmp(x->u.s.ptr, y->u.s.ptr, (size_t)n);
    if (r != 0) return r < 0 ? -1 : 1;
    return x->u.s.len == y->u.s.len ? 0 : (x->u.s.len < y->u.s.len ? -1 : 1);
  }
  if (!numeric(x) || !numeric(y)) dyn_trap("DynCompareType", "these two values have no ordering between them");
  if (x->tag == T_I64 && y->tag == T_I64)
    return x->u.i == y->u.i ? 0 : (x->u.i < y->u.i ? -1 : 1);
  {
    double p = as_f(x), q = as_f(y);
    return p == q ? 0 : (p < q ? -1 : 1);
  }
}

flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) <  0); }
flan_dyn flan_dyn_le(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) <= 0); }
flan_dyn flan_dyn_gt(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) >  0); }
flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(cmp(a, b) >= 0); }

/* Structural, and never traps — the header's one exception. */
static int eq(cell *x, cell *y) {
  if (numeric(x) && numeric(y)) {
    if (x->tag == T_I64 && y->tag == T_I64) return x->u.i == y->u.i;
    return as_f(x) == as_f(y);
  }
  if (x->tag != y->tag) return 0;
  switch (x->tag) {
    case T_NIL:  return 1;
    case T_BOOL: return x->u.b == y->u.b;
    case T_STR:  return x->u.s.len == y->u.s.len
                     && memcmp(x->u.s.ptr, y->u.s.ptr, (size_t)x->u.s.len) == 0;
    case T_VEC: {
      if (x->u.v.len != y->u.v.len) return 0;
      for (int64_t i = 0; i < x->u.v.len; i++)
        if (!eq(x->u.v.items[i], y->u.v.items[i])) return 0;
      return 1;
    }
    default: return 0;
  }
}

flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b) {
  return flan_dyn_from_bool(eq(as(a), as(b)));
}

/* ── Containers ────────────────────────────────────────────────────── */

static cell *need_vec(flan_dyn v) {
  cell *c = as(v);
  if (c->tag != T_VEC) dyn_trap("DynNotAVec", "this value is not a vector, so it has no elements");
  return c;
}

static int64_t need_index(flan_dyn i) {
  cell *c = as(i);
  if (c->tag != T_I64) dyn_trap("DynIndexType", "an index must be an integer");
  return c->u.i;
}

flan_dyn flan_dyn_len(flan_dyn v) {
  cell *c = as(v);
  if (c->tag == T_STR) return flan_dyn_from_i64(c->u.s.len);
  return flan_dyn_from_i64(need_vec(v)->u.v.len);
}

flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i) {
  cell *c = need_vec(v);
  int64_t k = need_index(i);
  if (k < 0 || k >= c->u.v.len) dyn_trap("Bounds", "index out of bounds");
  return word(c->u.v.items[k]);
}

void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x) {
  cell *c = need_vec(v);
  int64_t k = need_index(i);
  if (k < 0 || k >= c->u.v.len) dyn_trap("Bounds", "index out of bounds");
  c->u.v.items[k] = as(x);
}

void flan_dyn_push(flan_dyn v, flan_dyn x) {
  cell *c = need_vec(v);
  if (c->u.v.len == c->u.v.cap) {
    int64_t cap = c->u.v.cap * 2;
    cell **items = realloc(c->u.v.items, (size_t)cap * sizeof(cell *));
    if (items == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate");
    c->u.v.items = items;
    c->u.v.cap = cap;
  }
  c->u.v.items[c->u.v.len++] = as(x);
}

static void print_cell(cell *c) {
  switch (c->tag) {
    case T_NIL:  fputs("nil", stdout); break;
    case T_I64:  printf("%lld", (long long)c->u.i); break;
    /* %g, so that a whole-numbered f64 does not print as an i64 would and
     * the two remain distinguishable in a test's expected output. */
    case T_F64:  printf("%g", c->u.f); break;
    case T_BOOL: fputs(c->u.b ? "true" : "false", stdout); break;
    case T_STR:  printf("%.*s", (int)c->u.s.len, (const char *)c->u.s.ptr); break;
    case T_VEC:
      fputc('[', stdout);
      for (int64_t i = 0; i < c->u.v.len; i++) {
        if (i > 0) fputc(' ', stdout);
        print_cell(c->u.v.items[i]);
      }
      fputc(']', stdout);
      break;
  }
}

void flan_dyn_print(flan_dyn v) { print_cell(as(v)); }

/* ── Extraction ────────────────────────────────────────────────────── */

int64_t flan_dyn_need_i64(flan_dyn v) {
  cell *c = as(v);
  if (c->tag != T_I64) dyn_trap("DynExpectedI64", "this value was required to be an i64 and is not");
  return c->u.i;
}

double flan_dyn_need_f64(flan_dyn v) {
  cell *c = as(v);
  /* An i64 satisfies an f64 slot, because a dyn integer literal is an i64 by
   * the header's rule and (defvar x f64 (f 1)) would otherwise be unwritable
   * for any f returning dyn. The reverse is not true: f64 to i64 loses. */
  if (c->tag == T_I64) return (double)c->u.i;
  if (c->tag != T_F64) dyn_trap("DynExpectedF64", "this value was required to be an f64 and is not");
  return c->u.f;
}

int32_t flan_dyn_need_bool(flan_dyn v) {
  cell *c = as(v);
  if (c->tag != T_BOOL) dyn_trap("DynExpectedBool", "this value was required to be a bool and is not");
  return c->u.b;
}

/* ── Roots ─────────────────────────────────────────────────────────────
 *
 * Recorded and otherwise ignored. The shadow stack is kept, and its depth
 * checked against the pops, only so that a badly unbalanced emission fails
 * loudly here rather than silently: an over-pop is a compiler bug worth
 * dying on even in a stub that collects nothing. Under-pushing is invisible,
 * and stays invisible until the real collector lands. */

static flan_dyn **roots = NULL;
static int64_t    roots_len = 0, roots_cap = 0;

void flan_dyn_root_push(flan_dyn *slot) {
  if (roots_len == roots_cap) {
    int64_t cap = roots_cap == 0 ? 64 : roots_cap * 2;
    flan_dyn **r = realloc(roots, (size_t)cap * sizeof(flan_dyn *));
    if (r == NULL) dyn_trap("OutOfMemory", "the dyn runtime could not allocate");
    roots = r;
    roots_cap = cap;
  }
  roots[roots_len++] = slot;
}

void flan_dyn_root_pop(int64_t n) {
  if (n < 0 || n > roots_len) dyn_trap("DynRootUnderflow", "the dyn root stack was popped further than it was pushed - a compiler bug");
  roots_len -= n;
}

void flan_gc_init(void) { /* nothing to initialise: this stub never collects */ }