uCBQN/src/builtins/internal.c
2022-08-20 08:30:12 +03:00

317 lines
10 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.

#include "../core.h"
#include "../utils/mut.h"
#include "../utils/file.h"
#include "../builtins.h"
#include "../ns.h"
B itype_c1(B t, B x) {
B r;
if(isVal(x)) {
r = m_c8vec_0(type_repr(TY(x)));
} else {
if (isF64(x)) r = m_c8vec_0("tagged f64");
else if (isC32(x)) r = m_c8vec_0("tagged c32");
else if (isTag(x)) r = m_c8vec_0("tagged tag");
else if (isVar(x)) r = m_c8vec_0("tagged var");
else if (isExt(x)) r = m_c8vec_0("tagged extvar");
else r = m_c8vec_0("tagged unknown");
}
dec(x);
return r;
}
B elType_c1(B t, B x) {
B r = m_i32(isArr(x)? TI(x,elType) : selfElType(x));
dec(x);
return r;
}
B refc_c1(B t, B x) {
B r = isVal(x)? m_i32(v(x)->refc) : m_c8vec_0("(not heap-allocated)");
dec(x);
return r;
}
B squeeze_c1(B t, B x) {
if (!isArr(x)) return x;
return any_squeeze(x);
}
B deepSqueeze_c1(B t, B x) {
return squeeze_deep(x);
}
B isPure_c1(B t, B x) {
B r = m_f64(isPureFn(x));
dec(x);
return r;
}
B info_c2(B t, B w, B x) {
B s = emptyCVec();
i32 m = o2i(w);
if (isVal(x)) {
if (m) AFMT("%xl: ", x.u);
else AFMT("%xl: ", x.u>>48);
Value* xv = v(x);
AFMT("refc:%i ", xv->refc);
if (m) {
AFMT("mmInfo:%i ", xv->mmInfo);
AFMT("flags:%i ", xv->flags);
AFMT("extra:%i ", xv->extra);
}
AFMT("type:%i=%S ", PTY(xv), type_repr(PTY(xv)));
AFMT("alloc:%l", mm_size(xv));
decG(x);
} else {
AFMT("%xl: ", x.u);
A8("not heap-allocated");
}
return s;
}
B info_c1(B t, B x) {
return info_c2(t, m_i32(0), x);
}
#define FOR_VARIATION(F) F(Ai8 ) F(Si8 ) F(Ai8Inc ) F(Si8Inc ) \
F(Ai16) F(Si16) F(Ai16Inc) F(Si16Inc) \
F(Ai32) F(Si32) F(Ai32Inc) F(Si32Inc) \
F(Ac8 ) F(Sc8 ) F(Ac8Inc ) F(Sc8Inc ) \
F(Ac16) F(Sc16) F(Ac16Inc) F(Sc16Inc) \
F(Ac32) F(Sc32) F(Ac32Inc) F(Sc32Inc) \
F(Af64) F(Sf64) F(Af64Inc) F(Sf64Inc) \
F(Ah) F(Sh) F(AhInc) F(ShInc) \
F(Af) F(Sf) F(AfInc) F(SfInc) \
F(Ab) F(AbInc)
#define F(X) static B v_##X;
FOR_VARIATION(F)
#undef F
static B listVariations_def;
B listVariations_c2(B t, B w, B x) {
if (!isArr(x)) thrM("•internal.ListVariations: 𝕩 must be an array");
if (!isArr(w) || rnk(w)!=1) thrM("•internal.ListVariations: 𝕨 must be a list");
usz wia = IA(w);
SGetU(w)
bool c_incr=false, c_rmFill=false;
for (usz i = 0; i < wia; i++) {
u32 c = o2c(GetU(w, i));
if (c=='i') c_incr=true;
else if (c=='f') c_rmFill=true;
else thrF("internal.ListVariations: Unknown option '%c' in 𝕨", c);
}
decG(w);
u8 xe = TI(x,elType);
B xf = getFillQ(x);
bool ah = c_rmFill || noFill(xf);
bool ai8=false, ai16=false, ai32=false, af64=false,
ac8=false, ac16=false, ac32=false, abit=false;
usz xia = IA(x);
SGetU(x)
if (isNum(xf)) {
i32 min=I32_MAX, max=I32_MIN;
if (xe==el_i8 ) { i8* xp = i8any_ptr (x); for (usz i = 0; i < xia; i++) { if (xp[i]>max) max=xp[i]; if (xp[i]<min) min=xp[i]; } }
else if (xe==el_i16) { i16* xp = i16any_ptr(x); for (usz i = 0; i < xia; i++) { if (xp[i]>max) max=xp[i]; if (xp[i]<min) min=xp[i]; } }
else if (xe==el_i32) { i32* xp = i32any_ptr(x); for (usz i = 0; i < xia; i++) { if (xp[i]>max) max=xp[i]; if (xp[i]<min) min=xp[i]; } }
else if (xe==el_f64) { f64* xp = f64any_ptr(x); for (usz i = 0; i < xia; i++) { if (xp[i]>max) max=xp[i]; if (xp[i]<min) min=xp[i]; if(xp[i]!=(i32)xp[i]) goto onlyF64; } }
else for (usz i = 0; i < xia; i++) { B c = GetU(x, i); if (!isF64(c)) goto noSpec; if (c.f>max) max=c.f; if (c.f<min) min=c.f; }
ai8 = min==(i8 )min && max==(i8 )max;
ai16 = min==(i16)min && max==(i16)max;
ai32 = min==(i32)min && max==(i32)max;
abit = min>=0 && max<=1;
onlyF64:
af64 = true;
} else if (isC32(xf)) {
u32 max = 0;
if (xe!=el_c8) for (usz i = 0; i < xia; i++) {
B c = GetU(x, i);
if (!isC32(c)) goto noSpec;
if (o2cu(c)>max) max = o2cu(c);
}
ac8 = max == (u8 )max;
ac16 = max == (u16)max;
ac32 = true;
}
noSpec:;
B r = emptyHVec();
if(abit) { r=vec_addN(r,incG(v_Ab )); if(c_incr) { r=vec_addN(r,incG(v_AbInc )); } }
if(ai8 ) { r=vec_addN(r,incG(v_Ai8 ));r=vec_addN(r,incG(v_Si8 )); if(c_incr) { r=vec_addN(r,incG(v_Ai8Inc ));r=vec_addN(r,incG(v_Si8Inc )); } }
if(ai16) { r=vec_addN(r,incG(v_Ai16));r=vec_addN(r,incG(v_Si16)); if(c_incr) { r=vec_addN(r,incG(v_Ai16Inc));r=vec_addN(r,incG(v_Si16Inc)); } }
if(ai32) { r=vec_addN(r,incG(v_Ai32));r=vec_addN(r,incG(v_Si32)); if(c_incr) { r=vec_addN(r,incG(v_Ai32Inc));r=vec_addN(r,incG(v_Si32Inc)); } }
if(ac8 ) { r=vec_addN(r,incG(v_Ac8 ));r=vec_addN(r,incG(v_Sc8 )); if(c_incr) { r=vec_addN(r,incG(v_Ac8Inc ));r=vec_addN(r,incG(v_Sc8Inc )); } }
if(ac16) { r=vec_addN(r,incG(v_Ac16));r=vec_addN(r,incG(v_Sc16)); if(c_incr) { r=vec_addN(r,incG(v_Ac16Inc));r=vec_addN(r,incG(v_Sc16Inc)); } }
if(ac32) { r=vec_addN(r,incG(v_Ac32));r=vec_addN(r,incG(v_Sc32)); if(c_incr) { r=vec_addN(r,incG(v_Ac32Inc));r=vec_addN(r,incG(v_Sc32Inc)); } }
if(af64) { r=vec_addN(r,incG(v_Af64));r=vec_addN(r,incG(v_Sf64)); if(c_incr) { r=vec_addN(r,incG(v_Af64Inc));r=vec_addN(r,incG(v_Sf64Inc)); } }
if(ah) { r=vec_addN(r,incG(v_Ah ));r=vec_addN(r,incG(v_Sh )); if(c_incr) { r=vec_addN(r,incG(v_AhInc ));r=vec_addN(r,incG(v_ShInc )); } }
{ r=vec_addN(r,incG(v_Af ));r=vec_addN(r,incG(v_Sf )); if(c_incr) { r=vec_addN(r,incG(v_AfInc ));r=vec_addN(r,incG(v_SfInc )); } }
decG(x);
dec(xf);
return r;
}
B listVariations_c1(B t, B x) {
return listVariations_c2(t, incG(listVariations_def), x);
}
static bool u8_get(u8** cv, u8* cE, const char* x) {
u8* c = *cv;
while (true) {
if (!*x) {
*cv = c;
return true;
}
if (c==cE || *c!=*x) return false;
c++; x++;
}
}
static B variation_refs;
static void variation_gcRoot() {
mm_visit(variation_refs);
mm_visit(listVariations_def);
#define F(X) mm_visit(v_##X);
FOR_VARIATION(F)
#undef F
}
B variation_c2(B t, B w, B x) {
if (!isArr(w)) thrM("•internal.Variation: Non-array 𝕨");
if (!isArr(x)) thrM("•internal.Variation: Non-array 𝕩");
usz xia = IA(x);
C8Arr* wc = toC8Arr(w);
u8* wp = c8arrv_ptr(wc);
u8* wpE = wp+PIA(wc);
if (PIA(wc)==0) thrM("•internal.Variation: Zero-length 𝕨");
B res;
if (*wp == 'A' || *wp == 'S') {
bool slice = *wp == 'S';
wp++;
if (u8_get(&wp, wpE, "b" )) res = taga(cpyBitArr(incG(x)));
else if (u8_get(&wp, wpE, "i8" )) res = taga(cpyI8Arr (incG(x)));
else if (u8_get(&wp, wpE, "i16")) res = taga(cpyI16Arr(incG(x)));
else if (u8_get(&wp, wpE, "i32")) res = taga(cpyI32Arr(incG(x)));
else if (u8_get(&wp, wpE, "c8" )) res = taga(cpyC8Arr (incG(x)));
else if (u8_get(&wp, wpE, "c16")) res = taga(cpyC16Arr(incG(x)));
else if (u8_get(&wp, wpE, "c32")) res = taga(cpyC32Arr(incG(x)));
else if (u8_get(&wp, wpE, "f64")) res = taga(cpyF64Arr(incG(x)));
else if (u8_get(&wp, wpE, "h" )) res = taga(cpyHArr (incG(x)));
else if (u8_get(&wp, wpE, "f")) {
Arr* t = m_fillarrp(xia);
fillarr_setFill(t, getFillQ(x));
arr_shCopy(t, x);
HArr* h = NULL;
B* xp = arr_bptr(x);
if (xp==NULL) {
h = cpyHArr(incG(x));
xp = h->a;
}
B* rp = fillarr_ptr(t);
for (usz i = 0; i < xia; i++) rp[i] = inc(xp[i]);
if (h) ptr_dec(h);
res = taga(t);
} else thrF("•internal.Variation: Bad type \"%R\"", taga(wc));
if (slice) {
Arr* slice = TI(res,slice)(inc(res), 0, IA(res));
arr_shCopy(slice, res);
dec(res);
res = taga(slice);
}
if (u8_get(&wp, wpE, "Inc")) {
if (!variation_refs.u) {
variation_refs = emptyHVec();
}
variation_refs = vec_addN(variation_refs, incG(res));
}
if (wp!=wpE) thrM("•internal.Variation: Bad 𝕨");
} else thrM("•internal.Variation: Bad start of 𝕨");
decG(x);
ptr_dec(wc);
return res;
}
B clearRefs_c1(B t, B x) {
dec(x);
if (!isArr(variation_refs)) return m_f64(0);
usz res = IA(variation_refs);
dec(variation_refs);
variation_refs = m_f64(0);
return m_f64(res);
}
static B unshare(B x) {
if (!isArr(x)) return x;
usz xia = IA(x);
switch (TY(x)) {
case t_bitarr: return taga(cpyBitArr(inc(x)));
case t_i8arr: return taga(cpyI8Arr (inc(x)));
case t_i16arr: return taga(cpyI16Arr(inc(x)));
case t_i32arr: return taga(cpyI32Arr(inc(x)));
case t_c8arr: return taga(cpyC8Arr (inc(x)));
case t_c16arr: return taga(cpyC16Arr(inc(x)));
case t_c32arr: return taga(cpyC32Arr(inc(x)));
case t_f64arr: return taga(cpyF64Arr(inc(x)));
case t_harr: {
B* xp = harr_ptr(x);
M_HARR(r, xia)
for (usz i = 0; i < xia; i++) HARR_ADD(r, i, unshare(xp[i]));
return HARR_FC(r, x);
}
case t_fillarr: {
Arr* r = m_fillarrp(xia); arr_shCopy(r, x);
fillarr_setFill(r, unshare(c(FillArr,x)->fill));
B* rp = fillarr_ptr(r); B* xp = fillarr_ptr(a(x));
for (usz i = 0; i < xia; i++) rp[i] = unshare(xp[i]);
return taga(r);
}
default: thrF("•internal.Unshare: Cannot unshare array with type %i=%S", TY(x), type_repr(TY(x)));
}
}
B eequal_c2(B t, B w, B x) {
bool r = eequal(w, x);
dec(w); dec(x);
return m_i32(r);
}
B internalTemp_c1(B t, B x) {
#ifdef TEST_BITCPY
SGetU(x)
bit_cpy(bitarr_ptr(GetU(x,0)), o2s(GetU(x,1)), bitarr_ptr(GetU(x,2)), o2s(GetU(x,3)), o2s(GetU(x,4)));
#endif
return x;
}
B internalTemp_c2(B t, B w, B x) { dec(w); return x; }
B heapDump_c1(B t, B x) {
cbqn_heapDump();
return m_c32(0);
}
B unshare_c1(B t, B x) {
if (!isArr(x)) thrM("•internal.Unshare: Argument must be an array");
B r = unshare(x);
dec(x);
return r;
}
static B internalNS;
B getInternalNS() {
if (internalNS.u == 0) {
#define F(X) v_##X = m_c8vec_0(#X);
FOR_VARIATION(F)
#undef F
listVariations_def = m_c8vec_0("if");
gc_addFn(variation_gcRoot);
#define F(X) incG(bi_##X),
Body* d = m_nnsDesc("type","eltype","refc","squeeze","ispure","info","listvariations","variation","clearrefs","unshare","deepsqueeze","heapdump","eequal","temp");
internalNS = m_nns(d,F(itype)F(elType)F(refc)F(squeeze)F(isPure)F(info)F(listVariations)F(variation)F(clearRefs)F(unshare)F(deepSqueeze)F(heapDump)F(eequal)F(internalTemp));
#undef F
gc_add(internalNS);
}
return incG(internalNS);
}