5536 lines
226 KiB
C
5536 lines
226 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 <stdarg.h>
|
|
#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 two sinks in flan_dev.c a dyn value can be rendered into instead of
|
|
* stdout: an evaluated expression's value, and a watch slot. flan_dev.c is
|
|
* linked into every build, so these resolve whether or not the build is a dev
|
|
* one; the reference runs this way round so that flan_dev.c names nothing in
|
|
* this file and the dyn runtime stays droppable at the file level. */
|
|
void flan_dev_emit(const uint8_t *bytes, int64_t len);
|
|
void flan_dev_watch_emit(const uint8_t *bytes, int64_t len);
|
|
|
|
/* The one non-local exit a dyn operation can take. flan_rt.c's [rt_trap] is
|
|
* static, and re-implementing what it does — the break-loop hook, the flush,
|
|
* the socket, [_exit(134)] — would be a second answer to "how does a Flan
|
|
* program die where it stands", which that file went to some trouble to have
|
|
* only one of. So flan_rt.c exports a thin wrapper and this calls it. */
|
|
_Noreturn void flan_trap(const uint8_t *name, int64_t namelen);
|
|
|
|
/* The site and operation a walk over a view reports a trap at — a print, an
|
|
* equality, a length — set by the entry point that has them and read by the
|
|
* element readers the walk calls. NULL when the entry point has no site.
|
|
* Every trap in this file goes through [dyn_trap], which clears them first:
|
|
* a trap does not return to the [walk_leave] that would have, and a later
|
|
* walk must not name the site of one that was abandoned. */
|
|
static const uint8_t *walk_loc;
|
|
static int64_t walk_len;
|
|
static const char *walk_op = "print";
|
|
|
|
typedef struct { const uint8_t *loc; int64_t len; const char *op; } walk_site;
|
|
|
|
static walk_site walk_enter(const uint8_t *loc, int64_t len, const char *op) {
|
|
walk_site was;
|
|
was.loc = walk_loc; was.len = walk_len; was.op = walk_op;
|
|
walk_loc = loc; walk_len = loc != NULL ? len : 0; walk_op = op;
|
|
return was;
|
|
}
|
|
|
|
static void walk_leave(walk_site was) {
|
|
walk_loc = was.loc; walk_len = was.len; walk_op = was.op;
|
|
}
|
|
|
|
int flan_dev_reg_enabled(void);
|
|
/* runtime/flan_dev.c: set with the registry, so a view's crossing reads a
|
|
* word rather than making a call to learn it is in a release build. */
|
|
extern int flan_dev_views_checked;
|
|
|
|
static _Noreturn void dyn_trap(const uint8_t *name, int64_t namelen) {
|
|
walk_loc = NULL;
|
|
walk_len = 0;
|
|
walk_op = "print";
|
|
flan_trap(name, namelen);
|
|
}
|
|
/* A trap's sentence, printed after its site and kept for the break loop, which
|
|
* shows it beside the trap's name (flan_rt.c). */
|
|
void flan_say(const uint8_t *loc, int64_t loclen, const char *fmt, ...);
|
|
|
|
/* 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 map of the words the collector follows: where they 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] or
|
|
* [flan_dyn_env_new]. Nothing here ever writes one.
|
|
*
|
|
* Three kinds of word, one table each:
|
|
*
|
|
* - [offs]: a dyn word, marked by [mark_value].
|
|
* - [envs]: the environment half of an (Fn ...) value, pointer-sized. It holds
|
|
* a collector-allocated environment, null, or — for a named function widened
|
|
* into an Fn — that function's code address. [mark_env] follows only the
|
|
* first, and tells them apart by asking [envset] rather than by reading the
|
|
* word, so a code address is never dereferenced.
|
|
* - [vecs]: a (Vec T) header whose elements hold words of their own, with the
|
|
* element's descriptor. The marker reads the header's pointer and length
|
|
* where they are, so a push that reallocated is seen.
|
|
* - [maps]: a (Map K V) header whose values hold words of their own, with the
|
|
* value's descriptor. Read the same way, and walked over the full slots.
|
|
*
|
|
* [size] is the stride of one instance as the compiler's element-size
|
|
* arithmetic counts it, which is what a Vec's elements are laid out at. The
|
|
* collector reads it only through a [vecs] entry's element descriptor. */
|
|
struct flan_desc;
|
|
typedef struct flan_desc_vec {
|
|
int64_t off;
|
|
const struct flan_desc *elem;
|
|
} flan_desc_vec;
|
|
|
|
typedef struct flan_desc {
|
|
int64_t size;
|
|
int64_t n;
|
|
const int64_t *offs;
|
|
int64_t nenv;
|
|
const int64_t *envs;
|
|
int64_t nvec;
|
|
const flan_desc_vec *vecs;
|
|
int64_t nmap;
|
|
const flan_desc_vec *maps;
|
|
} 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
|
|
/* A character: the payload is its code point, a Unicode scalar value, so two
|
|
* equal chars are the same word and nothing about one is ever allocated. */
|
|
#define BOX_CHAR 5u
|
|
|
|
/* 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 */
|
|
#define OBJ_ENV 5 /* a closure's environment: bytes after the header,
|
|
marked through the descriptor it was made with.
|
|
Never a dyn value — nothing boxes one — so no tag
|
|
word, printer or operation ever sees this kind. */
|
|
|
|
/* 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_map, restated for the same reason and read the same way: only
|
|
* [data], [log2cap], [alloc] and [epoch]. With it, the three numbers of the
|
|
* block's geometry the marker needs — flan_rt.c's FLAN_MAP_HEAD, _GROUP and
|
|
* _ALIGN. If either file's table changes, change both. */
|
|
typedef struct flan_dyn_map_hdr {
|
|
void *data;
|
|
int64_t len;
|
|
int64_t log2cap;
|
|
void *alloc;
|
|
int64_t epoch;
|
|
} flan_dyn_map_hdr;
|
|
|
|
#define DYN_MAP_HEAD 24
|
|
#define DYN_MAP_GROUP 8
|
|
#define DYN_MAP_ALIGN 64
|
|
#define DYN_MAP_FULL 0x80
|
|
|
|
/* This mirror's numbers, compared against flan_rt.c's [flan_map_layout] by
|
|
* test/dyn_ops.c's "layout" mode. */
|
|
void flan_dyn_map_hdr_layout(int64_t out[10]) {
|
|
out[0] = (int64_t)sizeof(flan_dyn_map_hdr);
|
|
out[1] = (int64_t)offsetof(flan_dyn_map_hdr, data);
|
|
out[2] = (int64_t)offsetof(flan_dyn_map_hdr, len);
|
|
out[3] = (int64_t)offsetof(flan_dyn_map_hdr, log2cap);
|
|
out[4] = (int64_t)offsetof(flan_dyn_map_hdr, alloc);
|
|
out[5] = (int64_t)offsetof(flan_dyn_map_hdr, epoch);
|
|
out[6] = DYN_MAP_HEAD;
|
|
out[7] = DYN_MAP_GROUP;
|
|
out[8] = DYN_MAP_ALIGN;
|
|
out[9] = DYN_MAP_FULL;
|
|
}
|
|
|
|
/* 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: typed storage this file did not allocate and does not own.
|
|
The shape is in the header's [gen], which only a class instance
|
|
otherwise uses: VIEW_VEC means [base] is a [flan_dyn_vec_hdr *] whose
|
|
length is read live, which is why a Vec growing through the view
|
|
cannot go stale; VIEW_FLAT means [base] is the first element and the
|
|
header's [len] the count taken at the crossing, for a slice or a fixed
|
|
array; VIEW_STRUCT means [base] is one struct. [desc] is the element's
|
|
descriptor, or the struct's. [nul] is always NULL and sits where a
|
|
map's [klass] does, so a struct view answers "no class" to every class
|
|
question without a branch. A [view_guard] trails the header. */
|
|
struct { void *base; const uint8_t *desc; void *nul; } view;
|
|
/* OBJ_ENV: the descriptor the environment's bytes are marked through,
|
|
or NULL when it holds nothing the collector follows. [len] is the
|
|
byte count, and the bytes trail the header as a text's do. */
|
|
struct { const struct flan_desc *desc; } env;
|
|
/* 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 || o->kind == OBJ_ENV) 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); }
|
|
|
|
/* What trails an OBJ_VIEW's header: the dev check's record of its storage,
|
|
* explained with the view helpers below. Allocated with every view, and
|
|
* charged to the heap and taken back by the sweep with it. */
|
|
typedef struct view_guard {
|
|
const void *frame; /* NULL when no frame is checked */
|
|
uint64_t serial;
|
|
const char *fname; /* whose frame, for the sentence */
|
|
int64_t fnamelen;
|
|
uintptr_t rbase; /* 0 when no block is checked */
|
|
int64_t rseq;
|
|
const char *rtype;
|
|
int64_t rtypelen;
|
|
} view_guard;
|
|
|
|
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",
|
|
"char" };
|
|
|
|
#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
|
|
#define FLAN_DYN_TAG_CHAR 8
|
|
#define FLAN_DYN_TAG_LAST FLAN_DYN_TAG_CHAR
|
|
|
|
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;
|
|
case BOX_CHAR: return FLAN_DYN_TAG_CHAR;
|
|
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;
|
|
/* ...and a struct's view answers a map's, [gen] being its shape
|
|
(VIEW_STRUCT, below). */
|
|
case OBJ_VIEW: return (o->gen & 0xff) == 2 ? FLAN_DYN_TAG_MAP : 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_LAST) 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. [flan_dyn_emit_dev] and [flan_dyn_emit_watch] are
|
|
* the print walk aimed at flan_dev.c's buffers instead of stdout.
|
|
*
|
|
* 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]
|
|
*
|
|
* A space between elements and none inside the brackets, the same as
|
|
* lib/render.ml's slice loop: an acceptance test compares the two.
|
|
*
|
|
* 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
|
|
|
|
/* Where the rendering goes. stdout for [print], or one of flan_dev.c's
|
|
* buffers when the value is an evaluated expression's or a watched one: a
|
|
* value written to stdout arrives on the program's output rather than as the
|
|
* value the editor asked for. */
|
|
typedef void (*dyn_sink)(const uint8_t *p, int64_t n);
|
|
|
|
static void emit(dyn_sink w, const char *s) {
|
|
w((const uint8_t *)s, (int64_t)strlen(s));
|
|
}
|
|
|
|
static void emit_n(dyn_sink w, const uint8_t *p, int64_t n) { w(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(dyn_sink w, const uint8_t *p, int64_t n) {
|
|
int64_t i;
|
|
emit(w, "\"");
|
|
for (i = 0; i < n; i++) {
|
|
unsigned char c = p[i];
|
|
switch (c) {
|
|
case '"': emit(w, "\\\""); break;
|
|
case '\\': emit(w, "\\\\"); break;
|
|
case '\n': emit(w, "\\n"); break;
|
|
case '\t': emit(w, "\\t"); break;
|
|
case '\r': emit(w, "\\r"); break;
|
|
default:
|
|
if (c < 0x20) {
|
|
char b[5];
|
|
snprintf(b, sizeof b, "\\x%02x", c);
|
|
emit(w, b);
|
|
} else {
|
|
emit_n(w, &c, 1);
|
|
}
|
|
}
|
|
}
|
|
emit(w, "\"");
|
|
}
|
|
|
|
/* ── Characters ────────────────────────────────────────────────────────
|
|
*
|
|
* Text is UTF-8 and a char is one code point. A text's length and its
|
|
* indices count code points, so a byte that does not start a well-formed
|
|
* sequence — possible, because a text can be made from any typed bytes —
|
|
* counts as one char and reads as U+FFFD: the prelude's decode-rune refusal,
|
|
* width 1, given the replacement character as its value. */
|
|
|
|
static int utf8_encode(uint32_t cp, uint8_t out[4]) {
|
|
if (cp < 0x80) { out[0] = (uint8_t)cp; return 1; }
|
|
if (cp < 0x800) {
|
|
out[0] = (uint8_t)(0xC0 | (cp >> 6));
|
|
out[1] = (uint8_t)(0x80 | (cp & 0x3F));
|
|
return 2;
|
|
}
|
|
if (cp < 0x10000) {
|
|
out[0] = (uint8_t)(0xE0 | (cp >> 12));
|
|
out[1] = (uint8_t)(0x80 | ((cp >> 6) & 0x3F));
|
|
out[2] = (uint8_t)(0x80 | (cp & 0x3F));
|
|
return 3;
|
|
}
|
|
out[0] = (uint8_t)(0xF0 | (cp >> 18));
|
|
out[1] = (uint8_t)(0x80 | ((cp >> 12) & 0x3F));
|
|
out[2] = (uint8_t)(0x80 | ((cp >> 6) & 0x3F));
|
|
out[3] = (uint8_t)(0x80 | (cp & 0x3F));
|
|
return 4;
|
|
}
|
|
|
|
/* The code point at [p], of the [n] bytes left, and its width. Overlong
|
|
* forms, surrogates and anything past U+10FFFF are malformed. */
|
|
static uint32_t utf8_decode(const uint8_t *p, int64_t n, int *w) {
|
|
uint32_t c = p[0], cp;
|
|
int k, i;
|
|
*w = 1;
|
|
if (c < 0x80) return c;
|
|
if (c >= 0xC2 && c <= 0xDF) { k = 2; cp = c & 0x1F; }
|
|
else if (c >= 0xE0 && c <= 0xEF) { k = 3; cp = c & 0x0F; }
|
|
else if (c >= 0xF0 && c <= 0xF4) { k = 4; cp = c & 0x07; }
|
|
else return 0xFFFD;
|
|
if (n < k) return 0xFFFD;
|
|
for (i = 1; i < k; i++) {
|
|
if ((p[i] & 0xC0) != 0x80) return 0xFFFD;
|
|
cp = (cp << 6) | (p[i] & 0x3F);
|
|
}
|
|
if ((k == 3 && cp < 0x800) || (k == 4 && cp < 0x10000) || cp > 0x10FFFF ||
|
|
(cp >= 0xD800 && cp <= 0xDFFF))
|
|
return 0xFFFD;
|
|
*w = k;
|
|
return cp;
|
|
}
|
|
|
|
static int is_scalar(int64_t cp) {
|
|
return cp >= 0 && cp <= 0x10FFFF && !(cp >= 0xD800 && cp <= 0xDFFF);
|
|
}
|
|
|
|
/* A char's spelling, as lib/reader.ml's [read_byte] reads it back and
|
|
* lib/form.ml's [byte_repr] writes it: a name where there is one, \uXXXX
|
|
* for every other control character (C0, DEL and C1), the character itself after the
|
|
* backslash otherwise. */
|
|
static void char_spell(uint32_t cp, char buf[16]) {
|
|
uint8_t u[4];
|
|
int n, i;
|
|
switch (cp) {
|
|
case 32: strcpy(buf, "\\space"); return;
|
|
case 9: strcpy(buf, "\\tab"); return;
|
|
case 10: strcpy(buf, "\\newline"); return;
|
|
case 13: strcpy(buf, "\\return"); return;
|
|
case 0: strcpy(buf, "\\nul"); return;
|
|
case 8: strcpy(buf, "\\backspace"); return;
|
|
case 12: strcpy(buf, "\\formfeed"); return;
|
|
default: break;
|
|
}
|
|
if (cp < 32 || (cp >= 127 && cp <= 0x9F)) {
|
|
snprintf(buf, 16, "\\u%04X", (unsigned)cp);
|
|
return;
|
|
}
|
|
n = utf8_encode(cp, u);
|
|
buf[0] = '\\';
|
|
for (i = 0; i < n; i++) buf[1 + i] = (char)u[i];
|
|
buf[1 + n] = '\0';
|
|
}
|
|
|
|
/* A text is immutable, so its char count is taken once, when it is made, and
|
|
* kept in the header's [u.i], which a text does not otherwise use. A count
|
|
* equal to the byte length means every byte is ASCII, and an index is then a
|
|
* byte offset. [gen] is not touched: on a text it is [pin_text]'s stamp. */
|
|
static void text_measure(flan_obj *o) {
|
|
const uint8_t *p = obj_text_bytes(o);
|
|
int64_t i = 0, n = 0;
|
|
int w;
|
|
while (i < o->len) {
|
|
if (p[i] < 0x80) { i++; n++; continue; }
|
|
utf8_decode(p + i, o->len - i, &w);
|
|
i += w;
|
|
n++;
|
|
}
|
|
o->u.i = n;
|
|
}
|
|
|
|
/* The byte offset of char [k], 0 <= k <= the char count. */
|
|
static int64_t text_offset(flan_obj *o, int64_t k) {
|
|
const uint8_t *p = obj_text_bytes(o);
|
|
int64_t i = 0;
|
|
int w;
|
|
if (o->u.i == o->len) return k;
|
|
while (k > 0 && i < o->len) {
|
|
utf8_decode(p + i, o->len - i, &w);
|
|
i += w;
|
|
k--;
|
|
}
|
|
return i;
|
|
}
|
|
|
|
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 uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_obj *o);
|
|
static inline void view_guard_check(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_obj *o);
|
|
/* A struct view's fields, for the map arms of the printers. */
|
|
static int64_t view_nfields(flan_obj *o);
|
|
static flan_dyn view_field_key(flan_obj *o, int64_t i);
|
|
static flan_dyn view_field_val(flan_obj *o, int64_t i);
|
|
static void view_struct_name(flan_obj *o, const char **name, int64_t *len);
|
|
/* 1 when element (or, with [field], field) [i] of view [o] is a u64 above
|
|
* the largest dyn int: it has no dyn value, and the printers write its
|
|
* digits instead of reading it. */
|
|
static int view_big_u64(flan_obj *o, int64_t i, int field,
|
|
unsigned long long *out);
|
|
|
|
/* 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(dyn_sink w, flan_dyn v, int depth, int nested) {
|
|
char buf[64];
|
|
int32_t t = flan_dyn_tag(v);
|
|
if (depth > PRINT_DEPTH) { emit(w, "..."); return; }
|
|
switch (t) {
|
|
case FLAN_DYN_TAG_NIL:
|
|
emit(w, "nil");
|
|
return;
|
|
case FLAN_DYN_TAG_BOOL:
|
|
emit(w, dyn_payload(v) ? "true" : "false");
|
|
return;
|
|
case FLAN_DYN_TAG_INT:
|
|
snprintf(buf, sizeof buf, "%lld", (long long)dyn_int_value(v));
|
|
emit(w, 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(w, buf);
|
|
return;
|
|
}
|
|
case FLAN_DYN_TAG_TEXT: {
|
|
flan_obj *o = dyn_obj(v);
|
|
if (nested) emit_escaped(w, obj_text_bytes(o), o->len);
|
|
else emit_n(w, obj_text_bytes(o), o->len);
|
|
return;
|
|
}
|
|
/* A char at the top of a println is the character itself, and anywhere a
|
|
* reader must tell it apart — inside a value, in the inspector — the
|
|
* literal that reads back as it: Clojure's println against its pr. */
|
|
case FLAN_DYN_TAG_CHAR:
|
|
if (nested) char_spell((uint32_t)dyn_payload(v), buf);
|
|
else buf[utf8_encode((uint32_t)dyn_payload(v), (uint8_t *)buf)] = '\0';
|
|
emit(w, buf);
|
|
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(w, ":");
|
|
emit_n(w, kw_bytes(k), k->len);
|
|
return;
|
|
}
|
|
/* The map prints in edn's shape with the vec's spacing: a space between
|
|
* elements, key and value alike, so {:a 1 :b 2} sits beside the vec's
|
|
* [1 2 3]. 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 struct's view prints as the class instance it most resembles: its
|
|
* type's name as the shape tag, then its fields in declaration order. */
|
|
if (o->kind == OBJ_VIEW) {
|
|
const char *nm;
|
|
int64_t nl, n = view_nfields(o);
|
|
view_struct_name(o, &nm, &nl);
|
|
emit(w, "#");
|
|
emit_n(w, (const uint8_t *)nm, nl);
|
|
emit(w, "{");
|
|
for (i = 0; i < n; i++) {
|
|
if (i > 0) emit(w, " ");
|
|
render(w, view_field_key(o, i), depth + 1, 1);
|
|
emit(w, " ");
|
|
unsigned long long big;
|
|
if (view_big_u64(o, i, 1, &big)) {
|
|
snprintf(buf, sizeof buf, "%llu", big);
|
|
emit(w, buf);
|
|
} else
|
|
render(w, view_field_val(o, i), depth + 1, 1);
|
|
}
|
|
emit(w, "}");
|
|
return;
|
|
}
|
|
/* 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(w, "#");
|
|
emit_n(w, kw_bytes(o->u.v.klass), o->u.v.klass->len);
|
|
}
|
|
emit(w, "{");
|
|
for (i = 0; i < o->len; i++) {
|
|
if (i > 0) emit(w, " ");
|
|
render(w, o->u.v.items[i * 2], depth + 1, 1);
|
|
emit(w, " ");
|
|
render(w, o->u.v.items[i * 2 + 1], depth + 1, 1);
|
|
}
|
|
emit(w, "}");
|
|
return;
|
|
}
|
|
default: {
|
|
flan_obj *o = dyn_obj(v);
|
|
int64_t i, n = vecish_len(o);
|
|
emit(w, "[");
|
|
for (i = 0; i < n; i++) {
|
|
if (i > 0) emit(w, " ");
|
|
unsigned long long big;
|
|
if (o->kind == OBJ_VIEW && view_big_u64(o, i, 0, &big)) {
|
|
snprintf(buf, sizeof buf, "%llu", big);
|
|
emit(w, buf);
|
|
} else
|
|
render(w, vecish_at(o, i), depth + 1, 1);
|
|
}
|
|
emit(w, "]");
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
|
|
static void print_walk(flan_dyn v) { render(flan_write_stdout, v, 0, 0); }
|
|
|
|
/* The same rendering into an evaluated expression's value, and into the watch
|
|
* slot [flan_dev_watch_begin] opened. lib/render.ml's dyn arm calls these on
|
|
* the inspecting side and [flan_dyn_print] on [println]'s. A text is quoted
|
|
* even at the top, because the typed side's renderer quotes a string there:
|
|
* the value "5" and the value 5 must not read alike. */
|
|
void flan_dyn_emit_dev(flan_dyn v) {
|
|
walk_site was = walk_enter(NULL, 0, "print");
|
|
render(flan_dev_emit, v, 0, 1);
|
|
walk_leave(was);
|
|
}
|
|
void flan_dyn_emit_watch(flan_dyn v) {
|
|
walk_site was = walk_enter(NULL, 0, "print");
|
|
render(flan_dev_watch_emit, v, 0, 1);
|
|
walk_leave(was);
|
|
}
|
|
|
|
/* And into a condition's message, which flan_rt.c's sink bounds. */
|
|
void flan_msg_emit(const uint8_t *p, int64_t n);
|
|
void flan_dyn_emit_msg(flan_dyn v) {
|
|
walk_site was = walk_enter(NULL, 0, "print");
|
|
render(flan_msg_emit, v, 0, 1);
|
|
walk_leave(was);
|
|
}
|
|
|
|
/* 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);
|
|
/* A trap's sentence says 2.0 for a float of 2, so it cannot be read as
|
|
the int 2; inf and an exponent already say float. */
|
|
if (strspn(buf, "-0123456789") == strlen(buf)) say_puts(s, ".0");
|
|
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_CHAR:
|
|
char_spell((uint32_t)dyn_payload(v), buf);
|
|
say_puts(s, buf);
|
|
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; }
|
|
if (o->kind == OBJ_VIEW) {
|
|
const char *nm;
|
|
int64_t nl, n = view_nfields(o), j;
|
|
view_struct_name(o, &nm, &nl);
|
|
say_puts(s, "#");
|
|
for (j = 0; j < nl && s->n < s->cap - 8; j++) {
|
|
char c[2];
|
|
c[0] = nm[j];
|
|
c[1] = '\0';
|
|
say_puts(s, c);
|
|
}
|
|
say_puts(s, "{");
|
|
for (i = 0; i < n && s->n < s->cap - 8; i++) {
|
|
if (i > 0) say_puts(s, " ");
|
|
say_render(s, view_field_key(o, i), depth + 1);
|
|
say_puts(s, " ");
|
|
unsigned long long big;
|
|
if (view_big_u64(o, i, 1, &big)) {
|
|
char nb[32];
|
|
snprintf(nb, sizeof nb, "%llu", big);
|
|
say_puts(s, nb);
|
|
} else
|
|
say_render(s, view_field_val(o, i), depth + 1);
|
|
}
|
|
say_puts(s, i == n ? "}" : i > 0 ? " ...}" : "...}");
|
|
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++) {
|
|
if (i > 0) 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 ? "}" : i > 0 ? " ...}" : "...}");
|
|
return;
|
|
}
|
|
default: {
|
|
flan_obj *o = dyn_obj(v);
|
|
int64_t i, n = vecish_len(o);
|
|
if (depth >= 2) { say_puts(s, "[...]"); return; }
|
|
say_puts(s, "[");
|
|
for (i = 0; i < n && s->n < s->cap - 8; i++) {
|
|
if (i > 0) say_puts(s, " ");
|
|
unsigned long long big;
|
|
if (o->kind == OBJ_VIEW && view_big_u64(o, i, 0, &big)) {
|
|
char nb[32];
|
|
snprintf(nb, sizeof nb, "%llu", big);
|
|
say_puts(s, nb);
|
|
} else
|
|
say_render(s, vecish_at(o, i), depth + 1);
|
|
}
|
|
say_puts(s, i == n ? "]" : i > 0 ? " ...]" : "...]");
|
|
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
|
|
* ([flan_say] writes both): 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 (everything but the arithmetic, the ordering, [at], [set-at]
|
|
* and [push]) pass NULL, and so does test/dyn_ops.c, which calls the runtime
|
|
* directly and has no source position to offer. */
|
|
|
|
/* A trap's sentence written in pieces, then said in one through [flan_say],
|
|
* so it reaches the break loop like every other. */
|
|
static char said_buf[2048];
|
|
static size_t said_len;
|
|
|
|
static void said_add(const char *fmt, ...) {
|
|
va_list ap;
|
|
int n;
|
|
if (said_len >= sizeof said_buf) return;
|
|
va_start(ap, fmt);
|
|
n = vsnprintf(said_buf + said_len, sizeof said_buf - said_len, fmt, ap);
|
|
va_end(ap);
|
|
if (n > 0) said_len += (size_t)n;
|
|
if (said_len >= sizeof said_buf) said_len = sizeof said_buf - 1;
|
|
}
|
|
|
|
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);
|
|
flan_say(loc, loclen, "dyn %s: %s and %s, and %s — (%s %s %s)", op,
|
|
tag_of(a), tag_of(b), why, op, sa, sb);
|
|
dyn_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);
|
|
flan_say(loc, loclen, "dyn %s: %s, and %s — (%s %s)", op, tag_of(a), why, op,
|
|
sa);
|
|
dyn_trap((const uint8_t *)name, namelen);
|
|
}
|
|
|
|
#define TYPE_TRAP "DynType", 7
|
|
#define ARITH_TRAP "DynArith", 8
|
|
|
|
/* [at] and [set-at]'s, with the site their call was written at. */
|
|
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);
|
|
flan_say(loc, loclen,
|
|
"dyn %s: index %lld is out of bounds for %s of length %lld — %s", op,
|
|
(long long)i, tag_of(v), (long long)len, sv);
|
|
dyn_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.
|
|
*
|
|
* [push] is the one caller with a site to give: its growth is the allocation
|
|
* a program's own line asked for. Every other caller is the collector's own
|
|
* bookkeeping — an object, a class table, the keyword table — and passes
|
|
* NULL, which prints no prefix. */
|
|
static _Noreturn void trap_oom(const uint8_t *loc, int64_t loclen,
|
|
int64_t want) {
|
|
flan_say(loc, loclen,
|
|
"dyn heap: %lld bytes could not be allocated, with %lld live",
|
|
(long long)want, (long long)gc_bytes);
|
|
dyn_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(NULL, 0, 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, a map and an environment with a descriptor 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
|
|
&& !(o->kind == OBJ_ENV && o->u.env.desc != NULL)) 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(NULL, 0, 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));
|
|
}
|
|
|
|
/* ── Environments ──────────────────────────────────────────────────────
|
|
*
|
|
* The second word of an (Fn ...) value is one of three things: null, for a
|
|
* value made from a name or from an fn that captured nothing; the address of
|
|
* an environment this file allocated; or, for a named function widened into
|
|
* an Fn, that function's code address, which the widening thunk reads back
|
|
* and calls. The marker meets all three at the same offset and must follow
|
|
* only the second.
|
|
*
|
|
* Nothing in the word says which. A code address can have any low bits — on
|
|
* wasm32 it is a table index, a small integer — so no tag bit is free on that
|
|
* side, and dereferencing one to look for a header would read code or trap.
|
|
* So the collector keeps the set of environment addresses it has handed out
|
|
* and follows a word only when the set has it. An address that is not an
|
|
* environment is never read through, which also makes a stale or unwritten
|
|
* word harmless: at worst it keeps a live environment alive a little longer.
|
|
*
|
|
* Open addressing with linear probing. The sweep deletes each environment it
|
|
* frees, and shrinks the table once it is mostly empty. */
|
|
|
|
static uintptr_t *envset;
|
|
static int64_t envset_cap, envset_n;
|
|
|
|
static inline uint64_t ptr_hash(uintptr_t p) {
|
|
uint64_t x = (uint64_t)p;
|
|
x ^= x >> 33;
|
|
x *= 0xff51afd7ed558ccdULL;
|
|
x ^= x >> 33;
|
|
return x;
|
|
}
|
|
|
|
static void envset_put(uintptr_t p);
|
|
|
|
/* A fresh table of [cap] slots, a power of two, filled from [old]. */
|
|
static void envset_resize(int64_t cap) {
|
|
uintptr_t *old = envset;
|
|
int64_t oldcap = envset_cap, i;
|
|
envset = (uintptr_t *)calloc((size_t)cap, sizeof *envset);
|
|
if (envset == NULL) trap_oom(NULL, 0, cap * (int64_t)sizeof *envset);
|
|
envset_cap = cap;
|
|
envset_n = 0;
|
|
for (i = 0; i < oldcap; i++)
|
|
if (old[i] != 0) envset_put(old[i]);
|
|
free(old);
|
|
}
|
|
|
|
static void envset_put(uintptr_t p) {
|
|
uint64_t h;
|
|
if ((envset_n + 1) * 2 > envset_cap)
|
|
envset_resize(envset_cap ? envset_cap * 2 : 64);
|
|
h = ptr_hash(p) & (uint64_t)(envset_cap - 1);
|
|
while (envset[h] != 0) {
|
|
if (envset[h] == p) return;
|
|
h = (h + 1) & (uint64_t)(envset_cap - 1);
|
|
}
|
|
envset[h] = p;
|
|
envset_n++;
|
|
}
|
|
|
|
static int envset_has(uintptr_t p) {
|
|
uint64_t h;
|
|
if (envset_cap == 0 || p == 0) return 0;
|
|
h = ptr_hash(p) & (uint64_t)(envset_cap - 1);
|
|
while (envset[h] != 0) {
|
|
if (envset[h] == p) return 1;
|
|
h = (h + 1) & (uint64_t)(envset_cap - 1);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
/* One environment freed. Backward-shift deletion, so the table needs no
|
|
* tombstones: every entry after the hole that could have been placed in it
|
|
* moves back. */
|
|
static void envset_del(uintptr_t p) {
|
|
uint64_t mask, i, j, k;
|
|
if (envset_cap == 0) return;
|
|
mask = (uint64_t)(envset_cap - 1);
|
|
i = ptr_hash(p) & mask;
|
|
while (envset[i] != p) {
|
|
if (envset[i] == 0) return;
|
|
i = (i + 1) & mask;
|
|
}
|
|
j = i;
|
|
for (;;) {
|
|
j = (j + 1) & mask;
|
|
if (envset[j] == 0) break;
|
|
k = ptr_hash(envset[j]) & mask;
|
|
/* Move [j] back into the hole at [i] unless its home lies cyclically
|
|
in (i, j]. */
|
|
if ((i <= j) ? (i < k && k <= j) : (i < k || k <= j)) continue;
|
|
envset[i] = envset[j];
|
|
i = j;
|
|
}
|
|
envset[i] = 0;
|
|
envset_n--;
|
|
}
|
|
|
|
/* After a sweep: a table that has emptied to an eighth of its size is
|
|
* rebuilt at a size for what is left, so a program that once held a million
|
|
* environments does not keep a million-slot table. */
|
|
static int64_t envs_made; /* environments allocated since the last sweep */
|
|
|
|
static void envset_shrink(void) {
|
|
int64_t cap = 64, want = envset_n * 4;
|
|
/* Room for as many as the last cycle made, so a program that makes and
|
|
drops closures at a steady rate does not shrink and regrow the table
|
|
every cycle. */
|
|
if (envs_made * 2 > want) want = envs_made * 2;
|
|
envs_made = 0;
|
|
if (envset_cap <= 64 || envset_n * 8 > envset_cap) return;
|
|
while (cap < want) cap *= 2;
|
|
if (cap < envset_cap) envset_resize(cap);
|
|
}
|
|
|
|
static void mark_env(uintptr_t w) {
|
|
if (envset_has(w)) mark_push((flan_obj *)w - 1);
|
|
}
|
|
|
|
/* ── The Vec blocks a marker may read ──────────────────────────────────
|
|
*
|
|
* A (Vec T) header is copied by value, so the one the marker is handed may be
|
|
* a stale copy whose block another copy's push has since reallocated and
|
|
* freed. Reading its elements would read freed memory — and a block large
|
|
* enough for malloc to have unmapped it faults. So the marker never trusts a
|
|
* header's pointer: flan_rt.c reports every Vec block it allocates, moves or
|
|
* frees through [flan_vec_block_hook], this table keeps the live ones with
|
|
* their byte size and the allocator epoch they were made at, and a header is
|
|
* followed only when its pointer is a live block — for no more elements than
|
|
* the block holds, and not after its allocator has been reset past that
|
|
* epoch. A stale header whose pointer malloc has since reused for another Vec
|
|
* is bounded by that Vec's block and its words go through the same checks as
|
|
* any other, so nothing outside a live block is ever read.
|
|
*
|
|
* The hook is installed by [flan_dyn_track_vecs], which a program that can
|
|
* make a collector-owned environment calls first thing in main; blocks made
|
|
* before it cannot hold one. Allocator headers are never freed (flan_rt.c's
|
|
* [flan_arena_destroy]), so reading one's epoch is always safe.
|
|
*
|
|
* Open addressing with tombstones, since blocks come and go all the time. */
|
|
|
|
typedef struct {
|
|
uintptr_t ptr; /* 0 empty, 1 deleted */
|
|
int64_t bytes;
|
|
void *alloc;
|
|
int64_t epoch;
|
|
} vblock;
|
|
|
|
static vblock *vblocks;
|
|
static int64_t vblocks_cap, vblocks_n, vblocks_used;
|
|
|
|
extern void (*flan_vec_block_hook)(void *old, void *fresh, int64_t bytes,
|
|
void *alloc, int64_t epoch);
|
|
|
|
static void vblock_put(uintptr_t p, int64_t bytes, void *alloc, int64_t epoch);
|
|
|
|
static void vblock_resize(int64_t cap) {
|
|
vblock *old = vblocks;
|
|
int64_t oldcap = vblocks_cap, i;
|
|
vblocks = (vblock *)calloc((size_t)cap, sizeof *vblocks);
|
|
if (vblocks == NULL) trap_oom(NULL, 0, cap * (int64_t)sizeof *vblocks);
|
|
vblocks_cap = cap;
|
|
vblocks_n = 0;
|
|
vblocks_used = 0;
|
|
for (i = 0; i < oldcap; i++)
|
|
if (old[i].ptr > 1)
|
|
vblock_put(old[i].ptr, old[i].bytes, old[i].alloc, old[i].epoch);
|
|
free(old);
|
|
}
|
|
|
|
static vblock *vblock_find(uintptr_t p) {
|
|
uint64_t h;
|
|
if (vblocks_cap == 0 || p <= 1) return NULL;
|
|
h = ptr_hash(p) & (uint64_t)(vblocks_cap - 1);
|
|
while (vblocks[h].ptr != 0) {
|
|
if (vblocks[h].ptr == p) return &vblocks[h];
|
|
h = (h + 1) & (uint64_t)(vblocks_cap - 1);
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
static void vblock_put(uintptr_t p, int64_t bytes, void *alloc, int64_t epoch) {
|
|
uint64_t h;
|
|
vblock *hit = vblock_find(p);
|
|
if (hit != NULL) {
|
|
hit->bytes = bytes; hit->alloc = alloc; hit->epoch = epoch;
|
|
return;
|
|
}
|
|
if ((vblocks_used + 1) * 2 > vblocks_cap) {
|
|
int64_t cap = 64;
|
|
while (cap < (vblocks_n + 1) * 4) cap *= 2;
|
|
vblock_resize(cap);
|
|
}
|
|
h = ptr_hash(p) & (uint64_t)(vblocks_cap - 1);
|
|
while (vblocks[h].ptr > 1) h = (h + 1) & (uint64_t)(vblocks_cap - 1);
|
|
if (vblocks[h].ptr == 0) vblocks_used++;
|
|
vblocks[h].ptr = p;
|
|
vblocks[h].bytes = bytes;
|
|
vblocks[h].alloc = alloc;
|
|
vblocks[h].epoch = epoch;
|
|
vblocks_n++;
|
|
}
|
|
|
|
static void vblock_drop(uintptr_t p) {
|
|
vblock *hit = vblock_find(p);
|
|
if (hit != NULL) { hit->ptr = 1; vblocks_n--; }
|
|
}
|
|
|
|
static void vblock_hook(void *old, void *fresh, int64_t bytes, void *alloc,
|
|
int64_t epoch) {
|
|
if (old != NULL) vblock_drop((uintptr_t)old);
|
|
if (fresh != NULL) vblock_put((uintptr_t)fresh, bytes, alloc, epoch);
|
|
}
|
|
|
|
void flan_dyn_track_vecs(void) { flan_vec_block_hook = vblock_hook; }
|
|
|
|
/* Vecs still to walk, as (live block, element count, element descriptor).
|
|
* Explicit for the mark stack's reason: a data type can hold a Vec of itself,
|
|
* so how deep Vecs nest is the data's and not the type's, and recursion would
|
|
* put it on the C stack. */
|
|
typedef struct { char *p; int64_t n; const flan_desc *e; } vec_work;
|
|
static vec_work *vstack;
|
|
static int64_t vstack_n, vstack_cap;
|
|
|
|
/* Maps still to walk: a live block's control run, its slots, the slot count,
|
|
* the stride and value offset the block's own head records, and the value's
|
|
* descriptor. Queued for the Vec queue's reason. */
|
|
typedef struct {
|
|
const uint8_t *ctrl; char *slots; int64_t cap, stride, voff;
|
|
const flan_desc *e;
|
|
} map_work;
|
|
static map_work *mapstack;
|
|
static int64_t mapstack_n, mapstack_cap;
|
|
|
|
/* A live block, not reset since it was made: the checks a Vec's block and a
|
|
* Map's share. The allocator header is never freed, so its epoch is always
|
|
* readable. */
|
|
static vblock *live_block(void *p) {
|
|
vblock *b = vblock_find((uintptr_t)p);
|
|
if (b == NULL) return NULL;
|
|
if (b->alloc != NULL
|
|
&& (int64_t)((flan_dyn_alloc_hdr *)b->alloc)->epoch != b->epoch)
|
|
return NULL;
|
|
return b;
|
|
}
|
|
|
|
/* Queue the map whose header is at [h]. The slot count comes from the
|
|
* header and everything else from the block, and the walk is bounded by the
|
|
* block's recorded size, so a stale header copy naming a block another map
|
|
* now owns reads nothing outside that block. */
|
|
static void queue_map(const flan_dyn_map_hdr *h, const flan_desc *e) {
|
|
vblock *b;
|
|
const int64_t *head;
|
|
int64_t cap, ctrl, stride, voff;
|
|
if (e == NULL || h->data == NULL || h->log2cap <= 0 || h->log2cap > 40)
|
|
return;
|
|
b = live_block(h->data);
|
|
if (b == NULL || b->bytes < DYN_MAP_HEAD) return;
|
|
cap = (int64_t)1 << h->log2cap;
|
|
ctrl = (DYN_MAP_HEAD + cap + (DYN_MAP_GROUP - 1) + (DYN_MAP_ALIGN - 1))
|
|
& ~(int64_t)(DYN_MAP_ALIGN - 1);
|
|
head = (const int64_t *)h->data;
|
|
stride = head[1];
|
|
voff = head[2];
|
|
if (stride <= 0 || voff < 0 || voff + e->size > stride) return;
|
|
if (ctrl > b->bytes || (b->bytes - ctrl) / stride < cap) return;
|
|
if (mapstack_n == mapstack_cap) {
|
|
int64_t c = mapstack_cap ? mapstack_cap * 2 : 16;
|
|
map_work *m = (map_work *)realloc(mapstack, (size_t)c * sizeof *m);
|
|
if (m == NULL) trap_oom(NULL, 0, c * (int64_t)sizeof *m);
|
|
mapstack = m;
|
|
mapstack_cap = c;
|
|
}
|
|
mapstack[mapstack_n].ctrl = (const uint8_t *)h->data + DYN_MAP_HEAD;
|
|
mapstack[mapstack_n].slots = (char *)h->data + ctrl;
|
|
mapstack[mapstack_n].cap = cap;
|
|
mapstack[mapstack_n].stride = stride;
|
|
mapstack[mapstack_n].voff = voff;
|
|
mapstack[mapstack_n].e = e;
|
|
mapstack_n++;
|
|
}
|
|
|
|
/* The words [d] names inside the instance at [base]. A Vec entry is checked
|
|
* against the live blocks above and queued; [mark_desc] drains the queue
|
|
* before it returns. */
|
|
static void mark_words(char *base, const flan_desc *d) {
|
|
int64_t j;
|
|
for (j = 0; j < d->n; j++) mark_value(*(flan_dyn *)(base + d->offs[j]));
|
|
for (j = 0; j < d->nenv; j++) mark_env(*(uintptr_t *)(base + d->envs[j]));
|
|
for (j = 0; j < d->nmap; j++)
|
|
queue_map((const flan_dyn_map_hdr *)(base + d->maps[j].off),
|
|
d->maps[j].elem);
|
|
for (j = 0; j < d->nvec; j++) {
|
|
flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)(base + d->vecs[j].off);
|
|
const flan_desc *e = d->vecs[j].elem;
|
|
vblock *b;
|
|
int64_t n;
|
|
if (e == NULL || e->size <= 0 || h->len <= 0) continue;
|
|
b = live_block(h->ptr);
|
|
if (b == NULL) continue;
|
|
n = b->bytes / e->size;
|
|
if (h->len < n) n = h->len;
|
|
if (vstack_n == vstack_cap) {
|
|
int64_t cap = vstack_cap ? vstack_cap * 2 : 16;
|
|
vec_work *v = (vec_work *)realloc(vstack, (size_t)cap * sizeof *v);
|
|
if (v == NULL) trap_oom(NULL, 0, cap * (int64_t)sizeof *v);
|
|
vstack = v;
|
|
vstack_cap = cap;
|
|
}
|
|
vstack[vstack_n].p = (char *)h->ptr;
|
|
vstack[vstack_n].n = n;
|
|
vstack[vstack_n].e = e;
|
|
vstack_n++;
|
|
}
|
|
}
|
|
|
|
static void mark_desc(char *base, const flan_desc *d) {
|
|
mark_words(base, d);
|
|
while (vstack_n > 0 || mapstack_n > 0) {
|
|
int64_t i;
|
|
if (vstack_n > 0) {
|
|
vec_work w = vstack[--vstack_n];
|
|
for (i = 0; i < w.n; i++) mark_words(w.p + i * w.e->size, w.e);
|
|
} else {
|
|
map_work w = mapstack[--mapstack_n];
|
|
for (i = 0; i < w.cap; i++)
|
|
if (w.ctrl[i] & DYN_MAP_FULL)
|
|
mark_words(w.slots + i * w.stride + w.voff, w.e);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* ── Texts a str was taken from ────────────────────────────────────────
|
|
*
|
|
* A dyn text crossing into a str ([flan_dyn_need_as]) is not copied: the str
|
|
* is the text's own bytes, which never move, since this collector never
|
|
* moves anything. What could happen is a free — a str in a typed local,
|
|
* field or Vec is not a root, and typed storage is never scanned — so the
|
|
* crossing pins the text here, keyed by the temp arena's stamp, and every
|
|
* collection marks the pins whose stamp is still live. The str then lasts
|
|
* as long as the text is reachable from dyn or until the next free-temp,
|
|
* whichever is later: the lifetime i64->bytes's text already has, and text
|
|
* kept longer is cloned, as there.
|
|
*
|
|
* Rooting the text in the crossing's frame would be shorter than that and
|
|
* wrong for a str returned or stored, and a pin for good would keep every
|
|
* text a frame loop ever crossed. A copy into the temp arena would be sound
|
|
* too; this is the same lifetime without the copy, and a dev build takes the
|
|
* copy instead ([into_text]) so that a str kept past free-temp reads the
|
|
* arena's poison, as i64->bytes's text does, rather than whatever text the
|
|
* allocator put there next.
|
|
*
|
|
* A text is pinned once per stamp, however often it crosses: the stamp's
|
|
* number is written into the text's [gen], which nothing else reads or
|
|
* writes for a text — its char count is in [u.i], and whether it is ASCII is
|
|
* that count against its length ([text_measure]) — so a program that never calls free-temp and passes the same texts
|
|
* in a loop keeps a flat list. Distinct texts cost one pointer each here,
|
|
* and each keeps its own object alive until the stamp ends — heavier than
|
|
* i64->bytes's few bytes of arena, since the object has a header. The pins
|
|
* sit in runs, one per stamp, so an entry is a pointer and a run's stamp is
|
|
* kept once. */
|
|
const void *flan_temp_stamp(uint64_t *inc, uint64_t *epoch);
|
|
int32_t flan_temp_stamp_live(const void *a, uint64_t inc, uint64_t epoch);
|
|
|
|
typedef struct pin_run {
|
|
const void *a;
|
|
uint64_t inc, epoch;
|
|
int64_t start; /* its first entry in [pins] */
|
|
} pin_run;
|
|
|
|
static flan_obj **pins;
|
|
static int64_t pins_n, pins_cap;
|
|
static pin_run *runs;
|
|
static int64_t runs_n, runs_cap;
|
|
/* The number the newest run's texts carry in [gen]; never 0, which is what
|
|
a text is made with. A wrap would take four billion stamps, and costs one
|
|
duplicate entry when it lands on an old text's number. */
|
|
static uint32_t pin_gen;
|
|
|
|
static int64_t pins_count(void) { return pins_n; }
|
|
|
|
static void pins_prune(void) {
|
|
int64_t r, k = 0, rk = 0;
|
|
for (r = 0; r < runs_n; r++) {
|
|
int64_t lo = runs[r].start;
|
|
int64_t hi = r + 1 < runs_n ? runs[r + 1].start : pins_n;
|
|
if (!flan_temp_stamp_live(runs[r].a, runs[r].inc, runs[r].epoch)) continue;
|
|
memmove(pins + k, pins + lo, (size_t)(hi - lo) * sizeof *pins);
|
|
runs[rk] = runs[r];
|
|
runs[rk].start = k;
|
|
k += hi - lo;
|
|
rk++;
|
|
}
|
|
pins_n = k;
|
|
runs_n = rk;
|
|
}
|
|
|
|
static void *pins_grow(void *p, int64_t *cap, size_t each) {
|
|
int64_t c = *cap ? *cap * 2 : 64;
|
|
void *q = realloc(p, (size_t)c * each);
|
|
if (q == NULL) trap_oom(NULL, 0, c * (int64_t)each);
|
|
*cap = c;
|
|
return q;
|
|
}
|
|
|
|
static void pin_text(flan_obj *o) {
|
|
uint64_t inc, epoch;
|
|
const void *a = flan_temp_stamp(&inc, &epoch);
|
|
pin_run *last = runs_n > 0 ? &runs[runs_n - 1] : NULL;
|
|
if (last == NULL || last->a != a || last->inc != inc
|
|
|| last->epoch != epoch) {
|
|
if (runs_n == runs_cap) {
|
|
pins_prune();
|
|
if (runs_n == runs_cap) runs = pins_grow(runs, &runs_cap, sizeof *runs);
|
|
}
|
|
runs[runs_n].a = a;
|
|
runs[runs_n].inc = inc;
|
|
runs[runs_n].epoch = epoch;
|
|
runs[runs_n].start = pins_n;
|
|
runs_n++;
|
|
if (++pin_gen == 0) pin_gen = 1;
|
|
} else if (o->gen == pin_gen)
|
|
return;
|
|
if (pins_n == pins_cap) {
|
|
pins_prune();
|
|
if (pins_n == pins_cap) pins = pins_grow(pins, &pins_cap, sizeof *pins);
|
|
}
|
|
o->gen = pin_gen;
|
|
pins[pins_n++] = o;
|
|
}
|
|
|
|
/* How many texts are pinned now, for a test that the list stays flat. */
|
|
int64_t flan_dyn_pin_count(void) { return pins_count(); }
|
|
|
|
static void gc_mark_all(void) {
|
|
int64_t i;
|
|
unsigned k;
|
|
pins_prune();
|
|
for (i = 0; i < pins_n; i++) mark_push(pins[i]);
|
|
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 mark_desc((char *)roots[i].base, d);
|
|
}
|
|
for (k = 0; k < RING; k++) mark_push(ring[k]);
|
|
while (mstack_n > 0) {
|
|
flan_obj *o = mstack[--mstack_n];
|
|
int64_t n;
|
|
if (o->kind == OBJ_ENV) {
|
|
mark_desc((char *)(o + 1), o->u.env.desc);
|
|
continue;
|
|
}
|
|
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 || o->kind == OBJ_ENV) held += o->len;
|
|
if (o->kind == OBJ_VIEW && (o->gen & 0x100))
|
|
held += (int64_t)sizeof(view_guard);
|
|
if (o->kind == OBJ_ENV) envset_del((uintptr_t)(o + 1));
|
|
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;
|
|
}
|
|
/* A freed environment's address left the set above, before malloc can hand
|
|
it out again as something else. */
|
|
envset_shrink();
|
|
}
|
|
|
|
void *flan_dyn_env_new(int64_t size, const flan_desc *d) {
|
|
flan_obj *o = gc_alloc(OBJ_ENV, size);
|
|
o->len = size;
|
|
o->u.env.desc = (d != NULL && (d->n > 0 || d->nenv > 0 || d->nvec > 0
|
|
|| d->nmap > 0))
|
|
? d : NULL;
|
|
memset(o + 1, 0, (size_t)size);
|
|
envset_put((uintptr_t)(o + 1));
|
|
envs_made++;
|
|
return (void *)(o + 1);
|
|
}
|
|
|
|
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(NULL, 0, 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, 0, NULL, 0, NULL, 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; }
|
|
|
|
/* The same for one evaluation that trapped: the roots its frames pushed are
|
|
* dropped, and the ones below it kept. */
|
|
int64_t flan_dyn_root_mark(void) { return roots_n; }
|
|
void flan_dyn_root_restore(int64_t n) { if (n <= roots_n) roots_n = n; }
|
|
|
|
/* ── 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);
|
|
}
|
|
|
|
/* A u64 has a dyn int to become only up to the largest i64; past it the trap
|
|
* names the number, which read as an i64 would be a different one. [what] is
|
|
* "u64" for a scalar crossing and "u64 element" for one read through a view,
|
|
* so both say the same sentence. */
|
|
static flan_dyn u64_to_dyn(const uint8_t *loc, int64_t loclen, const char *op,
|
|
const char *what, uint64_t x) {
|
|
if (x > (uint64_t)INT64_MAX) {
|
|
flan_say(loc, loclen,
|
|
"dyn%s%s: this %s is %llu, above the largest dyn int "
|
|
"(9223372036854775807), so it has no dyn value",
|
|
op[0] ? " " : "", op, what, (unsigned long long)x);
|
|
dyn_trap((const uint8_t *)"DynRange", 8);
|
|
}
|
|
return flan_dyn_from_i64((int64_t)x);
|
|
}
|
|
|
|
flan_dyn flan_dyn_from_u64(uint64_t x, const uint8_t *loc, int64_t loclen) {
|
|
return u64_to_dyn(loc, loclen, "", "u64", x);
|
|
}
|
|
|
|
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);
|
|
text_measure(o);
|
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
|
}
|
|
|
|
/* Only a scalar value is a char; the reader and [chars] make nothing else,
|
|
* so a refusal here is a compiler bug and not a program's. */
|
|
flan_dyn flan_dyn_from_char(int32_t cp) {
|
|
if (!is_scalar(cp))
|
|
trap1(NULL, 0, TYPE_TRAP, "char", "a char is a Unicode scalar value",
|
|
flan_dyn_from_i64(cp));
|
|
return dyn_make(BOX_CHAR, (uint64_t)(uint32_t)cp);
|
|
}
|
|
|
|
/* A String crossing into dyn: its (Vec u8), by address, copied into dyn text.
|
|
* A copy and not a view, because dyn text is immutable and a String is not. */
|
|
flan_dyn flan_dyn_from_string(const void *vec) {
|
|
const flan_dyn_vec_hdr *v = (const flan_dyn_vec_hdr *)vec;
|
|
return flan_dyn_from_bytes((const uint8_t *)v->ptr, v->len);
|
|
}
|
|
|
|
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] included —
|
|
* see [class_hook]; 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 constrains.** A store into a slot the class declares
|
|
* — the constructor's, [put]'s, [set]'s — is checked against the slot's
|
|
* type. A key the class does not declare is refused by [get], [put] and
|
|
* [set] alike ([trap_no_slot]), so an instance's keys are its class's slots
|
|
* and the migration below, which keeps only those, drops nothing a program
|
|
* wrote.
|
|
*
|
|
* **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 TODO.org, "A redefined defclass
|
|
* migrates its instances lazily", 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);
|
|
|
|
/* What a slot may hold. A dyn value's tag is the whole of what can be asked
|
|
* of it, so these are the tags — plus a range on top of the int tag for a
|
|
* narrower integer type, the significand a float slot holds exactly, a
|
|
* class for a slot declared with one, and whether nil is admitted, which is
|
|
* what (Option T) says. [word] is a scalar type's name, for the sentence a
|
|
* refusal prints. */
|
|
enum { ST_ANY, ST_BOOL, ST_INT, ST_FLOAT, ST_TEXT, ST_CLASS };
|
|
|
|
typedef struct slot_type {
|
|
uint8_t kind;
|
|
uint8_t opt; /* nil admitted: (Option T) */
|
|
uint8_t fbits; /* ST_FLOAT: 53 for f64, 24 for f32 */
|
|
int64_t lo, hi; /* ST_INT only */
|
|
kw_entry *cls; /* ST_CLASS only */
|
|
const char *word; /* static; NULL for ST_ANY and ST_CLASS */
|
|
} slot_type;
|
|
|
|
typedef struct class_entry {
|
|
kw_entry *name;
|
|
kw_entry **slots; /* interned, immortal, in declaration order */
|
|
slot_type *types; /* one per slot, same order */
|
|
/* Per slot, the generation a migration last warned about a value that no
|
|
* longer fits the slot's type. One warning per slot per redefinition,
|
|
* however many instances carry such a value. */
|
|
uint32_t *warned;
|
|
int64_t nslots;
|
|
uint32_t gen;
|
|
/* Whether any slot has a type. A class with none pays nothing at a store
|
|
* beyond reading this. */
|
|
int typed;
|
|
} 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, now that the constructor
|
|
* registers its class, is only an instance built by something other than a
|
|
* constructor: test/dyn_ops.c, calling the runtime directly. */
|
|
static uint32_t class_gen(kw_entry *name) {
|
|
class_entry *e = class_find(name);
|
|
return e == NULL ? 0u : e->gen;
|
|
}
|
|
|
|
/* One slot's type, as [Check.class_spec_of] writes it: a scalar type's name,
|
|
* [#name] for a class, and a leading [?] for an (Option T). */
|
|
static slot_type slot_type_of(const uint8_t *w, int64_t n) {
|
|
static const struct {
|
|
const char *w; uint8_t kind, fbits; int64_t lo, hi;
|
|
} known[] = {
|
|
{ "bool", ST_BOOL, 0, 0, 0 },
|
|
{ "str", ST_TEXT, 0, 0, 0 },
|
|
{ "f32", ST_FLOAT, 24, 0, 0 },
|
|
{ "f64", ST_FLOAT, 53, 0, 0 },
|
|
{ "i8", ST_INT, 0, INT8_MIN, INT8_MAX },
|
|
{ "i16", ST_INT, 0, INT16_MIN, INT16_MAX },
|
|
{ "i32", ST_INT, 0, INT32_MIN, INT32_MAX },
|
|
{ "i64", ST_INT, 0, INT64_MIN, INT64_MAX },
|
|
{ "u8", ST_INT, 0, 0, UINT8_MAX },
|
|
{ "u16", ST_INT, 0, 0, UINT16_MAX },
|
|
{ "u32", ST_INT, 0, 0, UINT32_MAX },
|
|
{ "u64", ST_INT, 0, 0, INT64_MAX },
|
|
};
|
|
slot_type t = { ST_ANY, 0, 0, 0, 0, NULL, NULL };
|
|
size_t i;
|
|
if (n > 0 && w[0] == '?') {
|
|
t = slot_type_of(w + 1, n - 1);
|
|
if (t.kind != ST_ANY) t.opt = 1;
|
|
return t;
|
|
}
|
|
if (n > 1 && w[0] == '#') {
|
|
t.kind = ST_CLASS;
|
|
t.cls = dyn_kw(flan_dyn_kw(w + 1, n - 1));
|
|
return t;
|
|
}
|
|
for (i = 0; i < sizeof known / sizeof known[0]; i++)
|
|
if ((int64_t)strlen(known[i].w) == n && memcmp(known[i].w, w, (size_t)n) == 0) {
|
|
t.kind = known[i].kind;
|
|
t.fbits = known[i].fbits;
|
|
t.lo = known[i].lo;
|
|
t.hi = known[i].hi;
|
|
t.word = known[i].w;
|
|
return t;
|
|
}
|
|
/* A word this table does not know is a compiler newer than this runtime.
|
|
Holding anything is the answer that loses no data. */
|
|
return t;
|
|
}
|
|
|
|
static int slot_type_eq(const slot_type *a, const slot_type *b) {
|
|
return a->kind == b->kind && a->opt == b->opt && a->fbits == b->fbits
|
|
&& a->lo == b->lo && a->hi == b->hi && a->cls == b->cls;
|
|
}
|
|
|
|
/* The type as it was written, for a sentence. */
|
|
static void slot_type_text(const slot_type *t, char *buf, size_t cap) {
|
|
char base[96];
|
|
if (t->kind == ST_CLASS)
|
|
snprintf(base, sizeof base, "%.*s", (int)t->cls->len,
|
|
(const char *)(t->cls + 1));
|
|
else
|
|
snprintf(base, sizeof base, "%s", t->word != NULL ? t->word : "dyn");
|
|
if (t->opt) snprintf(buf, cap, "(Option %s)", base);
|
|
else snprintf(buf, cap, "%s", base);
|
|
}
|
|
|
|
/* Whether [v] may be stored in a slot of type [t], and what is stored: [v]
|
|
* itself, or — for an int into a float slot — the float it widens to. The
|
|
* widening is the typed side's rule read off the value rather than off a
|
|
* static type: an integer the float holds exactly is admitted as that float,
|
|
* and one it does not is refused, as (f64 x) would be for the
|
|
* type that could hold it. A float into an f32 slot has to be one an f32
|
|
* holds, which is the typed side refusing f64 into f32. */
|
|
static int slot_admit(const slot_type *t, flan_dyn v, flan_dyn *out) {
|
|
int tag = flan_dyn_tag(v);
|
|
*out = v;
|
|
if (t->kind == ST_ANY) return 1;
|
|
if (tag == FLAN_DYN_TAG_NIL) return t->opt;
|
|
switch (t->kind) {
|
|
case ST_BOOL: return tag == FLAN_DYN_TAG_BOOL;
|
|
case ST_TEXT: return tag == FLAN_DYN_TAG_TEXT;
|
|
case ST_CLASS:
|
|
return tag == FLAN_DYN_TAG_MAP && dyn_obj(v)->u.v.klass == t->cls;
|
|
case ST_FLOAT:
|
|
if (tag == FLAN_DYN_TAG_FLOAT) {
|
|
double d = dyn_num_value(v);
|
|
return t->fbits == 53 || d != d || (double)(float)d == d;
|
|
}
|
|
if (tag == FLAN_DYN_TAG_INT) {
|
|
/* Exact is a round trip, not a range: 2^54 is an f64 exactly and
|
|
2^53+1 is not. The range test before the cast back is what keeps
|
|
that cast defined, since INT64_MAX rounds up to 2^63. */
|
|
int64_t x = dyn_int_value(v);
|
|
double d = t->fbits == 53 ? (double)x : (double)(float)x;
|
|
if (!(d >= -9223372036854775808.0 && d < 9223372036854775808.0)
|
|
|| (int64_t)d != x)
|
|
return 0;
|
|
*out = flan_dyn_from_f64(d);
|
|
return 1;
|
|
}
|
|
return 0;
|
|
case ST_INT: {
|
|
int64_t x;
|
|
if (tag != FLAN_DYN_TAG_INT) return 0;
|
|
x = dyn_int_value(v);
|
|
return x >= t->lo && x <= t->hi;
|
|
}
|
|
default: return 1;
|
|
}
|
|
}
|
|
|
|
static int slot_fits(const slot_type *t, flan_dyn v) {
|
|
flan_dyn ignored;
|
|
return slot_admit(t, v, &ignored);
|
|
}
|
|
|
|
/* A class's slots as the compiler hands them over: one line per slot, the
|
|
* slot's name and then, after a space, its type's name — nothing for a slot
|
|
* written with no type. The same string comes from a constructor and from a
|
|
* reload, so it is read in one place. The count is returned; both arrays are
|
|
* NULL for a class with no slots, which allocates nothing. */
|
|
static int64_t class_spec(const uint8_t *spec, int64_t n, kw_entry ***names,
|
|
slot_type **types) {
|
|
int64_t count = 0, i, start;
|
|
if (n < 0) n = 0;
|
|
*names = NULL;
|
|
*types = NULL;
|
|
for (i = 0, start = 0; i <= n; i++)
|
|
if (i == n ? i > start : spec[i] == '\n') {
|
|
if (i > start) count++;
|
|
start = i + 1;
|
|
}
|
|
if (count == 0) return 0;
|
|
*names = (kw_entry **)malloc((size_t)count * sizeof **names);
|
|
*types = (slot_type *)malloc((size_t)count * sizeof **types);
|
|
if (*names == NULL || *types == NULL)
|
|
trap_oom(NULL, 0, count * (int64_t)(sizeof **names + sizeof **types));
|
|
count = 0;
|
|
for (i = 0, start = 0; i <= n; i++)
|
|
if (i == n ? i > start : spec[i] == '\n') {
|
|
if (i > start) {
|
|
int64_t sp = start;
|
|
while (sp < i && spec[sp] != ' ') sp++;
|
|
(*names)[count] = dyn_kw(flan_dyn_kw(spec + start, sp - start));
|
|
(*types)[count] = sp < i ? slot_type_of(spec + sp + 1, i - sp - 1)
|
|
: slot_type_of(NULL, 0);
|
|
count++;
|
|
}
|
|
start = i + 1;
|
|
}
|
|
return count;
|
|
}
|
|
|
|
static void class_add(kw_entry *k, kw_entry **list, slot_type *types,
|
|
int64_t count) {
|
|
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(NULL, 0, cap * (int64_t)sizeof *t);
|
|
classes = t;
|
|
classes_cap = cap;
|
|
}
|
|
classes[classes_n].name = k;
|
|
classes[classes_n].slots = list;
|
|
classes[classes_n].types = types;
|
|
classes[classes_n].warned =
|
|
count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL;
|
|
if (count > 0 && classes[classes_n].warned == NULL)
|
|
trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t));
|
|
classes[classes_n].nslots = count;
|
|
classes[classes_n].typed = 0;
|
|
{
|
|
int64_t j;
|
|
for (j = 0; j < count; j++)
|
|
if (types[j].kind != ST_ANY) classes[classes_n].typed = 1;
|
|
}
|
|
/* 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++;
|
|
}
|
|
|
|
/* One class's current definition, as the compiler's per-reload thunk hands
|
|
* it over: the class's name as a keyword, and [class_spec]'s string.
|
|
*
|
|
* The generation is bumped only when the definition actually differs — a
|
|
* slot's name or its type. 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;
|
|
slot_type *types;
|
|
int64_t count, i;
|
|
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);
|
|
count = class_spec(slots, n, &list, &types);
|
|
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] || !slot_type_eq(&e->types[i], &types[i])) {
|
|
same = 0;
|
|
break;
|
|
}
|
|
if (same) { free(list); free(types); return; }
|
|
free(e->slots);
|
|
free(e->types);
|
|
free(e->warned);
|
|
e->slots = list;
|
|
e->types = types;
|
|
e->warned =
|
|
count > 0 ? (uint32_t *)calloc((size_t)count, sizeof(uint32_t)) : NULL;
|
|
if (count > 0 && e->warned == NULL)
|
|
trap_oom(NULL, 0, count * (int64_t)sizeof(uint32_t));
|
|
e->nslots = count;
|
|
e->typed = 0;
|
|
for (i = 0; i < count; i++)
|
|
if (types[i].kind != ST_ANY) e->typed = 1;
|
|
/* 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;
|
|
}
|
|
class_add(k, list, types, count);
|
|
}
|
|
|
|
/* update-instance-for-redefined-class's dispatcher, as the last reload that
|
|
* installed a class or one of its methods left it; NULL until then. Set by a
|
|
* thunk and not found by name, because the name is a Flan symbol this file
|
|
* cannot spell and the body behind it moves with every method added. */
|
|
static void *migrate_fn;
|
|
|
|
void flan_dyn_class_hook(void *fn) { migrate_fn = fn; }
|
|
|
|
extern int (*flan_dyn_migrate_hook)(void *fn, uint64_t instance,
|
|
uint64_t added, uint64_t discarded);
|
|
|
|
/* Allocation and the map operations are further down, under their own
|
|
* headings; the hook's arguments are built with them. */
|
|
flan_dyn flan_dyn_vec_new(void);
|
|
flan_dyn flan_dyn_map_new(void);
|
|
void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen);
|
|
void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v);
|
|
flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc,
|
|
int64_t loclen);
|
|
void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc,
|
|
int64_t loclen);
|
|
|
|
/* The user hook, run on an instance the name-matching has just brought up to
|
|
* date. [inst], [added] and [gone] are rooted by the caller.
|
|
*
|
|
* Two things are kept for the length of the call, because the call is
|
|
* arbitrary Flan and may allocate as much as it likes:
|
|
*
|
|
* - the name-matched entries, rooted, so that taking the restart puts the
|
|
* instance back exactly as name-matching left it, whatever the method did
|
|
* to it before it signalled. That is the restart's whole meaning, and it
|
|
* is SBCL's choice of what a failed update leaves (std-class.lisp, the
|
|
* nlx-protect around the call) moved one step: SBCL restores the obsolete
|
|
* instance and retries at the next access, where here the name-matched
|
|
* one is kept and nothing is retried.
|
|
* - the temporaries ring, saved and put back. A migration starts inside
|
|
* [get] or [put], whose caller may be holding an object only the ring
|
|
* keeps alive — the result of the call beside it in the same expression.
|
|
* A method that allocates more than the ring holds would push it out and
|
|
* let the next collection free it, so the ring is rooted for the call and
|
|
* restored after it, and the caller sees the ring it left. */
|
|
static void class_hook(flan_obj *o, flan_dyn inst, flan_dyn added,
|
|
flan_dyn gone, int64_t n) {
|
|
flan_dyn *snap = NULL;
|
|
flan_obj *ring_was[RING];
|
|
flan_dyn ring_rooted[RING];
|
|
unsigned ring_at_was = ring_at, k;
|
|
int64_t j, roots_at = roots_n;
|
|
int r;
|
|
if (n > 0) {
|
|
snap = (flan_dyn *)malloc((size_t)n * 2 * sizeof *snap);
|
|
if (snap == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *snap);
|
|
memcpy(snap, o->u.v.items, (size_t)n * 2 * sizeof *snap);
|
|
for (j = 0; j < n; j++) root_add(&snap[j * 2 + 1], NULL);
|
|
}
|
|
memcpy(ring_was, ring, sizeof ring);
|
|
for (k = 0; k < RING; k++) {
|
|
ring_rooted[k] = ring[k] == NULL
|
|
? dyn_make(BOX_NIL, 0)
|
|
: dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)ring[k]);
|
|
root_add(&ring_rooted[k], NULL);
|
|
}
|
|
r = flan_dyn_migrate_hook(migrate_fn, inst, added, gone);
|
|
memcpy(ring, ring_was, sizeof ring);
|
|
ring_at = ring_at_was;
|
|
/* Nothing below allocates on the collector's heap, so the roots into
|
|
[snap] and this frame can go before either does. */
|
|
roots_n = roots_at;
|
|
if (r == 1) {
|
|
/* The restart: the entries name-matching left, in a block of their own,
|
|
* whatever the method grew or shrank the instance to. */
|
|
flan_dyn *back = NULL;
|
|
if (n > 0) {
|
|
back = (flan_dyn *)malloc((size_t)n * 2 * sizeof *back);
|
|
if (back == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *back);
|
|
memcpy(back, snap, (size_t)n * 2 * sizeof *back);
|
|
}
|
|
gc_bytes += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn);
|
|
free(o->u.v.items);
|
|
o->u.v.items = back;
|
|
o->u.v.cap = n;
|
|
o->len = n;
|
|
}
|
|
free(snap);
|
|
if (r == 2) {
|
|
kw_entry *c = o->u.v.klass;
|
|
flan_say(NULL, 0,
|
|
"dyn migrate: update-instance-for-redefined-class, migrating an "
|
|
"instance of %.*s, was left for a restart established outside "
|
|
"it. A migration runs inside get, put or set, and cannot be "
|
|
"left for one of their callers; the instance is kept as its "
|
|
"slots matched by name. Take migrate-by-name, or handle the "
|
|
"condition inside the method",
|
|
(int)c->len, (const char *)(c + 1));
|
|
dyn_trap((const uint8_t *)"DynMigrate", 10);
|
|
}
|
|
}
|
|
|
|
/* An entry at the end of a map, with no lookup first: for a map whose keys
|
|
* are known to be distinct already. A lookup compares keys with [dyn_equal],
|
|
* which migrates any stale instance it meets and runs that instance's hook —
|
|
* and a migration building its own hook's arguments must not start another
|
|
* one, or the instance it is migrating is migrated again inside itself. */
|
|
static void map_append(flan_obj *m, flan_dyn k, flan_dyn v) {
|
|
if (m->len == m->u.v.cap) {
|
|
int64_t cap = m->u.v.cap ? m->u.v.cap * 2 : 8;
|
|
flan_dyn *items =
|
|
(flan_dyn *)realloc(m->u.v.items, (size_t)cap * 2 * sizeof *items);
|
|
if (items == NULL) trap_oom(NULL, 0, cap * 2 * (int64_t)sizeof *items);
|
|
gc_bytes += (cap - m->u.v.cap) * 2 * (int64_t)sizeof *items;
|
|
m->u.v.items = items;
|
|
m->u.v.cap = cap;
|
|
}
|
|
m->u.v.items[m->len * 2] = k;
|
|
m->u.v.items[m->len * 2 + 1] = v;
|
|
m->len++;
|
|
}
|
|
|
|
/* Which of [o]'s entries is the slot [s], or -1. The interned identity
|
|
* compare, never [dyn_equal]: see [map_append]. [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 — as a
|
|
* key. */
|
|
static int64_t entry_of(flan_obj *o, kw_entry *s) {
|
|
int64_t i;
|
|
for (i = 0; i < o->len; i++) {
|
|
flan_dyn key = o->u.v.items[i * 2];
|
|
if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD && dyn_kw(key) == s)
|
|
return i;
|
|
}
|
|
return -1;
|
|
}
|
|
|
|
/* 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 — which is the property CLHS 4.3.6 guarantees, matched by name, with
|
|
* the instance's identity preserved because none of this allocates a new
|
|
* object. A slot it has just gained holds its type's zero value, Flan's
|
|
* zero-is-initialisation — false, 0, 0.0, the empty string — or nil where
|
|
* the type admits nil or has no zero: a dyn slot, an (Option T), a class.
|
|
*
|
|
* 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.
|
|
*
|
|
* In three steps, and the order is what keeps it sound.
|
|
*
|
|
* First, everything that allocates on the collector's heap: the hook's
|
|
* arguments, and an empty string for a gained string slot. A collection may
|
|
* run here, while [o] still holds its old entries whole. Nothing in this
|
|
* step compares a key with [dyn_equal] — see [map_append] — so nothing in it
|
|
* can migrate another instance and run a hook inside this migration.
|
|
*
|
|
* Second, the name-matching, which allocates nothing on the collector's
|
|
* heap, calls nothing that can migrate, and finishes by stamping [o]
|
|
* current. [e] is read only up to here: a hook may build an instance of a
|
|
* class the registry has not seen, and adding it moves [classes].
|
|
*
|
|
* Third, the hook, on an instance that is already current, so a method that
|
|
* reads or writes it finds it migrated and does not start a second
|
|
* migration. A method may touch anything, including a map something above
|
|
* this frame is walking; the migration of [o] itself is finished before it
|
|
* runs. */
|
|
/* Kept out of line: inlined into [class_sync], its frame and saved
|
|
* registers were paid on every [get] and [put] of every map, current or not
|
|
* — measured at about a tenth of an untyped [put]'s instructions. */
|
|
__attribute__((noinline))
|
|
static void class_migrate(flan_obj *o, class_entry *e) {
|
|
flan_dyn *fresh = NULL;
|
|
int64_t i, j, n;
|
|
/* Rooted by address for as long as they may be needed: each is a
|
|
* collector object held nowhere else. */
|
|
flan_dyn inst, added, gone, empty;
|
|
int64_t roots_at = roots_n;
|
|
int hook, need_empty = 0;
|
|
n = e->nslots;
|
|
/* CLHS 4.3.6: the method runs on every instance a redefinition reaches,
|
|
* whether or not the slot names moved — a changed type is a change a
|
|
* method may want to convert for. */
|
|
hook = migrate_fn != NULL && flan_dyn_migrate_hook != NULL;
|
|
for (j = 0; j < n; j++)
|
|
if (e->types[j].kind == ST_TEXT && !e->types[j].opt
|
|
&& entry_of(o, e->slots[j]) < 0)
|
|
need_empty = 1;
|
|
inst = dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
|
added = gone = empty = dyn_make(BOX_NIL, 0);
|
|
if (hook || need_empty) root_add(&inst, NULL);
|
|
if (need_empty) {
|
|
empty = flan_dyn_from_bytes((const uint8_t *)"", 0);
|
|
root_add(&empty, NULL);
|
|
}
|
|
if (hook) {
|
|
added = flan_dyn_vec_new();
|
|
root_add(&added, NULL);
|
|
gone = flan_dyn_map_new();
|
|
root_add(&gone, NULL);
|
|
for (j = 0; j < n; j++)
|
|
if (entry_of(o, e->slots[j]) < 0)
|
|
flan_dyn_push(added,
|
|
dyn_make(BOX_KW, (uint64_t)(uintptr_t)e->slots[j]),
|
|
NULL, 0);
|
|
/* Every key the class no longer declares, a raw [put]'s included:
|
|
* CLHS's discarded slots and their property list, as one map. [o]'s
|
|
* keys are distinct, so these are, and they are appended as they are. */
|
|
for (i = 0; i < o->len; i++) {
|
|
flan_dyn key = o->u.v.items[i * 2];
|
|
int kept = 0;
|
|
if (flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD)
|
|
for (j = 0; j < n; j++)
|
|
if (dyn_kw(key) == e->slots[j]) { kept = 1; break; }
|
|
if (!kept) map_append(dyn_obj(gone), key, o->u.v.items[i * 2 + 1]);
|
|
}
|
|
}
|
|
if (n > 0) {
|
|
fresh = (flan_dyn *)malloc((size_t)n * 2 * sizeof *fresh);
|
|
if (fresh == NULL) trap_oom(NULL, 0, n * 2 * (int64_t)sizeof *fresh);
|
|
}
|
|
for (j = 0; j < n; j++) {
|
|
const slot_type *t = &e->types[j];
|
|
flan_dyn v;
|
|
i = entry_of(o, e->slots[j]);
|
|
if (i >= 0) {
|
|
v = o->u.v.items[i * 2 + 1];
|
|
/* A kept value that the slot's new type does not admit is kept
|
|
anyway: throwing it away would be the data loss a redefinition
|
|
exists to avoid, and there is nothing to convert it to. What it
|
|
gets is a warning, once per slot per redefinition, and the next
|
|
write to the slot is checked like any other. */
|
|
if (!slot_fits(t, v) && e->warned[j] != e->gen) {
|
|
char sv[SAY_MAX], st[128];
|
|
kw_entry *c = o->u.v.klass, *sl = e->slots[j];
|
|
e->warned[j] = e->gen;
|
|
say(sv, SAY_MAX, v);
|
|
slot_type_text(t, st, sizeof st);
|
|
fflush(stdout);
|
|
fprintf(stderr,
|
|
"warning: %.*s was redefined, and its slot :%.*s is now "
|
|
"declared %s. An instance holds %s there, which is %s; it "
|
|
"keeps that value, and the next write to :%.*s is checked\n",
|
|
(int)c->len, (const char *)(c + 1),
|
|
(int)sl->len, (const char *)(sl + 1), st, sv,
|
|
tag_of(v), (int)sl->len, (const char *)(sl + 1));
|
|
}
|
|
}
|
|
else if (t->opt) v = dyn_make(BOX_NIL, 0);
|
|
else
|
|
switch (t->kind) {
|
|
case ST_BOOL: v = flan_dyn_from_bool(0); break;
|
|
case ST_INT: v = flan_dyn_from_i64(0); break;
|
|
case ST_FLOAT: v = flan_dyn_from_f64(0.0); break;
|
|
case ST_TEXT: v = empty; break;
|
|
default: v = dyn_make(BOX_NIL, 0); 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 += (n - o->u.v.cap) * 2 * (int64_t)sizeof(flan_dyn);
|
|
free(o->u.v.items);
|
|
o->u.v.items = fresh;
|
|
o->u.v.cap = n;
|
|
o->len = n;
|
|
o->gen = e->gen;
|
|
e = NULL;
|
|
if (hook) class_hook(o, inst, added, gone, n);
|
|
roots_n = roots_at;
|
|
}
|
|
|
|
/* Every read or write of an instance comes through here first: the class's
|
|
* entry, with [o] migrated to it if it was stale, or NULL for a map with no
|
|
* class. The common case — current — is a lookup and a compare, and the
|
|
* migration is a call of its own so that it stays out of the way. The entry
|
|
* is looked up again after one, because a hook may have moved the table. */
|
|
static class_entry *class_sync(flan_obj *o) {
|
|
class_entry *e;
|
|
if (o->kind != OBJ_MAP || o->u.v.klass == NULL) return NULL;
|
|
e = class_find(o->u.v.klass);
|
|
if (e == NULL || e->gen == o->gen) return e;
|
|
class_migrate(o, e);
|
|
return class_find(o->u.v.klass);
|
|
}
|
|
|
|
/* 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.
|
|
*
|
|
* [spec] is the class's definition, [class_spec]'s string, and it registers
|
|
* the class the first time any instance of it is built. That is what makes
|
|
* a slot's type checked in a program that is never reloaded — the registry
|
|
* used to be filled only by a reload. A class already registered keeps
|
|
* what it has, and has to: a constructor compiled before a redefinition may
|
|
* still be on some stack, and letting its definition win would put the
|
|
* class back the way it was. Redefining is [flan_dyn_class_def]'s alone. */
|
|
/* A constructor call's site: [pending] from the caller, moved to [building]
|
|
* by the constructor's first act, so a call through a function value — which
|
|
* sets nothing — finds none rather than an earlier call's. Nothing between
|
|
* the caller setting it and the constructor taking it can construct: the
|
|
* caller evaluated every argument first. */
|
|
static const uint8_t *site_pending, *site_building;
|
|
static int64_t site_pending_len, site_building_len;
|
|
|
|
void flan_dyn_ctor_site(const uint8_t *loc, int64_t loclen) {
|
|
site_pending = loc;
|
|
site_pending_len = loclen;
|
|
}
|
|
|
|
flan_dyn flan_dyn_map_new_class(flan_dyn k, const uint8_t *spec, int64_t n) {
|
|
flan_obj *o;
|
|
site_building = site_pending;
|
|
site_building_len = site_pending_len;
|
|
site_pending = NULL;
|
|
site_pending_len = 0;
|
|
if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD)
|
|
trap1(NULL, 0, TYPE_TRAP, "class instance", "a class tag is a keyword", k);
|
|
if (class_find(dyn_kw(k)) == NULL) {
|
|
kw_entry **list;
|
|
slot_type *types;
|
|
int64_t count = class_spec(spec, n, &list, &types);
|
|
class_add(dyn_kw(k), list, types, count);
|
|
}
|
|
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);
|
|
}
|
|
|
|
/* The kind of a value as a keyword named by [tag_words], or a class instance's
|
|
* class name as [flan_dyn_class_of] answers it. A class may not be named like
|
|
* a kind (the parser refuses it), so :map always means a plain map. Keywords
|
|
* are immortal, so each kind's keyword is interned once and kept. */
|
|
flan_dyn flan_dyn_type_of(flan_dyn v) {
|
|
static flan_dyn kinds[FLAN_DYN_TAG_LAST + 1];
|
|
static int interned;
|
|
int32_t t = flan_dyn_tag(v);
|
|
if (t == FLAN_DYN_TAG_MAP && dyn_obj(v)->u.v.klass != NULL)
|
|
return flan_dyn_class_of(v);
|
|
if (!interned) {
|
|
for (int i = 0; i <= FLAN_DYN_TAG_LAST; i++)
|
|
kinds[i] = flan_dyn_kw((const uint8_t *)tag_words[i],
|
|
(int64_t)strlen(tag_words[i]));
|
|
interned = 1;
|
|
}
|
|
return kinds[t];
|
|
}
|
|
|
|
/* ── 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(NULL, 0, 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(NULL, 0, (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. The typed language does widen an integer into a float, but only
|
|
* where the float holds every value of it exactly — an i32 into an f64, never
|
|
* an i64 (TODO.org, "Implicit numeric widening is legal; narrowing stays a
|
|
* hard error"). This boundary has no such guarantee to offer:
|
|
* the box carries one integer width and it is i64, so "an int here" means the
|
|
* widest one, which is exactly the conversion the typed lattice refuses. 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 (length 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);
|
|
}
|
|
|
|
static const char *an(const char *w); /* forward: "a" or "an" */
|
|
|
|
/* A dyn into a typed integer of width [kind] — 0..7 for i8 u8 i16 u16 i32
|
|
* u32 i64 u64, check.ml's [unbox] — answered as an i64 the caller narrows:
|
|
* an int in the width's range, or a char's code point where it fits. A byte
|
|
* takes only an ASCII char, because a byte past ASCII is not that char in
|
|
* UTF-8. A dyn int is an i64, so a u64 takes 0 up to the largest i64. The
|
|
* sentence names what was found and what would do, and no call: the site in
|
|
* front of it is the one that failed. */
|
|
static const char *const int_names[8] = { "i8", "u8", "i16", "u16",
|
|
"i32", "u32", "i64", "u64" };
|
|
|
|
int64_t flan_dyn_need_int(flan_dyn v, int32_t kind, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
static const int64_t lo[8] = { -128, 0, -32768, 0, INT32_MIN, 0, INT64_MIN, 0 };
|
|
static const int64_t hi[8] = { 127, 255, 32767, 65535, INT32_MAX,
|
|
4294967295LL, INT64_MAX, INT64_MAX };
|
|
int32_t t = flan_dyn_tag(v);
|
|
const char *name;
|
|
char sv[SAY_MAX];
|
|
if (kind < 0 || kind > 7) kind = 6;
|
|
name = int_names[kind];
|
|
if (t == FLAN_DYN_TAG_CHAR) {
|
|
int64_t cp = (int64_t)dyn_payload(v);
|
|
int64_t top = kind <= 1 ? 127 : hi[kind];
|
|
char cs[16];
|
|
if (cp <= top) return cp;
|
|
char_spell((uint32_t)cp, cs);
|
|
if (kind <= 1)
|
|
flan_say(loc, loclen,
|
|
"dyn: %s %s is wanted here, and the char %s is more than one "
|
|
"byte in UTF-8. Take its code point as an i32",
|
|
an(name), name, cs);
|
|
else
|
|
flan_say(loc, loclen,
|
|
"dyn: %s %s is wanted here, and the char %s, code point %lld, "
|
|
"is outside %s %s's range", an(name), name, cs, (long long)cp,
|
|
an(name), name);
|
|
flan_trap((const uint8_t *)"DynRange", 8);
|
|
}
|
|
if (t == FLAN_DYN_TAG_INT) {
|
|
int64_t x = dyn_int_value(v);
|
|
if (x >= lo[kind] && x <= hi[kind]) return x;
|
|
flan_say(loc, loclen,
|
|
"dyn: %s %s is wanted here, and the int %lld is outside %s %s's "
|
|
"range", an(name), name, (long long)x, an(name), name);
|
|
flan_trap((const uint8_t *)"DynRange", 8);
|
|
}
|
|
if (t == FLAN_DYN_TAG_NIL) sv[0] = '\0';
|
|
else say(sv, SAY_MAX, v);
|
|
flan_say(loc, loclen,
|
|
"dyn: %s %s is wanted here, and this is %s%s%s%s%s. %s %s takes an "
|
|
"int or a char's code point%s%s%s",
|
|
an(name), name, t == FLAN_DYN_TAG_NIL ? "" : an(tag_of(v)),
|
|
t == FLAN_DYN_TAG_NIL ? "" : " ", tag_of(v), t == FLAN_DYN_TAG_NIL ? "" : ", ", sv,
|
|
name[0] == 'i' ? "An" : "A", name,
|
|
t == FLAN_DYN_TAG_FLOAT ? "; convert a float with (" : "",
|
|
t == FLAN_DYN_TAG_FLOAT ? name : "",
|
|
t == FLAN_DYN_TAG_FLOAT ? " x)" : "");
|
|
flan_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
|
|
int32_t flan_dyn_need_i32(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|
return (int32_t)flan_dyn_need_int(v, 4, loc, loclen);
|
|
}
|
|
|
|
/* The int arm of a numeric cast written on a dyn ([check.ml]'s [cast_dyn]),
|
|
* reached once [flan_dyn_cast_kind] has said the box is not a float: an
|
|
* int's value, or a char's code point, so (i32 c) is the code point the
|
|
* implicit crossing into an i32 gives. */
|
|
int64_t flan_dyn_int_of(flan_dyn v) {
|
|
if (flan_dyn_tag(v) == FLAN_DYN_TAG_CHAR) return (int64_t)dyn_payload(v);
|
|
return flan_dyn_need_i64(v);
|
|
}
|
|
|
|
/* A typed char wanted: only a char. An int is refused rather than taken as a
|
|
* code point, because a number is not a character until (char n) says so. */
|
|
uint32_t flan_dyn_need_char(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|
int32_t t = flan_dyn_tag(v);
|
|
char sv[SAY_MAX];
|
|
if (t == FLAN_DYN_TAG_CHAR) return (uint32_t)dyn_payload(v);
|
|
if (t == FLAN_DYN_TAG_NIL) sv[0] = '\0';
|
|
else say(sv, SAY_MAX, v);
|
|
flan_say(loc, loclen, "dyn: a char is wanted here, and this is %s%s%s%s%s%s",
|
|
t == FLAN_DYN_TAG_NIL ? "" : an(tag_of(v)),
|
|
t == FLAN_DYN_TAG_NIL ? "" : " ", tag_of(v),
|
|
t == FLAN_DYN_TAG_NIL ? "" : ", ", sv,
|
|
t == FLAN_DYN_TAG_INT ? ". Convert a code point with (char n)" : "");
|
|
flan_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
|
|
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 ───────────────────────────────────────
|
|
*
|
|
* TODO.org, "A numeric cast opens a dyn box".
|
|
*
|
|
* [(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);
|
|
/* A char casts as its code point, an int: the arm after this reads it
|
|
through [flan_dyn_int_of], so (i32 c) is what passing c to an i32 is. */
|
|
if (tag == FLAN_DYN_TAG_CHAR) {
|
|
if (want_float && site_first_time(loc, loc_len)) {
|
|
fflush(stdout);
|
|
fprintf(stderr,
|
|
"%.*s: (%.*s x) found a dyn holding a char, and converted its "
|
|
"code point to %.*s — warned once for this site\n",
|
|
(int)loc_len, (const char *)loc, (int)target_len,
|
|
(const char *)target, (int)target_len, (const char *)target);
|
|
}
|
|
return 0;
|
|
}
|
|
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"
|
|
|
|
/* Char arithmetic, the typed side's rule (decision 131): a char plus or
|
|
* minus an int, or an int plus a char, is a char, trapping where the result
|
|
* is not a scalar value; a char minus a char is the int distance. 0 when the
|
|
* pair is none of those, for [arith] to refuse as it refuses any non-number. */
|
|
static int char_arith(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn a, flan_dyn b, flan_dyn *out) {
|
|
int ca = flan_dyn_tag(a) == FLAN_DYN_TAG_CHAR;
|
|
int cb = flan_dyn_tag(b) == FLAN_DYN_TAG_CHAR;
|
|
int64_t n;
|
|
if (op[0] == '-' && ca && cb) {
|
|
*out = flan_dyn_from_i64((int64_t)dyn_payload(a) - (int64_t)dyn_payload(b));
|
|
return 1;
|
|
}
|
|
int64_t cp, m;
|
|
int sub = op[0] == '-';
|
|
if (ca && flan_dyn_tag(b) == FLAN_DYN_TAG_INT) {
|
|
cp = (int64_t)dyn_payload(a);
|
|
m = dyn_int_value(b);
|
|
} else if (!sub && cb && flan_dyn_tag(a) == FLAN_DYN_TAG_INT) {
|
|
cp = (int64_t)dyn_payload(b);
|
|
m = dyn_int_value(a);
|
|
} else
|
|
return 0;
|
|
/* Checked, so a trap names the true sum or which side it left. */
|
|
if (sub ? __builtin_sub_overflow(cp, m, &n) : __builtin_add_overflow(cp, m, &n)) {
|
|
flan_say(loc, loclen, "dyn %s: %lld %s %lld is %s, so it is not a char",
|
|
op, (long long)cp, sub ? "minus" : "plus", (long long)m,
|
|
(sub ? m < 0 : m > 0) ? "past 0x10FFFF" : "below zero");
|
|
dyn_trap((const uint8_t *)"InvalidChar", 11);
|
|
}
|
|
if (!is_scalar(n)) {
|
|
flan_say(loc, loclen,
|
|
"dyn %s: %lld is not a Unicode scalar value, so it is not a char",
|
|
op, (long long)n);
|
|
dyn_trap((const uint8_t *)"InvalidChar", 11);
|
|
}
|
|
*out = flan_dyn_from_char((int32_t)n);
|
|
return 1;
|
|
}
|
|
|
|
static flan_dyn arith(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn a, flan_dyn b) {
|
|
int64_t x, y;
|
|
flan_dyn c;
|
|
if ((op[0] == '+' || op[0] == '-') && char_arith(loc, loclen, op, a, b, &c))
|
|
return c;
|
|
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);
|
|
}
|
|
/* (- x): an int wraps, as (- 0 x) does, and a float flips its sign, so the
|
|
* negation of 0.0 is -0.0 and not the 0.0 a subtraction from zero gives. */
|
|
flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
|
if (!is_num(a)) trap1(loc, loclen, TYPE_TRAP, "-", "it takes a number", a);
|
|
if (flan_dyn_tag(a) == FLAN_DYN_TAG_INT)
|
|
return flan_dyn_from_i64((int64_t)(0 - (uint64_t)dyn_int_value(a)));
|
|
return flan_dyn_from_f64(-dyn_num_value(a));
|
|
}
|
|
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);
|
|
}
|
|
|
|
/* ── Bits ──────────────────────────────────────────────────────────────
|
|
*
|
|
* Ints only: a float has no bits a program means, and a bool is most likely
|
|
* a reach for logical and from C, so its trap says which operator that is.
|
|
* Every answer is the one typed i64 code gives for the same operands. A shift
|
|
* count outside 0..63 traps rather than being masked as typed code masks it:
|
|
* there is no width here to have been chosen, and a count out of range is a
|
|
* mistake the value cannot show. */
|
|
|
|
#define BITS_INT "it takes integers"
|
|
#define BITS_BOOL "it takes integers; true and false are combined with and, or and not"
|
|
|
|
static int is_int(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_INT; }
|
|
static int is_bool(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_BOOL; }
|
|
|
|
static void want_ints(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn a, flan_dyn b) {
|
|
if (!is_int(a) || !is_int(b))
|
|
trap2(loc, loclen, TYPE_TRAP, op,
|
|
is_bool(a) || is_bool(b) ? BITS_BOOL : BITS_INT, a, b);
|
|
}
|
|
|
|
static void want_int(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn a) {
|
|
if (!is_int(a))
|
|
trap1(loc, loclen, TYPE_TRAP, op, is_bool(a) ? BITS_BOOL : BITS_INT, a);
|
|
}
|
|
|
|
flan_dyn flan_dyn_bitand(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
want_ints(loc, loclen, "bit-and", a, b);
|
|
return flan_dyn_from_i64(dyn_int_value(a) & dyn_int_value(b));
|
|
}
|
|
flan_dyn flan_dyn_bitor(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
want_ints(loc, loclen, "bit-or", a, b);
|
|
return flan_dyn_from_i64(dyn_int_value(a) | dyn_int_value(b));
|
|
}
|
|
flan_dyn flan_dyn_bitxor(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
want_ints(loc, loclen, "bit-xor", a, b);
|
|
return flan_dyn_from_i64(dyn_int_value(a) ^ dyn_int_value(b));
|
|
}
|
|
flan_dyn flan_dyn_bitnot(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
|
want_int(loc, loclen, "bit-not", a);
|
|
return flan_dyn_from_i64(~dyn_int_value(a));
|
|
}
|
|
|
|
static uint64_t shift_count(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn a, flan_dyn b) {
|
|
int64_t n;
|
|
want_ints(loc, loclen, op, a, b);
|
|
n = dyn_int_value(b);
|
|
if (n < 0 || n > 63)
|
|
trap2(loc, loclen, ARITH_TRAP, op,
|
|
"the count is outside 0 to 63, the bits an int has", a, b);
|
|
return (uint64_t)n;
|
|
}
|
|
|
|
flan_dyn flan_dyn_shl(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
uint64_t n = shift_count(loc, loclen, "<<", a, b);
|
|
return flan_dyn_from_i64((int64_t)((uint64_t)dyn_int_value(a) << n));
|
|
}
|
|
/* Arithmetic, as >> on a typed i64 is. */
|
|
flan_dyn flan_dyn_shr(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
uint64_t n = shift_count(loc, loclen, ">>", a, b);
|
|
int64_t x = dyn_int_value(a);
|
|
/* >> on a negative int64_t is implementation-defined in C before C23;
|
|
* the complement trick is arithmetic on every compiler. */
|
|
if (x < 0) return flan_dyn_from_i64(~(int64_t)(~(uint64_t)x >> n));
|
|
return flan_dyn_from_i64((int64_t)((uint64_t)x >> n));
|
|
}
|
|
|
|
static uint64_t rot(uint64_t x, uint64_t n, int left) {
|
|
n &= 63;
|
|
if (n == 0) return x;
|
|
return left ? (x << n) | (x >> (64 - n)) : (x >> n) | (x << (64 - n));
|
|
}
|
|
|
|
flan_dyn flan_dyn_rotl(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
want_ints(loc, loclen, "rotate-left", a, b);
|
|
return flan_dyn_from_i64((int64_t)rot((uint64_t)dyn_int_value(a),
|
|
(uint64_t)dyn_int_value(b), 1));
|
|
}
|
|
flan_dyn flan_dyn_rotr(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
want_ints(loc, loclen, "rotate-right", a, b);
|
|
return flan_dyn_from_i64((int64_t)rot((uint64_t)dyn_int_value(a),
|
|
(uint64_t)dyn_int_value(b), 0));
|
|
}
|
|
|
|
flan_dyn flan_dyn_popcount(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
|
want_int(loc, loclen, "popcount", a);
|
|
return flan_dyn_from_i64(__builtin_popcountll((uint64_t)dyn_int_value(a)));
|
|
}
|
|
/* 64 for zero, which the builtins leave undefined. */
|
|
flan_dyn flan_dyn_clz(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
|
uint64_t x;
|
|
want_int(loc, loclen, "leading-zeros", a);
|
|
x = (uint64_t)dyn_int_value(a);
|
|
return flan_dyn_from_i64(x == 0 ? 64 : __builtin_clzll(x));
|
|
}
|
|
flan_dyn flan_dyn_ctz(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
|
uint64_t x;
|
|
want_int(loc, loclen, "trailing-zeros", a);
|
|
x = (uint64_t)dyn_int_value(a);
|
|
return flan_dyn_from_i64(x == 0 ? 64 : __builtin_ctzll(x));
|
|
}
|
|
|
|
/* ── 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 str)] 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);
|
|
}
|
|
if (flan_dyn_tag(a) == FLAN_DYN_TAG_CHAR &&
|
|
flan_dyn_tag(b) == FLAN_DYN_TAG_CHAR) {
|
|
uint64_t x = dyn_payload(a), y = dyn_payload(b);
|
|
return x < y ? -1 : (x > y ? 1 : 0);
|
|
}
|
|
trap2(loc, loclen, TYPE_TRAP, op,
|
|
"it compares two numbers, two texts or two chars, 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);
|
|
}
|
|
|
|
/* The pick of min and max: numbers by value, keeping the one picked as it is
|
|
* (an int stays an int), and chars by code point. Anything else traps, text
|
|
* included, since min over text has no typed counterpart. The first is picked
|
|
* only when it is strictly less (or greater), so a tie or a NaN answers the
|
|
* second, as the typed (if (< a b) a b) does. */
|
|
static flan_dyn pick(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn a, flan_dyn b, int want) {
|
|
int both_chars = flan_dyn_tag(a) == FLAN_DYN_TAG_CHAR &&
|
|
flan_dyn_tag(b) == FLAN_DYN_TAG_CHAR;
|
|
if (!both_chars && !(is_num(a) && is_num(b)))
|
|
trap2(loc, loclen, TYPE_TRAP, op,
|
|
"it picks between two numbers or two chars, and these are neither",
|
|
a, b);
|
|
return order(loc, loclen, op, a, b) == want ? a : b;
|
|
}
|
|
flan_dyn flan_dyn_min(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return pick(loc, loclen, "min", a, b, -1);
|
|
}
|
|
flan_dyn flan_dyn_max(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return pick(loc, loclen, "max", a, b, 1);
|
|
}
|
|
|
|
/* ── 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
|
|
|
|
/* A container compared with itself is equal without reading an element, but
|
|
* in a dev build that shortcut would let a view inside it that has gone
|
|
* stale pass unremarked, where comparing any other container holding it
|
|
* traps. So a dev build walks the one container, as deep as equality would,
|
|
* and checks every view it holds — the same rule [eq_walk] applies at the
|
|
* top. A release build keeps no guards, and takes the shortcut. */
|
|
/* The containers one scan has already walked. A container reached twice —
|
|
* shared, or holding itself — is walked once, so a scan is linear in what it
|
|
* can reach rather than exponential, and a cycle ends. Open addressing over
|
|
* the object's address, each slot stamped with the scan that filled it. */
|
|
typedef struct { flan_obj *o; uint64_t stamp; } scan_slot;
|
|
static scan_slot *scan_seen;
|
|
static size_t scan_cap, scan_n;
|
|
/* The scan a slot was filled by. A slot from an earlier scan reads as empty,
|
|
* so starting a scan costs a counter bump rather than clearing a table that
|
|
* one large scan left large. */
|
|
static uint64_t scan_stamp;
|
|
|
|
static int scan_first_visit(flan_obj *o) {
|
|
size_t i, mask;
|
|
if (scan_n * 2 >= scan_cap) {
|
|
size_t ncap = scan_cap ? scan_cap * 2 : 64, j;
|
|
scan_slot *n = (scan_slot *)calloc(ncap, sizeof *n);
|
|
if (n == NULL) return 0; /* no room to remember: stop descending */
|
|
for (j = 0; j < scan_cap; j++) {
|
|
size_t k;
|
|
if (scan_seen[j].stamp != scan_stamp) continue;
|
|
for (k = ((uintptr_t)scan_seen[j].o >> 4) & (ncap - 1);
|
|
n[k].stamp == scan_stamp; k = (k + 1) & (ncap - 1)) {}
|
|
n[k] = scan_seen[j];
|
|
}
|
|
free(scan_seen);
|
|
scan_seen = n;
|
|
scan_cap = ncap;
|
|
}
|
|
mask = scan_cap - 1;
|
|
for (i = ((uintptr_t)o >> 4) & mask; scan_seen[i].stamp == scan_stamp;
|
|
i = (i + 1) & mask)
|
|
if (scan_seen[i].o == o) return 0;
|
|
scan_seen[i].o = o;
|
|
scan_seen[i].stamp = scan_stamp;
|
|
scan_n++;
|
|
return 1;
|
|
}
|
|
|
|
static void stale_walk(flan_dyn v, int depth) {
|
|
flan_obj *o;
|
|
int64_t i, n;
|
|
if (!dyn_boxed(v) || dyn_box(v) != BOX_OBJ || depth >= EQ_DEPTH) return;
|
|
o = dyn_obj(v);
|
|
if (o == NULL) return;
|
|
if (o->kind == OBJ_VIEW) {
|
|
view_guard_check(walk_loc, walk_len, walk_op, o);
|
|
return;
|
|
}
|
|
if (o->kind != OBJ_VEC && o->kind != OBJ_MAP) return;
|
|
if (!scan_first_visit(o)) return;
|
|
n = o->kind == OBJ_MAP ? o->len * 2 : o->len;
|
|
for (i = 0; i < n; i++) stale_walk(o->u.v.items[i], depth + 1);
|
|
}
|
|
|
|
/* Only when some guarded view has ever been made: until then there is
|
|
* nothing a scan could find, and a program that never crosses a typed value
|
|
* into dyn pays nothing for it. */
|
|
static int64_t views_guarded;
|
|
|
|
static void stale_scan(flan_dyn v, int depth) {
|
|
if (views_guarded == 0) return;
|
|
scan_stamp++; /* never 0, which is what a fresh slot holds */
|
|
scan_n = 0;
|
|
stale_walk(v, depth);
|
|
}
|
|
|
|
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) {
|
|
if (flan_dev_views_checked) stale_scan(a, depth);
|
|
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) {
|
|
if (flan_dev_views_checked) stale_scan(a, depth);
|
|
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) {
|
|
if (flan_dev_views_checked) stale_scan(a, depth);
|
|
return 1;
|
|
}
|
|
if (depth >= EQ_DEPTH) return 0;
|
|
/* A struct's view is equal to another view of the same struct type with
|
|
equal fields, and to nothing else — the answer an instance gets beside
|
|
a plain map, for the same reason: the type's name is its shape tag. */
|
|
if (x->kind == OBJ_VIEW || y->kind == OBJ_VIEW) {
|
|
const char *xn, *yn;
|
|
int64_t xl, yl, n;
|
|
if (x->kind != OBJ_VIEW || y->kind != OBJ_VIEW) return 0;
|
|
view_struct_name(x, &xn, &xl);
|
|
view_struct_name(y, &yn, &yl);
|
|
if (xl != yl || memcmp(xn, yn, (size_t)xl) != 0) return 0;
|
|
n = view_nfields(x);
|
|
if (n != view_nfields(y)) return 0;
|
|
for (i = 0; i < n; i++)
|
|
if (!dyn_equal(view_field_val(x, i), view_field_val(y, i), depth + 1))
|
|
return 0;
|
|
return 1;
|
|
}
|
|
/* 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;
|
|
}
|
|
|
|
static flan_dyn eq_walk(flan_dyn a, flan_dyn b) {
|
|
/* A view is checked before the identity shortcut, so a gone one traps
|
|
even compared with itself. */
|
|
if (dyn_boxed(a) && dyn_box(a) == BOX_OBJ && dyn_obj(a) != NULL
|
|
&& dyn_obj(a)->kind == OBJ_VIEW)
|
|
view_guard_check(walk_loc, walk_len, walk_op, dyn_obj(a));
|
|
if (dyn_boxed(b) && dyn_box(b) == BOX_OBJ && dyn_obj(b) != NULL
|
|
&& dyn_obj(b)->kind == OBJ_VIEW)
|
|
view_guard_check(walk_loc, walk_len, walk_op, dyn_obj(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]. A view over
|
|
* a Vec, a slice or a fixed array answers the vec tag and a view over a
|
|
* struct answers the map tag, so [flan_dyn_len], [flan_dyn_at],
|
|
* [flan_dyn_set_at], [flan_dyn_push], the map operations and the printers
|
|
* each add one branch for [OBJ_VIEW]. What follows is that branch's
|
|
* machinery.
|
|
*
|
|
* What one element is comes from a descriptor the compiler writes into
|
|
* read-only data (lib/check.ml, [view_desc]), a prefix code:
|
|
*
|
|
* b B h H i I l L i8 u8 i16 u16 i32 u32 i64 u64
|
|
* f d ? f32 f64 bool
|
|
* C char, a u32 code point
|
|
* t str (read as a copy; never written from here)
|
|
* a<n>;T a fixed [n T]
|
|
* sT a slice [T]
|
|
* cT a [const T]: only in what a crossing *into* a
|
|
* written type wants ([flan_dyn_need_as]); no view
|
|
* is ever of one
|
|
* vT a (Vec T)
|
|
* {Name;f1;T1f2;T2} a struct, its fields in declaration order
|
|
*
|
|
* Offsets are computed here by C's rule, the one Emit.lay spells: every
|
|
* scalar aligned to its size, a struct to its strictest field and padded to
|
|
* it, an array adding no padding of its own. test/programs/dyn-view-any.flan
|
|
* reads back a struct whose fields sit at offsets only that rule gets right,
|
|
* on both backends.
|
|
*
|
|
* A view never stores a collector pointer into typed storage: a read boxes
|
|
* (or copies, for a str), and a write unboxes a number or a bool. That is
|
|
* why a str element is read-only from here, and why an aggregate element is
|
|
* written through its own view rather than replaced whole. */
|
|
|
|
static int64_t desc_int(const uint8_t **p) {
|
|
int64_t n = 0;
|
|
while (**p >= '0' && **p <= '9') { n = n * 10 + (**p - '0'); (*p)++; }
|
|
if (**p == ';') (*p)++;
|
|
return n;
|
|
}
|
|
|
|
/* Past a name and its ';'. */
|
|
static const uint8_t *desc_name_end(const uint8_t *d) {
|
|
while (*d != ';') d++;
|
|
return d + 1;
|
|
}
|
|
|
|
static const uint8_t *desc_skip(const uint8_t *d) {
|
|
switch (*d) {
|
|
case 'a': d++; desc_int(&d); return desc_skip(d);
|
|
case 's': case 'c': case 'v': return desc_skip(d + 1);
|
|
case '{':
|
|
d = desc_name_end(d + 1);
|
|
while (*d != '}') d = desc_skip(desc_name_end(d));
|
|
return d + 1;
|
|
default: return d + 1;
|
|
}
|
|
}
|
|
|
|
static int64_t align_to(int64_t n, int64_t a) { return (n + a - 1) / a * a; }
|
|
|
|
static void desc_lay(const uint8_t *d, int64_t *size, int64_t *align) {
|
|
switch (*d) {
|
|
case 'b': case 'B': case '?': *size = 1; *align = 1; return;
|
|
case 'h': case 'H': *size = 2; *align = 2; return;
|
|
case 'i': case 'I': case 'f': case 'C': *size = 4; *align = 4; return;
|
|
case 't': case 's': case 'c': *size = 16; *align = 8; return;
|
|
case 'v': *size = 40; *align = 8; return;
|
|
case 'a': {
|
|
int64_t n, s, a;
|
|
d++;
|
|
n = desc_int(&d);
|
|
desc_lay(d, &s, &a);
|
|
*size = n * s;
|
|
*align = a;
|
|
return;
|
|
}
|
|
case '{': {
|
|
int64_t off = 0, al = 1, s, a;
|
|
d = desc_name_end(d + 1);
|
|
while (*d != '}') {
|
|
d = desc_name_end(d);
|
|
desc_lay(d, &s, &a);
|
|
if (a < 1) a = 1;
|
|
off = align_to(off, a) + s;
|
|
if (a > al) al = a;
|
|
d = desc_skip(d);
|
|
}
|
|
*size = align_to(off, al);
|
|
*align = al;
|
|
return;
|
|
}
|
|
default: *size = 8; *align = 8; return;
|
|
}
|
|
}
|
|
|
|
static inline int64_t desc_size(const uint8_t *d) {
|
|
int64_t s, a;
|
|
switch (*d) { /* the scalars, without the walk */
|
|
case 'b': case 'B': case '?': return 1;
|
|
case 'h': case 'H': return 2;
|
|
case 'i': case 'I': case 'f': case 'C': return 4;
|
|
case 'l': case 'L': case 'd': return 8;
|
|
default: break;
|
|
}
|
|
desc_lay(d, &s, &a);
|
|
return s;
|
|
}
|
|
|
|
/* A struct descriptor's fields, one at a time: [desc_fields] answers where
|
|
* the first one starts, and each [desc_next] answers a field's name, offset
|
|
* and type and steps past it, 0 at the closing brace. [*off] is the running
|
|
* offset. */
|
|
static const uint8_t *desc_fields(const uint8_t *d, int64_t *off) {
|
|
*off = 0;
|
|
return desc_name_end(d + 1);
|
|
}
|
|
|
|
static int desc_next(const uint8_t **at, int64_t *off, const uint8_t **name,
|
|
int64_t *namelen, int64_t *foff, const uint8_t **fty) {
|
|
const uint8_t *d = *at;
|
|
int64_t s, a;
|
|
if (*d == '}') return 0;
|
|
*name = d;
|
|
while (*d != ';') d++;
|
|
*namelen = (int64_t)(d - *name);
|
|
d++;
|
|
desc_lay(d, &s, &a);
|
|
if (a < 1) a = 1;
|
|
*foff = align_to(*off, a);
|
|
*off = *foff + s;
|
|
*fty = d;
|
|
*at = desc_skip(d);
|
|
return 1;
|
|
}
|
|
|
|
/* The field keyword [k] names, or NULL. */
|
|
static const uint8_t *desc_field(const uint8_t *d, flan_dyn k, int64_t *foff) {
|
|
const uint8_t *at, *name, *fty;
|
|
int64_t off, namelen;
|
|
kw_entry *kw;
|
|
if (flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) return NULL;
|
|
kw = dyn_kw(k);
|
|
at = desc_fields(d, &off);
|
|
while (desc_next(&at, &off, &name, &namelen, foff, &fty))
|
|
if (namelen == kw->len && memcmp(name, kw_bytes(kw), (size_t)namelen) == 0)
|
|
return fty;
|
|
return NULL;
|
|
}
|
|
|
|
static int64_t desc_nfields(const uint8_t *d) {
|
|
const uint8_t *at, *name, *fty;
|
|
int64_t off, namelen, foff, n = 0;
|
|
at = desc_fields(d, &off);
|
|
while (desc_next(&at, &off, &name, &namelen, &foff, &fty)) n++;
|
|
return n;
|
|
}
|
|
|
|
/* The Flan spelling of a descriptor's type, for a sentence. */
|
|
static void desc_spell(const uint8_t *d, char *buf, size_t cap) {
|
|
static const char scalars[] = "bBhHiIlLfd?tC";
|
|
static const char *const words[] = { "i8", "u8", "i16", "u16", "i32", "u32",
|
|
"i64", "u64", "f32", "f64", "bool",
|
|
"str", "char" };
|
|
const char *w;
|
|
char inner[96];
|
|
if (cap == 0) return;
|
|
buf[0] = '\0';
|
|
if (*d != '\0' && (w = strchr(scalars, *d)) != NULL) {
|
|
snprintf(buf, cap, "%s", words[w - scalars]);
|
|
return;
|
|
}
|
|
switch (*d) {
|
|
case 'a': {
|
|
int64_t n;
|
|
d++;
|
|
n = desc_int(&d);
|
|
desc_spell(d, inner, sizeof inner);
|
|
snprintf(buf, cap, "[%lld %s]", (long long)n, inner);
|
|
return;
|
|
}
|
|
case 's':
|
|
desc_spell(d + 1, inner, sizeof inner);
|
|
snprintf(buf, cap, "[%s]", inner);
|
|
return;
|
|
case 'c':
|
|
desc_spell(d + 1, inner, sizeof inner);
|
|
snprintf(buf, cap, "[const %s]", inner);
|
|
return;
|
|
case 'v':
|
|
desc_spell(d + 1, inner, sizeof inner);
|
|
snprintf(buf, cap, "(Vec %s)", inner);
|
|
return;
|
|
case '{': {
|
|
const uint8_t *e = desc_name_end(d + 1);
|
|
snprintf(buf, cap, "%.*s", (int)(e - d - 2), (const char *)d + 1);
|
|
return;
|
|
}
|
|
default: snprintf(buf, cap, "?"); return;
|
|
}
|
|
}
|
|
|
|
/* What a dev build remembers of a view's storage at the crossing, and checks
|
|
* before every read or write through it (runtime/flan_dev.c keeps both
|
|
* tables):
|
|
*
|
|
* a frame the shadow frame the storage belongs to and the serial that
|
|
* activation was given. Live while that frame is still on the
|
|
* chain with the same serial: a later call landing at the same
|
|
* address gets a different one.
|
|
* a block the registry entry of the heap or arena block holding the
|
|
* storage, by base and note sequence. Live while the entry is,
|
|
* which a free, a free-all, an arena's destroy and a Vec's
|
|
* growth (for the block it left) all end.
|
|
*
|
|
* A frame is found by the compiler's word ([here]) or, for a stack address
|
|
* it could not tie to the calling frame, by address (flan_dev.c,
|
|
* [flan_dev_frame_owner]). A release build keeps neither table, so a view
|
|
* there records nothing and checks nothing. Storage neither table knows — a
|
|
* global, rodata, C memory — is not checked. */
|
|
/* [view_guard] is defined beside [flan_obj], since the sweep charges it. */
|
|
|
|
uint64_t flan_dev_frame_claim(void *frame, const char **name, int64_t *namelen);
|
|
int32_t flan_dev_frame_alive(const void *frame, uint64_t serial);
|
|
int32_t flan_dev_reg_claim(const void *p, uintptr_t *base, int64_t *seq,
|
|
const char **type, int64_t *typelen);
|
|
int32_t flan_dev_reg_alive(uintptr_t base, int64_t seq);
|
|
struct flan_frame;
|
|
extern struct flan_frame *flan_frame_head; /* runtime/flan_dev.c */
|
|
|
|
#define VIEW_FLAT 0 /* [base] is the first element, [o->len] the count */
|
|
#define VIEW_VEC 1 /* [base] is a Vec's header, read live */
|
|
#define VIEW_STRUCT 2 /* [base] is the struct, [desc] the struct's own */
|
|
|
|
/* A view carries a guard only when the dev registry is on: a release build
|
|
* would allocate and zero it for nothing, and a crossing is on the hot path.
|
|
* VIEW_GUARDED in [gen] says the guard is there. */
|
|
#define VIEW_GUARDED 0x100 /* bits 16-31 hold the element size */
|
|
/* Bits 9-10: an element kind [flan_dyn_at] boxes inline. */
|
|
#define VIEW_FAST_I64 1
|
|
#define VIEW_FAST_F64 2
|
|
#define VIEW_FAST_BOOL 3
|
|
static inline view_guard *view_g(flan_obj *o) {
|
|
return (o->gen & VIEW_GUARDED) ? (view_guard *)(o + 1) : NULL;
|
|
}
|
|
static inline int view_shape(flan_obj *o) { return (int)(o->gen & 0xff); }
|
|
|
|
void *flan_dev_frame_owner(const void *p);
|
|
|
|
/* What a dev build records of storage the compiler could not tie to the
|
|
* calling frame: the frame that owns it when it is on the stack (a slice of
|
|
* a local, a slice parameter over a caller's), else the registry block that
|
|
* holds it. Neither, and nothing is checked. */
|
|
static void guard_storage(view_guard *g, const void *p) {
|
|
void *f;
|
|
g->frame = NULL;
|
|
g->rbase = 0;
|
|
if (p == NULL) return;
|
|
if ((f = flan_dev_frame_owner(p)) != NULL) {
|
|
g->frame = f;
|
|
g->serial = flan_dev_frame_claim(f, &g->fname, &g->fnamelen);
|
|
return;
|
|
}
|
|
flan_dev_reg_claim(p, &g->rbase, &g->rseq, &g->rtype, &g->rtypelen);
|
|
}
|
|
|
|
|
|
/* A new view record, its guard empty. */
|
|
static inline __attribute__((always_inline)) flan_obj *
|
|
view_new(void *base, int64_t len, const uint8_t *desc,
|
|
int shape) {
|
|
int dev = flan_dev_views_checked;
|
|
flan_obj *o =
|
|
gc_alloc(OBJ_VIEW, dev ? (int64_t)sizeof(view_guard) : 0);
|
|
o->u.view.base = base;
|
|
o->u.view.desc = desc;
|
|
o->u.view.nul = NULL;
|
|
o->gen = (uint32_t)shape | (dev ? VIEW_GUARDED : 0);
|
|
/* A flat or Vec view's element size, kept so an access does not read the
|
|
descriptor again; 0 when it does not fit the 16 bits, and then it does. */
|
|
if (shape != VIEW_STRUCT) {
|
|
int64_t sz = desc_size(desc);
|
|
if (sz > 0 && sz < 0x10000) o->gen |= (uint32_t)sz << 16;
|
|
/* The three element kinds [flan_dyn_at] reads without a call. */
|
|
o->gen |= (uint32_t)(*desc == 'l' ? VIEW_FAST_I64
|
|
: *desc == 'd' ? VIEW_FAST_F64
|
|
: *desc == '?' ? VIEW_FAST_BOOL : 0) << 9;
|
|
}
|
|
o->len = len;
|
|
if (dev) {
|
|
memset(view_g(o), 0, sizeof(view_guard));
|
|
views_guarded++;
|
|
}
|
|
return o;
|
|
}
|
|
|
|
/* The stale-storage check. The sentence never renders the view: it has just
|
|
* been found to point at storage that is gone, and rendering reads it. */
|
|
static __attribute__((noinline)) void view_guard_slow(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_obj *o);
|
|
static inline __attribute__((always_inline)) void view_guard_check(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_obj *o) {
|
|
if (o->gen & VIEW_GUARDED) view_guard_slow(loc, loclen, op, o);
|
|
}
|
|
|
|
static __attribute__((noinline)) void view_guard_slow(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_obj *o) {
|
|
view_guard *g = view_g(o);
|
|
if (g->frame != NULL && !flan_dev_frame_alive(g->frame, g->serial)) {
|
|
flan_say(loc, loclen,
|
|
"dyn %s: this view points into a local of %.*s, and that call "
|
|
"has returned. A view of a local lasts as long as the call that "
|
|
"made it",
|
|
op, (int)g->fnamelen, g->fname);
|
|
dyn_trap((const uint8_t *)"DynStale", 8);
|
|
}
|
|
if (g->rbase != 0 && !flan_dev_reg_alive(g->rbase, g->rseq)) {
|
|
flan_say(loc, loclen,
|
|
"dyn %s: this view's storage, a block of %.*s, has been "
|
|
"released — freed, cleared by free-all, or left behind when a "
|
|
"Vec grew. Take the view again after the change",
|
|
op, (int)g->rtypelen, g->rtype);
|
|
dyn_trap((const uint8_t *)"DynStale", 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. Like
|
|
* the guard's, the sentence never renders the view. */
|
|
static void view_vec_check(const uint8_t *loc, int64_t loclen, 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) {
|
|
flan_say(loc, loclen,
|
|
"dyn %s: this view's container's allocator was released — the "
|
|
"Vec was made at epoch %lld and the allocator is at %lld now",
|
|
op, (long long)h->epoch, (long long)(int64_t)a->epoch);
|
|
dyn_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. [view_len] checks the guard first. */
|
|
static int64_t view_len(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_obj *o) {
|
|
view_guard_check(loc, loclen, op, o);
|
|
if (view_shape(o) == VIEW_VEC) {
|
|
flan_dyn_vec_hdr *h = (flan_dyn_vec_hdr *)o->u.view.base;
|
|
view_vec_check(loc, loclen, op, h);
|
|
return h->len;
|
|
}
|
|
return o->len;
|
|
}
|
|
|
|
static void *view_base(flan_obj *o) {
|
|
if (view_shape(o) == VIEW_VEC) return ((flan_dyn_vec_hdr *)o->u.view.base)->ptr;
|
|
return o->u.view.base;
|
|
}
|
|
|
|
/* A view of the aggregate element at [p], inside [parent]'s storage. An
|
|
* element of a Vec is checked against the Vec's block, since the Vec's
|
|
* growth is what would leave it behind; any other inline element shares its
|
|
* parent's guard. A slice element's data is somewhere else, so it is looked
|
|
* up afresh. */
|
|
static flan_dyn view_child(flan_obj *parent, const uint8_t *d, uint8_t *p) {
|
|
flan_obj *c;
|
|
switch (*d) {
|
|
case 's': {
|
|
void *data;
|
|
int64_t n;
|
|
memcpy(&data, p, 8);
|
|
memcpy(&n, p + 8, 8);
|
|
c = view_new(data, n, d + 1, VIEW_FLAT);
|
|
if (view_g(c) != NULL) guard_storage(view_g(c), data);
|
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c);
|
|
}
|
|
case 'a': {
|
|
const uint8_t *e = d + 1;
|
|
int64_t n = desc_int(&e);
|
|
c = view_new(p, n, e, VIEW_FLAT);
|
|
break;
|
|
}
|
|
case 'v': c = view_new(p, 0, d + 1, VIEW_VEC); break;
|
|
default: c = view_new(p, 0, d, VIEW_STRUCT); break;
|
|
}
|
|
if (view_g(c) == NULL) {}
|
|
else if (view_shape(parent) == VIEW_VEC) guard_storage(view_g(c), p);
|
|
else if (view_g(parent) != NULL) *view_g(c) = *view_g(parent);
|
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)c);
|
|
}
|
|
|
|
/* One element, boxed on the way out. A number widens to a dyn int or float,
|
|
* except a u64 above the largest i64, which has no dyn int to become. */
|
|
static flan_dyn view_read(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_obj *parent, const uint8_t *d, uint8_t *p) {
|
|
switch (*d) {
|
|
case 'b': { int8_t x; memcpy(&x, p, 1); return flan_dyn_from_i64(x); }
|
|
case 'B': { uint8_t x; memcpy(&x, p, 1); return flan_dyn_from_i64(x); }
|
|
case 'h': { int16_t x; memcpy(&x, p, 2); return flan_dyn_from_i64(x); }
|
|
case 'H': { uint16_t x; memcpy(&x, p, 2); return flan_dyn_from_i64(x); }
|
|
case 'i': { int32_t x; memcpy(&x, p, 4); return flan_dyn_from_i64(x); }
|
|
case 'I': { uint32_t x; memcpy(&x, p, 4); return flan_dyn_from_i64(x); }
|
|
case 'l': { int64_t x; memcpy(&x, p, 8); return flan_dyn_from_i64(x); }
|
|
case 'L': {
|
|
uint64_t x;
|
|
memcpy(&x, p, 8);
|
|
return u64_to_dyn(loc, loclen, op, "u64 element", x);
|
|
}
|
|
case 'f': { float x; memcpy(&x, p, 4); return flan_dyn_from_f64((double)x); }
|
|
case 'd': { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); }
|
|
case '?': return flan_dyn_from_bool(*p ? 1 : 0);
|
|
case 'C': { uint32_t x; memcpy(&x, p, 4); return flan_dyn_from_char((int32_t)x); }
|
|
case 't': {
|
|
const uint8_t *s;
|
|
int64_t n;
|
|
memcpy(&s, p, 8);
|
|
memcpy(&n, p + 8, 8);
|
|
return flan_dyn_from_bytes(s, n);
|
|
}
|
|
default: return view_child(parent, d, p);
|
|
}
|
|
}
|
|
|
|
/* The range each integer element holds. */
|
|
static int int_range(uint8_t c, int64_t *lo, int64_t *hi) {
|
|
switch (c) {
|
|
case 'b': *lo = INT8_MIN; *hi = INT8_MAX; return 1;
|
|
case 'B': *lo = 0; *hi = UINT8_MAX; return 1;
|
|
case 'h': *lo = INT16_MIN; *hi = INT16_MAX; return 1;
|
|
case 'H': *lo = 0; *hi = UINT16_MAX; return 1;
|
|
case 'i': *lo = INT32_MIN; *hi = INT32_MAX; return 1;
|
|
case 'I': *lo = 0; *hi = UINT32_MAX; return 1;
|
|
case 'l': *lo = INT64_MIN; *hi = INT64_MAX; return 1;
|
|
case 'L': *lo = 0; *hi = INT64_MAX; return 1;
|
|
default: return 0;
|
|
}
|
|
}
|
|
|
|
/* One element, unboxed on the way in. The dyn value's tag must be the one
|
|
* the element's type wants, or this traps by name and never coerces a
|
|
* mismatched value into the slot; an int the element's width cannot hold
|
|
* traps too, naming both. An int goes into a float element when the float
|
|
* holds it exactly, the rule a class's typed float slot follows, and traps
|
|
* when it does not. A float into an f32 narrows, as (f32 x) does. [v] is the
|
|
* view and [x] the value, for the sentence. */
|
|
/* "an" before a word said with a vowel sound: an i8, an f32, an Item; a
|
|
* u8, a bool, a [3 i32]. */
|
|
static const char *an(const char *w) {
|
|
if (w[0] == 'u' && w[1] >= '0' && w[1] <= '9') return "a";
|
|
if (w[0] != '\0' && strchr("aeiouAEIOU", w[0]) != NULL) return "an";
|
|
if (w[0] == 'f' && w[1] >= '0' && w[1] <= '9') return "an";
|
|
return "a";
|
|
}
|
|
|
|
/* A write into a struct field that the field refuses: the field by name, its
|
|
* type, what was wrong, and the call with the key in it. [why] finishes the
|
|
* sentence after the field's type. */
|
|
static _Noreturn void field_refuse(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_dyn v, flan_dyn key,
|
|
const uint8_t *d, flan_dyn x,
|
|
const char *trap, const char *why) {
|
|
char ty[128], sn[96], sv[SAY_MAX], sx[SAY_MAX];
|
|
const char *nm;
|
|
int64_t nl;
|
|
kw_entry *k = dyn_kw(key);
|
|
desc_spell(d, ty, sizeof ty);
|
|
view_struct_name(dyn_obj(v), &nm, &nl);
|
|
snprintf(sn, sizeof sn, "%.*s", (int)nl, nm);
|
|
say(sv, SAY_MAX, v);
|
|
say(sx, SAY_MAX, x);
|
|
said_len = 0;
|
|
said_add("dyn %s: field :%.*s of %s %s is %s %s%s — ", op, (int)k->len,
|
|
(const char *)kw_bytes(k), an(sn), sn, an(ty), ty, why);
|
|
if (strcmp(op, "set") == 0)
|
|
said_add("(set (get %s :%.*s) %s)", sv, (int)k->len,
|
|
(const char *)kw_bytes(k), sx);
|
|
else
|
|
said_add("(put %s :%.*s %s)", sv, (int)k->len, (const char *)kw_bytes(k),
|
|
sx);
|
|
flan_say(loc, loclen, "%s", said_buf);
|
|
dyn_trap((const uint8_t *)trap, (int64_t)strlen(trap));
|
|
}
|
|
|
|
/* ", and 1.5 is a float": what the refused value is, for a field's sentence. */
|
|
static void value_is(char *buf, size_t cap, flan_dyn x) {
|
|
char sx[SAY_MAX];
|
|
const char *t = tag_of(x);
|
|
if (flan_dyn_tag(x) == FLAN_DYN_TAG_NIL) {
|
|
snprintf(buf, cap, ", and the value is nil");
|
|
return;
|
|
}
|
|
say(sx, SAY_MAX, x);
|
|
snprintf(buf, cap, ", and %s is %s %s", sx, an(t), t);
|
|
}
|
|
|
|
/* One element or field, unboxed on the way in. The dyn value's tag must be
|
|
* the one the element's type wants, or this traps by name and never coerces a
|
|
* mismatched value into the slot; an int the element's width cannot hold
|
|
* traps too, naming both. An int goes into a float element when the float
|
|
* holds it exactly, the rule a class's typed float slot follows, and traps
|
|
* when it does not. A float into an f32 narrows, as (f32 x) does. [v] is the
|
|
* view and [x] the value, for the sentence; [key] is the field's keyword
|
|
* when [v] is a struct's view and nil for an element, and a field's refusal
|
|
* names the field. */
|
|
static void view_write(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn v, flan_dyn key, const uint8_t *d, flan_dyn x,
|
|
uint8_t *p) {
|
|
char ty[128], why[160];
|
|
int64_t lo, hi;
|
|
int field = flan_dyn_tag(key) == FLAN_DYN_TAG_KEYWORD;
|
|
desc_spell(d, ty, sizeof ty);
|
|
if (int_range(*d, &lo, &hi)) {
|
|
int64_t n;
|
|
/* A char is written as its code point where it fits, [into_put]'s rule:
|
|
into a byte only when ASCII, since a byte past ASCII is not that char
|
|
in UTF-8. */
|
|
if (flan_dyn_tag(x) == FLAN_DYN_TAG_CHAR) {
|
|
char cs[16];
|
|
int byte = *d == 'b' || *d == 'B';
|
|
n = (int64_t)dyn_payload(x);
|
|
if (n <= (byte ? 127 : hi)) goto store;
|
|
char_spell((uint32_t)n, cs);
|
|
if (byte)
|
|
snprintf(why, sizeof why, ", and the char %s is more than one byte in "
|
|
"UTF-8. Take its code point as an i32", cs);
|
|
else
|
|
snprintf(why, sizeof why, ", which holds %lld to %lld, and the char "
|
|
"%s, code point %lld, does not fit", (long long)lo,
|
|
(long long)hi, cs, (long long)n);
|
|
if (field) field_refuse(loc, loclen, op, v, key, d, x, "DynRange", why);
|
|
flan_say(loc, loclen, "dyn %s: this element is %s %s%s", op, an(ty), ty,
|
|
why);
|
|
dyn_trap((const uint8_t *)"DynRange", 8);
|
|
}
|
|
if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT) {
|
|
if (field) {
|
|
value_is(why, sizeof why, x);
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynType", why);
|
|
}
|
|
trap2(loc, loclen, TYPE_TRAP, op, "this view's elements are int", v, x);
|
|
}
|
|
n = dyn_int_value(x);
|
|
if (n < lo || n > hi) {
|
|
if (field) {
|
|
if (*d == 'L')
|
|
snprintf(why, sizeof why,
|
|
", which holds no negative number, and %lld does not fit",
|
|
(long long)n);
|
|
else
|
|
snprintf(why, sizeof why,
|
|
", which holds %lld to %lld, and %lld does not fit",
|
|
(long long)lo, (long long)hi, (long long)n);
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynRange", why);
|
|
}
|
|
if (*d == 'L')
|
|
flan_say(loc, loclen,
|
|
"dyn %s: %lld does not fit a u64 element, which holds no "
|
|
"negative number", op, (long long)n);
|
|
else
|
|
flan_say(loc, loclen,
|
|
"dyn %s: %lld does not fit %s %s element, which holds %lld "
|
|
"to %lld", op, (long long)n, an(ty), ty, (long long)lo,
|
|
(long long)hi);
|
|
dyn_trap((const uint8_t *)"DynRange", 8);
|
|
}
|
|
store:
|
|
switch (*d) {
|
|
case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; }
|
|
case 'h': case 'H': { uint16_t h = (uint16_t)n; memcpy(p, &h, 2); return; }
|
|
case 'i': case 'I': { uint32_t w = (uint32_t)n; memcpy(p, &w, 4); return; }
|
|
default: memcpy(p, &n, 8); return;
|
|
}
|
|
}
|
|
switch (*d) {
|
|
case 'f': case 'd': {
|
|
double f;
|
|
if (flan_dyn_tag(x) == FLAN_DYN_TAG_INT) {
|
|
/* [slot_admit]'s rule for a class's float slot: exact is a round
|
|
trip, and the range test keeps the cast back defined. */
|
|
int64_t n = dyn_int_value(x);
|
|
f = *d == 'f' ? (double)(float)n : (double)n;
|
|
if (!(f >= -9223372036854775808.0 && f < 9223372036854775808.0)
|
|
|| (int64_t)f != n) {
|
|
if (field) {
|
|
snprintf(why, sizeof why,
|
|
", and %lld has no exact %s. Write it as a float, as in "
|
|
"%lld.0", (long long)n, ty, (long long)n);
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynRange", why);
|
|
}
|
|
flan_say(loc, loclen,
|
|
"dyn %s: %lld has no exact %s, so it does not go into this "
|
|
"element. Write it as a float, as in %lld.0",
|
|
op, (long long)n, ty, (long long)n);
|
|
dyn_trap((const uint8_t *)"DynRange", 8);
|
|
}
|
|
} else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT)
|
|
f = dyn_num_value(x);
|
|
else {
|
|
if (field) {
|
|
value_is(why, sizeof why, x);
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynType", why);
|
|
}
|
|
trap2(loc, loclen, TYPE_TRAP, op, "this view's elements are float", v, x);
|
|
}
|
|
if (*d == 'f') { float g = (float)f; memcpy(p, &g, 4); }
|
|
else memcpy(p, &f, 8);
|
|
return;
|
|
}
|
|
case '?':
|
|
if (flan_dyn_tag(x) != FLAN_DYN_TAG_BOOL) {
|
|
if (field) {
|
|
value_is(why, sizeof why, x);
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynType", why);
|
|
}
|
|
trap2(loc, loclen, TYPE_TRAP, op, "this view's elements are bool", v, x);
|
|
}
|
|
*p = dyn_payload(x) ? 1 : 0;
|
|
return;
|
|
/* Only a char: an int is a number until (char n) converts it. */
|
|
case 'C':
|
|
if (flan_dyn_tag(x) != FLAN_DYN_TAG_CHAR) {
|
|
if (field) {
|
|
value_is(why, sizeof why, x);
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynType", why);
|
|
}
|
|
trap2(loc, loclen, TYPE_TRAP, op, "this view's elements are char", v, x);
|
|
}
|
|
{ uint32_t w = (uint32_t)dyn_payload(x); memcpy(p, &w, 4); }
|
|
return;
|
|
case 't':
|
|
if (field)
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynType",
|
|
", which is read-only through a dyn view");
|
|
trap2(loc, loclen, TYPE_TRAP, op,
|
|
"a str element is read-only through a dyn view", v, x);
|
|
default: {
|
|
char sx[SAY_MAX];
|
|
if (field)
|
|
field_refuse(loc, loclen, op, v, key, d, x, "DynType",
|
|
", which a dyn view does not replace whole. Write into "
|
|
"its own elements or fields instead");
|
|
say(sx, SAY_MAX, x);
|
|
flan_say(loc, loclen,
|
|
"dyn %s: this element is %s %s, and a dyn view does not replace "
|
|
"it whole — write into its own elements or fields instead of "
|
|
"storing %s",
|
|
op, an(ty), ty, sx);
|
|
dyn_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* Element [i] of a vec-shaped view. The caller has checked the bounds. */
|
|
static inline uint8_t *view_elem_at(flan_obj *o, int64_t i) {
|
|
int64_t sz = (int64_t)(o->gen >> 16);
|
|
if (sz == 0) sz = desc_size(o->u.view.desc);
|
|
return (uint8_t *)view_base(o) + i * sz;
|
|
}
|
|
|
|
/* 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, native bytes boxed on the way out) — the pair
|
|
* [dyn_equal]'s VEC arm and the printers need. */
|
|
static int64_t vecish_len(flan_obj *o) {
|
|
return o->kind == OBJ_VIEW ? view_len(walk_loc, walk_len, walk_op, o) : o->len;
|
|
}
|
|
|
|
static flan_dyn vecish_at(flan_obj *o, int64_t i) {
|
|
if (o->kind == OBJ_VIEW)
|
|
return view_read(walk_loc, walk_len, walk_op, o, o->u.view.desc,
|
|
view_elem_at(o, i));
|
|
return o->u.v.items[i];
|
|
}
|
|
|
|
/* A struct view's field [k], or a trap naming the fields there are: a
|
|
* struct's shape is fixed, so a key it does not have is a mistake rather
|
|
* than an absence. */
|
|
static uint8_t *view_field(const uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_obj *o, flan_dyn k, const uint8_t **fty) {
|
|
int64_t off;
|
|
const uint8_t *d = o->u.view.desc;
|
|
view_guard_check(loc, loclen, op, o);
|
|
*fty = desc_field(d, k, &off);
|
|
if (*fty == NULL) {
|
|
char sk[SAY_MAX], nm[96];
|
|
const uint8_t *at, *name, *t;
|
|
int64_t o2, namelen, foff;
|
|
say(sk, SAY_MAX, k);
|
|
desc_spell(d, nm, sizeof nm);
|
|
said_len = 0;
|
|
said_add("dyn %s: a %s has no field %s. Its fields are", op, nm, sk);
|
|
at = desc_fields(d, &o2);
|
|
while (desc_next(&at, &o2, &name, &namelen, &foff, &t))
|
|
said_add(" :%.*s", (int)namelen, (const char *)name);
|
|
flan_say(loc, loclen, "%s", said_buf);
|
|
dyn_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
return (uint8_t *)o->u.view.base + off;
|
|
}
|
|
|
|
/* The crossing. [base] is the container's address (a Vec's header, the
|
|
* array's or the struct's first byte) or a slice's data, [len] a flat
|
|
* view's element count, [desc] the element's descriptor (the struct's own,
|
|
* for a struct view). [here] is the checker's word that the storage is the
|
|
* calling function's own frame; otherwise a dev build finds the frame that
|
|
* owns a stack address, or the registry block that holds a heap one. */
|
|
static inline __attribute__((always_inline)) flan_dyn
|
|
view_make(void *base, int64_t len, const uint8_t *desc,
|
|
int shape, int32_t here) {
|
|
flan_obj *o = view_new(base, len, desc, shape);
|
|
view_guard *g = view_g(o);
|
|
if (g == NULL) {}
|
|
else if (here) {
|
|
if (flan_frame_head != NULL) {
|
|
g->frame = flan_frame_head;
|
|
g->serial =
|
|
flan_dev_frame_claim(flan_frame_head, &g->fname, &g->fnamelen);
|
|
}
|
|
} else
|
|
guard_storage(g, base);
|
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
|
}
|
|
|
|
flan_dyn flan_dyn_view_slice(void *data, int64_t len, const uint8_t *desc,
|
|
int64_t desclen, int32_t here) {
|
|
(void)desclen;
|
|
return view_make(data, len, desc, VIEW_FLAT, here);
|
|
}
|
|
|
|
flan_dyn flan_dyn_view_at(void *addr, int64_t len, const uint8_t *desc,
|
|
int64_t desclen, int32_t shape, int32_t here) {
|
|
(void)desclen;
|
|
return view_make(addr, len, desc, shape, here);
|
|
}
|
|
|
|
/* A struct view's fields by position, for the printers and equality. */
|
|
static int64_t view_nfields(flan_obj *o) {
|
|
view_guard_check(walk_loc, walk_len, walk_op, o);
|
|
return desc_nfields(o->u.view.desc);
|
|
}
|
|
|
|
static int view_nth(flan_obj *o, int64_t i, const uint8_t **name,
|
|
int64_t *namelen, int64_t *foff, const uint8_t **fty) {
|
|
int64_t off;
|
|
const uint8_t *at = desc_fields(o->u.view.desc, &off);
|
|
while (desc_next(&at, &off, name, namelen, foff, fty))
|
|
if (i-- == 0) return 1;
|
|
return 0;
|
|
}
|
|
|
|
static flan_dyn view_field_key(flan_obj *o, int64_t i) {
|
|
const uint8_t *name, *fty;
|
|
int64_t namelen, foff;
|
|
if (!view_nth(o, i, &name, &namelen, &foff, &fty)) return flan_dyn_nil();
|
|
return flan_dyn_kw(name, namelen);
|
|
}
|
|
|
|
static flan_dyn view_field_val(flan_obj *o, int64_t i) {
|
|
const uint8_t *name, *fty;
|
|
int64_t namelen, foff;
|
|
if (!view_nth(o, i, &name, &namelen, &foff, &fty)) return flan_dyn_nil();
|
|
return view_read(walk_loc, walk_len, walk_op, o, fty,
|
|
(uint8_t *)o->u.view.base + foff);
|
|
}
|
|
|
|
static int view_big_u64(flan_obj *o, int64_t i, int field,
|
|
unsigned long long *out) {
|
|
const uint8_t *d, *p;
|
|
uint64_t x;
|
|
if (field) {
|
|
const uint8_t *name;
|
|
int64_t namelen, foff;
|
|
if (!view_nth(o, i, &name, &namelen, &foff, &d)) return 0;
|
|
p = (const uint8_t *)o->u.view.base + foff;
|
|
} else {
|
|
d = o->u.view.desc;
|
|
p = view_elem_at(o, i);
|
|
}
|
|
if (*d != 'L') return 0;
|
|
memcpy(&x, p, 8);
|
|
if (x <= (uint64_t)INT64_MAX) return 0;
|
|
*out = (unsigned long long)x;
|
|
return 1;
|
|
}
|
|
|
|
static void view_struct_name(flan_obj *o, const char **name, int64_t *len) {
|
|
const uint8_t *d = o->u.view.desc;
|
|
const uint8_t *e = desc_name_end(d + 1);
|
|
*name = (const char *)d + 1;
|
|
*len = (int64_t)(e - d - 2);
|
|
}
|
|
|
|
/* print, =, length and has-key with the site they were written at, so a
|
|
* view that traps inside one — gone, or a u64 too wide to compare — says
|
|
* where, and names the operation. The compiler calls these; the site-less
|
|
* ones stay for test/dyn_ops.c and the runtime's own callers. */
|
|
static flan_dyn len_walk(flan_dyn v);
|
|
static flan_dyn contains_walk(flan_dyn m, flan_dyn k);
|
|
|
|
void flan_dyn_print_at(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|
walk_site was = walk_enter(loc, loclen, "print");
|
|
print_walk(v);
|
|
walk_leave(was);
|
|
}
|
|
|
|
void flan_dyn_print(flan_dyn v) { flan_dyn_print_at(v, NULL, 0); }
|
|
|
|
/* The same onto stdout, as a value inside a larger one prints: a text
|
|
* quoted and a char as its literal. println's walk calls it for a dyn or a
|
|
* char inside a typed struct, array or slice. */
|
|
void flan_dyn_print_nested_at(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|
walk_site was = walk_enter(loc, loclen, "print");
|
|
render(flan_write_stdout, v, 0, 1);
|
|
walk_leave(was);
|
|
}
|
|
|
|
flan_dyn flan_dyn_eq_at(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
walk_site was = walk_enter(loc, loclen, "=");
|
|
flan_dyn r = eq_walk(a, b);
|
|
walk_leave(was);
|
|
return r;
|
|
}
|
|
|
|
flan_dyn flan_dyn_eq(flan_dyn a, flan_dyn b) {
|
|
return flan_dyn_eq_at(a, b, NULL, 0);
|
|
}
|
|
|
|
flan_dyn flan_dyn_len_at(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|
walk_site was = walk_enter(loc, loclen, "length");
|
|
flan_dyn r = len_walk(v);
|
|
walk_leave(was);
|
|
return r;
|
|
}
|
|
|
|
flan_dyn flan_dyn_len(flan_dyn v) { return flan_dyn_len_at(v, NULL, 0); }
|
|
|
|
flan_dyn flan_dyn_map_contains_at(flan_dyn m, flan_dyn k, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
walk_site was = walk_enter(loc, loclen, "has-key");
|
|
flan_dyn r = contains_walk(m, k);
|
|
walk_leave(was);
|
|
return r;
|
|
}
|
|
|
|
flan_dyn flan_dyn_map_contains(flan_dyn m, flan_dyn k) {
|
|
return flan_dyn_map_contains_at(m, k, NULL, 0);
|
|
}
|
|
|
|
/* The first ABI, kept for test/dyn_ops.c: FLAN_VIEW_I64/F64/BOOL. */
|
|
static const uint8_t *old_elem_desc(int32_t elem) {
|
|
return (const uint8_t *)(elem == FLAN_VIEW_I64 ? "l"
|
|
: elem == FLAN_VIEW_F64 ? "d" : "?");
|
|
}
|
|
|
|
flan_dyn flan_dyn_view_vec(void *hdr, int32_t elem) {
|
|
return view_make(hdr, 0, old_elem_desc(elem), VIEW_VEC, 0);
|
|
}
|
|
|
|
flan_dyn flan_dyn_view_flat(void *data, int64_t len, int32_t elem) {
|
|
return view_make(data, len, old_elem_desc(elem), VIEW_FLAT, 0);
|
|
}
|
|
|
|
/* ── Dyn into a written type ───────────────────────────────────────────
|
|
*
|
|
* The reverse of a view: a dyn value reaching typed code that wrote a str, a
|
|
* slice, a fixed array or a struct (lib/check.ml, [into_typed]). [want] is
|
|
* the written type's descriptor, the prefix code above, with [c] for a
|
|
* [const T]; [out] is where the typed value goes — a str's or slice's two
|
|
* words, or the array's or struct's bytes. Four answers, in order:
|
|
*
|
|
* a text its own bytes, for a str or a [const u8], pinned
|
|
* ([pin_text]) and never copied;
|
|
* a view of typed storage whose element type is the one wanted: that
|
|
* storage, checked for staleness in a dev build, never copied;
|
|
* a vec, map copied and unboxed element by element, each checked, for a
|
|
* [const T], a fixed array or a struct — a [const T]'s block
|
|
* in the temp arena ([flan_temp_block]);
|
|
* anything else traps, naming the element and what it is.
|
|
*
|
|
* A [T] that can be written through is never a copy. A write through a copy
|
|
* would not reach the dyn vec, and the same program would then answer
|
|
* differently with the vec typed or dyn; so a plain dyn vec, or a view of
|
|
* other elements, into a [T] traps and names [const T]. A fixed array and a
|
|
* struct are values, copied on the typed side as well, so a copy there
|
|
* changes nothing. */
|
|
|
|
void *flan_temp_block(int64_t bytes, int64_t align, int64_t elem,
|
|
const char *type, int64_t typelen);
|
|
|
|
typedef struct into_site {
|
|
const uint8_t *loc;
|
|
int64_t loclen;
|
|
char op[140]; /* "into [const i64]" */
|
|
char where[192]; /* "element 2", "field :x of element 2"; "" */
|
|
} into_site;
|
|
|
|
static _Noreturn void into_trap(into_site *s, const char *trap,
|
|
const char *fmt, ...) {
|
|
char msg[640];
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vsnprintf(msg, sizeof msg, fmt, ap);
|
|
va_end(ap);
|
|
flan_say(s->loc, s->loclen, "dyn %s: %s", s->op, msg);
|
|
dyn_trap((const uint8_t *)trap, (int64_t)strlen(trap));
|
|
}
|
|
|
|
static const char *into_who(into_site *s) {
|
|
return s->where[0] ? s->where : "this";
|
|
}
|
|
|
|
/* "element 2 is a text, "a", and an i64 is wanted there". A view is checked
|
|
* for staleness before it is rendered, since rendering reads it. */
|
|
static _Noreturn void into_wrong(into_site *s, flan_dyn x, const char *why) {
|
|
char sx[SAY_MAX];
|
|
const char *t = tag_of(x);
|
|
if (dyn_boxed(x) && dyn_box(x) == BOX_OBJ && dyn_obj(x) != NULL
|
|
&& dyn_obj(x)->kind == OBJ_VIEW)
|
|
view_guard_check(s->loc, s->loclen, s->op, dyn_obj(x));
|
|
if (flan_dyn_tag(x) == FLAN_DYN_TAG_NIL)
|
|
into_trap(s, "DynType", "%s is nil, and %s", into_who(s), why);
|
|
say(sx, SAY_MAX, x);
|
|
into_trap(s, "DynType", "%s is %s %s, %s, and %s", into_who(s), an(t), t,
|
|
sx, why);
|
|
}
|
|
|
|
/* "an i64 is wanted there". */
|
|
static void into_wanted(char *buf, size_t cap, const uint8_t *d) {
|
|
char ty[128];
|
|
desc_spell(d, ty, sizeof ty);
|
|
snprintf(buf, cap, "%s %s is wanted there", an(ty), ty);
|
|
}
|
|
|
|
/* Whether a view's descriptor [a] starts with the whole of the code [b].
|
|
* The code is prefix-free, so a view's (inside a longer one) matches exactly
|
|
* when these bytes do. */
|
|
static int desc_same(const uint8_t *a, const uint8_t *b) {
|
|
size_t n = (size_t)(desc_skip(b) - b);
|
|
return memcmp(a, b, n) == 0;
|
|
}
|
|
|
|
/* A vec's length and element [i], a plain one's word or a view's element
|
|
* boxed. [o] is a vec-tagged object whose guard has been checked. */
|
|
static int64_t into_len(into_site *s, flan_obj *o) {
|
|
return o->kind == OBJ_VIEW ? view_len(s->loc, s->loclen, s->op, o) : o->len;
|
|
}
|
|
|
|
static flan_dyn into_at(into_site *s, flan_obj *o, int64_t i) {
|
|
if (o->kind == OBJ_VIEW)
|
|
return view_read(s->loc, s->loclen, s->op, o, o->u.view.desc,
|
|
view_elem_at(o, i));
|
|
return o->u.v.items[i];
|
|
}
|
|
|
|
/* A view object, or NULL; checked for staleness when it is one. */
|
|
static flan_obj *into_view(into_site *s, flan_dyn x) {
|
|
flan_obj *o;
|
|
if (!dyn_boxed(x) || dyn_box(x) != BOX_OBJ) return NULL;
|
|
o = dyn_obj(x);
|
|
if (o == NULL || o->kind != OBJ_VIEW) return NULL;
|
|
view_guard_check(s->loc, s->loclen, s->op, o);
|
|
return o;
|
|
}
|
|
|
|
/* Steps [s->where] into a part of what it names; [into_leave] steps back. */
|
|
static void into_enter(into_site *s, const char *fmt, ...) {
|
|
char part[96], rest[192];
|
|
va_list ap;
|
|
va_start(ap, fmt);
|
|
vsnprintf(part, sizeof part, fmt, ap);
|
|
va_end(ap);
|
|
memcpy(rest, s->where, sizeof rest);
|
|
if (rest[0] == '\0') snprintf(s->where, sizeof s->where, "%s", part);
|
|
else snprintf(s->where, sizeof s->where, "%s of %s", part, rest);
|
|
}
|
|
|
|
static void into_leave(into_site *s, const char *saved) {
|
|
memcpy(s->where, saved, sizeof s->where);
|
|
}
|
|
|
|
static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p);
|
|
static void into_slice(into_site *s, const uint8_t *d, flan_dyn x,
|
|
uint8_t *p);
|
|
|
|
/* A text's bytes as a str's two words, pinned — or, in a dev build, copied
|
|
* into the temp arena, whose registry note and poison catch a str kept past
|
|
* free-temp (see [pin_text]). */
|
|
static void into_text(flan_dyn x, uint8_t *p) {
|
|
flan_obj *o = dyn_obj(x);
|
|
const uint8_t *b = obj_text_bytes(o);
|
|
if (flan_dev_reg_enabled()) {
|
|
uint8_t *q = NULL;
|
|
if (o->len > 0) {
|
|
q = (uint8_t *)flan_temp_block(o->len, 1, 1, "u8", 2);
|
|
if (q == NULL) trap_oom(NULL, 0, o->len);
|
|
memcpy(q, b, (size_t)o->len);
|
|
}
|
|
memcpy(p, &q, 8);
|
|
memcpy(p + 8, &o->len, 8);
|
|
return;
|
|
}
|
|
pin_text(o);
|
|
memcpy(p, &b, 8);
|
|
memcpy(p + 8, &o->len, 8);
|
|
}
|
|
|
|
/* [n] elements of [e] from the vec-tagged [o] into [p]. */
|
|
static void into_elems(into_site *s, const uint8_t *e, flan_obj *o, int64_t n,
|
|
uint8_t *p) {
|
|
int64_t i, sz = desc_size(e);
|
|
char saved[192];
|
|
memcpy(saved, s->where, sizeof saved);
|
|
for (i = 0; i < n; i++) {
|
|
flan_dyn x;
|
|
into_enter(s, "element %lld", (long long)i);
|
|
x = into_at(s, o, i);
|
|
into_put(s, e, x, p + i * sz);
|
|
into_leave(s, saved);
|
|
}
|
|
}
|
|
|
|
static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p) {
|
|
char why[256], ty[128];
|
|
int64_t lo, hi;
|
|
if (int_range(*d, &lo, &hi)) {
|
|
int64_t n;
|
|
/* A char goes in as its code point where it fits, as it does into a
|
|
typed parameter ([flan_dyn_need_int]): into a byte only when ASCII,
|
|
since a byte past ASCII is not that char in UTF-8. */
|
|
if (flan_dyn_tag(x) == FLAN_DYN_TAG_CHAR) {
|
|
char cs[16];
|
|
n = (int64_t)dyn_payload(x);
|
|
if (n <= ((*d == 'b' || *d == 'B') ? 127 : hi)) goto store;
|
|
char_spell((uint32_t)n, cs);
|
|
desc_spell(d, ty, sizeof ty);
|
|
if (*d == 'b' || *d == 'B')
|
|
into_trap(s, "DynRange", "%s is the char %s, which is more than one "
|
|
"byte in UTF-8, so it is not %s %s. Take its code point as "
|
|
"an i32", into_who(s), cs, an(ty), ty);
|
|
into_trap(s, "DynRange", "%s is the char %s, code point %lld, and %s %s "
|
|
"holds %lld to %lld", into_who(s), cs, (long long)n, an(ty),
|
|
ty, (long long)lo, (long long)hi);
|
|
}
|
|
if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT) {
|
|
into_wanted(why, sizeof why, d);
|
|
into_wrong(s, x, why);
|
|
}
|
|
n = dyn_int_value(x);
|
|
if (n < lo || n > hi) {
|
|
desc_spell(d, ty, sizeof ty);
|
|
if (*d == 'L')
|
|
into_trap(s, "DynRange", "%s is %lld, and a u64 holds no negative "
|
|
"number", into_who(s), (long long)n);
|
|
into_trap(s, "DynRange", "%s is %lld, and %s %s holds %lld to %lld",
|
|
into_who(s), (long long)n, an(ty), ty, (long long)lo,
|
|
(long long)hi);
|
|
}
|
|
store:
|
|
switch (*d) {
|
|
case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; }
|
|
case 'h': case 'H': { uint16_t h = (uint16_t)n; memcpy(p, &h, 2); return; }
|
|
case 'i': case 'I': { uint32_t w = (uint32_t)n; memcpy(p, &w, 4); return; }
|
|
default: memcpy(p, &n, 8); return;
|
|
}
|
|
}
|
|
switch (*d) {
|
|
case 'f': case 'd': {
|
|
double f = 0;
|
|
/* An int goes into a float when the float holds it exactly: a view's
|
|
element write and a class's float slot take the same rule. */
|
|
if (flan_dyn_tag(x) == FLAN_DYN_TAG_INT) {
|
|
int64_t n = dyn_int_value(x);
|
|
f = *d == 'f' ? (double)(float)n : (double)n;
|
|
if (!(f >= -9223372036854775808.0 && f < 9223372036854775808.0)
|
|
|| (int64_t)f != n)
|
|
into_trap(s, "DynRange", "%s is %lld, which has no exact %s. Write "
|
|
"it as a float, as in %lld.0", into_who(s), (long long)n,
|
|
*d == 'f' ? "f32" : "f64", (long long)n);
|
|
} else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT) {
|
|
f = dyn_num_value(x);
|
|
/* A finite float past f32's range would become inf, which is a change
|
|
of value and not a rounding: refused, as an int out of range is. */
|
|
if (*d == 'f' && f == f && f - f == 0 && (f > 3.4028234663852886e38
|
|
|| f < -3.4028234663852886e38)) {
|
|
char sx[SAY_MAX];
|
|
say(sx, SAY_MAX, x);
|
|
into_trap(s, "DynRange", "%s is %s, and an f32 holds -3.4028235e38 "
|
|
"to 3.4028235e38", into_who(s), sx);
|
|
}
|
|
} else {
|
|
into_wanted(why, sizeof why, d);
|
|
into_wrong(s, x, why);
|
|
}
|
|
if (*d == 'f') { float g = (float)f; memcpy(p, &g, 4); }
|
|
else memcpy(p, &f, 8);
|
|
return;
|
|
}
|
|
case '?':
|
|
if (flan_dyn_tag(x) != FLAN_DYN_TAG_BOOL) {
|
|
into_wanted(why, sizeof why, d);
|
|
into_wrong(s, x, why);
|
|
}
|
|
*p = dyn_payload(x) ? 1 : 0;
|
|
return;
|
|
case 'C':
|
|
if (flan_dyn_tag(x) != FLAN_DYN_TAG_CHAR) {
|
|
into_wanted(why, sizeof why, d);
|
|
into_wrong(s, x, why);
|
|
}
|
|
{ uint32_t w = (uint32_t)dyn_payload(x); memcpy(p, &w, 4); }
|
|
return;
|
|
case 't':
|
|
if (!is_text(x))
|
|
into_wrong(s, x, "a str is wanted there, which only a text becomes");
|
|
into_text(x, p);
|
|
return;
|
|
case 'a': {
|
|
const uint8_t *e = d + 1;
|
|
int64_t n = desc_int(&e), len;
|
|
flan_obj *o;
|
|
if (!is_vec(x)) {
|
|
desc_spell(d, ty, sizeof ty);
|
|
snprintf(why, sizeof why, "%s %s is made from a vec", an(ty), ty);
|
|
into_wrong(s, x, why);
|
|
}
|
|
o = into_view(s, x);
|
|
if (o == NULL) o = dyn_obj(x);
|
|
len = into_len(s, o);
|
|
if (len != n) {
|
|
desc_spell(d, ty, sizeof ty);
|
|
into_trap(s, "DynRange", "%s has %lld element%s, and %s %s holds "
|
|
"exactly %lld", s->where[0] ? s->where : "this vec",
|
|
(long long)len, len == 1 ? "" : "s", an(ty), ty,
|
|
(long long)n);
|
|
}
|
|
/* A view of the same elements is the same bytes: an array is a value,
|
|
copied on the typed side too. */
|
|
if (o->kind == OBJ_VIEW && desc_same(o->u.view.desc, e)) {
|
|
if (n > 0) memcpy(p, view_base(o), (size_t)(n * desc_size(e)));
|
|
return;
|
|
}
|
|
into_elems(s, e, o, n, p);
|
|
return;
|
|
}
|
|
case '{': {
|
|
const uint8_t *at, *name, *fty;
|
|
int64_t off, namelen, foff;
|
|
flan_obj *o;
|
|
char saved[192];
|
|
if (!is_map(x)) {
|
|
desc_spell(d, ty, sizeof ty);
|
|
snprintf(why, sizeof why, "%s %s is made from a map", an(ty), ty);
|
|
into_wrong(s, x, why);
|
|
}
|
|
o = into_view(s, x);
|
|
if (o != NULL && desc_same(o->u.view.desc, d)) {
|
|
memcpy(p, o->u.view.base, (size_t)desc_size(d));
|
|
return;
|
|
}
|
|
memcpy(saved, s->where, sizeof saved);
|
|
/* What the value is called in a sentence: its place inside the whole,
|
|
else what it is — a struct's view, a class's instance, a map. */
|
|
{
|
|
char what[160];
|
|
flan_obj *m = dyn_obj(x);
|
|
int64_t i, n;
|
|
if (s->where[0]) snprintf(what, sizeof what, "%s", s->where);
|
|
else if (o != NULL) {
|
|
const char *nm;
|
|
int64_t nl;
|
|
view_struct_name(o, &nm, &nl);
|
|
snprintf(what, sizeof what, "this %.*s", (int)nl, nm);
|
|
} else if (m->u.v.klass != NULL) {
|
|
kw_entry *k = m->u.v.klass;
|
|
snprintf(what, sizeof what, "this %.*s", (int)k->len,
|
|
(const char *)kw_bytes(k));
|
|
} else
|
|
snprintf(what, sizeof what, "this map");
|
|
at = desc_fields(d, &off);
|
|
while (desc_next(&at, &off, &name, &namelen, &foff, &fty))
|
|
if (!flan_dyn_truthy(flan_dyn_map_contains_at(
|
|
x, flan_dyn_kw(name, namelen), s->loc, s->loclen))) {
|
|
desc_spell(d, ty, sizeof ty);
|
|
into_trap(s, "DynType", "%s has no :%.*s, and %s %s needs every "
|
|
"field", what, (int)namelen, (const char *)name, an(ty),
|
|
ty);
|
|
}
|
|
/* A key the struct has no field for is refused, as a class refuses a
|
|
slot it does not declare: dropping it would lose what was written. */
|
|
if (o == NULL) class_sync(m);
|
|
n = o != NULL ? view_nfields(o) : m->len;
|
|
for (i = 0; i < n; i++) {
|
|
flan_dyn k = o != NULL ? view_field_key(o, i) : m->u.v.items[2 * i];
|
|
int64_t foff2;
|
|
if (desc_field(d, k, &foff2) == NULL) {
|
|
char sk[SAY_MAX];
|
|
int64_t off2;
|
|
const uint8_t *at2;
|
|
say(sk, SAY_MAX, k);
|
|
desc_spell(d, ty, sizeof ty);
|
|
said_len = 0;
|
|
said_add("dyn %s: %s has %s, and %s %s has no field %s. Its fields "
|
|
"are", s->op, what, sk, an(ty), ty, sk);
|
|
at2 = desc_fields(d, &off2);
|
|
while (desc_next(&at2, &off2, &name, &namelen, &foff, &fty))
|
|
said_add(" :%.*s", (int)namelen, (const char *)name);
|
|
flan_say(s->loc, s->loclen, "%s", said_buf);
|
|
dyn_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
}
|
|
}
|
|
at = desc_fields(d, &off);
|
|
while (desc_next(&at, &off, &name, &namelen, &foff, &fty)) {
|
|
flan_dyn k = flan_dyn_kw(name, namelen), v;
|
|
v = flan_dyn_get(x, k, s->loc, s->loclen);
|
|
into_enter(s, "field :%.*s", (int)namelen, (const char *)name);
|
|
into_put(s, fty, v, p + foff);
|
|
into_leave(s, saved);
|
|
}
|
|
return;
|
|
}
|
|
case 's': case 'c':
|
|
into_slice(s, d, x, p);
|
|
return;
|
|
default:
|
|
desc_spell(d, ty, sizeof ty);
|
|
snprintf(why, sizeof why, "%s %s is not made from a dyn value", an(ty), ty);
|
|
into_wrong(s, x, why);
|
|
}
|
|
}
|
|
|
|
/* The copy a [const T] reads, of a plain vec or a view of other elements. */
|
|
static void into_copy(into_site *s, const uint8_t *e, flan_obj *o,
|
|
uint8_t *out) {
|
|
static const char scalars[] = "bBhHiIlLfd?tC";
|
|
static const char *const words[] = { "i8", "u8", "i16", "u16", "i32", "u32",
|
|
"i64", "u64", "f32", "f64", "bool",
|
|
"str", "char" };
|
|
const char *w = *e != '\0' ? strchr(scalars, *e) : NULL;
|
|
/* The registry keeps the name by pointer, so it is static text. */
|
|
const char *type = w != NULL ? words[w - scalars] : "element";
|
|
int64_t n = into_len(s, o), size, align;
|
|
uint8_t *block = NULL;
|
|
desc_lay(e, &size, &align);
|
|
if (n > 0 && size > 0) {
|
|
block = (uint8_t *)flan_temp_block(n * size, align, size, type,
|
|
(int64_t)strlen(type));
|
|
if (block == NULL) trap_oom(s->loc, s->loclen, n * size);
|
|
memset(block, 0, (size_t)(n * size));
|
|
into_elems(s, e, o, n, block);
|
|
}
|
|
memcpy(out, &block, 8);
|
|
memcpy(out + 8, &n, 8);
|
|
}
|
|
|
|
/* A [T] or a [const T], at the top or inside an array or a struct. A text
|
|
* is a [const u8]'s bytes, a view of the very elements wanted is its own
|
|
* storage, and a [const T] of anything else vec-shaped is a copy; a [T]
|
|
* never is, since a write through it would not reach the vec. */
|
|
static void into_slice(into_site *s, const uint8_t *d, flan_dyn x,
|
|
uint8_t *p) {
|
|
const uint8_t *e = d + 1;
|
|
int mut = *d == 's';
|
|
const char *who = s->where[0] ? s->where : "this vec";
|
|
char ty[128], ety[128], why[256];
|
|
flan_obj *o;
|
|
desc_spell(d, ty, sizeof ty);
|
|
desc_spell(e, ety, sizeof ety);
|
|
if (is_text(x) && *e == 'B') {
|
|
if (mut)
|
|
into_wrong(s, x, "a text is read-only, so it becomes a str or a "
|
|
"[const u8] and never a [u8]");
|
|
into_text(x, p);
|
|
return;
|
|
}
|
|
if (!is_vec(x)) {
|
|
snprintf(why, sizeof why, "only a vec becomes %s %s", an(ty), ty);
|
|
into_wrong(s, x, why);
|
|
}
|
|
o = into_view(s, x);
|
|
if (o != NULL && desc_same(o->u.view.desc, e)) {
|
|
void *b = view_base(o);
|
|
int64_t n = view_len(s->loc, s->loclen, s->op, o);
|
|
memcpy(p, &b, 8);
|
|
memcpy(p + 8, &n, 8);
|
|
return;
|
|
}
|
|
if (mut) {
|
|
char have[128];
|
|
if (o != NULL) {
|
|
desc_spell(o->u.view.desc, have, sizeof have);
|
|
into_trap(s, "DynType", "%s is a view of %s elements, so %s %s of it "
|
|
"would be a copy, and a write through the copy would never "
|
|
"reach the vec. Take it as [const %s], which reads a copy",
|
|
who, have, an(ty), ty, ety);
|
|
}
|
|
into_trap(s, "DynType", "%s is a dyn vec, so %s %s of it would be a "
|
|
"copy, and a write through the copy would never reach the vec. "
|
|
"Take it as [const %s], which reads a copy", who, an(ty), ty,
|
|
ety);
|
|
}
|
|
into_copy(s, e, o != NULL ? o : dyn_obj(x), p);
|
|
}
|
|
|
|
void flan_dyn_need_as(flan_dyn v, const uint8_t *want, int64_t wantlen,
|
|
void *out, const uint8_t *loc, int64_t loclen) {
|
|
into_site s;
|
|
char ty[128];
|
|
uint8_t *p = (uint8_t *)out;
|
|
(void)wantlen;
|
|
s.loc = loc;
|
|
s.loclen = loclen;
|
|
s.where[0] = '\0';
|
|
desc_spell(want, ty, sizeof ty);
|
|
snprintf(s.op, sizeof s.op, "into %s", ty);
|
|
switch (*want) {
|
|
case 't':
|
|
if (!is_text(v)) into_wrong(&s, v, "only a text becomes a str");
|
|
into_text(v, p);
|
|
return;
|
|
default:
|
|
into_put(&s, want, v, p);
|
|
return;
|
|
}
|
|
}
|
|
|
|
static flan_dyn len_walk(flan_dyn v) {
|
|
if (is_text(v)) return flan_dyn_from_i64(dyn_obj(v)->u.i);
|
|
/* 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);
|
|
if (o->kind == OBJ_VIEW) return flan_dyn_from_i64(view_nfields(o));
|
|
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(walk_loc, walk_len, walk_op, o));
|
|
return flan_dyn_from_i64(o->len);
|
|
}
|
|
trap1(NULL, 0, TYPE_TRAP, "length", "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 uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn v, flan_dyn i) {
|
|
if (flan_dyn_tag(i) != FLAN_DYN_TAG_INT)
|
|
trap2(loc, loclen, TYPE_TRAP, op, "an index must be an int", v, i);
|
|
return dyn_int_value(i);
|
|
}
|
|
|
|
/* A text answers its [i]th char, counting code points: O(1) on an ASCII
|
|
* text, a walk from the front on any other. A typed str counts bytes.
|
|
*
|
|
* [at]'s, and [get]'s over a text or a vec: one body, so the two always
|
|
* count the same way. [soft] is [get]'s — an index out of range is nil
|
|
* rather than a trap. */
|
|
static flan_dyn at_core(flan_dyn v, flan_dyn i, const uint8_t *loc,
|
|
int64_t loclen, int soft, const char *op) {
|
|
int64_t k;
|
|
flan_obj *o;
|
|
/* m[:k] on a map is (get m :k), whatever the key: get's rule, nil when
|
|
* absent. */
|
|
if (is_map(v)) return flan_dyn_get(v, i, loc, loclen);
|
|
if (!is_text(v) && !is_vec(v))
|
|
trap2(loc, loclen, TYPE_TRAP, op, "only a text, a vec or a map is indexed",
|
|
v, i);
|
|
k = need_index(loc, loclen, op, v, i);
|
|
o = dyn_obj(v);
|
|
if (o->kind == OBJ_VIEW) {
|
|
int64_t len = view_len(loc, loclen, op, o);
|
|
if (k < 0 || k >= len) {
|
|
if (soft) return flan_dyn_nil();
|
|
trap_range(loc, loclen, op, v, k, len);
|
|
}
|
|
{
|
|
uint8_t *p = view_elem_at(o, k);
|
|
switch ((o->gen >> 9) & 3) {
|
|
case VIEW_FAST_I64: { int64_t x; memcpy(&x, p, 8); return flan_dyn_from_i64(x); }
|
|
case VIEW_FAST_F64: { double x; memcpy(&x, p, 8); return flan_dyn_from_f64(x); }
|
|
case VIEW_FAST_BOOL: return flan_dyn_from_bool(*p ? 1 : 0);
|
|
default: return view_read(loc, loclen, op, o, o->u.view.desc, p);
|
|
}
|
|
}
|
|
}
|
|
if (o->kind == OBJ_TEXT) {
|
|
int64_t off;
|
|
int w;
|
|
if (k < 0 || k >= o->u.i) {
|
|
if (soft) return flan_dyn_nil();
|
|
trap_range(loc, loclen, op, v, k, o->u.i);
|
|
}
|
|
off = text_offset(o, k);
|
|
return dyn_make(BOX_CHAR,
|
|
utf8_decode(obj_text_bytes(o) + off, o->len - off, &w));
|
|
}
|
|
if (k < 0 || k >= o->len) {
|
|
if (soft) return flan_dyn_nil();
|
|
trap_range(loc, loclen, op, v, k, o->len);
|
|
}
|
|
return o->u.v.items[k];
|
|
}
|
|
|
|
flan_dyn flan_dyn_at(flan_dyn v, flan_dyn i, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
return at_core(v, i, loc, loclen, 0, "at");
|
|
}
|
|
|
|
/* (slice s lo) and (slice s lo hi) over a text; nil for [hi] is the length.
|
|
* The typed slice of a string is a view, and this is a copy: a text is
|
|
* immutable, so no program can tell the two apart. A vec's slice would have
|
|
* to share its elements with the vec to mean what the typed one means, which
|
|
* a copy does not, so a vec traps by type rather than answering differently. */
|
|
flan_dyn flan_dyn_slice(flan_dyn v, flan_dyn lo, flan_dyn hi,
|
|
const uint8_t *loc, int64_t loclen) {
|
|
int64_t a, b, len;
|
|
flan_obj *o;
|
|
if (!is_text(v))
|
|
trap2(loc, loclen, TYPE_TRAP, "slice", "only a text is sliced", v, lo);
|
|
o = dyn_obj(v);
|
|
/* The bounds count chars, as [length] and [at] do. */
|
|
len = o->u.i;
|
|
a = need_index(loc, loclen, "slice", v, lo);
|
|
b = flan_dyn_tag(hi) == FLAN_DYN_TAG_NIL
|
|
? len : need_index(loc, loclen, "slice", v, hi);
|
|
if (a < 0 || b < a || b > len) {
|
|
char sv[SAY_MAX];
|
|
say(sv, SAY_MAX, v);
|
|
flan_say(loc, loclen,
|
|
"dyn slice: [%lld %lld) is out of bounds for text of length %lld "
|
|
"— %s", (long long)a, (long long)b, (long long)len, sv);
|
|
dyn_trap((const uint8_t *)"DynRange", 8);
|
|
}
|
|
a = text_offset(o, a);
|
|
b = text_offset(o, b);
|
|
return flan_dyn_from_bytes(obj_text_bytes(o) + a, b - a);
|
|
}
|
|
|
|
/* (chars t): a text's chars, a fresh vec of them. */
|
|
flan_dyn flan_dyn_chars(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|
flan_obj *o;
|
|
flan_dyn out;
|
|
int64_t i = 0;
|
|
int w;
|
|
if (!is_text(v))
|
|
trap1(loc, loclen, TYPE_TRAP, "chars", "only a text has chars", v);
|
|
out = flan_dyn_vec_new();
|
|
o = dyn_obj(v);
|
|
while (i < o->len) {
|
|
uint32_t cp = utf8_decode(obj_text_bytes(o) + i, o->len - i, &w);
|
|
flan_dyn_push(out, dyn_make(BOX_CHAR, cp), loc, loclen);
|
|
i += w;
|
|
}
|
|
return out;
|
|
}
|
|
|
|
/* (text x): a vec of chars, or one char, as a text — [chars] undone. */
|
|
flan_dyn flan_dyn_text(flan_dyn v, const uint8_t *loc, int64_t loclen) {
|
|
uint8_t u[4];
|
|
int64_t i, n, total = 0;
|
|
flan_obj *src, *o;
|
|
if (flan_dyn_tag(v) == FLAN_DYN_TAG_CHAR) {
|
|
int k = utf8_encode((uint32_t)dyn_payload(v), u);
|
|
return flan_dyn_from_bytes(u, k);
|
|
}
|
|
if (!is_vec(v))
|
|
trap1(loc, loclen, TYPE_TRAP, "text",
|
|
"text is made from a vec of chars or from one char", v);
|
|
src = dyn_obj(v);
|
|
n = vecish_len(src);
|
|
for (i = 0; i < n; i++) {
|
|
flan_dyn c = vecish_at(src, i);
|
|
if (flan_dyn_tag(c) != FLAN_DYN_TAG_CHAR) {
|
|
char sc[SAY_MAX];
|
|
say(sc, SAY_MAX, c);
|
|
flan_say(loc, loclen,
|
|
"dyn text: element %lld is %s %s, and text is made from chars "
|
|
"only", (long long)i, an(tag_of(c)), sc);
|
|
flan_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
total += utf8_encode((uint32_t)dyn_payload(c), u);
|
|
}
|
|
o = gc_alloc(OBJ_TEXT, total);
|
|
o->len = total;
|
|
total = 0;
|
|
for (i = 0; i < n; i++) {
|
|
int k = utf8_encode((uint32_t)dyn_payload(vecish_at(src, i)), u);
|
|
memcpy(obj_text_bytes(o) + total, u, (size_t)k);
|
|
total += k;
|
|
}
|
|
text_measure(o);
|
|
return dyn_make(BOX_OBJ, (uint64_t)(uintptr_t)o);
|
|
}
|
|
|
|
void flan_dyn_set_at(flan_dyn v, flan_dyn i, flan_dyn x, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
int64_t k;
|
|
flan_obj *o;
|
|
if (is_text(v))
|
|
trap2(loc, loclen, TYPE_TRAP, "set-at",
|
|
"a text is immutable — build another one", v, i);
|
|
/* Assigning m[:k] is (put m :k x), a class slot's type check with it. */
|
|
if (is_map(v)) {
|
|
flan_dyn_map_put(v, i, x, loc, loclen);
|
|
return;
|
|
}
|
|
if (!is_vec(v))
|
|
trap2(loc, loclen, TYPE_TRAP, "set-at",
|
|
"only a vec or a map is assigned into", v, i);
|
|
k = need_index(loc, loclen, "set-at", v, i);
|
|
o = dyn_obj(v);
|
|
if (o->kind == OBJ_VIEW) {
|
|
int64_t len = view_len(loc, loclen, "set-at", o);
|
|
if (k < 0 || k >= len) trap_range(loc, loclen, "set-at", v, k, len);
|
|
view_write(loc, loclen, "set-at", v, flan_dyn_nil(), o->u.view.desc, x,
|
|
view_elem_at(o, k));
|
|
return;
|
|
}
|
|
if (k < 0 || k >= o->len) trap_range(loc, loclen, "set-at", v, k, o->len);
|
|
o->u.v.items[k] = x;
|
|
}
|
|
|
|
void flan_dyn_push(flan_dyn v, flan_dyn x, const uint8_t *loc, int64_t loclen) {
|
|
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(loc, loclen, TYPE_TRAP, "push", "only a vec is pushed to", v, x);
|
|
}
|
|
o = dyn_obj(v);
|
|
if (o->kind == OBJ_VIEW) {
|
|
uint8_t buf[16];
|
|
/* The typed Vec's own traps print a site too, and without one from the
|
|
* caller the best this can name is the operation. */
|
|
static const uint8_t push_loc[] = "(dyn push)";
|
|
const uint8_t *site = loc != NULL && loclen > 0 ? loc : push_loc;
|
|
int64_t sitelen = loc != NULL && loclen > 0 ? loclen
|
|
: (int64_t)sizeof(push_loc) - 1;
|
|
int64_t size, align;
|
|
if (view_shape(o) != VIEW_VEC)
|
|
trap2(loc, loclen, TYPE_TRAP, "push",
|
|
"this view is a slice or an array and cannot grow", v, x);
|
|
view_len(loc, loclen, "push", o);
|
|
desc_lay(o->u.view.desc, &size, &align);
|
|
/* Only a number or a bool is ever written, and [view_write] refuses the
|
|
rest before a byte of [buf] is used. */
|
|
memset(buf, 0, sizeof buf);
|
|
view_write(loc, loclen, "push", v, flan_dyn_nil(), o->u.view.desc, x, buf);
|
|
if (!flan_vec_push(o->u.view.base, buf, size, align, site, sitelen))
|
|
trap_oom(loc, loclen, 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(loc, loclen, 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 Clojure's answer, which is the rule
|
|
* on the dyn side: TODO.org, "The dynamic paths mimic Clojure, the static
|
|
* paths mimic Odin". [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 uint8_t *loc, int64_t loclen, const char *op,
|
|
flan_dyn m, flan_dyn k) {
|
|
flan_obj *o;
|
|
if (!is_map(m)) trap2(loc, loclen, 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(NULL, 0, "get", m, k);
|
|
if (o->kind == OBJ_VIEW) {
|
|
const uint8_t *fty;
|
|
uint8_t *p = view_field(NULL, 0, "get", o, k, &fty);
|
|
return view_read(NULL, 0, "get", o, fty, p);
|
|
}
|
|
int64_t i = map_find(o, k);
|
|
return i < 0 ? flan_dyn_nil() : o->u.v.items[i * 2 + 1];
|
|
}
|
|
|
|
/* A program's (get m k) and (.k m): the same, with the site a value that is
|
|
* not a map is refused at, and a key an instance's class does not declare
|
|
* refused rather than answered nil — [trap_no_slot]. */
|
|
static class_entry *class_sync(flan_obj *o);
|
|
static int64_t class_slot(class_entry *e, flan_dyn k);
|
|
static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_obj *o,
|
|
class_entry *e, flan_dyn k);
|
|
flan_dyn flan_dyn_get(flan_dyn m, flan_dyn k, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
class_entry *e;
|
|
if (!is_map(m)) trap2(loc, loclen, TYPE_TRAP, "get", "only a map answers it", m, k);
|
|
/* A struct's view: its field, or a trap at this site naming the fields. */
|
|
if (dyn_obj(m)->kind == OBJ_VIEW) {
|
|
const uint8_t *fty;
|
|
uint8_t *p = view_field(loc, loclen, "get", dyn_obj(m), k, &fty);
|
|
return view_read(loc, loclen, "get", dyn_obj(m), fty, p);
|
|
}
|
|
e = class_sync(dyn_obj(m));
|
|
if (e != NULL && class_slot(e, k) < 0)
|
|
trap_no_slot(loc, loclen, "get", dyn_obj(m), e, k);
|
|
return flan_dyn_map_get(m, k);
|
|
}
|
|
|
|
/* The [get] builtin's, which [.field] does not share: over a map it is
|
|
* [flan_dyn_get], and over a vec or a text it is [at] that answers nil for an
|
|
* index out of range, negative included, where [at] traps. The index must
|
|
* still be an int — a wrong kind of key is a mistake, not an absence. */
|
|
flan_dyn flan_dyn_get_at(flan_dyn v, flan_dyn i, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
/* Through [at]'s own body, so however [at] counts a text — by code point —
|
|
* [get] counts the same. */
|
|
if (!is_text(v) && !is_vec(v)) return flan_dyn_get(v, i, loc, loclen);
|
|
return at_core(v, i, loc, loclen, 1, "get");
|
|
}
|
|
|
|
static flan_dyn contains_walk(flan_dyn m, flan_dyn k) {
|
|
flan_obj *o = want_map(walk_loc, walk_len, walk_op, m, k);
|
|
if (o->kind == OBJ_VIEW) {
|
|
int64_t off;
|
|
view_guard_check(walk_loc, walk_len, walk_op, o);
|
|
return flan_dyn_from_bool(desc_field(o->u.view.desc, k, &off) != NULL);
|
|
}
|
|
return flan_dyn_from_bool(map_find(o, k) >= 0);
|
|
}
|
|
|
|
/* A class slot's type, checked at the store — SBCL's place for it
|
|
* (src/pcl/slots.lisp, [set-slot-value]'s typecheck before the write),
|
|
* because the store is where the wrong value is. -1 when [k] is not a slot
|
|
* the class declares. */
|
|
static int64_t class_slot(class_entry *e, flan_dyn k) {
|
|
int64_t j;
|
|
if (e == NULL || flan_dyn_tag(k) != FLAN_DYN_TAG_KEYWORD) return -1;
|
|
for (j = 0; j < e->nslots; j++)
|
|
if (e->slots[j] == dyn_kw(k)) return j;
|
|
return -1;
|
|
}
|
|
|
|
/* The three stores that reach a declared slot, for the sentence a refusal
|
|
* prints: the call as it would have been written. */
|
|
enum { BY_PUT, BY_SET, BY_NEW };
|
|
|
|
static _Noreturn void trap_slot_type(const uint8_t *loc, int64_t loclen,
|
|
int by, flan_obj *o, class_entry *e,
|
|
int64_t j, flan_dyn m, flan_dyn v) {
|
|
char sm[SAY_MAX], sv[SAY_MAX], st[128];
|
|
const slot_type *t = &e->types[j];
|
|
kw_entry *sl = e->slots[j], *c = o->u.v.klass;
|
|
int sn = (int)sl->len, cn = (int)c->len;
|
|
const char *ss = (const char *)(sl + 1), *cs = (const char *)(c + 1);
|
|
say(sm, SAY_MAX, m);
|
|
say(sv, SAY_MAX, v);
|
|
slot_type_text(t, st, sizeof st);
|
|
said_len = 0;
|
|
said_add("dyn %s: the slot :%.*s of %.*s is declared %s, and ",
|
|
by == BY_PUT ? "put" : by == BY_SET ? "set" : "construct", sn, ss,
|
|
cn, cs, st);
|
|
/* A number of the right kind that does not fit is not news about its tag. */
|
|
if ((t->kind == ST_INT && flan_dyn_tag(v) == FLAN_DYN_TAG_INT)
|
|
|| (t->kind == ST_FLOAT
|
|
&& (flan_dyn_tag(v) == FLAN_DYN_TAG_INT
|
|
|| flan_dyn_tag(v) == FLAN_DYN_TAG_FLOAT)))
|
|
said_add("%s is not a value it holds exactly — ", sv);
|
|
else if (t->kind == ST_CLASS && flan_dyn_tag(v) == FLAN_DYN_TAG_MAP)
|
|
said_add("this is not an instance of it — ");
|
|
else
|
|
said_add("this is %s — ", tag_of(v));
|
|
if (by == BY_PUT)
|
|
said_add("(put %s :%.*s %s)", sm, sn, ss, sv);
|
|
else if (by == BY_SET)
|
|
said_add("(set (get %s :%.*s) %s)", sm, sn, ss, sv);
|
|
else if (site_building != NULL && loc != NULL)
|
|
said_add("(%.*s ...) with :%.*s %s; the slot is declared at %.*s",
|
|
cn, cs, sn, ss, sv, (int)loclen, (const char *)loc);
|
|
else
|
|
said_add("(%.*s ...) with :%.*s %s", cn, cs, sn, ss, sv);
|
|
/* A constructor's refusal is placed at the call that was wrong, when the
|
|
call said where it was, and names the slot's declaration after it. */
|
|
flan_say(by == BY_NEW && site_building != NULL ? site_building : loc,
|
|
by == BY_NEW && site_building != NULL ? site_building_len : loclen,
|
|
"%s", said_buf);
|
|
dyn_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
|
|
/* The value a store into [o] under [k] actually stores: [v], or the float an
|
|
* int widens to in a float slot. A class with no typed slot answers at its
|
|
* flag, and a map with no class before that. */
|
|
static flan_dyn check_slot(const uint8_t *loc, int64_t loclen, int by,
|
|
flan_obj *o, class_entry *e, flan_dyn m,
|
|
flan_dyn k, flan_dyn v) {
|
|
int64_t j;
|
|
flan_dyn out;
|
|
if (e == NULL || !e->typed) return v;
|
|
j = class_slot(e, k);
|
|
if (j < 0) return v;
|
|
if (!slot_admit(&e->types[j], v, &out))
|
|
trap_slot_type(loc, loclen, by, o, e, j, m, v);
|
|
return out;
|
|
}
|
|
|
|
static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v);
|
|
|
|
/* A key an instance's class does not declare, read or written. An instance
|
|
* has exactly its class's slots — a typo in a slot name is an error at the
|
|
* access and not a new key — so get, put and set all refuse one; a plain map
|
|
* takes any key. */
|
|
static _Noreturn void trap_no_slot(const uint8_t *loc, int64_t loclen,
|
|
const char *op, flan_obj *o,
|
|
class_entry *e, flan_dyn k) {
|
|
char sk[SAY_MAX];
|
|
kw_entry *c = o->u.v.klass;
|
|
int64_t i;
|
|
say(sk, SAY_MAX, k);
|
|
said_len = 0;
|
|
said_add("dyn %s: %.*s has no slot %s. Its slots are", op, (int)c->len,
|
|
(const char *)(c + 1), sk);
|
|
if (e == NULL || e->nslots == 0) said_add(" none");
|
|
else
|
|
for (i = 0; i < e->nslots; i++)
|
|
said_add(" :%.*s", (int)e->slots[i]->len,
|
|
(const char *)(e->slots[i] + 1));
|
|
flan_say(loc, loclen, "%s", said_buf);
|
|
dyn_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
|
|
/* A constructor's stores: [flan_dyn_map_set]'s, with the refusal worded for
|
|
* the constructor call it happened inside rather than for a [put] nobody
|
|
* wrote, and placed at the slot's declaration. */
|
|
void flan_dyn_slot_init(flan_dyn m, flan_dyn k, flan_dyn v,
|
|
const uint8_t *loc, int64_t loclen) {
|
|
flan_obj *o = want_map(loc, loclen, "construct", m, k);
|
|
class_entry *e = o->u.v.klass == NULL ? NULL : class_find(o->u.v.klass);
|
|
map_store(o, k, check_slot(loc, loclen, BY_NEW, o, e, m, k, v));
|
|
}
|
|
|
|
/* (set (get inst :slot) v). Three refusals, each its own sentence, because
|
|
* they are three different mistakes: the value is not a class instance at
|
|
* all (a map's entries are written with [put], which is where inserting a
|
|
* key is real); the key is not a slot the class declares; the value does not
|
|
* fit the slot's type. The first is why this is not [put]. */
|
|
void flan_dyn_slot_set(flan_dyn m, flan_dyn k, flan_dyn v,
|
|
const uint8_t *loc, int64_t loclen) {
|
|
flan_obj *o;
|
|
class_entry *e;
|
|
int64_t j;
|
|
flan_dyn out;
|
|
if (is_map(m) && dyn_obj(m)->kind == OBJ_VIEW) {
|
|
const uint8_t *fty;
|
|
uint8_t *p = view_field(loc, loclen, "set", dyn_obj(m), k, &fty);
|
|
view_write(loc, loclen, "set", m, k, fty, v, p);
|
|
return;
|
|
}
|
|
if (!is_map(m) || dyn_obj(m)->u.v.klass == NULL) {
|
|
char sm[SAY_MAX];
|
|
say(sm, SAY_MAX, m);
|
|
flan_say(loc, loclen,
|
|
"dyn set: (get m k) is a place only on a class instance, and "
|
|
"this is %s%s — %s. A map's entries are written with put",
|
|
is_map(m) ? "a map with no class" : "a ",
|
|
is_map(m) ? "" : tag_of(m), sm);
|
|
dyn_trap((const uint8_t *)"DynType", 7);
|
|
}
|
|
o = dyn_obj(m);
|
|
e = class_sync(o);
|
|
j = class_slot(e, k);
|
|
if (j < 0) trap_no_slot(loc, loclen, "set", o, e, k);
|
|
if (!slot_admit(&e->types[j], v, &out))
|
|
trap_slot_type(loc, loclen, BY_SET, o, e, j, m, v);
|
|
map_store(o, k, out);
|
|
}
|
|
|
|
static void map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc,
|
|
int64_t loclen, int any_key) {
|
|
flan_obj *o;
|
|
class_entry *e;
|
|
if (!is_map(m)) trap2(loc, loclen, TYPE_TRAP, "put", "only a map answers it", m, k);
|
|
o = dyn_obj(m);
|
|
if (o->kind == OBJ_VIEW) {
|
|
const uint8_t *fty;
|
|
uint8_t *p = view_field(loc, loclen, "put", o, k, &fty);
|
|
view_write(loc, loclen, "put", m, k, fty, v, p);
|
|
return;
|
|
}
|
|
e = class_sync(o);
|
|
if (!any_key && e != NULL && class_slot(e, k) < 0)
|
|
trap_no_slot(loc, loclen, "put", o, e, k);
|
|
/* A map with no class, and a class with no typed slot, stop at the test. */
|
|
if (e != NULL && e->typed) v = check_slot(loc, loclen, BY_PUT, o, e, m, k, v);
|
|
map_store(o, k, v);
|
|
}
|
|
|
|
/* A program's put, and the store under a dyn's [.k] and [:k]. */
|
|
void flan_dyn_map_put(flan_dyn m, flan_dyn k, flan_dyn v, const uint8_t *loc,
|
|
int64_t loclen) {
|
|
map_put(m, k, v, loc, loclen, 0);
|
|
}
|
|
|
|
/* With no site and any key: an untagged map literal's stores, and
|
|
* test/dyn_ops.c, which builds instances' odd states by hand. No program
|
|
* reaches an instance through it. */
|
|
void flan_dyn_map_set(flan_dyn m, flan_dyn k, flan_dyn v) {
|
|
map_put(m, k, v, NULL, 0, 1);
|
|
}
|
|
|
|
/* The store under all three, with the instance already brought up to date. */
|
|
static inline void map_store(flan_obj *o, flan_dyn k, flan_dyn v) {
|
|
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(NULL, 0, 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++;
|
|
}
|