JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
flan/runtime/flan_dyn.c

1809 lines
75 KiB
C
Raw Blame History

/* 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 <stdint.h>
#include <stddef.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/* ── 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);
/* Growing a Vec through a dyn view borrows flan_rt.c's own growth: doubling,
* allocator adoption and the epoch check all live in [flan_vec_push], and
* re-implementing any of that here would be a second copy of logic the
* duplicity doctrine (docs/SPIKE-DUPLICITY.md) says belongs on one side only.
* [v] is declared [void *] rather than [flan_vec *] so this file need not
* name flan_rt.c's type; the two structs' layouts must agree, which is
* [flan_dyn_vec_hdr] below, restated for the same reason [flan_desc] is. */
int8_t flan_vec_push(void *v, const void *elem, int64_t size, int64_t align,
const uint8_t *loc, int64_t loclen);
/* ── 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 5, 6 and 7 are unspoken for — keywords and maps took 4 and BOX_OBJ's
* [kind] field, not new top-level tags — 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;
/* A type's dyn map: where the dyn words are inside one instance of it. The
* compiler emits one of these per type that has any, as static data, and hands
* a pointer to it to [flan_dyn_root_push_desc]. Nothing here ever writes one.
* [size] is not read by the collector; it is the stride an array of the type
* has, which is what the typed-container view will need. */
typedef struct flan_desc {
int64_t size;
int64_t n;
const int64_t *offs;
} flan_desc;
#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
/* A keyword. The payload is a pointer to an interned entry that is not a GC
* object at all: keywords are immortal by construction — the intern table
* below holds the only copy of each name, nothing ever removes one, and the
* collector never sees the tag ([mark_value] walks BOX_OBJ and nothing else).
* Interning is what buys the Lisp symbol model: two keywords with the same
* name are the same word, so equality is the identity compare [dyn_equal]
* already opens with, never a memcmp. */
#define BOX_KW 4u
/* Restated from flan_dyn.h — a view's element kind. */
#define FLAN_VIEW_I64 0
#define FLAN_VIEW_F64 1
#define FLAN_VIEW_BOOL 2
/* 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 */
#define OBJ_MAP 3 /* keys and values interleaved: k0 v0 k1 v1 ... */
#define OBJ_VIEW 4 /* a typed container crossing into dyn as a view */
/* flan_vec, restated. This file must not name flan_rt.c's [flan_vec] — see
* the "if either table changes, change both" note above [flan_vec_push] —
* so a view over a [(Vec T)] is built from an address whose first five words
* this mirrors exactly. Only [ptr], [len] and [epoch]/[alloc] are ever read
* through it; nothing here writes one. */
typedef struct flan_dyn_vec_hdr {
void *ptr;
int64_t len;
int64_t cap;
void *alloc;
int64_t epoch;
} flan_dyn_vec_hdr;
/* This mirror's own layout, reported the same way flan_rt.c's
* [flan_vec_layout] reports the original's — see that function's comment
* for what ties the two together and why nothing at compile time otherwise
* does. */
void flan_dyn_vec_hdr_layout(int64_t out[6]) {
out[0] = (int64_t)sizeof(flan_dyn_vec_hdr);
out[1] = (int64_t)offsetof(flan_dyn_vec_hdr, ptr);
out[2] = (int64_t)offsetof(flan_dyn_vec_hdr, len);
out[3] = (int64_t)offsetof(flan_dyn_vec_hdr, cap);
out[4] = (int64_t)offsetof(flan_dyn_vec_hdr, alloc);
out[5] = (int64_t)offsetof(flan_dyn_vec_hdr, epoch);
}
/* flan_allocator's prefix, far enough to read the one word a stale-container
* check needs. The struct has more fields after [epoch]; this file never
* touches them; and the alignment of a leading same-typed prefix is the same
* in any translation unit that agrees on the field order, which is the
* "change both" this comment is the other half of. */
typedef struct flan_dyn_alloc_hdr {
void *proc;
void *data;
uint32_t caps;
uint64_t epoch;
} flan_dyn_alloc_hdr;
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 or entries
of a map */
union {
int64_t i; /* OBJ_INT */
struct { flan_dyn *items; int64_t cap; } v; /* OBJ_VEC and OBJ_MAP —
a map shares the vec's arm on purpose: its entries are the same malloc
block of dyn words, interleaved key then value, with [len] counting
entries and [cap] counting entries too. Sharing the arm is what lets the
marker and the sweep treat the two kinds with one load and a doubled
count rather than a second field to keep in step. */
/* OBJ_VIEW: a typed container's elements, native words this file did not
allocate and does not own. [is_vec] set means [base] is a
[flan_dyn_vec_hdr *] and [len] here is unused — the live length is
read from the header on every operation, which is the whole of why a
Vec growing through the view cannot go stale. [is_vec] clear means
[base] is the first element's address and [len] is the snapshot taken
at the crossing, for a slice or a fixed array, neither of which moves.
[elem] is one of FLAN_VIEW_I64/F64/BOOL. */
struct { void *base; int64_t len; int32_t elem; int32_t is_vec; } view;
/* OBJ_TEXT's bytes trail the header; see [obj_text_bytes]. */
} u;
} flan_obj;
/* How many dyn words hang off an object's items block — the count the marker
* walks and the sweep charges. A map holds two per entry.
*
* OBJ_VIEW answers 0 explicitly rather than falling into the [o->len] arm.
* [mark_push] never puts a view on the mark stack — it traces only
* OBJ_VEC/OBJ_MAP — so this is not reachable today, but [o->u.view.base]
* aliases [o->u.v.items] in the union, and a native array of i64 or f64
* reinterpreted as dyn words is exactly the kind of thing this file's
* roots contract exists to prevent happening by accident. Answering 0 here
* is what keeps a future change to the marking gate from silently trusting
* this function's default arm instead of failing loudly. */
static inline int64_t obj_words(flan_obj *o) {
if (o->kind == OBJ_VIEW) return 0;
return o->kind == OBJ_MAP ? o->len * 2 : o->len;
}
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 the
* addresses, so growing it moves the array and not the slots.
*
* A root is an address and a shape. The shape is NULL for the common case —
* the address is a dyn word and marking it is one call — and a [flan_desc] for
* an aggregate, which is a struct or an array of them with dyn fields
* somewhere inside. The descriptor is static data the compiler emitted for
* that type, and the pairing of address with descriptor is made at the *push*,
* by the code that knows what is at that address, which is why nothing in the
* heap or on the stack needs a header word for the collector to read. See
* flan_dyn.h's [flan_dyn_root_push_desc] for the whole of that argument. */
typedef struct {
void *base;
const flan_desc *desc; /* NULL: [base] is one flan_dyn */
} flan_root;
static flan_root *roots;
static int64_t roots_n, roots_cap;
/* How much of the bottom of that stack belongs to the globals rather than to
* any frame. The globals are pushed once, before the first frame runs, and
* never popped — so they are exactly the entries below this line, and every
* frame's roots are exactly the entries above it. Zero until a [main] says
* otherwise, which is also the right answer for a program that has no dyn
* globals to push. See [flan_dyn_root_globals_begin]. */
static int64_t roots_base;
/* ── 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", "keyword", "map" };
#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
#define FLAN_DYN_TAG_KEYWORD 6
#define FLAN_DYN_TAG_MAP 7
static inline flan_obj *dyn_obj(flan_dyn v) {
return (flan_obj *)(uintptr_t)dyn_payload(v);
}
/* An interned keyword's entry: the name's bytes trail the length, one malloc
* per distinct name, never freed. Not a flan_obj — the collector has no
* business with something immortal — and the tag alone says which it is. */
typedef struct kw_entry {
int64_t len;
/* bytes trail */
} kw_entry;
static inline kw_entry *dyn_kw(flan_dyn v) {
return (kw_entry *)(uintptr_t)dyn_payload(v);
}
static inline uint8_t *kw_bytes(kw_entry *k) { return (uint8_t *)(k + 1); }
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;
case BOX_KW: return FLAN_DYN_TAG_KEYWORD;
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;
/* A view answers the same tag a heap vec does: from a dyn program's
side there is nothing to tell them apart by, which is the point of a
view being indistinguishable rather than a fourth kind of vec. */
case OBJ_VEC: return FLAN_DYN_TAG_VEC;
case OBJ_VIEW: return FLAN_DYN_TAG_VEC;
case OBJ_MAP: return FLAN_DYN_TAG_MAP;
default: return FLAN_DYN_TAG_INT;
}
}
}
}
const char *flan_dyn_tag_name(int32_t tag) {
if (tag < 0 || tag > FLAN_DYN_TAG_MAP) 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 `<vec>` 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_char], which is where the typed side's printers —
* [flan_escape_bytes] and flan_dev.c's emitters — now share their one copy of
* it: printers that disagree about what a string looks like are that many
* wire formats.
*
* This copy is deliberate, and the argument for it is docs/SPIKE-DUPLICITY.md
* §9's: the dyn printer lives inside the runtime that owns the storage it
* walks, which is why it prints a dyn vec structurally where the typed
* printer answers <vec>. The whole printer is this side's; the table it
* shares with the other side is the part that must not drift. 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);
/* forward: the view helpers, needed by [render] and [say_render] above where
* they are defined, alongside the container operations below */
static int64_t view_len(const char *op, flan_obj *o);
static void *view_base(flan_obj *o);
static flan_dyn view_box(int32_t elem, const uint8_t *p);
static int64_t view_elem_size(int32_t elem);
/* forward: needed by [dyn_equal] below, defined alongside the view helpers
* further down — a length and an element reader that answer correctly
* whether [o] is an ordinary heap vec or a view over a typed container. */
static int64_t vecish_len(flan_obj *o);
static flan_dyn vecish_at(flan_obj *o, int64_t i);
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;
}
/* A keyword prints with its colon, bare, at every depth: :a is its own
* spelling the way true is, and quoting it would make it a text. */
case FLAN_DYN_TAG_KEYWORD: {
kw_entry *k = dyn_kw(v);
emit(":");
emit_n(kw_bytes(k), k->len);
return;
}
/* The map prints in edn's shape with the vec's spacing: a space before
* every element, key and value alike, so { :a 1 :b 2} sits beside the vec's
* [ 1 2 3] rather than inventing a fourth convention. Entries come out in
* insertion order, which is the only order the representation has. */
case FLAN_DYN_TAG_MAP: {
flan_obj *o = dyn_obj(v);
int64_t i;
emit("{");
for (i = 0; i < o->len; i++) {
emit(" ");
render(o->u.v.items[i * 2], depth + 1, 1);
emit(" ");
render(o->u.v.items[i * 2 + 1], depth + 1, 1);
}
emit("}");
return;
}
default: {
flan_obj *o = dyn_obj(v);
int64_t i, n = o->kind == OBJ_VIEW ? view_len("print", o) : o->len;
emit("[");
for (i = 0; i < n; i++) {
emit(" ");
if (o->kind == OBJ_VIEW)
render(view_box(o->u.view.elem,
(const uint8_t *)view_base(o)
+ i * view_elem_size(o->u.view.elem)),
depth + 1, 1);
else
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;
}
case FLAN_DYN_TAG_KEYWORD: {
kw_entry *k = dyn_kw(v);
int64_t i;
say_puts(s, ":");
for (i = 0; i < k->len && s->n < s->cap - 6; i++) {
char c[2];
c[0] = (char)kw_bytes(k)[i];
c[1] = '\0';
say_puts(s, c);
}
if (i < k->len) say_puts(s, "...");
return;
}
case FLAN_DYN_TAG_MAP: {
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 * 2], depth + 1);
say_puts(s, " ");
say_render(s, o->u.v.items[i * 2 + 1], depth + 1);
}
say_puts(s, i < o->len ? " ...}" : "}");
return;
}
default: {
flan_obj *o = dyn_obj(v);
int64_t i, n = o->kind == OBJ_VIEW ? view_len("print", o) : o->len;
if (depth >= 2) { say_puts(s, "[...]"); return; }
say_puts(s, "[");
for (i = 0; i < n && s->n < s->cap - 8; i++) {
say_puts(s, " ");
if (o->kind == OBJ_VIEW)
say_render(s,
view_box(o->u.view.elem,
(const uint8_t *)view_base(o)
+ i * view_elem_size(o->u.view.elem)),
depth + 1);
else
say_render(s, o->u.v.items[i], depth + 1);
}
say_puts(s, i < n ? " ...]" : "]");
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 and a map have 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 && o->kind != OBJ_MAP) 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++) {
const flan_desc *d = roots[i].desc;
if (d == NULL) mark_value(*(flan_dyn *)roots[i].base);
else {
int64_t j;
for (j = 0; j < d->n; j++)
mark_value(*(flan_dyn *)((char *)roots[i].base + d->offs[j]));
}
}
for (k = 0; k < RING; k++) mark_push(ring[k]);
while (mstack_n > 0) {
flan_obj *o = mstack[--mstack_n];
int64_t n = obj_words(o);
for (i = 0; i < n; 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 || o->kind == OBJ_MAP) {
int64_t per = o->kind == OBJ_MAP ? 2 : 1;
held += o->u.v.cap * per * (int64_t)sizeof(flan_dyn);
free(o->u.v.items);
}
gc_bytes -= held;
gc_count--;
*link = next;
free(o);
}
o = next;
}
}
static void root_add(void *base, const flan_desc *d) {
if (roots_n == roots_cap) {
int64_t cap = roots_cap ? roots_cap * 2 : 64;
flan_root *r = (flan_root *)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].base = base;
roots[roots_n].desc = d;
roots_n++;
}
void flan_dyn_root_push(flan_dyn *slot) { root_add(slot, NULL); }
/* The aggregate form. One entry on the same stack, so one [flan_dyn_root_pop]
* takes off a mixture of the two and a function's pop count stays the number
* of pushes it made. A NULL descriptor is not an error — it is a type the
* compiler found no dyn in — but it still occupies an entry, because the count
* is what the epilogue knows, and it is turned into an empty descriptor rather
* than stored as NULL, which on this stack means something else. */
static const flan_desc desc_empty = { 0, 0, NULL };
void flan_dyn_root_push_desc(void *base, const flan_desc *d) {
root_add(base, d == NULL ? &desc_empty : d);
}
/* Clamped at the globals 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. The floor is [roots_base] and not
* zero because the globals under it were never any frame's to pop: an
* over-popping frame taking them with it is the one way this clamp could turn
* a miscount into a use-after-free. */
void flan_dyn_root_pop(int64_t n) {
if (n <= 0) return;
roots_n = roots_n - n > roots_base ? roots_n - n : roots_base;
}
/* The two halves of "the globals are the bottom of this stack".
*
* [begin] empties it outright, because a re-entered [main] is about to push
* the same globals again and the entries the previous run left are the ones
* that would be duplicated. [end] records how many of them there are.
*
* Nothing between the two may allocate: between them the globals hold whatever
* the previous run left in them and are not rooted, so a collection there
* would sweep values the slots still point at. The emitted [main] calls
* [begin] immediately before the pushes and [end] immediately after, with only
* the pushes in between, which is what makes that hold. */
void flan_dyn_root_globals_begin(void) { roots_n = 0; roots_base = 0; }
void flan_dyn_root_globals_end(void) { roots_base = roots_n; }
void flan_dyn_root_reset(void) { roots_n = roots_base; }
/* ── 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);
}
flan_dyn flan_dyn_map_new(void) {
flan_obj *o = gc_alloc(OBJ_MAP, 0);
o->len = 0;
o->u.v.items = NULL;
o->u.v.cap = 0;
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
}
/* ── Keywords ──────────────────────────────────────────────────────────
*
* One global table, append-only, never freed: a keyword is a *name*, the set
* of names a program uses is written in its source (plus whatever an edn file
* contributes), and a name is not something the collector should be asked to
* prove liveness of. Interning here rather than at each site is what makes
* two spellings of :a one word — the constructor scans for the bytes and
* answers the entry that already holds them, so keyword equality upstream is
* the identity compare and never touches the bytes again.
*
* The scan is linear. A structural hash would repay itself on a program with
* thousands of distinct keywords; a config file has dozens, every literal in
* compiled code could be hoisted to one construction the day it matters, and
* a table this simple has nothing in it to get wrong. */
static kw_entry **kws;
static int64_t kws_n, kws_cap;
flan_dyn flan_dyn_kw(const uint8_t *p, int64_t n) {
int64_t i;
kw_entry *k;
if (n < 0) n = 0;
for (i = 0; i < kws_n; i++) {
k = kws[i];
if (k->len == n && (n == 0 || memcmp(kw_bytes(k), p, (size_t)n) == 0))
return dyn_make(BOX_KW, (uint64_t)(uintptr_t)k);
}
if (kws_n == kws_cap) {
int64_t cap = kws_cap ? kws_cap * 2 : 32;
kw_entry **t = (kw_entry **)realloc(kws, (size_t)cap * sizeof *t);
if (t == NULL) trap_oom(cap * (int64_t)sizeof *t);
kws = t;
kws_cap = cap;
}
k = (kw_entry *)malloc(sizeof(kw_entry) + (size_t)n);
if (k == NULL) trap_oom((int64_t)sizeof(kw_entry) + n);
k->len = n;
if (n > 0) memcpy(kw_bytes(k), p, (size_t)n);
kws[kws_n++] = k;
return dyn_make(BOX_KW, (uint64_t)(uintptr_t)k);
}
/* ── 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);
}
/* ── A numeric cast opening a box, FIX.org 2026-09-20 ───────────────────
*
* [(f64 d)] on a dyn. The *conversion* is not done here: [check.ml] lowers
* such a cast to a branch on this function's answer, and each arm is the
* ordinary [flan_dyn_need_i64]/[flan_dyn_need_f64] followed by the cast the
* emitter already emits for a typed argument of that type. So this function
* decides one thing — which of the two numeric tags the box holds — and
* everything about the arithmetic (the fptosi range check, NaN, the
* narrowing rule) stays where it already was, identical in both backends and
* identical to the typed spelling of the same cast.
*
* Answers 1 for a float box, 0 for an int box. Every other tag traps, with
* the same [trap1] sentence the typed boundary's own refusals use — bool
* included, which mirrors [flan_dyn_need_i64] refusing a bool today rather
* than inventing a new rule for casts.
*
* [want_float] is what the *target* type is: 1 for f32/f64, 0 for the
* integer widths. When it disagrees with the box, the cast still happens —
* the author's call, "just coerce it with a warning" — and the warning below
* is the whole of what the disagreement costs. A cast is already a
* conversion operator, [(f64 5)] converts a typed integer, so converting
* across the box is the cast doing its job; the warning exists because the
* box's kind was not what the program apparently expected.
*
* Once per *site*, not per value. These casts sit in per-cell-per-frame
* loops — sand.flan runs at 120fps — and a per-occurrence line would be a
* flood rather than a diagnostic. The site is the [loc] text [check.ml]
* passes in, and the table below is keyed on its *bytes* rather than its
* address: the two backends emit their own constants for it and neither
* promises that two mentions of one site share one pointer.
*
* The table is fixed and small because it is only ever as large as the
* number of cross-kind cast sites a program has, which is a handful in the
* programs this was written for. A program with more than [SITE_MAX] of them
* stops deduplicating for the overflow — it still warns, every time, which
* is the noisy failure rather than the silent one. Not thread-safe, and
* deliberately: a duplicated or dropped line under a race is a diagnostic
* that came out twice, and the alternative is a lock on a path that runs per
* cast in a frame loop. */
#define SITE_MAX 64
static struct { const uint8_t *ptr; int64_t len; } warned_sites[SITE_MAX];
static int warned_count;
static int site_first_time(const uint8_t *loc, int64_t loc_len) {
for (int i = 0; i < warned_count; i++)
if (warned_sites[i].len == loc_len &&
memcmp(warned_sites[i].ptr, loc, (size_t)loc_len) == 0)
return 0;
if (warned_count < SITE_MAX) {
warned_sites[warned_count].ptr = loc;
warned_sites[warned_count].len = loc_len;
warned_count++;
}
return 1;
}
int32_t flan_dyn_cast_kind(flan_dyn v, const uint8_t *loc, int64_t loc_len,
const uint8_t *target, int64_t target_len,
int32_t want_float) {
int32_t tag = flan_dyn_tag(v);
if (tag != FLAN_DYN_TAG_INT && tag != FLAN_DYN_TAG_FLOAT) {
/* [trap1] takes the operation as a C string and the target is a Flan
* slice, so it is copied out. Every cast name is two or three bytes; the
* clamp is for a caller this file cannot see. */
char name[8];
size_t n = (size_t)target_len < sizeof name - 1 ? (size_t)target_len
: sizeof name - 1;
memcpy(name, target, n);
name[n] = '\0';
trap1(TYPE_TRAP, name, "a number was wanted", v);
}
int32_t is_float = tag == FLAN_DYN_TAG_FLOAT ? 1 : 0;
if (is_float != (want_float ? 1 : 0) && site_first_time(loc, loc_len)) {
fflush(stdout);
fprintf(stderr,
"flan %.*s: (%.*s x) found a dyn holding %s, and converted it to "
"%.*s — warned once for this site\n",
(int)loc_len, (const char *)loc, (int)target_len,
(const char *)target, tag_of(v), (int)target_len,
(const char *)target);
}
return is_float;
}
/* nil <-> None at an (Option T) boundary. Cannot trap — every dyn value
* answers this one way or the other. */
int32_t flan_dyn_is_nil(flan_dyn v) {
return flan_dyn_tag(v) == FLAN_DYN_TAG_NIL ? 1 : 0;
}
/* (Some nil)'s run-time half: a dyn value the checker could not see was nil
* at compile time, reaching Some anyway. [op] is "some" rather than a Flan
* spelling of the call, matching how every other dyn trap here names the
* operation that refused. */
flan_dyn flan_dyn_need_not_nil(flan_dyn v) {
if (flan_dyn_tag(v) == FLAN_DYN_TAG_NIL)
trap1(TYPE_TRAP, "some",
"Some cannot hold nil -- nil and None would become the same case "
"of an (Option dyn)", v);
return v;
}
/* Clojure's truthiness, not C's or Python's: nil and false are the only
* falsey values, and everything else — 0, 0.0, "", an empty vec, an empty
* map, any keyword — is truthy. Never traps; every tag answers. */
uint8_t flan_dyn_truthy(flan_dyn v) {
int32_t t = flan_dyn_tag(v);
if (t == FLAN_DYN_TAG_NIL) return 0;
if (t == FLAN_DYN_TAG_BOOL) return (uint8_t)(dyn_payload(v) ? 1 : 0);
return 1;
}
/* ── 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, xn, yn;
if (x == y) return 1;
if (depth >= EQ_DEPTH) return 0;
/* [x]/[y] may each be an ordinary heap vec or a view (M2 item 3) — the
tag does not say which, so [vecish_len]/[vecish_at] below read either
shape correctly. Reading raw through [x->u.v.items] the way this arm
used to is wrong for a view: nothing sets [len] for OBJ_VIEW, so it
reads back 0, and the elements alias [u.view.base] reinterpreted as
dyn words — two views with different contents would compare equal, a
view and an equal heap vec would compare unequal, and a map keyed by
any view would collide with every other view, silently, with nothing
to crash. */
xn = vecish_len(x);
yn = vecish_len(y);
if (xn != yn) return 0;
for (i = 0; i < xn; i++)
if (!dyn_equal(vecish_at(x, i), vecish_at(y, i), depth + 1)) return 0;
return 1;
}
/* Two maps are equal when they hold the same keys and each key answers an
* equal value — by lookup and never by position, because two maps built by
* inserting the same pairs in different orders are the same map. Sizes are
* compared first, so one lookup per entry of x is the whole walk: every key
* of x found in y at equal size means every key of y was found. Quadratic,
* like everything else about this map, and wrong to be clever about before
* the linear scan itself is. */
if (ta == FLAN_DYN_TAG_MAP) {
flan_obj *x = dyn_obj(a), *y = dyn_obj(b);
int64_t i, j;
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++) {
flan_dyn k = x->u.v.items[i * 2];
int found = 0;
for (j = 0; j < y->len; j++) {
if (dyn_equal(k, y->u.v.items[j * 2], depth + 1)) {
if (!dyn_equal(x->u.v.items[i * 2 + 1], y->u.v.items[j * 2 + 1],
depth + 1))
return 0;
found = 1;
break;
}
}
if (!found) return 0;
}
return 1;
}
/* nil, bool and keyword, whose whole content the identity test above
* already compared — a keyword's bytes were interned into exactly one
* entry, so two keywords are equal iff they are the same word. 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 ────────────────────────────────────────────────────────*/
static inline int is_map(flan_dyn v) {
return flan_dyn_tag(v) == FLAN_DYN_TAG_MAP;
}
/* ── Typed containers as views ─────────────────────────────────────────
*
* Every entry point below already dispatches on [flan_dyn_tag], which does
* not distinguish a view from a heap vec — see [flan_dyn_tag]'s switch — so
* [flan_dyn_len], [flan_dyn_at], [flan_dyn_set_at], [flan_dyn_push] and the
* printer each add one branch for [OBJ_VIEW] beside the existing [OBJ_VEC]
* one. What follows is that branch's machinery. */
static int64_t view_elem_size(int32_t elem) {
return elem == FLAN_VIEW_BOOL ? 1 : 8;
}
/* The stale-container check flan_rt.c's [flan_vec_check] runs for a typed
* Vec, restated for a view's own trap rather than reused: the duplicity
* doctrine's dyn side gets its own spelling (docs/SPIKE-DUPLICITY.md), and a
* dyn program that hits this wants the same park-and-inspect [flan_trap]
* gives every other dyn mistake, not the typed side's [rt_die]. A Vec with
* no allocator yet — one nobody has pushed to — has nothing to check.
*
* The message never renders the view it just declared unsafe to read —
* review's second finding, and it was not a decoration this dropped for
* safety's sake, it was a real infinite recursion: [say] on a view calls
* [say_render]'s view branch, which calls [view_len], which calls back in
* here, unconditionally, because the epoch is still stale. Every render of
* this same view would hit the same check and take the same branch, so
* nothing about depth or a visited set closes it — the fix is that a
* stale-container check must never read the container it has just refused
* to trust, not even to describe it in the sentence explaining why. */
static void view_vec_check(const char *op, flan_dyn_vec_hdr *h) {
if (h->alloc) {
flan_dyn_alloc_hdr *a = (flan_dyn_alloc_hdr *)h->alloc;
if ((int64_t)a->epoch != h->epoch) {
fflush(stdout);
fprintf(stderr,
"dyn %s: this view's container's allocator was released — the "
"Vec was made at epoch %lld and the allocator is at %lld now\n",
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
flan_trap((const uint8_t *)"DynRange", 8);
}
}
}
/* [len] and [base], read live for a Vec view (so a push that grows and
* moves the underlying Vec is seen the very next operation) and read from
* the snapshot for a flat one. */
static int64_t view_len(const char *op, flan_obj *o) {
if (o->u.view.is_vec) {
flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)o->u.view.base;
view_vec_check(op, h);
return h->len;
}
return o->u.view.len;
}
static void *view_base(flan_obj *o) {
if (o->u.view.is_vec) return ((flan_dyn_vec_hdr *)o->u.view.base)->ptr;
return o->u.view.base;
}
/* Reads box the element on the way out — the runtime already knows how to
* box an i64, an f64 or a bool, so this is that, from raw bytes rather than
* from a C value already in hand. */
static flan_dyn view_box(int32_t elem, const uint8_t *p) {
switch (elem) {
case FLAN_VIEW_I64: { int64_t x; memcpy(&x, p, 8); return flan_dyn_from_i64(x); }
case FLAN_VIEW_F64: { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); }
default: { uint8_t b = *p; return flan_dyn_from_bool(b); }
}
}
/* A length and an element reader that answer correctly whether [o] is an
* ordinary heap vec (OBJ_VEC, elements are dyn words) or a view over a
* typed container (OBJ_VIEW, elements are native bytes boxed on the way
* out) — the pair [dyn_equal]'s VEC arm needs so that a view compares
* correctly against another view and against an ordinary vec alike. Reading
* [o->len]/[o->u.v.items] directly, the way that arm used to, answers 0 and
* garbage for a view: nothing sets [len] for OBJ_VIEW, and its elements
* alias [u.view.base] reinterpreted as dyn words rather than the native
* bytes they are. */
static int64_t vecish_len(flan_obj *o) {
return o->kind == OBJ_VIEW ? view_len("=", o) : o->len;
}
static flan_dyn vecish_at(flan_obj *o, int64_t i) {
if (o->kind == OBJ_VIEW)
return view_box(o->u.view.elem,
(const uint8_t *)view_base(o)
+ i * view_elem_size(o->u.view.elem));
return o->u.v.items[i];
}
/* Writes tag-check on the way in: the dyn value's tag must be the one this
* view's element type wants, or this traps by name and never coerces or
* truncates a mismatched value into the slot. [v] is the view, for the
* sentence's container half; [x] is the value that was refused. */
static void view_unbox(const char *op, flan_dyn v, int32_t elem, flan_dyn x,
uint8_t *p) {
switch (elem) {
case FLAN_VIEW_I64: {
int64_t n;
if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT)
trap2(TYPE_TRAP, op, "this view's elements are int", v, x);
n = dyn_int_value(x);
memcpy(p, &n, 8);
return;
}
case FLAN_VIEW_F64: {
double d;
if (flan_dyn_tag(x) != FLAN_DYN_TAG_FLOAT)
trap2(TYPE_TRAP, op, "this view's elements are float", v, x);
d = dyn_num_value(x);
memcpy(p, &d, 8);
return;
}
default: {
uint8_t b;
if (flan_dyn_tag(x) != FLAN_DYN_TAG_BOOL)
trap2(TYPE_TRAP, op, "this view's elements are bool", v, x);
b = dyn_payload(x) ? 1 : 0;
*p = b;
return;
}
}
}
flan_dyn flan_dyn_view_vec(void *hdr, int32_t elem) {
flan_obj *o = gc_alloc(OBJ_VIEW, 0);
o->u.view.base = hdr;
o->u.view.len = 0;
o->u.view.elem = elem;
o->u.view.is_vec = 1;
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
}
flan_dyn flan_dyn_view_flat(void *data, int64_t len, int32_t elem) {
flan_obj *o = gc_alloc(OBJ_VIEW, 0);
o->u.view.base = data;
o->u.view.len = len;
o->u.view.elem = elem;
o->u.view.is_vec = 0;
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
}
flan_dyn flan_dyn_len(flan_dyn v) {
if (is_text(v) || is_map(v)) return flan_dyn_from_i64(dyn_obj(v)->len);
if (is_vec(v)) {
flan_obj *o = dyn_obj(v);
if (o->kind == OBJ_VIEW) return flan_dyn_from_i64(view_len("len", o));
return flan_dyn_from_i64(o->len);
}
trap1(TYPE_TRAP, "len", "only a text, a vec or a map 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 (o->kind == OBJ_VIEW) {
int64_t len = view_len("at", o);
if (k < 0 || k >= len) trap_range("at", v, k, len);
return view_box(o->u.view.elem,
(const uint8_t *)view_base(o) + k * view_elem_size(o->u.view.elem));
}
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;
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 (o->kind == OBJ_VIEW) {
int64_t len = view_len("set-at", o);
uint8_t *p;
if (k < 0 || k >= len) trap_range("set-at", v, k, len);
p = (uint8_t *)view_base(o) + k * view_elem_size(o->u.view.elem);
view_unbox("set-at", v, o->u.view.elem, x, p);
return;
}
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->kind == OBJ_VIEW) {
uint8_t buf[8];
static const uint8_t push_loc[] = "(dyn push)";
int64_t size;
if (!o->u.view.is_vec)
trap2(TYPE_TRAP, "push",
"this view is a slice or an array and cannot grow", v, x);
size = view_elem_size(o->u.view.elem);
view_unbox("push", v, o->u.view.elem, x, buf);
if (!flan_vec_push(o->u.view.base, buf, size, size, push_loc,
(int64_t)sizeof(push_loc) - 1))
trap_oom(size);
return;
}
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;
}
/* ── Maps ──────────────────────────────────────────────────────────────
*
* Association pairs in one block, scanned linearly with the structural
* equality above. Not a hash table, and that is a decision rather than a
* shortcut deferred: hashing dyn values structurally means a hash function
* over every tag kept in step with [dyn_equal] forever — the exact same-side
* duplication the duplicity audit warns the typed side's printers into — and
* the maps this exists for are documents read from files, tens of entries.
* "The answer to 'I need more performance' will never be a faster GC"; nor
* will it be a faster dyn map. Type the program.
*
* A key occurs once: [set] replaces the value of an equal key in place, which
* is what makes a map keyed by anything — including another map — a set with
* dedup for free. Insertion order is preserved and is the print order.
*
* Absence answers nil rather than trapping. A key that is not in a map is an
* answer to a question the caller was allowed to ask — the same line [eq]
* takes about unrelated tags — and nil is the value FIX.org's queue says
* arrives with maps. [contains] is the question to ask when nil might also be
* *stored*, and both are here so neither has to be guessed from the other. */
static int64_t map_find(flan_obj *o, flan_dyn k) {
int64_t i;
for (i = 0; i < o->len; i++)
if (dyn_equal(o->u.v.items[i * 2], k, 0)) return i;
return -1;
}
static flan_obj *want_map(const char *op, flan_dyn m, flan_dyn k) {
if (!is_map(m)) trap2(TYPE_TRAP, op, "only a map answers it", m, k);
return dyn_obj(m);
}
flan_dyn flan_dyn_map_get(flan_dyn m, flan_dyn k) {
flan_obj *o = want_map("get", m, k);
int64_t i = map_find(o, k);
return i < 0 ? flan_dyn_nil() : o->u.v.items[i * 2 + 1];
}
flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) {
flan_obj *o = want_map("has-key?", m, k);
return flan_dyn_from_bool(map_find(o, k) >= 0);
}
void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) {
flan_obj *o = want_map("put", m, k);
int64_t i = map_find(o, k);
if (i >= 0) {
o->u.v.items[i * 2 + 1] = v;
return;
}
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 * 2 * sizeof *items);
if (items == NULL) trap_oom(cap * 2 * (int64_t)sizeof *items);
/* Charged now for the reason push's growth is: the trigger has to see
* the block while it is growing, not after. */
gc_bytes += (cap - o->u.v.cap) * 2 * (int64_t)sizeof *items;
o->u.v.items = items;
o->u.v.cap = cap;
}
o->u.v.items[o->len * 2] = k;
o->u.v.items[o->len * 2 + 1] = v;
o->len++;
}
Reference in New Issue View Git Blame Copy Permalink