/* 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 #include #include #include #include /* 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 */ }