Joseph Ferano
5cfefa586b
Rebased onto dev-loop. Three conflicts were additive and both sides are kept: FIX.org's two appended sections, want_map's diagnostics argument against the class_sync inserted beside it, and test_dev.ml's agent-socket block against this lane's migration block, whose comment no longer says "the block above" now that something sits between. The fourth is the one the auto-merge hid. flan_dyn_class_def's argument check was written against the pre-diagnostics trap1 and merged clean into a tree where trap1 takes a location first, so the class name would have been read as a length. dune build does not compile flan_dyn.c, so the green build said nothing; caught by compiling a program. Two pins in test_session.ml asserted "flan_dyn_class_def" against the IR text, which every module contains because emit.ml declares every runtime entry point in all of them. Both now assert the call and the packed slot list. Checked by mutation: with the thunk suppressed the old needles pass and the new ones fail, along with the daemon's slot count. Also disclosed: say_render is the second raw reader beside render, and neither syncs, so a stale instance shows its old slots in the inspector until something touches it. That is the editor-facing consequence of keeping the printers printers, and it is now in the runtime comment and in FIX.org rather than left to be met. And the stale-caller walk says in as many words that it is a tripwire, unreachable on purpose, not a filter to be tidied away.
2243 lines
97 KiB
C
2243 lines
97 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 <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;
|
|
|
|
/* A keyword's interned entry, declared here because a map's shape tag is one.
|
|
* The definition, the table and the argument for interning are further down,
|
|
* under "Keywords". */
|
|
struct kw_entry;
|
|
|
|
typedef struct flan_obj {
|
|
struct flan_obj *next; /* every object ever allocated, newest first */
|
|
uint8_t kind;
|
|
uint8_t mark;
|
|
/* OBJ_MAP with a [klass] only: the generation of the class definition this
|
|
instance was built against. Compared against the registry's current
|
|
generation on every access that observes the slot set, and a mismatch is
|
|
a lazy migration — see [class_sync] and "Classes" below.
|
|
|
|
It lives *here*, in the padding that [kind] and [mark] leave in front of
|
|
[len]'s alignment, and that placement is the whole reason the field is
|
|
free: [sizeof(flan_obj)] is 48 with it and was 48 without it. The union
|
|
is exactly 24 bytes — [items], [cap], [klass] fill it — so there is no
|
|
spare word inside the arm, and a field after it would have cost every
|
|
dyn object in the heap eight bytes for a word only class instances read.
|
|
[flan_dyn_obj_size] answers the number and dyn_ops.c's [classes] mode
|
|
asserts it, so a later field that pushes it past 48 fails a test rather
|
|
than costing that silently.
|
|
|
|
Zero means "built before any class definition was registered", which is
|
|
also the answer for every map that is not an instance. The registry's
|
|
first registration of a name lands on 1, so a gen-0 instance of a
|
|
registered class migrates once, which is what makes a program built
|
|
before this existed correct rather than merely unbroken. */
|
|
uint32_t gen;
|
|
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;
|
|
/* OBJ_MAP only, and NULL for every map that is not a defclass
|
|
instance: the shape tag. It is the interned entry of the
|
|
class's name — :point for (defclass point [x y]) — so the
|
|
identity compare that makes keyword equality cheap is also
|
|
what makes a class check cheap, and the tag needs no marking
|
|
because an interned entry is immortal and is not a GC object
|
|
(see [mark_value], which follows BOX_OBJ and nothing else).
|
|
|
|
It lives in the header rather than in a reserved entry of the
|
|
map itself, which is the one place this departs from the
|
|
queue's note: an entry would be counted by [len], walked by
|
|
[render], and compared by [dyn_equal]'s key loop, so every
|
|
instance would answer a length one larger than its slot count
|
|
and print a key nobody wrote. A field cannot be reached by
|
|
[get] or [put] at all, so no user key can collide with it.
|
|
|
|
A vec leaves it NULL. The arm is shared, so the field exists
|
|
for both kinds; nothing reads it for an OBJ_VEC. */
|
|
struct kw_entry *klass; } 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;
|
|
/* A class instance prints its shape tag in front, Clojure's own spelling
|
|
* for a record: #point{ :x 1 :y 2}. The tag is not an entry, so it is
|
|
* written here or it is not written at all. */
|
|
if (o->u.v.klass != NULL) {
|
|
emit("#");
|
|
emit_n(kw_bytes(o->u.v.klass), o->u.v.klass->len);
|
|
}
|
|
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; }
|
|
/* The same tag [render] writes, so a trap sentence naming an instance
|
|
* says which class it was. Truncated with the rest when the buffer is
|
|
* short: [say] is a 96-byte sentence, not a printer. */
|
|
if (o->u.v.klass != NULL && s->n < s->cap - 8) {
|
|
int64_t j;
|
|
say_puts(s, "#");
|
|
for (j = 0; j < o->u.v.klass->len && s->n < s->cap - 8; j++) {
|
|
char c[2];
|
|
c[0] = (char)kw_bytes(o->u.v.klass)[j];
|
|
c[1] = '\0';
|
|
say_puts(s, c);
|
|
}
|
|
}
|
|
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. */
|
|
|
|
/* Where the operation was written, printed as flan_rt.c's traps print it: the
|
|
* GNU "file:line:col: " prefix, so `next-error` walks to the dyn failure the
|
|
* same way it walks to a bounds failure. The pair is what an emitted string
|
|
* literal already is — a pointer and a length, not a C string — and the
|
|
* emitter hands it over exactly as [flan_dyn_cast_kind]'s site does.
|
|
*
|
|
* A NULL [loc] prints nothing at all and the sentence after it is byte for
|
|
* byte the one this file printed before: the entry points that have not been
|
|
* given a site yet (every one but the five arithmetic and four ordering ones)
|
|
* pass NULL, and so does test/dyn_ops.c, which calls the runtime directly and
|
|
* has no source position to offer. */
|
|
static void trap_where(const uint8_t *loc, int64_t loclen) {
|
|
if (loc != NULL && loclen > 0)
|
|
fprintf(stderr, "%.*s: ", (int)loclen, (const char *)loc);
|
|
}
|
|
|
|
static _Noreturn void trap2(const uint8_t *loc, int64_t loclen,
|
|
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);
|
|
trap_where(loc, loclen);
|
|
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 uint8_t *loc, int64_t loclen,
|
|
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);
|
|
trap_where(loc, loclen);
|
|
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
|
|
|
|
/* No site reaches these two yet: [at], [set-at], [push] and the allocator
|
|
* paths are not among the nine entry points this pass gave a location to. The
|
|
* parameter is here so that giving them one later is a call-site change and
|
|
* not another round of signature churn. */
|
|
static _Noreturn void trap_range(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_dyn v, int64_t i,
|
|
int64_t len) {
|
|
char sv[SAY_MAX];
|
|
say(sv, SAY_MAX, v);
|
|
fflush(stdout);
|
|
trap_where(loc, loclen);
|
|
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->gen = 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;
|
|
/* Shared arm, and nothing reads this for a vec; written anyway so that the
|
|
field's value is never whatever [gc_alloc] happened to leave. */
|
|
o->u.v.klass = NULL;
|
|
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;
|
|
o->u.v.klass = NULL;
|
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
|
}
|
|
|
|
/* ── Classes ───────────────────────────────────────────────────────────
|
|
*
|
|
* The registry a redefined (defclass ...) updates, and the lazy migration
|
|
* that makes the instances built against the old definition answer the new
|
|
* one. This is CLHS 4.3.6 — [update-instance-for-redefined-class] — with the
|
|
* user hook left out; docs/SBCL-REDEFINITION-NOTES.md is where the protocol
|
|
* was read off and candidate C is this.
|
|
*
|
|
* **Why a registry at all, when a class instance is already just a map.**
|
|
* Because a map cannot be asked what it is *supposed* to hold. The instance
|
|
* knows the keys it has; only the class knows the keys it ought to have, and
|
|
* "ought to have" is the whole content of a redefinition. So one entry per
|
|
* class name, holding the current slot list and a generation, and an
|
|
* instance holds the generation it was built against.
|
|
*
|
|
* **Why nothing here is a GC object.** A class's name and its slots are
|
|
* *names*, and [flan_dyn_kw]'s entries are interned, immortal and not on the
|
|
* collector's heap — the same argument the [klass] field makes one screen up.
|
|
* The table below is [malloc]ed, append-only and never freed, so the marker
|
|
* has nothing to trace here and no root has to be pushed for it. A registry
|
|
* of dyn vectors would have needed both, and would have needed them to
|
|
* survive a collection triggered from inside a migration.
|
|
*
|
|
* **What the registry does not do.** It does not constrain [put]. A class
|
|
* instance is an open map — FIX.org already defers refusing [(get p :z)] —
|
|
* so a key nobody declared can be written to one, and the migration below
|
|
* will *drop* it at the next redefinition, because its rule is that an
|
|
* instance's keys are the class's slots. That is real data loss and it is
|
|
* written down as such in FIX.org rather than dressed up as enforcement.
|
|
*
|
|
* **Where a migration happens.** [want_map], so every [get], [put] and
|
|
* [has-key?]; [flan_dyn_len]'s map arm; and [dyn_equal]'s, so two instances
|
|
* of different generations are compared as the class currently defines them
|
|
* rather than by the shapes they happen to be carrying. CLHS asks for "no
|
|
* later than the next time a slot is read or written" and those are the
|
|
* three places that read or write the slot *set*.
|
|
*
|
|
* **The two printers are deliberately not among them**, and the consequence
|
|
* is visible to whoever is sitting in front of the editor, so it is written
|
|
* out rather than left as a footnote. [render] — which [print] and every
|
|
* value the editor renders go through — and [say_render] — the 96-byte
|
|
* sentence a trap prints — both walk [items] raw and neither syncs.
|
|
*
|
|
* The reason is the same for both: [say_render] runs inside trap reporting,
|
|
* where the heap is whatever the trap left, and a printer that frees an
|
|
* object's entry block and installs another is not something to have on
|
|
* that path; [render] is the same function's sibling and is called from it
|
|
* for nested values, so splitting them would put a mutation one recursion
|
|
* below a trap anyway.
|
|
*
|
|
* What that costs: **a stale instance shows its OLD slots to the editor
|
|
* until something touches it.** A watch expression, the value [C-x C-e]
|
|
* answers, and the inspector's render of a dyn all reach a class instance
|
|
* through [render], so immediately after a [defclass] is redefined the
|
|
* inspector can show a slot the class no longer has, and not show one it
|
|
* has gained — while [(get p :z)] typed at the same instant answers the new
|
|
* definition and migrates it, after which the inspector agrees. CLHS's
|
|
* "implementation-dependent time" permits it and it is the price of the
|
|
* printer staying a printer; it is not a bug report waiting to happen only
|
|
* because it is written down here, in FIX.org, and nowhere else. */
|
|
|
|
/* Interning, which is under "Keywords" further down. This file includes no
|
|
* header of its own — every entry point is written out in flan_dyn.h and
|
|
* defined here in the order the sections read best — so the one call that
|
|
* runs ahead of its definition declares itself. */
|
|
flan_dyn flan_dyn_kw(const uint8_t *p, int64_t n);
|
|
|
|
typedef struct class_entry {
|
|
kw_entry *name;
|
|
kw_entry **slots; /* interned, immortal, in declaration order */
|
|
int64_t nslots;
|
|
uint32_t gen;
|
|
} class_entry;
|
|
|
|
static class_entry *classes;
|
|
static int64_t classes_n, classes_cap;
|
|
|
|
static class_entry *class_find(kw_entry *name) {
|
|
int64_t i;
|
|
for (i = 0; i < classes_n; i++)
|
|
if (classes[i].name == name) return &classes[i];
|
|
return NULL;
|
|
}
|
|
|
|
/* The generation a new instance of [name] is stamped with. Zero for a class
|
|
* no definition has been registered for, which is every class in a program
|
|
* that was built and never reloaded: nothing has changed shape, so nothing
|
|
* needs to migrate, and the registry earns its keep only once an editor has
|
|
* sent a new definition. */
|
|
static uint32_t class_gen(kw_entry *name) {
|
|
class_entry *e = class_find(name);
|
|
return e == NULL ? 0u : e->gen;
|
|
}
|
|
|
|
/* One class's current slot list, as the compiler's per-reload thunk hands it
|
|
* over: the class's name as a keyword, and the slot names packed into one
|
|
* string, newline between and no leading colons — the shape a string literal
|
|
* already crosses in, rather than a dyn vector this would have to root.
|
|
*
|
|
* The generation is bumped only when the list actually differs. That is what
|
|
* makes C-c C-k idempotent: reloading a file re-runs every one of its class
|
|
* definitions, and a bump per reload would migrate every instance in the
|
|
* program every time anybody saved, for no change. */
|
|
void flan_dyn_class_def(flan_dyn name, const uint8_t *slots, int64_t n) {
|
|
kw_entry *k;
|
|
kw_entry **list = NULL;
|
|
int64_t count = 0, i, start;
|
|
class_entry *e;
|
|
if (flan_dyn_tag(name) != FLAN_DYN_TAG_KEYWORD)
|
|
/* No location: the caller is the thunk a reload runs, which has no
|
|
source position of its own — the class's own [defclass] is where a
|
|
reader would look, and it is not on any stack by the time this runs.
|
|
Unreachable from written Flan in any case; only the compiler emits
|
|
this call, and it emits a keyword. */
|
|
trap1(NULL, 0, TYPE_TRAP, "class definition",
|
|
"a class name is a keyword", name);
|
|
k = dyn_kw(name);
|
|
if (n < 0) n = 0;
|
|
/* Count first, then fill: one allocation of the right size, and an empty
|
|
* class — (defclass marker []) is in the corpus — allocates nothing. */
|
|
for (i = 0, start = 0; i <= n; i++)
|
|
if (i == n ? i > start : slots[i] == '\n') {
|
|
if (i > start) count++;
|
|
start = i + 1;
|
|
}
|
|
if (count > 0) {
|
|
list = (kw_entry **)malloc((size_t)count * sizeof *list);
|
|
if (list == NULL) trap_oom(count * (int64_t)sizeof *list);
|
|
count = 0;
|
|
for (i = 0, start = 0; i <= n; i++)
|
|
if (i == n ? i > start : slots[i] == '\n') {
|
|
if (i > start)
|
|
list[count++] = dyn_kw(flan_dyn_kw(slots + start, i - start));
|
|
start = i + 1;
|
|
}
|
|
}
|
|
e = class_find(k);
|
|
if (e != NULL) {
|
|
int same = e->nslots == count;
|
|
if (same)
|
|
for (i = 0; i < count; i++)
|
|
if (e->slots[i] != list[i]) { same = 0; break; }
|
|
if (same) { free(list); return; }
|
|
free(e->slots);
|
|
e->slots = list;
|
|
e->nslots = count;
|
|
/* Wrapping is not a correctness question — what matters is that the new
|
|
* generation differs from the one the live instances carry — but zero is
|
|
* reserved for "no definition registered", so it is stepped over. */
|
|
e->gen = e->gen + 1u;
|
|
if (e->gen == 0u) e->gen = 1u;
|
|
return;
|
|
}
|
|
if (classes_n == classes_cap) {
|
|
int64_t cap = classes_cap ? classes_cap * 2 : 8;
|
|
class_entry *t =
|
|
(class_entry *)realloc(classes, (size_t)cap * sizeof *t);
|
|
if (t == NULL) trap_oom(cap * (int64_t)sizeof *t);
|
|
classes = t;
|
|
classes_cap = cap;
|
|
}
|
|
classes[classes_n].name = k;
|
|
classes[classes_n].slots = list;
|
|
classes[classes_n].nslots = count;
|
|
/* One, never zero: an instance built before this registration carries zero
|
|
* and has to be seen as stale, because the definition it was built from is
|
|
* exactly the one nobody recorded. */
|
|
classes[classes_n].gen = 1u;
|
|
classes_n++;
|
|
}
|
|
|
|
/* The migration. [o] is left holding exactly the class's current slots, in
|
|
* the class's order, with the values it already had for the ones it still
|
|
* has and nil for the ones it has just gained — which is precisely the
|
|
* property CLHS 4.3.6 guarantees, matched by name, with the instance's
|
|
* identity preserved because none of this allocates a new object.
|
|
*
|
|
* Rebuilt into a fresh block rather than compacted in place, and the order is
|
|
* the class's rather than the instance's, so that a migrated instance is
|
|
* indistinguishable from one the constructor has just built. [dyn_equal]
|
|
* compares maps by lookup and would not have cared; [render] and [len] print
|
|
* and count in insertion order and would have. One malloc per instance per
|
|
* redefinition is the price, and a migration happens once.
|
|
*
|
|
* Nothing here allocates on the collector's heap, so no collection can run
|
|
* part-way through and see an object whose [len] and [items] disagree.
|
|
*
|
|
* Nor can it free a block something above it is walking. The block it frees
|
|
* is [o]'s, and every caller syncs [o] before it starts walking [o] — so a
|
|
* re-entry through a nested [dyn_equal], including a map used as a key of
|
|
* itself, finds [o] already current and returns at the generation compare.
|
|
* The key scan here uses the interned identity compare and calls
|
|
* [dyn_equal] not at all, so it cannot re-enter from inside. */
|
|
static void class_sync(flan_obj *o) {
|
|
class_entry *e;
|
|
flan_dyn *fresh = NULL;
|
|
int64_t i, j;
|
|
if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return;
|
|
e = class_find(o->u.v.klass);
|
|
if (e == NULL || e->gen == o->gen) return;
|
|
if (e->nslots > 0) {
|
|
fresh = (flan_dyn *)malloc((size_t)e->nslots * 2 * sizeof *fresh);
|
|
if (fresh == NULL) trap_oom(e->nslots * 2 * (int64_t)sizeof *fresh);
|
|
}
|
|
for (j = 0; j < e->nslots; j++) {
|
|
flan_dyn v = dyn_make(BOX_NIL, 0);
|
|
for (i = 0; i < o->len; i++) {
|
|
flan_dyn key = o->u.v.items[i * 2];
|
|
/* [flan_dyn_tag] and not a bare [dyn_box]: a float is not boxed at
|
|
all, so its payload bits can read as any box tag, and reading a
|
|
non-keyword's payload as a [kw_entry *] is a wild pointer. A raw
|
|
[put] can have left a float — or anything else — in here. */
|
|
if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD
|
|
&& dyn_kw(key) == e->slots[j]) {
|
|
v = o->u.v.items[i * 2 + 1];
|
|
break;
|
|
}
|
|
}
|
|
fresh[j * 2] = dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]);
|
|
fresh[j * 2 + 1] = v;
|
|
}
|
|
/* Charged the way [map_set]'s growth is, in both directions: a class that
|
|
* lost slots gives the bytes back, or the trigger drifts up by whatever
|
|
* every migration in the program ever released. */
|
|
gc_bytes += (e->nslots - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn);
|
|
free(o->u.v.items);
|
|
o->u.v.items = fresh;
|
|
o->u.v.cap = e->nslots;
|
|
o->len = e->nslots;
|
|
o->gen = e->gen;
|
|
}
|
|
|
|
/* The same map with a shape tag on it: what a (defclass ...) constructor
|
|
* calls. [k] is a keyword and anything else traps by name — the compiler
|
|
* hands it the class's own name and nothing else can reach this. */
|
|
flan_dyn flan_dyn_map_new_class(flan_dyn k) {
|
|
flan_obj *o;
|
|
if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD)
|
|
trap1(NULL, 0, TYPE_TRAP, "class instance", "a class tag is a keyword", k);
|
|
o = gc_alloc(OBJ_MAP, 0);
|
|
o->len = 0;
|
|
o->u.v.items = NULL;
|
|
o->u.v.cap = 0;
|
|
o->u.v.klass = dyn_kw(k);
|
|
/* Stamped at construction against whatever the registry currently says, so
|
|
* an instance built by the constructor this reload just installed is
|
|
* already current and never migrates. */
|
|
o->gen = class_gen(o->u.v.klass);
|
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
|
}
|
|
|
|
/* The shape tag, as a value: the class's name as a keyword, or nil. Never
|
|
* traps. Absence is an answer here for the reason it is one in [map_get] —
|
|
* asking what class a value is, is a question every value can be asked, and
|
|
* an ordinary map, a number and nil all truthfully answer "none". */
|
|
int64_t flan_dyn_obj_size(void) { return (int64_t)sizeof(flan_obj); }
|
|
|
|
flan_dyn flan_dyn_class_of(flan_dyn v) {
|
|
flan_obj *o;
|
|
if (flan_dyn_tag(v) != FLAN_DYN_TAG_MAP) return flan_dyn_nil();
|
|
o = dyn_obj(v);
|
|
if (o->u.v.klass == NULL) return flan_dyn_nil();
|
|
return dyn_make(BOX_KW, (uint64_t)(uintptr_t)o->u.v.klass);
|
|
}
|
|
|
|
/* ── 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(NULL, 0, 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(NULL, 0, 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(NULL, 0, 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.
|
|
*
|
|
* What the table stores is the loc's pointer, never a copy — the same licence
|
|
* the allocation registry takes for its type names (flan_dev.c:1073-1075).
|
|
* The bytes are a string constant in the image of whatever module emitted the
|
|
* cast, and a module that emitted a string constant is never unloaded: the
|
|
* cell table forbids dlclose outright (flan_dev.c:27), and the one path that
|
|
* does unload — an expression thunk — is gated on the module having emitted
|
|
* no string literal at all ([nstr] in lib/emit.ml:383-391). A cast site's loc
|
|
* IS a string literal, emitted through [string_const] like any other, so a
|
|
* module holding one of these sites is on the never-unloaded side of that
|
|
* test. If that ever stops being true the table has to copy.
|
|
*
|
|
* Not thread-safe, and that is a statement about who runs this rather than a
|
|
* shrug: [flan_dyn_cast_kind] runs on the program's own thread and Flan has
|
|
* no second one today. The dev agent's listener thread reads flan_dev.c's
|
|
* tables — which is why *those* carry a seqlock — and never touches this one.
|
|
* Were a second thread ever to reach a cast, the cost would not be a line
|
|
* printed twice: {ptr, len} is a pair only meaningful together, and a reader
|
|
* that took the new pointer with the old length would read off the end of a
|
|
* string literal, exactly the hazard flan_dev.c:1126-1129 describes. The fix
|
|
* then is the registry's, not 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';
|
|
/* This one has a site: the cast's own, which the emitter already hands
|
|
* over for the cross-kind warning below. It was the first entry point on
|
|
* this side to take a location and it was not passing it on. */
|
|
trap1(loc, loc_len, 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,
|
|
"%.*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, is_float ? "a float" : "an int",
|
|
(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(NULL, 0, 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 uint8_t *loc, int64_t loclen, const char *op,
|
|
const char *why, flan_dyn a, flan_dyn b) {
|
|
if (!is_num(a) || !is_num(b)) trap2(loc, loclen, TYPE_TRAP, op, why, a, b);
|
|
}
|
|
|
|
#define ARITH_NUM "it takes two numbers"
|
|
|
|
static flan_dyn arith(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn a, flan_dyn b) {
|
|
int64_t x, y;
|
|
want_nums(loc, loclen, 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(loc, loclen, ARITH_TRAP, op, "it does not divide by zero", a, b);
|
|
if (x == INT64_MIN && y == -1)
|
|
trap2(loc, loclen, 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(loc, loclen, 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, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return arith(loc, loclen, "+", a, b);
|
|
}
|
|
flan_dyn flan_dyn_sub(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return arith(loc, loclen, "-", a, b);
|
|
}
|
|
flan_dyn flan_dyn_mul(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return arith(loc, loclen, "*", a, b);
|
|
}
|
|
flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return arith(loc, loclen, "/", a, b);
|
|
}
|
|
flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return arith(loc, loclen, "%", 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 uint8_t *loc, int64_t loclen, 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(loc, loclen, 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, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return flan_dyn_from_bool(order(loc, loclen, "<", a, b) == -1);
|
|
}
|
|
flan_dyn flan_dyn_le(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
int c = order(loc, loclen, "<=", a, b);
|
|
return flan_dyn_from_bool(c == -1 || c == 0);
|
|
}
|
|
flan_dyn flan_dyn_gt(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return flan_dyn_from_bool(order(loc, loclen, ">", a, b) == 1);
|
|
}
|
|
flan_dyn flan_dyn_ge(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
int c = order(loc, loclen, ">=", 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;
|
|
/* Two instances of one class built either side of a redefinition hold
|
|
different key sets, and comparing those key sets would answer "not
|
|
equal" about a difference the class no longer has. So both are brought
|
|
to the current definition first and the comparison is then the ordinary
|
|
one. The decision this records: equality is over the class as it is
|
|
now, and not over the shapes the two values were born with. */
|
|
class_sync(x);
|
|
class_sync(y);
|
|
/* The shape tag is part of the value. Two instances of one class compare
|
|
* by their entries as any two maps do; an instance and a plain map with
|
|
* the same entries do not, which is Clojure's answer for a record beside
|
|
* a map and is the only answer a tag can have if it means anything. An
|
|
* identity compare, because both sides are interned entries. */
|
|
if (x->u.v.klass != y->u.v.klass) 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(NULL, 0, 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(NULL, 0, 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(NULL, 0, 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)) return flan_dyn_from_i64(dyn_obj(v)->len);
|
|
/* A map's length is its slot count, so a stale instance would answer the
|
|
count of a definition that no longer exists. Migrated first for the same
|
|
reason [get] is. */
|
|
if (is_map(v)) {
|
|
flan_obj *o = dyn_obj(v);
|
|
class_sync(o);
|
|
return flan_dyn_from_i64(o->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(NULL, 0, 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(NULL, 0, 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(NULL, 0, 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(NULL, 0, "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(NULL, 0, "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(NULL, 0, TYPE_TRAP, "set-at", "a text is immutable — build another one", v, i);
|
|
if (!is_vec(v))
|
|
trap2(NULL, 0, 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(NULL, 0, "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(NULL, 0, "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(NULL, 0, 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(NULL, 0, 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) {
|
|
flan_obj *o;
|
|
if (!is_map(m)) trap2(NULL, 0, TYPE_TRAP, op, "only a map answers it", m, k);
|
|
o = dyn_obj(m);
|
|
/* The lazy half of the redefinition protocol: [get], [put] and [has-key?]
|
|
all arrive here, and CLHS 4.3.6 asks for the update to happen no later
|
|
than the next read or write of a slot. A plain map returns from the
|
|
first line of [class_sync] untouched. */
|
|
class_sync(o);
|
|
return o;
|
|
}
|
|
|
|
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++;
|
|
}
|