From 0a69c1e457b01f052241d6fd5836301392aced16 Mon Sep 17 00:00:00 2001 From: dzaima Date: Thu, 13 May 2021 21:20:10 +0300 Subject: [PATCH] =?UTF-8?q?native=20monadic=20=E2=86=95?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/fillarr.c | 7 +++++ src/fns.c | 64 ++++++++++++++++++++++++++++++++++++++---- src/h.h | 17 +++++++++-- src/load.c | 3 +- src/main.c | 8 ------ src/mm_buddyTemplate.c | 2 +- 6 files changed, 82 insertions(+), 19 deletions(-) diff --git a/src/fillarr.c b/src/fillarr.c index 2a1791ef..5720fefd 100644 --- a/src/fillarr.c +++ b/src/fillarr.c @@ -51,6 +51,13 @@ B getFillE(B x) { // errors if there's no fill } bool noFill(B x) { return x.u == bi_noFill.u; } +B m_fillarrp(usz ia) { + return m_arr(fsizeof(FillArr,a,B,ia), t_fillarr); +} +void fillarr_setFill(B x, B fill) { // consumes fill + c(FillArr, x)->fill = fill; +} + typedef struct FillSlice { struct Slice; B* a; diff --git a/src/fns.c b/src/fns.c index 1ef36738..697da1d6 100644 --- a/src/fns.c +++ b/src/fns.c @@ -9,19 +9,71 @@ void print_funBI(B x) { printf("%s", format_pf(c(Fun,x)->extra)); } B funBI_identity(B x) { return inc(c(BFn,x)->ident); } - +void ud_rec(B** p, usz d, usz r, usz* pos, usz* sh) { + if (d==r) { + i32* rp; + *(*p)++ = m_i32arrv(&rp, r); + memcpy(rp, pos, 4*r); + } else { + usz c = sh[d]; + for (usz i = 0; i < c; i++) { + pos[d] = i; + ud_rec(p, d+1, r, pos, sh); + } + } +} B ud_c1(B t, B x) { - usz xu = o2s(x); - if (xu=I32_MAX)) { + f64* rp; B r = m_f64arrv(&rp, xu); + for (usz i = 0; i < xu; i++) rp[i] = i; + return r; + } + if (xu==0) { B r = bi_emptyIVec; ptr_inc(v(r)); return r; } i32* rp; B r = m_i32arrv(&rp, xu); for (usz i = 0; i < xu; i++) rp[i] = i; return r; } - f64* rp; B r = m_f64arrv(&rp, xu); - for (usz i = 0; i < xu; i++) rp[i] = i; + BS2B xgetU = TI(x).getU; + usz xia = a(x)->ia; + if (rnk(x)!=1) thrM("↕: Argument must be a vector"); + if (xia>UR_MAX) thrM("↕: Result rank too large"); + usz sh[xia]; + usz ria = 1; + for (usz i = 0; i < xia; i++) { + usz c = o2s(xgetU(x, i)); + if (c > I32_MAX) thrM("↕: Result too large"); + sh[i] = c; + if (c*(u64)ria >= U32_MAX) thrM("↕: Result too large"); + ria*= c; + } + dec(x); + B r = m_fillarrp(ria); + + fillarr_setFill(r, m_f64(0)); + B* rp = fillarr_ptr(r); + for (usz i = 0; i < ria; i++) rp[i] = m_f64(0); // don't break if allocation errors + usz* rsh = arr_shAllocI(r, ria, xia); + if (rsh) memcpy(rsh, sh, sizeof(usz)*xia); + + usz pos[xia]; B* crp = rp; + ud_rec(&crp, 0, xia, pos, sh); + + if (ria) fillarr_setFill(r, inc(rp[0])); + else { + i32* fp; + fillarr_setFill(r, m_i32arrv(&fp, xia)); + for (usz i = 0; i < xia; i++) fp[i] = 0; + } return r; } +B rt_ud; +B ud_c2(B t, B w, B x) { + return c2(rt_ud, w, x); +} + B pair_c1(B t, B x) { return m_v1( x); } B pair_c2(B t, B w, B x) { return m_v2(w, x); } B ltack_c1(B t, B x) { return x; } @@ -118,7 +170,7 @@ B fne_c2(B t, B w, B x) { #define BI_FNS1(F) F(BI_A,BI_M,BI_D) -#define F(A,M,D) M(ud) A(fne) A(feq) A(ltack) A(rtack) M(fmtF) M(fmtN) +#define F(A,M,D) A(ud) A(fne) A(feq) A(ltack) A(rtack) M(fmtF) M(fmtN) BI_FNS0(F); static inline void fns_init() { BI_FNS1(F) ti[t_funBI].print = print_funBI; diff --git a/src/h.h b/src/h.h index 7608bc1c..f01e1d44 100644 --- a/src/h.h +++ b/src/h.h @@ -8,8 +8,17 @@ #include #include -#define i8 int8_t -#define u8 uint8_t +#define rtLen 63 +#ifdef CATCH_ERRORS + #define PROPER_FILLS (EACH_FILLS&SFNS_FILLS) +#else + #undef EACH_FILLS + #define EACH_FILLS false + #define PROPER_FILLS false +#endif + +#define i8 int8_t +#define u8 uint8_t #define i16 int16_t #define u16 uint16_t #define i32 int32_t @@ -20,11 +29,13 @@ #define I32_MAX ((i32)((1LL<<31)-1)) #define I32_MIN ((i32)(-(1LL<<31))) #define CHR_MAX 1114111 -#define U16_MAX ((u16)-1) +#define U16_MAX ((u16)~(u16)0) +#define U32_MAX ((u32)~(u32)0) #define UD __builtin_unreachable(); #define NOINLINE __attribute__ ((noinline)) #define NORETURN __attribute__ ((noreturn)) #define AUTO __auto_type +#define RARE(X) __builtin_expect(X,0) typedef u32 usz; typedef u8 ur; diff --git a/src/load.c b/src/load.c index fdeab248..5c64a23a 100644 --- a/src/load.c +++ b/src/load.c @@ -52,7 +52,7 @@ static inline void load_init() { bool rtComplete[] = { /* +-×÷⋆√⌊⌈|¬ */ 1,1,1,1,1,0,1,1,1,1, /* ∧∨<>≠=≤≥≡≢ */ 1,1,1,1,1,1,1,1,1,1, - /* ⊣⊢⥊∾≍↑↓↕«» */ 1,1,0,1,1,0,0,0,1,1, + /* ⊣⊢⥊∾≍↑↓↕«» */ 1,1,0,1,1,0,0,1,1,1, /* ⌽⍉/⍋⍒⊏⊑⊐⊒∊ */ 0,0,1,1,0,1,0,0,0,0, /* ⍷⊔!˙˜˘¨⌜⁼´ */ 0,0,1,1,1,0,1,1,0,1, /* ˝`∘○⊸⟜⌾⊘◶⎉ */ 0,1,1,1,1,1,0,1,0,0, @@ -99,6 +99,7 @@ static inline void load_init() { rt_slash = rtObjGet(rtObjRaw, 32); gc_add(rt_slash); rt_join = rtObjGet(rtObjRaw, 23); gc_add(rt_join); rt_gradeUp = rtObjGet(rtObjRaw, 33); gc_add(rt_gradeUp); + rt_ud = rtObjGet(rtObjRaw, 27); gc_add(rt_ud); for (usz i = 0; i < runtimeLen; i++) { #ifdef ALL_R1 diff --git a/src/main.c b/src/main.c index d9abc965..2154cc02 100644 --- a/src/main.c +++ b/src/main.c @@ -25,15 +25,7 @@ // #define RT_PERF // time runtime primitives // #define NO_COMP // don't load the compiler, instead execute src/interp; needed for ./precompiled.bqn -#ifdef CATCH_ERRORS - #define PROPER_FILLS (EACH_FILLS&SFNS_FILLS) -#else - #undef EACH_FILLS - #define EACH_FILLS false - #define PROPER_FILLS false -#endif -#define rtLen 63 #include "h.h" #include "stuff.c" #include "heap.c" diff --git a/src/mm_buddyTemplate.c b/src/mm_buddyTemplate.c index 8065a129..341b8eaf 100644 --- a/src/mm_buddyTemplate.c +++ b/src/mm_buddyTemplate.c @@ -74,7 +74,7 @@ void BN(free)(Value* x) { void* BN(allocL)(u8 bucket, u8 type) { EmptyValue* x = buckets[bucket]; - if (x==NULL) x = BN(makeEmpty)(bucket); + if (RARE(x==NULL)) x = BN(makeEmpty)(bucket); else buckets[bucket] = x->next; #ifdef USE_VALGRIND VALGRIND_MAKE_MEM_UNDEFINED(x, BSZ(bucket));