/* flan_dyn — tagged values, a mark-sweep heap, and the operations over them. * * Milestone 1 of dynamic-by-default: code nobody annotated computes with * values that carry their type at run time, code that is fully annotated * compiles to exactly what it compiled to before, and a build that asks for * neither a collector nor a tag can be told that it has one. * * The argument for every decision in here — why NaN-boxing rather than low-bit * tagging, why mark-sweep rather than anything cleverer, why the roots are * pushed rather than found — is docs/SPIKE-DYNAMIC.md. This file carries the * parts of it a reader needs *while reading the code*, and points at the doc * for the rest. * * ── What this file may depend on ────────────────────────────────────── * * flan_rt.c, and nothing else in the tree. The dependency does not run the * other way: no line of flan_rt.c or flan_dev.c names anything defined here. * That is the whole of what makes a `--no-gc` build possible — not because the * linker drops this object (it does not; a named object is linked whole, and * `nm` on any corpus program finds flan_dyn_add in it), but because nothing * else needs it, so *not compiling it* is a change at the three sites that * name it and nowhere else. A single back-reference from the release runtime * would make the collector unconditional and the refusal a lie. See the doc's * "Dropping the collector". * * ── Threads ─────────────────────────────────────────────────────────── * * There are none, and the globals below are plain globals for the reason the * handler stack, the restart stack and the frame chain in the other two files * are: one thread runs Flan. The dev agent's listener thread runs C and the * loader and never enters a Flan body, so it never allocates and never marks. * If the language grows threads, the heap needs a lock and the roots need to * be thread-local, and that is one change in two places rather than a rewrite. */ #include #include #include #include /* ── What we borrow from flan_rt.c ───────────────────────────────────── * * Declared rather than included: the build hands clang each runtime .c on its * own with no include path (see [Build.compile_c]), so a #include of * flan_dyn.h would not resolve. runtime/flan_dyn.h says the same things a * second time and test/dyn_ops.c includes it, which is what keeps the two * copies honest. */ void flan_write_stdout(const uint8_t *p, int64_t n); /* The one non-local exit a dyn operation can take. flan_rt.c's [rt_trap] is * static, and re-implementing what it does — the break-loop hook, the flush, * the socket, [_exit(134)] — would be a second answer to "how does a Flan * program die where it stands", which that file went to some trouble to have * only one of. So flan_rt.c exports a thin wrapper and this calls it. */ _Noreturn void flan_trap(const uint8_t *name, int64_t namelen); /* ── The representation ──────────────────────────────────────────────── * * NaN-boxed, in a word. A double is *itself*: the 2^64 minus a NaN's worth of * bit patterns that are not quiet NaNs are read straight back as f64, at no * cost, which is what a language where f64 is first class and where sand.flan * runs a physics loop wants. Everything else hides inside the quiet-NaN space. * * The box is sign bit + all-ones exponent + quiet bit, which is * 0xFFF8000000000000. Bits 50..48 are three tag bits; bits 47..0 are the * payload, which is exactly the width of an x86-64 user-space pointer. * * 63 62..52 51 50..48 47..0 * 1 1...1 1 tag payload * * The collision this scheme always has to answer for is a real f64 that is * already a *negative* quiet NaN: those bits are indistinguishable from a box. * [flan_dyn_from_f64] answers it by canonicalising every NaN to the positive * quiet NaN on the way in. That is not a new rule invented here — flan_rt.c's * [flan_f64_to_bytes] already renders every NaN as "nan" with no sign, and * carries three paragraphs on why the sign bit of a NaN is not a fact about * the arithmetic and should not be shown. A dyn value takes the same line one * step further and does not *store* it. Nothing observable changes: NaN is not * equal to itself, so no comparison can see which NaN it is, and the printer * was already refusing to say. * * Integers. i64 is first class here and 48 bits is not 64, so an int that fits * the payload is inline and one that does not is a heap box. The inline range * is ±2^47, which is every array index, every counter and every timestamp in * milliseconds until the year 6429; the box is what keeps the other end of the * type honest rather than quietly wrapping. See the doc. * * Tags 6 and 7 are unspoken for, and that is where a typed handle goes when * interop arrives — a (Vec i64) crossing into dyn without being copied. Again, * the doc. */ typedef uint64_t flan_dyn; #define DYN_QNAN 0xFFF8000000000000ULL #define DYN_TAGMASK 0x0007000000000000ULL #define DYN_PAYMASK 0x0000FFFFFFFFFFFFULL #define DYN_TAGSHIFT 48 /* The four box tags. Not the same numbers as FLAN_DYN_TAG_* in the header: * those are what a *reader* is told (float and int are two answers), these are * how the word is laid out (a float is not boxed at all, and a big int is a * pointer). [flan_dyn_tag] is the translation. */ #define BOX_NIL 0u #define BOX_BOOL 1u #define BOX_INT 2u #define BOX_OBJ 3u /* Spelled as a negated positive rather than as a shift of -1: shifting a * negative value left is undefined, and this file is swept by UBSan. */ #define DYN_INT_MAX (((int64_t)1 << 47) - 1) #define DYN_INT_MIN (-DYN_INT_MAX - 1) static inline int dyn_boxed(flan_dyn v) { return (v & DYN_QNAN) == DYN_QNAN; } static inline unsigned dyn_box(flan_dyn v) { return (unsigned)((v & DYN_TAGMASK) >> DYN_TAGSHIFT); } static inline uint64_t dyn_payload(flan_dyn v) { return v & DYN_PAYMASK; } static inline flan_dyn dyn_make(unsigned tag, uint64_t payload) { return DYN_QNAN | ((uint64_t)tag << DYN_TAGSHIFT) | (payload & DYN_PAYMASK); } /* ── The heap ────────────────────────────────────────────────────────── * * One header, three kinds, and a singly-linked list of everything ever * allocated. The list is the sweep's; there is no other index, no free list * and no size class, because the collector's stated job is to be small enough * to read in one sitting. A heap that wants to be faster than this wants the * program to be typed instead. * * [mark] is a byte and not a bit in a side table for the same reason. A side * table is the right answer when the sweep is the cost, and the sweep is never * going to be the cost here. * * A vec's elements live in a plain malloc block hanging off the header rather * than in a GC object of their own. Two reasons: a growth is then a [realloc] * and not a copy this file writes, and the elements are never reachable except * through their vec, so giving them an identity would buy nothing and cost a * header. Their bytes are counted in [gc_bytes] and freed when the vec is * swept, which is the whole of their lifetime. */ #define OBJ_TEXT 0 #define OBJ_VEC 1 #define OBJ_INT 2 /* an i64 too wide for the payload */ typedef struct flan_obj { struct flan_obj *next; /* every object ever allocated, newest first */ uint8_t kind; uint8_t mark; int64_t len; /* bytes of a text, elements of a vec */ union { int64_t i; /* OBJ_INT */ struct { flan_dyn *items; int64_t cap; } v; /* OBJ_VEC */ /* OBJ_TEXT's bytes trail the header; see [obj_text_bytes]. */ } u; } flan_obj; static inline uint8_t *obj_text_bytes(flan_obj *o) { return (uint8_t *)(o + 1); } static flan_obj *gc_all; /* the sweep list */ static int64_t gc_bytes; /* what the live objects hold, headers included */ static int64_t gc_count; static int64_t gc_next; /* collect when an allocation would pass this */ static int64_t gc_floor = 1 << 20; static int gc_ready; /* ── Roots ───────────────────────────────────────────────────────────── * * Addresses of slots, pushed by the code that owns them. Not a conservative * scan of the C stack, and the reason is worth stating once here rather than * only in the doc: a conservative scan has to decide whether an arbitrary word * is a pointer, and NaN-boxing makes that decision *wrong* in both directions * — a live double is bit-identical to a boxed pointer often enough to retain * garbage, and a payload with the box stripped is not the pointer the scanner * would look for. Precision here is cheaper than the arguments about it. * * Growable, because a deep recursion over dyn locals is an ordinary program * and a fixed table would be a limit nobody could predict. The array holds * [flan_dyn *], so growing it moves the array and not the slots. */ static flan_dyn **roots; static int64_t roots_n, roots_cap; /* ── The temporaries ring ────────────────────────────────────────────── * * The hazard this exists for, plainly: mark-sweep frees what is unreachable, * and a freshly allocated object is unreachable until somebody roots it. So * * flan_dyn_push(v, flan_dyn_add(flan_dyn_from_bytes(p, n), ...)); * * — or any expression with two allocating calls in it — can have the second * allocation collect the result of the first, in the window before the * compiler has stored either into a rooted slot. C's argument evaluation order * is unspecified, so this is not even a window a careful emitter could close * by ordering its calls. * * The answer is the smallest one that does not need the other lane to have * read a document: every object this file allocates is written into a fixed * ring, and the marker roots the whole ring unconditionally. Any expression * making at most RING allocations before rooting its result is then safe, with * no ABI change and no contract for anybody to get wrong. The cost is a store * and a masked increment per allocation, and up to RING objects' worth of * float in the heap — which the trigger absorbs, because the trigger is a * fraction of live bytes and not a count. * * 64 slots. An expression with 65 allocating calls in it and no intervening * root would be a single Flan form with 65 constructors in it, which is not a * form anybody writes; if it ever is, the compiler roots its intermediates and * this ring is belt on top of braces. */ #define RING 64 static flan_obj *ring[RING]; static unsigned ring_at; /* ── Tag words ───────────────────────────────────────────────────────── * * One table. The trap messages below and [flan_dyn_tag_name] read it, so a * sentence a program dies with and a name an inspector shows cannot drift * apart. Words and never numbers: "cannot add int and text" is a sentence * somebody can act on and "tag 2 and tag 4" is a puzzle. */ static const char *const tag_words[] = { "nil", "bool", "int", "float", "text", "vec" }; #define FLAN_DYN_TAG_NIL 0 #define FLAN_DYN_TAG_BOOL 1 #define FLAN_DYN_TAG_INT 2 #define FLAN_DYN_TAG_FLOAT 3 #define FLAN_DYN_TAG_TEXT 4 #define FLAN_DYN_TAG_VEC 5 static inline flan_obj *dyn_obj(flan_dyn v) { return (flan_obj *)(uintptr_t)dyn_payload(v); } int32_t flan_dyn_tag(flan_dyn v) { if (!dyn_boxed(v)) return FLAN_DYN_TAG_FLOAT; switch (dyn_box(v)) { case BOX_NIL: return FLAN_DYN_TAG_NIL; case BOX_BOOL: return FLAN_DYN_TAG_BOOL; case BOX_INT: return FLAN_DYN_TAG_INT; default: { flan_obj *o = dyn_obj(v); if (o == NULL) return FLAN_DYN_TAG_NIL; switch (o->kind) { case OBJ_TEXT: return FLAN_DYN_TAG_TEXT; case OBJ_VEC: return FLAN_DYN_TAG_VEC; default: return FLAN_DYN_TAG_INT; } } } } const char *flan_dyn_tag_name(int32_t tag) { if (tag < 0 || tag > FLAN_DYN_TAG_VEC) return "?"; return tag_words[tag]; } static inline const char *tag_of(flan_dyn v) { return flan_dyn_tag_name(flan_dyn_tag(v)); } /* ── Rendering, for messages and for print ───────────────────────────── * * One walk, two callers. [flan_dyn_print] writes to stdout through * [flan_write_stdout], so a dyn print and a typed print interleave correctly * in the one buffer; a trap message renders into a small buffer and puts the * values in the sentence. * * What it renders, per tag, is what typed [print] renders for the * corresponding type — captured from a running program rather than read off * lib/render.ml, because that file is the REPL's inspector and not necessarily * println's expansion: * * int %lld 42 * float %g, and "nan" unsigned 3.5, 1, nan * bool the word true / false * text bare at the top level, hi / "a b" * quoted and escaped inside * vec a slice's spelling [ 1 2 3] * * The leading space before every element is not a slip: it is what * lib/render.ml's slice loop emits and what a Flan program prints today, and * an acceptance test comparing the two would notice a tidier answer. * * nil is the one tag with no typed counterpart, and it renders as `nil`. * * A typed Vec prints as `` rather than structurally, and a dyn vec does * not: it prints the way a *slice* does. That is deliberate and is argued in * the doc — the typed refusal is about borrowing storage the printer does not * own, and a dyn vec's storage is the collector's, so there is nothing to * borrow and nobody to ask. * * DEPTH is a cycle stop and nothing else. A typed value cannot contain itself, * so the typed printer needs no run-time cap; [flan_dyn_set_at] makes a dyn * vec that can, so this one does. Past the cap it prints render.ml's "...", * which is the same mark that file uses for the same idea. */ #define PRINT_DEPTH 16 static void emit(const char *s) { flan_write_stdout((const uint8_t *)s, (int64_t)strlen(s)); } static void emit_n(const uint8_t *p, int64_t n) { flan_write_stdout(p, n); } /* A text inside a structure, quoted and escaped. The same table as * flan_rt.c's [flan_escape_bytes] and flan_dev.c's [flan_dev_emit_str], and * for the same reason those two are the same as each other: three printers * that disagree about what a string looks like is three wire formats. If that * table changes, change this one. Streamed rather than built, so there is no * buffer to overrun and no length to cap. */ static void emit_escaped(const uint8_t *p, int64_t n) { int64_t i; emit("\""); for (i = 0; i < n; i++) { unsigned char c = p[i]; switch (c) { case '"': emit("\\\""); break; case '\\': emit("\\\\"); break; case '\n': emit("\\n"); break; case '\t': emit("\\t"); break; case '\r': emit("\\r"); break; default: if (c < 0x20) { char b[5]; snprintf(b, sizeof b, "\\x%02x", c); emit(b); } else { emit_n(&c, 1); } } } emit("\""); } static int64_t dyn_int_value(flan_dyn v); /* forward: both int shapes */ static double dyn_num_value(flan_dyn v); static void render(flan_dyn v, int depth, int nested) { char buf[64]; int32_t t = flan_dyn_tag(v); if (depth > PRINT_DEPTH) { emit("..."); return; } switch (t) { case FLAN_DYN_TAG_NIL: emit("nil"); return; case FLAN_DYN_TAG_BOOL: emit(dyn_payload(v) ? "true" : "false"); return; case FLAN_DYN_TAG_INT: snprintf(buf, sizeof buf, "%lld", (long long)dyn_int_value(v)); emit(buf); return; case FLAN_DYN_TAG_FLOAT: { double d; memcpy(&d, &v, sizeof d); /* x != x rather than isnan, which keeps math.h out of this file and is * the comparison flan_rt.c and the prelude both use. */ if (d != d) snprintf(buf, sizeof buf, "nan"); else snprintf(buf, sizeof buf, "%g", d); emit(buf); return; } case FLAN_DYN_TAG_TEXT: { flan_obj *o = dyn_obj(v); if (nested) emit_escaped(obj_text_bytes(o), o->len); else emit_n(obj_text_bytes(o), o->len); return; } default: { flan_obj *o = dyn_obj(v); int64_t i; emit("["); for (i = 0; i < o->len; i++) { emit(" "); render(o->u.v.items[i], depth + 1, 1); } emit("]"); return; } } } void flan_dyn_print(flan_dyn v) { render(v, 0, 0); } /* The same walk into a buffer, for a trap's sentence. Bounded and truncated * rather than allocating: a trap is the one moment when allocating would be a * second thing to go wrong, and the message's job is to name the value, not to * reproduce it. The depth is 2 rather than PRINT_DEPTH for the same reason. */ #define SAY_MAX 96 typedef struct { char *p; int64_t n, cap; } sayer; static void say_puts(sayer *s, const char *t) { while (*t && s->n < s->cap - 1) s->p[s->n++] = *t++; s->p[s->n] = '\0'; } static void say_render(sayer *s, flan_dyn v, int depth) { char buf[64]; int32_t t = flan_dyn_tag(v); if (s->n >= s->cap - 4) return; switch (t) { case FLAN_DYN_TAG_NIL: say_puts(s, "nil"); return; case FLAN_DYN_TAG_BOOL: say_puts(s, dyn_payload(v) ? "true" : "false"); return; case FLAN_DYN_TAG_INT: snprintf(buf, sizeof buf, "%lld", (long long)dyn_int_value(v)); say_puts(s, buf); return; case FLAN_DYN_TAG_FLOAT: { double d; memcpy(&d, &v, sizeof d); if (d != d) snprintf(buf, sizeof buf, "nan"); else snprintf(buf, sizeof buf, "%g", d); say_puts(s, buf); return; } case FLAN_DYN_TAG_TEXT: { flan_obj *o = dyn_obj(v); int64_t i; say_puts(s, "\""); for (i = 0; i < o->len && s->n < s->cap - 6; i++) { char c[2]; uint8_t b = obj_text_bytes(o)[i]; c[0] = b >= 0x20 ? (char)b : '.'; c[1] = '\0'; say_puts(s, c); } say_puts(s, i < o->len ? "...\"" : "\""); return; } default: { flan_obj *o = dyn_obj(v); int64_t i; if (depth >= 2) { say_puts(s, "[...]"); return; } say_puts(s, "["); for (i = 0; i < o->len && s->n < s->cap - 8; i++) { say_puts(s, " "); say_render(s, o->u.v.items[i], depth + 1); } say_puts(s, i < o->len ? " ...]" : "]"); return; } } } static void say(char *buf, int64_t cap, flan_dyn v) { sayer s; s.p = buf; s.n = 0; s.cap = cap; buf[0] = '\0'; say_render(&s, v, 0); } /* ── Traps ───────────────────────────────────────────────────────────── * * The shape of every message: the operation, then what was wrong in words, * then the call as it would have been written. So a program that adds a number * to a string stops with * * dyn +: int and text, and + wants two numbers — (+ 3 "hi") * * which names the operation, both tags, and both values, in that order, * because that is the order somebody reads it in. [flan_trap] then parks the * program in a dev session and ends it standing up in a standalone build; the * sentence is the same either way, which is the point of routing through the * hook rather than calling abort here. * * The trap *name* — what the break loop shows and what a `layout` op will say * it cannot place — is "DynType" for a tag that was not what the operation * wanted, "DynRange" for an index outside a vec or a text, "DynArith" for a * division by zero or the one quotient that overflows, and "DynHeap" for an * allocation the host refused. Four names rather than one because they are * four different mistakes and a person stopped in one of them wants to know * which without reading the sentence twice — and because the break loop lists * them by name. */ static _Noreturn void trap2(const char *name, int64_t namelen, const char *op, const char *why, flan_dyn a, flan_dyn b) { char sa[SAY_MAX], sb[SAY_MAX]; say(sa, SAY_MAX, a); say(sb, SAY_MAX, b); fflush(stdout); fprintf(stderr, "dyn %s: %s and %s, and %s — (%s %s %s)\n", op, tag_of(a), tag_of(b), why, op, sa, sb); flan_trap((const uint8_t *)name, namelen); } static _Noreturn void trap1(const char *name, int64_t namelen, const char *op, const char *why, flan_dyn a) { char sa[SAY_MAX]; say(sa, SAY_MAX, a); fflush(stdout); fprintf(stderr, "dyn %s: %s, and %s — (%s %s)\n", op, tag_of(a), why, op, sa); flan_trap((const uint8_t *)name, namelen); } #define TYPE_TRAP "DynType", 7 #define ARITH_TRAP "DynArith", 8 static _Noreturn void trap_range(const char *op, flan_dyn v, int64_t i, int64_t len) { char sv[SAY_MAX]; say(sv, SAY_MAX, v); fflush(stdout); fprintf(stderr, "dyn %s: index %lld is out of bounds for %s of length %lld — %s\n", op, (long long)i, tag_of(v), (long long)len, sv); flan_trap((const uint8_t *)"DynRange", 8); } /* ── Allocation and collection ───────────────────────────────────────── * * Collection happens here and nowhere else, which is the fact the roots * contract rests on: between two allocations nothing is swept, so a * temporary living only in a C local survives the operation it was made in. * A growing vec's element array is a [realloc] and not an allocation in this * sense — it cannot collect, because the value being pushed may not be rooted * yet. That means a program that only ever pushes can hold more than the * trigger says before the next real allocation catches up, which is fine: what * it is holding is the vec, and the vec is live. * * The trigger is the plainest one that works: collect when this allocation * would carry the heap past a limit, then set the limit to twice what survived * — with a floor, so a program with a tiny live set does not collect on every * other allocation. That gives amortised O(1) collections per byte allocated * and a heap bounded at twice the live set plus the floor, which is the * property the million-allocation test asserts. * * "The answer to 'I need more performance' will never be a faster GC, it will * be to type the whole program" — so there is no generation, no card table, no * incremental phase, and no free list. */ static void gc_mark_all(void); static void gc_sweep(void); void flan_gc_init(void) { if (gc_ready) return; gc_ready = 1; gc_all = NULL; gc_bytes = 0; gc_count = 0; gc_next = gc_floor; } /* The trigger is recomputed from the new floor by the same formula the sweep * uses, rather than only being raised to meet it. Raising alone left a heap * that had been given a *lower* floor still running to the old one — the first * collection then happened a megabyte in, and a test that had asked for 64K * measured a megabyte. */ void flan_gc_set_floor(int64_t bytes) { gc_floor = bytes > 0 ? bytes : (1 << 20); gc_next = gc_bytes * 2; if (gc_next < gc_floor) gc_next = gc_floor; } int64_t flan_gc_live_bytes(void) { return gc_bytes; } int64_t flan_gc_count(void) { return gc_count; } void flan_gc_collect(void) { gc_mark_all(); gc_sweep(); gc_next = gc_bytes * 2; if (gc_next < gc_floor) gc_next = gc_floor; } /* Out of memory is the one failure in here that is not the program's fault and * not recoverable by anything this file can do. It takes the trap path like * everything else, so a dev session parks on it and can be read, rather than * the allocation quietly answering NULL and every caller below growing a null * check for a case none of them can handle. */ static _Noreturn void trap_oom(int64_t want) { fflush(stdout); fprintf(stderr, "dyn heap: %lld bytes could not be allocated, with %lld live\n", (long long)want, (long long)gc_bytes); flan_trap((const uint8_t *)"DynHeap", 7); } static flan_obj *gc_alloc(uint8_t kind, int64_t extra) { int64_t need = (int64_t)sizeof(flan_obj) + extra; flan_obj *o; if (!gc_ready) flan_gc_init(); if (gc_bytes + need > gc_next) flan_gc_collect(); o = (flan_obj *)malloc((size_t)need); if (o == NULL) trap_oom(need); o->next = gc_all; o->kind = kind; o->mark = 0; o->len = 0; memset(&o->u, 0, sizeof o->u); gc_all = o; gc_bytes += need; gc_count++; /* Into the ring before anything else can allocate. See the ring's comment: * this is the one line that makes an expression with two constructors in it * safe without the other lane having agreed to anything. */ ring[ring_at] = o; ring_at = (ring_at + 1) % RING; return o; } /* The mark stack. Explicit rather than recursive, because a vec of a vec of a * vec is an ordinary dyn value and its depth is the program's, not this * file's: a recursive marker would put the heap's depth on the C stack and a * long enough chain would overflow it during a collection, which is the worst * possible moment. Grown on demand and kept between collections, so a steady * program stops paying for it after the first one. */ static flan_obj **mstack; static int64_t mstack_n, mstack_cap; static void mark_push(flan_obj *o) { if (o == NULL || o->mark) return; o->mark = 1; /* Only a vec has anything to trace. A text and a boxed int are leaves, and * marking them is the whole of their visit. */ if (o->kind != OBJ_VEC) return; if (mstack_n == mstack_cap) { int64_t cap = mstack_cap ? mstack_cap * 2 : 64; flan_obj **m = (flan_obj **)realloc(mstack, (size_t)cap * sizeof *m); if (m == NULL) trap_oom(cap * (int64_t)sizeof *m); mstack = m; mstack_cap = cap; } mstack[mstack_n++] = o; } static void mark_value(flan_dyn v) { if (dyn_boxed(v) && dyn_box(v) == BOX_OBJ) mark_push(dyn_obj(v)); } static void gc_mark_all(void) { int64_t i; unsigned k; for (i = 0; i < roots_n; i++) mark_value(*roots[i]); for (k = 0; k < RING; k++) mark_push(ring[k]); while (mstack_n > 0) { flan_obj *o = mstack[--mstack_n]; for (i = 0; i < o->len; i++) mark_value(o->u.v.items[i]); } } static void gc_sweep(void) { flan_obj **link = &gc_all; flan_obj *o = gc_all; while (o != NULL) { flan_obj *next = o->next; if (o->mark) { o->mark = 0; link = &o->next; } else { int64_t held = (int64_t)sizeof(flan_obj); if (o->kind == OBJ_TEXT) held += o->len; if (o->kind == OBJ_VEC) { held += o->u.v.cap * (int64_t)sizeof(flan_dyn); free(o->u.v.items); } gc_bytes -= held; gc_count--; *link = next; free(o); } o = next; } } void flan_dyn_root_push(flan_dyn *slot) { if (roots_n == roots_cap) { int64_t cap = roots_cap ? roots_cap * 2 : 64; flan_dyn **r = (flan_dyn **)realloc(roots, (size_t)cap * sizeof *r); if (r == NULL) trap_oom(cap * (int64_t)sizeof *r); roots = r; roots_cap = cap; } roots[roots_n++] = slot; } /* Clamped at empty rather than refused. A pop that outruns its pushes means * the frame machinery is already out of step, and the useful thing at that * point is a heap that still collects, not a second failure on top of the * first. flan_rt.c's [flan_handler_pop] takes the same line for the same * reason, by frame rather than by count. */ void flan_dyn_root_pop(int64_t n) { if (n <= 0) return; roots_n = n < roots_n ? roots_n - n : 0; } void flan_dyn_root_reset(void) { roots_n = 0; } /* ── Constructors ──────────────────────────────────────────────────────*/ flan_dyn flan_dyn_nil(void) { return dyn_make(BOX_NIL, 0); } flan_dyn flan_dyn_from_bool(uint8_t b) { return dyn_make(BOX_BOOL, b ? 1u : 0u); } flan_dyn flan_dyn_from_i64(int64_t x) { flan_obj *o; if (x >= DYN_INT_MIN && x <= DYN_INT_MAX) return dyn_make(BOX_INT, (uint64_t)x); /* Wider than the payload, so it goes on the heap. Rare by construction — * see the representation note — and it is the case that keeps i64 an i64 * rather than a 48-bit integer with a different name. */ o = gc_alloc(OBJ_INT, 0); o->u.i = x; return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } flan_dyn flan_dyn_from_f64(double x) { flan_dyn v; /* Every NaN becomes the one positive quiet NaN, which is what keeps a * negative quiet NaN from being read back as a box. The argument that this * loses nothing is in the representation note above and in flan_rt.c's * [flan_f64_to_bytes]. */ if (x != x) return 0x7FF8000000000000ULL; memcpy(&v, &x, sizeof v); return v; } flan_dyn flan_dyn_from_bytes(const uint8_t *p, int64_t n) { flan_obj *o; if (n < 0) n = 0; o = gc_alloc(OBJ_TEXT, n); o->len = n; if (n > 0) memcpy(obj_text_bytes(o), p, (size_t)n); return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } flan_dyn flan_dyn_vec_new(void) { flan_obj *o = gc_alloc(OBJ_VEC, 0); o->len = 0; o->u.v.items = NULL; o->u.v.cap = 0; return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o); } /* ── Reading a value back ──────────────────────────────────────────────*/ static int64_t dyn_int_value(flan_dyn v) { if (dyn_box(v) == BOX_INT) { /* Sign-extend from 48 bits. The shift pair is the portable spelling; a * bitfield would be one line shorter and implementation-defined. */ uint64_t p = dyn_payload(v); return (int64_t)(p << 16) >> 16; } return dyn_obj(v)->u.i; } static double dyn_num_value(flan_dyn v) { double d; if (flan_dyn_tag(v) == FLAN_DYN_TAG_INT) return (double)dyn_int_value(v); memcpy(&d, &v, sizeof d); return d; } static inline int is_num(flan_dyn v) { int32_t t = flan_dyn_tag(v); return t == FLAN_DYN_TAG_INT || t == FLAN_DYN_TAG_FLOAT; } static inline int is_text(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_TEXT; } static inline int is_vec(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_VEC; } int64_t flan_dyn_need_i64(flan_dyn v) { if (flan_dyn_tag(v) != FLAN_DYN_TAG_INT) trap1(TYPE_TRAP, "i64", "an int was wanted", v); return dyn_int_value(v); } /* A float, and an int is not one. Refusing the widening is the decision, not * an omission: typed Flan has no implicit widening anywhere — [(print-i64 x)] * used to force an explicit [(i64 x)] at every site — and a boundary that * quietly turned an int into a float would be the one place in the language * where a *value* changed type without anybody writing it down. The dyn * *operators* promote, because arithmetic between a 2 and a 2.5 has an obvious * answer and refusing it makes dynamic code worse; the boundary into a typed * f64 parameter does not, because there the annotation is somebody's stated * expectation and a mismatch is worth hearing about. * * Where this is sharper than the typed language is a *literal*. `(g 1)` * against `(defn g [x f64] ...)` compiles, because the checker gives the * literal the type the parameter asks for; a dyn value written as `1` has * already been through flan_dyn_from_i64 and cannot remember that it was a * literal. So the same source read as dyn traps where read as typed it does * not. That is a real divergence, it is the compiler's to close — by tagging * such a literal as a float where it can see the context — and it is written * down in the doc's boundary section so that closing it is a decision somebody * makes rather than a surprise somebody meets. Softening the check here is the * option not to take: this function sees a tag and nothing else, so it could * not tell (g 1) from (g (len xs)). */ double flan_dyn_need_f64(flan_dyn v) { if (flan_dyn_tag(v) != FLAN_DYN_TAG_FLOAT) trap1(TYPE_TRAP, "f64", "a float was wanted", v); return dyn_num_value(v); } uint8_t flan_dyn_need_bool(flan_dyn v) { if (flan_dyn_tag(v) != FLAN_DYN_TAG_BOOL) trap1(TYPE_TRAP, "bool", "a bool was wanted", v); return (uint8_t)(dyn_payload(v) ? 1 : 0); } /* ── Arithmetic ──────────────────────────────────────────────────────── * * Two ints answer an int; anything else numeric answers a float. The promotion * is the one place dyn is more permissive than the typed language, and the * case for it is that (+ 1 2.5) has exactly one sensible answer and a language * that refuses it is not dynamic in any useful sense. A program that wants the * refusal annotates, which is the whole bargain. * * Integer division and remainder by zero trap rather than answering. That * matches typed Flan, which signals ArithError and dies with "divide by zero" * if nothing handles it; the condition is not signalled here because a dyn * operation has no [loc] to report and no transfer channel in its hands, which * is the same reason the six traps in flan_rt.c park rather than signal. The * float case is left to IEEE — 1.0/0.0 is inf and that is an answer, not a * failure. * * The INT64_MIN / -1 pair overflows, and is the only pair that does. It gets * its own sentence for the reason flan_rt.c's gives it one: somebody meeting * it has probably never had to think about it. */ static void want_nums(const char *op, const char *why, flan_dyn a, flan_dyn b) { if (!is_num(a) || !is_num(b)) trap2(TYPE_TRAP, op, why, a, b); } #define ARITH_NUM "it takes two numbers" static flan_dyn arith(const char *op, flan_dyn a, flan_dyn b) { int64_t x, y; want_nums(op, ARITH_NUM, a, b); if (flan_dyn_tag(a) == FLAN_DYN_TAG_INT && flan_dyn_tag(b) == FLAN_DYN_TAG_INT) { x = dyn_int_value(a); y = dyn_int_value(b); switch (op[0]) { case '+': return flan_dyn_from_i64((int64_t)((uint64_t)x + (uint64_t)y)); case '-': return flan_dyn_from_i64((int64_t)((uint64_t)x - (uint64_t)y)); case '*': return flan_dyn_from_i64((int64_t)((uint64_t)x * (uint64_t)y)); case '/': if (y == 0) trap2(ARITH_TRAP, op, "it does not divide by zero", a, b); if (x == INT64_MIN && y == -1) trap2(ARITH_TRAP, op, "the quotient is one past the largest i64, which is true of " "this pair of operands and no other", a, b); return flan_dyn_from_i64(x / y); default: if (y == 0) trap2(ARITH_TRAP, op, "it does not divide by zero", a, b); if (x == INT64_MIN && y == -1) return flan_dyn_from_i64(0); return flan_dyn_from_i64(x % y); } } { double p = dyn_num_value(a), q = dyn_num_value(b); switch (op[0]) { case '+': return flan_dyn_from_f64(p + q); case '-': return flan_dyn_from_f64(p - q); case '*': return flan_dyn_from_f64(p * q); case '/': return flan_dyn_from_f64(p / q); default: /* No fmod, which would drag math.h in for one operator. The identity is * the definition of the remainder, and the trunc is what C's [%] does * for integers, so the two operators agree about sign. */ if (q == 0.0) return flan_dyn_from_f64(p - p); /* nan, by 0/0 */ { double t = p / q; double k; /* A quotient past 2^63 has no integer part this can name, and the * cast would be undefined rather than merely wrong. Every such * remainder is zero to the precision a double has left, so that is * what it answers — which is also fmod's answer. */ if (!(t > -9.2233720368547758e18 && t < 9.2233720368547758e18)) return flan_dyn_from_f64(t == t ? 0.0 : t); k = (t < 0) ? -(double)(int64_t)(-t) : (double)(int64_t)t; return flan_dyn_from_f64(p - k * q); } } } } 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 ────────────────────────────────────────────────────────── * * Numbers against numbers, text against text, and nothing else. Text orders * bytewise, which is [memcmp] with the shorter one first on a tie — the same * order a sort of a [(Vec string)] would want and the only order that needs no * locale, no collation table and no argument. * * A number against a text traps rather than answering. The temptation is to * order by tag so that every value is comparable and sorting never fails; the * reason not to is that the resulting order is an artefact of this file's tag * numbering, and a program that sorted a mixed vec would get a stable answer * that means nothing. */ static int order(const char *op, flan_dyn a, flan_dyn b) { if (is_num(a) && is_num(b)) { if (flan_dyn_tag(a) == FLAN_DYN_TAG_INT && flan_dyn_tag(b) == FLAN_DYN_TAG_INT) { int64_t x = dyn_int_value(a), y = dyn_int_value(b); return x < y ? -1 : (x > y ? 1 : 0); } { double p = dyn_num_value(a), q = dyn_num_value(b); /* NaN is unordered, and the honest answer is that it is neither less * than nor greater than anything. Reported as "greater" would make a * sort loop; reported as 2 lets each operator below answer false, which * is what IEEE says every one of them answers. */ if (p != p || q != q) return 2; return p < q ? -1 : (p > q ? 1 : 0); } } if (is_text(a) && is_text(b)) { flan_obj *x = dyn_obj(a), *y = dyn_obj(b); int64_t n = x->len < y->len ? x->len : y->len; int c = n > 0 ? memcmp(obj_text_bytes(x), obj_text_bytes(y), (size_t)n) : 0; if (c != 0) return c < 0 ? -1 : 1; return x->len < y->len ? -1 : (x->len > y->len ? 1 : 0); } trap2(TYPE_TRAP, op, "it compares two numbers or two texts, and these are neither", a, b); } flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(order("<", a, b) == -1); } flan_dyn flan_dyn_le(flan_dyn a, flan_dyn b) { int c = order("<=", a, b); return flan_dyn_from_bool(c == -1 || c == 0); } flan_dyn flan_dyn_gt(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool(order(">", a, b) == 1); } flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b) { int c = order(">=", a, b); return flan_dyn_from_bool(c == 1 || c == 0); } /* ── Equality ────────────────────────────────────────────────────────── * * Structural, and the only operation here that never traps: two values of * unrelated tags are unequal, which is an answer, and making it an error would * mean a dyn program could not ask "is this the string I expected" without * first checking that it is a string at all. * * A number equals a number by value across the two tags — (= 1 1.0) is true — * which is the same promotion the operators do and for the same reason. Text * is bytewise and not by identity: two separately built texts with the same * bytes are equal, and the doc's "string identity" section says why that is * the only defensible choice when a text is immutable. * * A vec is equal element by element, with an identity shortcut first. The * depth cap is the cycle stop: [set_at] lets a vec contain itself, and past * the cap two vecs are equal only if they are the same vec, which terminates * and answers correctly for the case that actually arises (a cycle compared * against itself). Two *distinct* cyclic vecs with the same shape answer * false, which is a wrong answer to a question nobody has asked yet; the * honest fix is a visited set and it can be added the day somebody needs it. */ #define EQ_DEPTH 64 static int dyn_equal(flan_dyn a, flan_dyn b, int depth) { int32_t ta = flan_dyn_tag(a), tb = flan_dyn_tag(b); if (a == b && ta != FLAN_DYN_TAG_FLOAT) return 1; if (is_num(a) && is_num(b)) { if (ta == FLAN_DYN_TAG_INT && tb == FLAN_DYN_TAG_INT) return dyn_int_value(a) == dyn_int_value(b); return dyn_num_value(a) == dyn_num_value(b); } if (ta != tb) return 0; if (ta == FLAN_DYN_TAG_TEXT) { flan_obj *x = dyn_obj(a), *y = dyn_obj(b); if (x->len != y->len) return 0; return x->len == 0 || memcmp(obj_text_bytes(x), obj_text_bytes(y), (size_t)x->len) == 0; } if (ta == FLAN_DYN_TAG_VEC) { flan_obj *x = dyn_obj(a), *y = dyn_obj(b); int64_t i; if (x == y) return 1; if (depth >= EQ_DEPTH) return 0; if (x->len != y->len) return 0; for (i = 0; i < x->len; i++) if (!dyn_equal(x->u.v.items[i], y->u.v.items[i], depth + 1)) return 0; return 1; } /* nil and bool, whose whole content is the payload the identity test above * already compared. Reached only when that test said no. */ return 0; } flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b) { return flan_dyn_from_bool((uint8_t)dyn_equal(a, b, 0)); } /* ── Containers ────────────────────────────────────────────────────────*/ flan_dyn flan_dyn_len(flan_dyn v) { if (is_text(v) || is_vec(v)) return flan_dyn_from_i64(dyn_obj(v)->len); trap1(TYPE_TRAP, "len", "only a text or a vec has one", v); } /* The index has to be an int, and that is a separate sentence from the * container being wrong: (at v "1") and (at 3 1) are two different mistakes * and telling somebody "these are the wrong types" names neither. */ static int64_t need_index(const char *op, flan_dyn v, flan_dyn i) { if (flan_dyn_tag(i) != FLAN_DYN_TAG_INT) trap2(TYPE_TRAP, op, "an index must be an int", v, i); return dyn_int_value(i); } /* A text answers a byte, as an int. That is what [(at s i)] on a * [(Slice u8)] does in the typed language, and a text is a run of bytes in * both. Codepoints are utf8's job and stay there. */ flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i) { int64_t k; flan_obj *o; if (!is_text(v) && !is_vec(v)) trap2(TYPE_TRAP, "at", "only a text or a vec is indexed", v, i); k = need_index("at", v, i); o = dyn_obj(v); if (k < 0 || k >= o->len) trap_range("at", v, k, o->len); if (o->kind == OBJ_TEXT) return flan_dyn_from_i64(obj_text_bytes(o)[k]); return o->u.v.items[k]; } void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x) { int64_t k; flan_obj *o; (void)x; if (is_text(v)) trap2(TYPE_TRAP, "set-at", "a text is immutable — build another one", v, i); if (!is_vec(v)) trap2(TYPE_TRAP, "set-at", "only a vec is assigned into", v, i); k = need_index("set-at", v, i); o = dyn_obj(v); if (k < 0 || k >= o->len) trap_range("set-at", v, k, o->len); o->u.v.items[k] = x; } void flan_dyn_push(flan_dyn v, flan_dyn x) { flan_obj *o; if (!is_vec(v)) { /* The value is in the sentence rather than the vec, because the vec is the * thing that is wrong and the value is what says which push it was. */ trap2(TYPE_TRAP, "push", "only a vec is pushed to", v, x); } o = dyn_obj(v); if (o->len == o->u.v.cap) { int64_t cap = o->u.v.cap ? o->u.v.cap * 2 : 8; flan_dyn *items = (flan_dyn *)realloc(o->u.v.items, (size_t)cap * sizeof *items); if (items == NULL) trap_oom(cap * (int64_t)sizeof *items); /* The growth is charged to the heap so the trigger sees it, and it is * charged *here* rather than at the next collection because a vec that * doubles a dozen times between allocations would otherwise be invisible * to the trigger until it was already large. */ gc_bytes += (cap - o->u.v.cap) * (int64_t)sizeof *items; o->u.v.items = items; o->u.v.cap = cap; } o->u.v.items[o->len++] = x; }