Constraints parsing peeled a body-leading map only when its first key was
literally :where; any other keyword fell through to the body, so a typo'd
key surfaced as a baffling error from inside what was meant as a predicate
and a stray map at body start compiled away silently. Any keyword-first map
is read as a constraint map now, but only when something follows it in the
body — a single-form map body is a real dyn value and not a discarded
statement, so that case is left alone.
An empty map literal still parses as a struct literal, (P {}) still meaning
the zero struct for a real struct name — the parser has no symbol table to
tell (take {}) apart from it at that point. check.ml now catches the case
where the name turns out to be a known function instead and says so, rather
than "unknown struct take".
flan_dyn.c's tag comment still said 6 and 7 were free; keywords and maps
took 4 and a kind field under BOX_OBJ, not new top-level tags, so 5, 6 and 7
are what is actually open for the interop handle. NEXT.md and json.flan both
still pointed at test/programs/arena-edn.flan, gone since edn/read stopped
taking an allocator; both now point at what replaced it.
flan_rt.c's flan_str_eq comment claimed the empty string literal was a
hypothetical null-pointer string; it isn't, its address is an interned
symbol's. The real case the zero-length guard exists for is a zero-length
container converted to a string. check.ml's ordering refusal said a string
has no comparison at all, which stopped being true when typed = and !=
grew strings in daed039 — split the message so an equality refusal and an
ordering refusal say the right noun, and updated the pinned rejects_check
rows to match. string-eq.flan gained the row the fast path most wants
tested, a slice against the prefix it was cut from sharing a base pointer at
different lengths, plus a != row at equal length with differing bytes;
acceptance now carries the real output, captured by running the program on
all three lanes. x86.ml's xor-1 comment now names the 0/1 return contract as
a requirement flan_str_eq must hold, not an incidental fact. SPIKE-DUPLICITY
now says plainly that its equality-and-ordering argument landed in daed039
and marks its transcript as the historical state that argument was made
against. FIX.org ticks M2 queue item 5.
And the acceptance runner: the tail check that turns a nonzero failure count
into exit 1 was already there and already fired — a fresh build with one row
broken already exited 1 before anything here changed. What wasn't proven is
that every path through the file's clang/wasmtime/raylib/lldb probes still
reaches that tail rather than skipping past rows that already failed. An
at_exit guard now closes that class regardless of which path the process
leaves by, flushing stdout first so a failing run's FAIL lines survive
Unix._exit rather than being dropped from the buffer. Verified both
directions with a deliberately broken row: dune test exits nonzero and the
log still carries the FAIL line and the failure count; restored, the same
run is exit 0 with nothing printed but green summaries. The other test
binaries were checked for the same gap and none have it — each gates its
own exit on a single failures ref that the tail already reads.
1325 lines
54 KiB
C
1325 lines
54 KiB
C
/* 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 <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);
|
|
|
|
/* ── 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;
|
|
|
|
#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
|
|
|
|
/* 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 ... */
|
|
|
|
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_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. */
|
|
static inline int64_t obj_words(flan_obj *o) {
|
|
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
|
|
* [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", "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;
|
|
case OBJ_VEC: 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_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;
|
|
}
|
|
/* 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;
|
|
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;
|
|
}
|
|
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;
|
|
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 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++) mark_value(*roots[i]);
|
|
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;
|
|
}
|
|
}
|
|
|
|
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);
|
|
}
|
|
|
|
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);
|
|
}
|
|
|
|
/* ── 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;
|
|
}
|
|
/* 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;
|
|
}
|
|
|
|
flan_dyn flan_dyn_len(flan_dyn v) {
|
|
if (is_text(v) || is_vec(v) || is_map(v))
|
|
return flan_dyn_from_i64(dyn_obj(v)->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 (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;
|
|
}
|
|
|
|
/* ── 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++;
|
|
}
|