uCBQN/src/h.h
2021-04-10 19:50:50 +03:00

584 lines
18 KiB
C
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

#pragma once
#include <inttypes.h>
#include <stdbool.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <stddef.h>
#include <stdarg.h>
#define i8 int8_t
#define u8 uint8_t
#define i16 int16_t
#define u16 uint16_t
#define i32 int32_t
#define u32 uint32_t
#define i64 int64_t
#define u64 uint64_t
#define f64 double
#define I32_MAX ((i32)((1LL<<31)-1))
#define U16_MAX ((u16)-1)
#define UD __builtin_unreachable();
#define NOINLINE __attribute__ ((noinline))
#define usz u32
#define ur u8
#define CTR_FOR(F)
#define CTR_DEF(N) u64 N;
#define CTR_PRINT(N) printf(#N ": %lu\n", N);
CTR_FOR(CTR_DEF)
#ifdef DEBUG
#include<assert.h>
#define VALIDATE(x) validate(x) // preferred validating level
#else
#define assert(x) {if (!(x)) __builtin_unreachable();}
#define VALIDATE(x) x
#endif
#define fsizeof(T,F,E,n) (offsetof(T, F) + sizeof(E)*n) // type; FAM name; FAM type; amount
#define ftag(x) ((u64)(x) << 48)
#define tag(v, t) b(((u64)(v)) | ftag(t))
// .111111111110000000000000000000000000000000000000000000000000000 infinity
// .111111111111000000000000000000000000000000000000000000000000000 qNaN
// .111111111110nnn................................................ sNaN aka tagged aka not f64, if nnn≠0
// 0111111111110................................................... direct value with no need of refcounting
const u16 C32_TAG = 0b0111111111110001; // 0111111111110001................00000000000ccccccccccccccccccccc char
const u16 TAG_TAG = 0b0111111111110010; // 0111111111110010................nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn special value (0=nothing, 1=undefined var, 2=bad header; 3=optimized out; 4=error?; 5=no fill)
const u16 VAR_TAG = 0b0111111111110011; // 0111111111110011ddddddddddddddddnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn variable reference
const u16 I32_TAG = 0b0111111111110111; // 0111111111110111................nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn 32-bit int; unused
const u16 MD1_TAG = 0b1111111111110010; // 1111111111110010ppppppppppppppppppppppppppppppppppppppppppppp000 1-modifier
const u16 MD2_TAG = 0b1111111111110011; // 1111111111110011ppppppppppppppppppppppppppppppppppppppppppppp000 2-modifier
const u16 FUN_TAG = 0b1111111111110100; // 1111111111110100ppppppppppppppppppppppppppppppppppppppppppppp000 function
const u16 NSP_TAG = 0b1111111111110101; // 1111111111110101ppppppppppppppppppppppppppppppppppppppppppppp000 namespace maybe?
const u16 OBJ_TAG = 0b1111111111110110; // 1111111111110110ppppppppppppppppppppppppppppppppppppppppppppp000 custom object (e.g. bigints)
const u16 ARR_TAG = 0b1111111111110111; // 1111111111110111ppppppppppppppppppppppppppppppppppppppppppppp000 array (everything else is an atom)
const u16 VAL_TAG = 0b1111111111110 ; // 1111111111110................................................... pointer to Value, needs refcounting
enum Type {
/* 0*/ t_empty, // empty bucket placeholder
/* 1*/ t_fun_def, t_fun_block,
/* 3*/ t_md1_def, t_md1_block,
/* 5*/ t_md2_def, t_md2_block,
/* 7*/ t_noGC, // doesn't get visited, shouldn't be unallocated by gc
/* 8*/ t_fork, t_atop,
/*10*/ t_md1D, t_md2D, t_md2H,
/*13*/ t_harr , t_i32arr , t_fillarr , t_c32arr ,
/*17*/ t_hslice, t_i32slice, t_fillslice, t_c32slice,
/*21*/ t_comp, t_block, t_body, t_scope,
Type_MAX
};
char* format_type(u8 u) {
switch(u) { default: return"(unknown type)";
case t_empty:return"empty"; case t_noGC:return"noGC";
case t_fun_def:return"fun_def"; case t_fun_block:return"fun_block";
case t_md1_def:return"md1_def"; case t_md1_block:return"md1_block";
case t_md2_def:return"md2_def"; case t_md2_block:return"md2_block";
case t_fork:return"fork"; case t_atop:return"atop";
case t_md1D:return"md1D"; case t_md2D:return"md2D"; case t_md2H:return"md2H";
case t_harr :return"harr" ; case t_i32arr :return"i32arr" ; case t_fillarr :return"fillarr" ; case t_c32arr :return"c32arr" ;
case t_hslice:return"hslice"; case t_i32slice:return"i32slice"; case t_fillslice:return"fillslice"; case t_c32slice:return"c32slice";
case t_comp:return"comp"; case t_block:return"block"; case t_body:return"body"; case t_scope:return"scope";
}
}
enum PrimFns {
pf_none,
pf_add, pf_sub, pf_mul, pf_div, pf_pow, pf_floor, pf_eq, pf_le, pf_log, // arith.c
pf_shape, pf_pick, pf_ud, pf_pair, pf_fne, pf_feq, pf_lt, pf_rt, pf_fmtF, pf_fmtN, // sfns.c
pf_fork, pf_atop, pf_md1d, pf_md2d, // derv.c
pf_type, pf_decp, pf_primInd, pf_glyph, pf_fill, // sysfn.c
pf_grLen, pf_grOrd, pf_asrt, pf_sys, pf_internal, // sysfn.c
};
char* format_pf(u8 u) {
switch(u) { default: case pf_none: return"(unknown fn)";
case pf_add:return"+"; case pf_sub:return"-"; case pf_mul:return"×"; case pf_div:return"÷"; case pf_pow:return""; case pf_floor:return""; case pf_eq:return"="; case pf_le:return""; case pf_log:return"⋆⁼";
case pf_shape:return""; case pf_pick:return""; case pf_ud:return""; case pf_pair:return"{𝕨‿𝕩}"; case pf_fne:return""; case pf_feq:return""; case pf_lt:return""; case pf_rt:return""; case pf_fmtF:case pf_fmtN:return"";
case pf_fork:return"(fork)"; case pf_atop:return"(atop)"; case pf_md1d:return"(derived 1-modifier)"; case pf_md2d:return"(derived 2-modifier)";
case pf_type:return"•Type"; case pf_decp:return"Decompose"; case pf_primInd:return"•PrimInd"; case pf_glyph:return"•Glyph"; case pf_fill:return"•FillFn";
case pf_grLen:return"•GroupLen"; case pf_grOrd:return"•groupOrd"; case pf_asrt:return"!"; case pf_sys:return"•getsys"; case pf_internal:return"•Internal";
}
}
enum PrimMd1 {
pm1_none,
pm1_tbl, pm1_scan, // md1.c
};
char* format_pm1(u8 u) {
switch(u) {
default: case pf_none: return"(unknown 1-modifier)";
case pm1_tbl: return""; case pm1_scan: return"`";
}
}
typedef union B {
u64 u;
i64 s;
f64 f;
} B;
#define b(x) ((B)(x))
typedef struct Value {
i32 refc; // plain old reference count
u8 mmInfo; // bucket size, mark&sweep bits when that's needed; currently unused
u8 flags; // is sorted/a permutation/whatever in the future, currently primitive index for self-hosted runtime
u8 type; // access into TypeInfo among generally knowing what type of object this is
ur extra; // whatever object-specific stuff. Rank for arrays, id for functions
} Value;
typedef struct Arr {
struct Value;
usz ia;
usz* sh;
} Arr;
// memory manager
typedef void (*V2v)(Value*);
void* mm_allocN(usz sz, u8 type);
void mm_free(Value* x);
void mm_visit(B x);
u64 mm_round(usz x);
u64 mm_size(Value* x);
u64 mm_totalAllocated();
void mm_forHeap(V2v f);
B mm_alloc(usz sz, u8 type, u64 tag) {
assert(tag>1LL<<16 || tag==0); // make sure it's `ftag`ged :|
return b((u64)mm_allocN(sz,type) | tag);
}
// some primitive actions
void dec(B x);
B inc(B x);
void ptr_dec(void* x);
void ptr_inc(void* x);
void print(B x);
void arr_print(B x);
B m_v1(B a );
B m_v2(B a, B b );
B m_v3(B a, B b, B c );
B m_v4(B a, B b, B c, B d);
#define c(T,x) ((T*)((x).u&0xFFFFFFFFFFFFull))
#define v(x) c(Value, x)
#define a(x) c(Arr , x)
#define rnk(x ) (v(x)->extra) // expects argument to be Arr
#define srnk(x,r) (v(x)->extra=(r))
#define VT(x,t) assert(isVal(x) && v(x)->type==t)
void print_vmStack();
#ifdef DEBUG
B validate(B x);
B recvalidate(B x);
#else
#define validate(x) x
#define recvalidate(x) x
#endif
B err(char* s) {
puts(s); fflush(stdout);
print_vmStack();
__builtin_trap();
exit(1);
}
// tag checks
#ifdef ATOM_I32
bool isI32(B x) { return (x.u>>48) == I32_TAG; }
#else
bool isI32(B x) { return false; }
#endif
bool isFun(B x) { return (x.u>>48) == FUN_TAG; }
bool isArr(B x) { return (x.u>>48) == ARR_TAG; }
bool isC32(B x) { return (x.u>>48) == C32_TAG; }
bool isVar(B x) { return (x.u>>48) == VAR_TAG; }
bool isMd1(B x) { return (x.u>>48) == MD1_TAG; }
bool isMd2(B x) { return (x.u>>48) == MD2_TAG; }
bool isMd (B x) { return (x.u>>49) ==(MD2_TAG>>1); }
bool isNsp(B x) { return (x.u>>48) == NSP_TAG; }
bool isObj(B x) { return (x.u>>48) == OBJ_TAG; }
// bool isVal(B x) { return ((x.u>>51) == VAL_TAG) & ((x.u<<13) != 0); }
// bool isF64(B x) { return ((x.u>>51&0xFFF) != 0xFFE) | ((x.u<<1)==(b(1.0/0.0).u<<1)); }
bool isVal(B x) { return (x.u - (((u64)VAL_TAG<<51) + 1)) < ((1ull<<51) - 1); } // ((x.u>>51) == VAL_TAG) & ((x.u<<13) != 0);
bool isF64(B x) { return (x.u<<1) - ((0xFFEull<<52) + 2) >= (1ull<<52) - 2; }
bool isAtm(B x) { return !isVal(x); }
// shape mess
typedef struct ShArr {
struct Value;
usz a[];
} ShArr;
usz* allocSh(ur r) {
assert(r>0);
B x = mm_alloc(fsizeof(ShArr, a, usz, r), t_noGC, ftag(OBJ_TAG));
return ((ShArr*)v(x))->a;
}
ShArr* shObj(B x) { return (ShArr*)((u64)a(x)->sh-offsetof(ShArr,a)); }
void decSh(B x) { if (rnk(x)>1) ptr_dec(shObj(x)); }
void arr_shVec(B x, usz ia) {
a(x)->ia = ia;
srnk(x, 1);
a(x)->sh = &a(x)->ia;
}
usz* arr_shAlloc(B x, usz ia, usz r) {
a(x)->ia = ia;
srnk(x,r);
if (r>1) return a(x)->sh = allocSh(r);
a(x)->sh = &a(x)->ia;
return 0;
}
void arr_shCopy(B n, B o) { // copy shape from o to n
assert(isArr(o));
a(n)->ia = a(o)->ia;
ur r = srnk(n,rnk(o));
if (r<=1) {
a(n)->sh = &a(n)->ia;
} else {
a(n)->sh = a(o)->sh;
ptr_inc(shObj(o));
}
}
bool shEq(B w, B x) { assert(isArr(w)); assert(isArr(x));
ur wr = rnk(w); usz* wsh = a(w)->sh;
ur xr = rnk(x); usz* xsh = a(x)->sh;
if (wr!=xr) return false;
if (wsh==xsh) return true;
return memcmp(wsh,xsh,wr*sizeof(usz))==0;
}
usz arr_csz(B x) {
ur xr = rnk(x);
if (xr<=1) return 1;
usz* sh = a(x)->sh;
usz r = 1;
for (i32 i = 1; i < xr; i++) r*= sh[i];
return r;
}
// make objects
B m_arr(usz min, u8 type) { return mm_alloc(min, type, ftag(ARR_TAG)); }
B m_f64(f64 n) { assert(isF64(b(n))); return b(n); } // assert just to make sure we're actually creating a float
B m_c32(i32 n) { return tag(n, C32_TAG); } // TODO check validity?
#ifdef ATOM_I32
B m_i32(i32 n) { return tag(n, I32_TAG); }
#else
B m_i32(i32 n) { return m_f64(n); }
#endif
B m_error() { return tag(4, TAG_TAG); }
B m_usz(usz n) { return n==(i32)n? m_i32(n) : m_f64(n); }
i32 o2i (B x) { if ((i32)x.f!=x.f) err("o2i"": expected integer"); return (i32)x.f; }
usz o2s (B x) { if ((usz)x.f!=x.f) err("o2s"": expected integer"); return (usz)x.f; }
i64 o2i64(B x) { if ((i64)x.f!=x.f) err("o2i64: expected integer"); return (i64)x.f; }
i32 o2iu (B x) { return isI32(x)? (i32)(u32)x.u : (i32)x.f; }
bool q_i32(B x) { return isI32(x) || isF64(x)&(x.f==(i32)x.f); }
typedef struct Slice {
struct Arr;
B p;
} Slice;
void slice_free(B x) { dec(c(Slice,x)->p); decSh(x); }
void slice_print(B x) { arr_print(x); }
typedef void (*B2v)(B);
typedef B (* BS2B)(B, usz);
typedef B (*BSS2B)(B, usz, usz);
typedef B (* B2B)(B);
typedef B (* BB2B)(B, B);
typedef B (* BBB2B)(B, B, B);
typedef B (* BBBB2B)(B, B, B, B);
typedef B (*BBBBB2B)(B, B, B, B, B);
typedef bool (*B2b)(B);
typedef struct TypeInfo {
B2v free; // expects refc==0
BS2B get; // increments result, doesn't consume arg; TODO figure out if this should never allocate, so GC wouldn't happen
BB2B m1_d; // consume all args; (m, f)
BBB2B m2_d; // consume all args; (m, f, g)
BS2B slice; // consumes; create slice from given starting position; add ia, rank, shape yourself
B2b canStore; // doesn't consume
B2v print; // doesn't consume
B2v visit; // for GC when that comes around
B2B decompose; // consumes; must return a HArr
} TypeInfo;
TypeInfo ti[Type_MAX];
#define TI(x) (ti[v(x)->type])
void do_nothing(B x) { }
void def_print(B x) { printf("(type %d)", v(x)->type); }
B get_self(B x, usz n) { return x; }
B def_m1_d(B m, B f ) { return err("cannot derive this"); }
B def_m2_d(B m, B f, B g) { return err("cannot derive this"); }
B def_slice(B x, usz s) { return err("cannot slice non-array!"); }
B def_decompose(B x) { return m_v2(m_i32((isFun(x)|isMd(x))? 0 : -1),x); }
bool def_canStore(B x) { return false; }
B bi_nothing, bi_noVar, bi_badHdr, bi_optOut, bi_noFill;
void hdr_init() {
for (i32 i = 0; i < Type_MAX; ++i) {
ti[i].visit = ti[i].free = do_nothing;
ti[i].get = get_self;
ti[i].print = def_print;
ti[i].m1_d = def_m1_d;
ti[i].m2_d = def_m2_d;
ti[i].decompose = def_decompose;
ti[i].slice = def_slice;
ti[i].canStore = def_canStore;
}
bi_nothing = tag(0, TAG_TAG);
bi_noVar = tag(1, TAG_TAG);
bi_badHdr = tag(2, TAG_TAG);
bi_optOut = tag(3, TAG_TAG);
bi_noFill = tag(5, TAG_TAG);
assert((MD1_TAG>>1) == (MD2_TAG>>1)); // just to be sure it isn't changed incorrectly, `isMd` depends on this
}
bool isNothing(B b) { return b.u==bi_nothing.u; }
// refcount
static inline void value_free(B x, Value* vx) {
ti[vx->type].free(x);
mm_free(vx);
}
static NOINLINE void value_freeR1(Value* x) { value_free(tag(x, OBJ_TAG), x); }
static NOINLINE void value_freeR2(Value* vx, B x) { value_free(x, vx); }
void dec(B x) {
if (!isVal(VALIDATE(x))) return;
Value* vx = v(x);
if(!--vx->refc) value_free(x, vx);
}
B inc(B x) {
if (isVal(VALIDATE(x))) v(x)->refc++;
return x;
}
void ptr_dec(void* x) { if(!--((Value*)x)->refc) value_free(tag(x, OBJ_TAG), x); }
void ptr_inc(void* x) { ((Value*)x)->refc++; }
void ptr_decR(void* x) { if(!--((Value*)x)->refc) value_freeR1(x); }
void decR(B x) {
if (!isVal(x)) return; Value* vx = v(x);
if(!--vx->refc) value_freeR2(vx, x);
}
bool reusable(B x) { return v(x)->refc==1; }
void printUTF8(u32 c);
void print(B x) {
if (isF64(x)) {
printf("%g", x.f);
} else if (isC32(x)) {
if ((u32)x.u>=32) { printf("'"); printUTF8((u32)x.u); printf("'"); }
else printf("\\x%x", (u32)x.u);
} else if (isI32(x)) {
printf("%d", (i32)x.u);
} else if (isVal(x)) {
#ifdef DEBUG
if (isVal(x) && v(x)->refc<0) {printf("(FREED)"); exit(1);} else
#endif
TI(x).print(x);
}
else if (isVar(x)) printf("(var d=%d i=%d)", (u16)(x.u>>32), (i32)x.u);
else if (x.u==bi_nothing.u) printf("·");
else if (x.u==bi_optOut.u) printf("(value optimized out)");
else if (x.u==bi_noVar.u) printf("(unset variable placeholder)");
else if (x.u==bi_badHdr.u) printf("(bad header note)");
else printf("(todo tag %lx)", x.u>>48);
}
void printRaw(B x) {
if (isAtm(x)) {
if (isF64(x)) printf("%g", x.f);
else if (isC32(x)) printUTF8((u32)x.u);
else err("bad printRaw argument: atom arguments should be either numerical or characters");
} else {
usz ia = a(x)->ia;
BS2B xget = TI(x).get;
for (usz i = 0; i < ia; i++) {
B c = xget(x,i);
if (c.u==0) { printf(" "); continue; }
if (!isC32(c)) err("bad printRaw argument: expected all character items");
printUTF8((u32)c.u);
}
}
}
B eq_c2(B t, B w, B x);
bool equal(B w, B x) { // doesn't consume
bool wa = isArr(w);
bool xa = isArr(x);
if (wa!=xa) return false;
if (!wa) return o2iu(eq_c2(bi_nothing, inc(w), inc(x)))?1:0;
if (!shEq(w,x)) return false;
usz ia = a(x)->ia;
BS2B xget = TI(x).get;
BS2B wget = TI(w).get;
for (usz i = 0; i < ia; i++) {
B wc=wget(w,i); B xc=xget(x,i); // getdec
bool eq=equal(wc,xc);
decR(wc); decR(xc);
if(!eq) return false;
}
return true;
}
typedef struct Fun {
struct Value;
BB2B c1;
BBB2B c2;
} Fun;
B c1_invalid(B f, B x) { return err("This function can't be called monadically"); }
B c2_invalid(B f, B w, B x) { return err("This function can't be called dyadically"); }
NOINLINE B c1_rare(B f, B x) { dec(x);
if (isMd(f)) return err("Calling a modifier");
return inc(VALIDATE(f));
}
NOINLINE B c2_rare(B f, B w, B x) { dec(w); dec(x);
if (isMd(f)) return err("Calling a modifier");
return inc(VALIDATE(f));
}
B c1(B f, B x) { // BQN-call f monadically; consumes x
if (isFun(f)) return VALIDATE(c(Fun,f)->c1(f, x));
return c1_rare(f, x);
}
B c2(B f, B w, B x) { // BQN-call f dyadically; consumes w,x
if (isFun(f)) return VALIDATE(c(Fun,f)->c2(f, w, x));
return c2_rare(f, w, x);
}
typedef struct Md1 {
struct Value;
BB2B c1; // f(md1d{this,f}, x); consumes x
BBB2B c2; // f(md1d{this,f},w,x); consumes w,x
} Md1;
typedef struct Md2 {
struct Value;
BB2B c1; // f(md2d{this,f,g}, x); consumes x
BBB2B c2; // f(md2d{this,f,g},w,x); consumes w,x
} Md2;
B m_md1D(B m, B f );
B m_md2D(B m, B f, B g);
B m_md2H(B m, B g);
B m_fork(B f, B g, B h);
B m_atop( B g, B h);
void arr_print(B x) {
usz r = rnk(x);
BS2B xget = TI(x).get;
usz ia = a(x)->ia;
if (r!=1) {
if (r==0) {
printf("<");
print(xget(x,0));
return;
}
usz* sh = a(x)->sh;
for (i32 i = 0; i < r; i++) {
if(i==0)printf("%d",sh[i]);
else printf("‿%d",sh[i]);
}
printf("");
} else if (ia>0) {
for (usz i = 0; i < ia; i++) {
B c = xget(x,i);
bool is = isC32(c);
dec(c);
if (!is) goto reg;
}
printf("\"");
for (usz i = 0; i < ia; i++) printUTF8((u32)xget(x,i).u); // c32, no need to decrement
printf("\"");
return;
}
reg:;
printf("");
for (usz i = 0; i < ia; i++) {
if (i!=0) printf(", ");
B c = xget(x,i);
print(c);
dec(c);
}
printf("");
}
#ifdef DEBUG
B validate(B x) {
if (!isVal(x)) return x;
if (v(x)->refc<=0 || (v(x)->refc>>28) == 'a') {
printf("bad refcount for type %d: %d; val=%p\nattempting to print: ", v(x)->type, v(x)->refc, (void*)x.u); fflush(stdout);
print(x); puts(""); fflush(stdout);
err("");
}
if (isArr(x)) {
ur r = rnk(x);
if (r<=1) assert(a(x)->sh == &a(x)->ia);
else validate(tag(shObj(x),OBJ_TAG));
}
return x;
}
B recvalidate(B x) {
validate(x);
if (isArr(x)) {
BS2B xget = TI(x).get;
usz ia = a(x)->ia;
for (usz i = 0; i < ia; i++) {
B c = xget(x,i);
assert(c.u!=x.u);
recvalidate(c);
dec(c);
}
}
return x;
}
#endif
#ifdef ALLOC_STAT
u64* ctr_a = 0;
u64* ctr_f = 0;
u64 actrc = 21000;
u64 talloc = 0;
#ifdef ALLOC_SIZES
u32** actrs;
#endif
#endif
static void onAlloc(usz sz, u8 type) {
#ifdef ALLOC_STAT
if (!ctr_a) {
#ifdef ALLOC_SIZES
actrs = malloc(sizeof(u32*)*actrc);
for (i32 i = 0; i < actrc; i++) actrs[i] = calloc(Type_MAX, sizeof(u32));
#endif
ctr_a = calloc(Type_MAX, sizeof(u64));
ctr_f = calloc(Type_MAX, sizeof(u64));
}
assert(type<Type_MAX);
#ifdef ALLOC_SIZES
actrs[(sz+3)/4>=actrc? actrc-1 : (sz+3)/4][type]++;
#endif
ctr_a[type]++;
talloc+= sz;
#endif
}
static void onFree(Value* x) {
#ifdef ALLOC_STAT
ctr_f[x->type]++;
#endif
#ifdef DEBUG
x->refc = 0x61616161;
#endif
}