From bad822447f703a584fe7338d609ebfcd29e7a349 Mon Sep 17 00:00:00 2001 From: dzaima Date: Tue, 30 Mar 2021 00:57:07 +0300 Subject: [PATCH] 1 --- .gitignore | 6 + asmBuild | 2 + build | 2 + cc.bqn | 42 +++++ debugBuild | 2 + genRuntime | 3 + src/arith.c | 72 ++++++++ src/derv.c | 78 +++++++++ src/h.h | 441 ++++++++++++++++++++++++++++++++++++++++++++++++ src/harr.c | 96 +++++++++++ src/i32arr.c | 61 +++++++ src/main.c | 166 ++++++++++++++++++ src/md1.c | 103 ++++++++++++ src/md2.c | 20 +++ src/mm.c | 50 ++++++ src/sfns.c | 116 +++++++++++++ src/sysfn.c | 120 +++++++++++++ src/utf.c | 27 +++ src/vm.c | 467 +++++++++++++++++++++++++++++++++++++++++++++++++++ test.bqn | 29 ++++ 20 files changed, 1903 insertions(+) create mode 100644 .gitignore create mode 100755 asmBuild create mode 100755 build create mode 100755 cc.bqn create mode 100755 debugBuild create mode 100755 genRuntime create mode 100644 src/arith.c create mode 100644 src/derv.c create mode 100644 src/h.h create mode 100644 src/harr.c create mode 100644 src/i32arr.c create mode 100644 src/main.c create mode 100644 src/md1.c create mode 100644 src/md2.c create mode 100644 src/mm.c create mode 100644 src/sfns.c create mode 100644 src/sysfn.c create mode 100644 src/utf.c create mode 100644 src/vm.c create mode 100755 test.bqn diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..cb3edc18 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +main.s +BQN +src/runtime +src/compiler +src/interp +c.bqn \ No newline at end of file diff --git a/asmBuild b/asmBuild new file mode 100755 index 00000000..79a14fe9 --- /dev/null +++ b/asmBuild @@ -0,0 +1,2 @@ +#!/usr/bin/env bash +clang -std=c11 -Wall -Wno-microsoft-anon-tag -fms-extensions -O3 -masm=intel -S src/main.c diff --git a/build b/build new file mode 100755 index 00000000..7db09716 --- /dev/null +++ b/build @@ -0,0 +1,2 @@ +#!/usr/bin/env bash +clang -std=c11 -O3 -Wall -Wno-microsoft-anon-tag -fms-extensions -o BQN -lm src/main.c diff --git a/cc.bqn b/cc.bqn new file mode 100755 index 00000000..03ec9938 --- /dev/null +++ b/cc.bqn @@ -0,0 +1,42 @@ +#! /usr/bin/env dbqn +args←•args +return ← 1≡⊑args +args↓˜↩ return +"call with argument specifying path of mlochbaum/BQN!"!2≤≠args +path←(⊑args)∾"/src/" +args↓˜↩1 +L ← {"m_vaB("∾(⍕≠𝕩)∾(∾","⊸∾¨𝕩)∾")"} +LI ← {"m_cai32("∾(⍕≠𝕩)∾",(i32[]){"∾(1↓∾","⊸∾¨𝕩)∾"})"} +# Escape the special characters that appear in BQN sources. +Esc←{ + in ← (@+0‿9‿10‿13)∾"'""" # Null, Tab, LF, CR, and quotes + out ← "0tnr" # Whitespace characters changed to letters + i ← in⊐𝕩 + 𝕩 ↩ i ⊏⟜out⌾((i<≠out)⊸/) 𝕩 # Replace + ∾(i<≠in) /⟜"\"⊸∾¨ 𝕩 # Insert \ +} +Str ← "m_str32(U"""∾Esc∾""")"˜ # A BQN string +Char ← {"m_c32(U'"∾(Esc⥊𝕩)∾"')"} # A BQN character +Num ← {s←"-"/˜𝕩<0 ⋄ ∞⊸=∘|◶⟨"m_f64("∾")"∾˜s∾⍕∘| ⋄ "m_f64("∾s∾"1.0/0.0)"⟩𝕩} # Format number + +F ← ⍕ # Format number + +Import ← •Import path⊸∾ +FChars ← •FChars path⊸∾ + +compile ← Import "c.bqn" +useInd ← "-i"≡⊑args ⋄ args↓˜↩useInd +Comp ← (3+useInd) ↑ ((<"inci(runtime["∾⍕∾"])"˙)¨↕62)⊸Compile +J ← ∾∾⟜\n¨ +Fconst ← ≡◶⟨@⊸≤◶Num‿Char, Str, ⊑⟩ +prov ← {"inci("∾𝕩∾")"}¨"bi_type"‿"bi_fill"‿"bi_log"‿"bi_grLen"‿"bi_grOrd"‿"bi_asrt"‿"bi_add"‿"bi_sub"‿"bi_mul"‿"bi_div"‿"bi_pow"‿"bi_floor"‿"bi_eq"‿"bi_le"‿"bi_fne"‿"bi_shape"‿"bi_pick"‿"bi_ud"‿"bi_tbl"‿"bi_scan"‿"bi_fillBy"‿"bi_val" +Fout ← {((≠𝕩)↑⟨LI F¨,L ·prov⊸∾⍟(𝕨⊣0) Fconst¨,L (LI F¨)¨,L (L F¨)¨⟩) {𝕎𝕩}¨ 𝕩} +Frun ← 1⊸Fout +Long ← {¯2↓∾𝕩∾¨<","∾\n} +•Out⍟(¬return) (⊑"r"‿"c"‿"f"‿"e"⊐⊏)◶⟨ + {𝕩⋄ref‿len←Import "pr.bqn"⋄Long Frun len⊸↓⌾(1⊸⊑)Comp ref} + {𝕩⋄Long Fout Comp FChars "c.bqn"} + {𝕩⋄Long Fout Comp FChars "f.bqn"} + {𝕩⋄Long Fout Comp ⟨"Modify←GetHighlights←⊢⋄"⟩∾∾ (FChars ⊢)∘∾⟜".bqn"¨ "../svg"‿"e"} + ¯1 ↓ · J L∘Fout∘Comp¨ +⟩ args diff --git a/debugBuild b/debugBuild new file mode 100755 index 00000000..d628a21e --- /dev/null +++ b/debugBuild @@ -0,0 +1,2 @@ +#!/usr/bin/env bash +clang -DDEBUG -std=c11 -g -Wall -Wno-microsoft-anon-tag -fms-extensions -o BQN -lm src/main.c diff --git a/genRuntime b/genRuntime new file mode 100755 index 00000000..add10838 --- /dev/null +++ b/genRuntime @@ -0,0 +1,3 @@ +#!/usr/bin/env bash +./cc.bqn $1 r > src/runtime +./cc.bqn $1 c > src/compiler diff --git a/src/arith.c b/src/arith.c new file mode 100644 index 00000000..988343b5 --- /dev/null +++ b/src/arith.c @@ -0,0 +1,72 @@ +#include "h.h" +#include + +#define ffnx(name, expr, extra) B name(B t, B w, B x) { \ + if (isF64(w) & isF64(x)) return m_f64(expr); \ + extra \ + return err(#name ": invalid arithmetic"); \ +} +#define ffn(name, op, extra) ffnx(name, w.f op x.f, extra) + +ffn(add_c2, +, { + if (isC32(w) & isF64(x)) return m_c32((u32)w.u + o2i(x)); + if (isF64(w) & isC32(x)) return m_c32((u32)x.u + o2i(w)); +}) +ffn(sub_c2, -, { + if (isC32(w) & isF64(x)) return m_c32((u32)w.u - o2i(x)); + if (isC32(w) & isC32(x)) return m_f64((u32)w.u - (i64)(u32)x.u); +}) +ffn(mul_c2, *, {}) +ffn(div_c2, /, {}) +ffn(le_c2, <=, { + if (isC32(w) & isC32(x)) return m_f64(w.u<=x.u); + if (isF64(w) & isC32(x)) return m_f64(1); + if (isC32(w) & isF64(x)) return m_f64(0); +}) +ffnx(pow_c2, pow(w.f,x.f), {}) +ffnx(log_c2, log(x.f)/log(w.f), {}) + +#undef ffn +#undef ffnx + +B decp_c1(B t, B x); +B eq_c2(B t, B w, B x) { + if(isF64(w)&isF64(x)) return m_i32(w.f==x.f); + if (w.u==x.u) return m_i32(1); + if (!isVal(w) | !isVal(x)) { dec(w);dec(x); return m_i32(0); } + if (v(w)->type!=v(x)->type) { dec(w);dec(x); return m_i32(0); } + B2B dcf = TI(w).decompose; + if (dcf == def_decompose) { dec(w);dec(x); return m_i32(0); } + w=dcf(w); B* wp = harr_ptr(w); + x=dcf(x); B* xp = harr_ptr(x); + if (o2i(wp[0])<=1) { dec(w);dec(x); return m_i32(0); } + i32 wia = a(w)->ia; + i32 xia = a(x)->ia; + if (wia != xia) { dec(w);dec(x); return m_i32(0); } + for (i32 i = 0; i0?1:-1:0); return err("getting sign of non-number"); } +B div_c1(B t, B x) { if (isF64(x)) return m_f64( 1/x.f ); return err("getting reciprocal of non-number"); } +B pow_c1(B t, B x) { if (isF64(x)) return m_f64( exp(x.f)); return err("getting exp of non-number"); } +B floor_c1(B t, B x) { if (isF64(x)) return m_f64(floor(x.f)); return err("getting floor of non-number"); } +B log_c1(B t, B x) { if (isF64(x)) return m_f64( log(x.f)); return err("getting log of non-number"); } +B eq_c1(B t, B x) { B r = m_i32(isArr(x)? a(x)->rank : 0); dec(x); return r; } + + + +#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME; +#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = c1_invalid; c(Fun,bi_##NAME)->id=pf_##NAME; +#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = c2_invalid;c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME; + +B bi_add, bi_sub, bi_mul, bi_div, bi_pow, bi_floor, bi_eq, bi_le, bi_log; +void arith_init() { ba(add) ba(sub) ba(mul) ba(div) ba(pow) bm(floor) ba(eq) bd(le) ba(log) } + +#undef ba +#undef bd +#undef bm diff --git a/src/derv.c b/src/derv.c new file mode 100644 index 00000000..27d757fc --- /dev/null +++ b/src/derv.c @@ -0,0 +1,78 @@ +#include "h.h" + +typedef struct Md1D { // F _md + struct Fun; + B m; // known to be Md1 at creation; kept as type B as refc-- might want to know tagged ptr info + B f; +} Md1D; +typedef struct Md2D { // F _md_ G + struct Fun; + B m; + B f, g; +} Md2D; +typedef struct Md2H { // _md_ G + struct Md1; + B m; + B g; +} Md2H; +typedef struct Fork { + struct Fun; + B f, g, h; +} Fork; +typedef struct Atop { + struct Fun; + B g, h; +} Atop; + +void md1D_free(B x) { dec(c(Md1D,x)->m); dec(c(Md1D,x)->f); } +void md2D_free(B x) { dec(c(Md2D,x)->m); dec(c(Md2D,x)->f); dec(c(Md2D,x)->g); } +void md2H_free(B x) { dec(c(Md2H,x)->m); dec(c(Md2H,x)->g); } +void fork_free(B x) { dec(c(Fork,x)->f); dec(c(Fork,x)->g); dec(c(Fork,x)->h); } +void atop_free(B x) { dec(c(Atop,x)->g); dec(c(Atop,x)->h); } + +void md1D_print(B x) { printf("(md1D ");print(c(Md1D,x)->f);printf(" ");print(c(Md1D,x)->m); printf(")"); } +void md2D_print(B x) { printf("(md2D ");print(c(Md2D,x)->f);printf(" ");print(c(Md2D,x)->m);printf(" ");print(c(Md2D,x)->g);printf(")"); } +void md2H_print(B x) { printf("(md2H "); print(c(Md2H,x)->m);printf(" ");print(c(Md2H,x)->g);printf(")"); } +void fork_print(B x) { printf("(fork ");print(c(Fork,x)->f);printf(" ");print(c(Fork,x)->g);printf(" ");print(c(Fork,x)->h);printf(")"); } +void atop_print(B x) { printf("(atop "); print(c(Atop,x)->g);printf(" ");print(c(Atop,x)->h);printf(")"); } + +B md1D_c1(B t , B x) { return c(Md1,c(Md1D, t)->m)->c1(c(Md1D, t)->m, c(Md1D, t)->f, x); } +B md1D_c2(B t, B w, B x) { return c(Md1,c(Md1D, t)->m)->c2(c(Md1D, t)->m, c(Md1D, t)->f, w, x); } +B md2D_c1(B t , B x) { return c(Md2,c(Md2D, t)->m)->c1(c(Md2D, t)->m, c(Md2D, t)->f, c(Md2D, t)->g, x); } +B md2D_c2(B t, B w, B x) { return c(Md2,c(Md2D, t)->m)->c2(c(Md2D, t)->m, c(Md2D, t)->f, c(Md2D, t)->g, w, x); } +B atop_c1(B t , B x) { return c1(c(Atop,t)->g, c1(c(Atop,t)->h, x)); } +B atop_c2(B t, B w, B x) { return c1(c(Atop,t)->g, c2(c(Atop,t)->h, w, x)); } +B fork_c1(B t , B x) { B g=c1(c(Fork,t)->h, inci(x)); return c2(c(Fork,t)->g, c1(c(Fork,t)->f, x), g); } +B fork_c2(B t, B w, B x) { B g=c2(c(Fork,t)->h, inci(w), inci(x)); return c2(c(Fork,t)->g, c2(c(Fork,t)->f, w, x), g); } +B md2H_c1(B t, B f , B x) { return c(Md2,c(Md2H, t)->m)->c1(c(Md2H,t)->m, f, c(Md2H,t)->g, x); } +B md2H_c2(B t, B f, B w, B x) { return c(Md2,c(Md2H, t)->m)->c2(c(Md2H,t)->m, f, c(Md2H,t)->g, w, x); } + +B md1D_decompose(B x) { B r=m_v3(m_i32(4),inci(c(Md1D,x)->f),inci(c(Md1D,x)->m) ); dec(x); return r; } +B md2D_decompose(B x) { B r=m_v4(m_i32(5),inci(c(Md2D,x)->f),inci(c(Md2D,x)->m), inci(c(Md2D,x)->g)); dec(x); return r; } +B md2H_decompose(B x) { B r=m_v3(m_i32(6), inci(c(Md2H,x)->m), inci(c(Md2H,x)->g)); dec(x); return r; } +B fork_decompose(B x) { B r=m_v4(m_i32(3),inci(c(Fork,x)->f),inci(c(Fork,x)->g), inci(c(Fork,x)->h)); dec(x); return r; } +B atop_decompose(B x) { B r=m_v3(m_i32(2), inci(c(Atop,x)->g), inci(c(Atop,x)->h)); dec(x); return r; } + +// consume all args +B m_md1D(B m, B f ) { B r = mm_alloc(sizeof(Md1D), t_md1D, ftag(FUN_TAG)); c(Md1D,r)->f = f; c(Md1D,r)->m = m; c(Md1D,r)->c1=md1D_c1; c(Md1D,r)->c2=md1D_c2; c(Md1D,r)->id=pf_md1d; return r; } +B m_md2D(B m, B f, B g) { B r = mm_alloc(sizeof(Md2D), t_md2D, ftag(FUN_TAG)); c(Md2D,r)->f = f; c(Md2D,r)->m = m; c(Md2D,r)->g = g; c(Md2D,r)->c1=md2D_c1; c(Md2D,r)->c2=md2D_c2; c(Md2D,r)->id=pf_md2d; return r; } +B m_md2H(B m, B g) { B r = mm_alloc(sizeof(Md2H), t_md2H, ftag(MD1_TAG)); c(Md2H,r)->m = m; c(Md2H,r)->g = g; c(Md2H,r)->c1=md2H_c1; c(Md2H,r)->c2=md2H_c2; return r; } +B m_fork(B f, B g, B h) { B r = mm_alloc(sizeof(Fork), t_fork, ftag(FUN_TAG)); c(Fork,r)->f = f; c(Fork,r)->g = g; c(Fork,r)->h = h; c(Fork,r)->c1=fork_c1; c(Fork,r)->c2=fork_c2; c(Fork,r)->id=pf_fork; return r; } +B m_atop( B g, B h) { B r = mm_alloc(sizeof(Atop), t_atop, ftag(FUN_TAG)); c(Atop,r)->g = g; c(Atop,r)->h = h; c(Atop,r)->c1=atop_c1; c(Atop,r)->c2=atop_c2; c(Atop,r)->id=pf_atop; return r; } + +// consume all args +B m1_d(B m, B f ) { if(isMd1(m)) return TI(m).m1_d(m, f ); return err("Interpreting non-1-modifier as 1-modifier"); } +B m2_d(B m, B f, B g) { if(isMd2(m)) return TI(m).m2_d(m, f, g); return err("Interpreting non-2-modifier as 2-modifier"); } +B m2_h(B m, B g) { return m_md2H(m, g); } + + + +void derv_init() { + ti[t_md1D].free = md1D_free; ti[t_md1D].print = md1D_print; ti[t_md1D].decompose = md1D_decompose; + ti[t_md2D].free = md2D_free; ti[t_md2D].print = md2D_print; ti[t_md2D].decompose = md2D_decompose; + ti[t_md2H].free = md2H_free; ti[t_md2H].print = md2H_print; ti[t_md2H].decompose = md2H_decompose; + ti[t_fork].free = fork_free; ti[t_fork].print = fork_print; ti[t_fork].decompose = fork_decompose; + ti[t_atop].free = atop_free; ti[t_atop].print = atop_print; ti[t_atop].decompose = atop_decompose; + ti[t_md1_def].m1_d = m_md1D; + ti[t_md2_def].m2_d = m_md2D; +} \ No newline at end of file diff --git a/src/h.h b/src/h.h new file mode 100644 index 00000000..ac634a06 --- /dev/null +++ b/src/h.h @@ -0,0 +1,441 @@ +#pragma once +#include +#include +#include +#include +#include +#include +#include +#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(); + +#ifdef DEBUG + #include + #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 usz u32 +#define ur u8 +#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 +u16 C32_TAG = 0b0111111111110001; // 0111111111110001................00000000000ccccccccccccccccccccc char +u16 TAG_TAG = 0b0111111111110010; // 0111111111110010................nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn special value (0=nothing, 1=undefined var, 2=bad header; 3=optimized out; 4=error?) +u16 VAR_TAG = 0b0111111111110011; // 0111111111110011ddddddddddddddddnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn variable reference +u16 I32_TAG = 0b0111111111110111; // 0111111111110111................nnnnnnnnnnnnnnnnnnnnnnnnnnnnnnnn 32-bit int; unused +u16 MD1_TAG = 0b1111111111110010; // 1111111111110010ppppppppppppppppppppppppppppppppppppppppppppp000 1-modifier +u16 MD2_TAG = 0b1111111111110011; // 1111111111110011ppppppppppppppppppppppppppppppppppppppppppppp000 2-modifier +u16 FUN_TAG = 0b1111111111110100; // 1111111111110100ppppppppppppppppppppppppppppppppppppppppppppp000 function +u16 NSP_TAG = 0b1111111111110101; // 1111111111110101ppppppppppppppppppppppppppppppppppppppppppppp000 namespace maybe? +u16 OBJ_TAG = 0b1111111111110110; // 1111111111110110ppppppppppppppppppppppppppppppppppppppppppppp000 custom object (e.g. bigints) +u16 ARR_TAG = 0b1111111111110111; // 1111111111110111ppppppppppppppppppppppppppppppppppppppppppppp000 array (everything else is an atom) +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, + + /*15*/ t_comp, t_block, t_body, t_scope, + + + Type_MAX +}; + +enum PrimFns { + pf_not, + 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_lt, pf_rt, // sfns.c + pf_fork, pf_atop, pf_md1d, pf_md2d, // derv.c + pf_type, pf_decp, pf_primInd, pf_glyph, pf_fill, pf_grLen, pf_grOrd, pf_asrt, // sysfn.c +}; +char* format_pf(u8 u) { + switch(u) { + default: case pf_not: 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_lt:return"⊣"; case pf_rt: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"!"; } +} +enum PrimMd1 { + pm1_not, + pm1_tbl, pm1_scan, // md1.c +}; +char* format_pm1(u8 u) { + switch(u) { + default: case pf_not: 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; + u16 flags; // incl GC stuff when that's a thing, possibly whether is sorted/a permutation/whatever, bucket size, etc + u8 type; // needed globally so refc-- and GC know what to visit +} Value; +typedef struct Arr { + struct Value; + ur rank; + usz ia; + usz* sh; +} Arr; + +// memory manager +B mm_alloc(usz sz, u8 type, u64 tag); +void mm_free(Value* x); +void mm_visit(B x); + +// some primitive actions +void dec(B x); +void inc(B x); +void ptr_dec(void* x); +void ptr_inc(void* x); +void 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)) +Value* v(B x) { return c(Value, x); } +Arr* a(B x) { return c(Arr , x); } + +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(); + 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 (a(x)->rank>1) ptr_dec(shObj(x)); } + +void arr_shVec(B x, usz ia) { + a(x)->ia = ia; + a(x)->rank = 1; + a(x)->sh = &a(x)->ia; +} +usz* arr_shAlloc(B x, usz ia, usz r) { + a(x)->ia = ia; + a(x)->rank = 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 + a(n)->ia = a(o)->ia; + ur r = a(n)->rank = a(o)->rank; + 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) { // assumes both are Arr + ur wr = a(w)->rank; usz* wsh = a(w)->sh; + ur xr = a(x)->rank; 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 = a(x)->rank; + 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; } + + +typedef void (*B2V)(B); +typedef B (*BS2B)(B, 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 struct TypeInfo { + B2V free; // expects refc==0 + B2V visit; // for GC when that comes around + B2V print; // doesn't consume + BS2B get; // increments result, doesn't consume arg + BB2B m1_d; // consume all args + BBB2B m2_d; // consume all args + B2B decompose; // consumes; must return a HArr +} TypeInfo; +TypeInfo ti[Type_MAX]; +#define TI(x) (ti[v(x)->type]) + + +void do_nothing(B x) { } +B get_self(B x, usz n) { return x; } +void def_print(B x) { printf("(type %d)", v(x)->type); } +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_decompose(B x) { return m_v2(m_i32((isFun(x)|isMd(x))? 0 : -1),x); } + +B bi_nothing, bi_noVar, bi_badHdr, bi_optOut; +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; + } + bi_nothing = tag(0, TAG_TAG); + bi_noVar = tag(1, TAG_TAG); + bi_badHdr = tag(2, TAG_TAG); + bi_optOut = tag(3, TAG_TAG); +} + +bool isNothing(B b) { return b.u==bi_nothing.u; } + + +// refcount +void dec(B x) { + if (!isVal(VALIDATE(x))) return; + Value* vx = v(x); + assert(vx->refc>0); + if (!--vx->refc) { + // printf("freeing type %d: %p\n", vx->type, (void*)x.u);fflush(stdout); + ti[vx->type].free(x); + mm_free(vx); + } +} +void inc (B x) { if (isVal(VALIDATE(x))) v(x)->refc++; } +B inci(B x) { inc(x); return x; } +void ptr_dec(void* x) { dec(tag(x, OBJ_TAG)); } +void ptr_inc(void* x) { inc(tag(x, OBJ_TAG)); } +bool reusable(B x) { return v(x)->refc==1; } + +void printUTF8(u32 c) { + if (c<128) printf("%c", c); + else if (c<=0x07FF) printf("%c%c" , 0xC0| c>>6 , 0x80| (c &0x3F) ); + else if (c<=0xFFFF) printf("%c%c%c" , 0xE0| c>>12, 0x80| (c>>6 &0x3F), 0x80| (c &0x3F) ); + else printf("%c%c%c%c", 0xF0| c>>18, 0x80| (c>>12 &0x3F), 0x80| (c>>6 &0x3F), 0x80| (c&0x3F)); +} + +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); +} + + + +typedef struct Fun { + struct Value; + u8 id; + 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"); } + +B c1(B f, B x) { // BQN-call f monadically; consumes x + if (isFun(f)) return VALIDATE(c(Fun,f)->c1(f, x)); + dec(x); + if (isMd(f)) return err("Calling a modifier"); + return inci(VALIDATE(f)); +} +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)); + dec(w);dec(x); + if (isMd(f)) return err("Calling a modifier"); + return inci(VALIDATE(f)); +} + + + +typedef struct Md1 { + struct Value; + u8 id; + BBB2B c1; // f(m,f, x); consumes x + BBBB2B c2; // f(m,f,w,x); consumes w,x +} Md1; +typedef struct Md2 { + struct Value; + u8 id; + BBBB2B c1; // f(m,f,g, x); consumes x + BBBBB2B c2; // f(m,f,g,w,x); consumes w,x +} Md2; + + +void arr_print(B x) { + usz r = a(x)->rank; + 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 = a(x)->rank; + 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 \ No newline at end of file diff --git a/src/harr.c b/src/harr.c new file mode 100644 index 00000000..6214e5d6 --- /dev/null +++ b/src/harr.c @@ -0,0 +1,96 @@ +#include "h.h" + +typedef struct HArr { + struct Arr; + B a[]; +} HArr; + +typedef struct HArr_p { + B b; + B* a; + HArr* c; +} HArr_p; +HArr_p harr_parts(B b) { + HArr* p = c(HArr,b); + return (HArr_p){.b = b, .a = p->a, .c = p}; +} + + +HArr_p m_harrv(usz ia) { + B r = m_arr(fsizeof(HArr,a,B,ia), t_harr); + arr_shVec(r, ia); + return harr_parts(r); +} + +HArr_p m_harrc(B x) { assert(isArr(x)); + B r = m_arr(fsizeof(HArr,a,B,a(x)->ia), t_harr); + arr_shCopy(r, x); + return harr_parts(r); +} + +HArr_p m_harrp(usz ia) { // doesn't write any shape/size info! be careful! + return harr_parts(m_arr(fsizeof(HArr,a,B,ia), t_harr)); +} + + + +B* harr_ptr(B x) { + assert(v(x)->type==t_harr); + return c(HArr,x)->a; +} + +HArr* toHArr(B x) { + if (v(x)->type==t_harr) return c(HArr,x); + HArr_p r = m_harrc(x); + usz ia = r.c->ia; + BS2B xget = TI(x).get; + for (usz i = 0; i < ia; i++) r.a[i] = xget(x,i); + dec(x); + return r.c; +} + + + +B m_vaf64(usz sz, ...) { + va_list vargs; + va_start(vargs, sz); + HArr_p r = m_harrv(sz); + for (usz i = 0; i < sz; i++) r.a[i] = m_f64(va_arg(vargs, f64)); + va_end(vargs); + return r.b; +} + +B m_vaB(usz sz, ...) { + va_list vargs; + va_start(vargs, sz); + HArr_p r = m_harrv(sz); + for (usz i = 0; i < sz; i++) r.a[i] = va_arg(vargs, B); + va_end(vargs); + return r.b; +} + +B m_v1(B a ) { HArr_p r = m_harrv(1); r.a[0] = a; return r.b; } +B m_v2(B a, B b ) { HArr_p r = m_harrv(2); r.a[0] = a; r.a[1] = b; return r.b; } +B m_v3(B a, B b, B c ) { HArr_p r = m_harrv(3); r.a[0] = a; r.a[1] = b; r.a[2] = c; return r.b; } +B m_v4(B a, B b, B c, B d) { HArr_p r = m_harrv(4); r.a[0] = a; r.a[1] = b; r.a[2] = c; r.a[3] = d; return r.b; } + + + +void harr_print(B x) { + arr_print(x); +} +B harr_get(B x, usz n) { + return inci(c(HArr,x)->a[n]); +} +void harr_free(B x) { + decSh(x); + B* p = harr_ptr(x); + usz ia = a(x)->ia; + for (usz i = 0; i < ia; i++) dec(p[i]); +} + +void harr_init() { + ti[t_harr].free = harr_free; + ti[t_harr].print = harr_print; + ti[t_harr].get = harr_get; +} \ No newline at end of file diff --git a/src/i32arr.c b/src/i32arr.c new file mode 100644 index 00000000..bc475186 --- /dev/null +++ b/src/i32arr.c @@ -0,0 +1,61 @@ +#include "h.h" + +typedef struct I32Arr { + struct Arr; + i32 a[]; +} I32Arr; + + +B m_i32arrv(usz ia) { + B r = m_arr(fsizeof(I32Arr,a,i32,ia), t_i32arr); + arr_shVec(r, ia); + return r; +} +B m_i32arrc(B x) { assert(isArr(x)); + B r = m_arr(fsizeof(I32Arr,a,B,a(x)->ia), t_i32arr); + arr_shCopy(r, x); + return r; +} +B m_i32arrp(usz ia) { // doesn't write any shape/size info! be careful! + return m_arr(fsizeof(I32Arr,a,i32,ia), t_i32arr); +} + + +i32* i32arr_ptr(B x) { + assert(v(x)->type==t_i32arr); + return c(I32Arr,x)->a; +} + + +B m_vai32(usz sz, ...) { + va_list vargs; + va_start(vargs, sz); + B r = m_i32arrv(sz); + i32* rp = i32arr_ptr(r); + for (usz i = 0; i < sz; i++) rp[i] = va_arg(vargs, i32); + va_end(vargs); + return r; +} + +I32Arr* toI32Arr(B x) { + if (v(x)->type==t_i32arr) return c(I32Arr,x); + B r = m_i32arrc(x); + i32* rp = i32arr_ptr(r); + usz ia = a(r)->ia; + BS2B xget = TI(x).get; + for (usz i = 0; i < ia; i++) rp[i] = o2i(xget(x,i)); + dec(x); + return c(I32Arr,r); +} + + +void i32arr_free(B x) { decSh(x); } +void i32arr_print(B x) { arr_print(x); } +B i32arr_get(B x, usz n) { assert(v(x)->type==t_i32arr); return m_i32(c(I32Arr,x)->a[n]); } + +void i32arr_init() { + ti[t_i32arr].free = i32arr_free; + ti[t_i32arr].print = i32arr_print; + ti[t_i32arr].get = i32arr_get; +} + diff --git a/src/main.c b/src/main.c new file mode 100644 index 00000000..75bde6b0 --- /dev/null +++ b/src/main.c @@ -0,0 +1,166 @@ +// #define ATOM_I32 +#ifdef DEBUG + // #define DEBUG_VM +#endif +// #define ALLOC_STAT + +#include "h.h" +#include "mm.c" +#include "harr.c" +#include "i32arr.c" +#include "arith.c" +#include "sfns.c" +#include "md1.c" +#include "md2.c" +#include "sysfn.c" +#include "derv.c" +#include "vm.c" +#include "utf.c" + +void pr(char* a, B b) { + printf("%s", a); + print(b); + puts(""); + dec(b); + fflush(stdout); +} + +Block* ca3(B b) { + B* ps = harr_ptr(b); + Block* r = compile(inci(ps[0]),inci(ps[1]),inci(ps[2])); + dec(b); + return r; +} + +B m_str8(char* s) { + u64 sz = strlen(s); + HArr_p r = m_harrv(sz); + for (u64 i = 0; i < sz; i++) r.a[i] = m_c32(s[i]); + return r.b; +} +B m_str32(u32* s) { + u64 sz = 0; + while(s[sz])sz++; + HArr_p r = m_harrv(sz); + for (u64 i = 0; i < sz; i++) r.a[i] = m_c32(s[i]); + return r.b; +} +B m_cai32(usz ia, i32* a) { + B r = m_i32arrv(ia); + i32* rp = i32arr_ptr(r); + for (usz i = 0; i < ia; i++) rp[i] = a[i]; + return r; +} + +__ssize_t getline (char **__restrict __lineptr, size_t *restrict n, FILE *restrict stream); + +int main() { + hdr_init(); + harr_init(); + i32arr_init(); + arith_init(); + sfns_init(); + md1_init(); + md2_init(); + sysfn_init(); + derv_init(); + comp_init(); + + + // fake runtime + // B bi_N = bi_nothing; + // B runtime[] = { + // /* +-×÷⋆√⌊⌈|¬ */ bi_add, bi_sub , bi_mul , bi_div, bi_pow, bi_N , bi_floor, bi_N , bi_N, bi_N, + // /* ∧∨<>≠=≤≥≡≢ */ bi_N , bi_N , bi_N , bi_N , bi_N , bi_eq, bi_le , bi_N , bi_N, bi_fne, + // /* ⊣⊢⥊∾≍↑↓↕«» */ bi_lt , bi_rt , bi_shape, bi_N , bi_N , bi_N , bi_N , bi_ud , bi_N, bi_N, + // /* ⌽⍉/⍋⍒⊏⊑⊐⊒∊ */ bi_N , bi_N , bi_N , bi_N , bi_N , bi_N , bi_pick , bi_N , bi_N, bi_N, + // /* ⍷⊔!˙˜˘¨⌜⁼´ */ bi_N , bi_N , bi_asrt , bi_N , bi_N , bi_N , bi_N , bi_tbl, bi_N, bi_N, + // /* ˝`∘○⊸⟜⌾⊘◶⎉ */ bi_N , bi_scan, bi_N , bi_N , bi_N , bi_N , bi_N , bi_val, bi_N, bi_N, + // /* ⚇⍟ */ bi_N , bi_N + // }; + // Block* c = ca3( + // #include "interp" + // ); + // B interp = m_funBlock(c, 0); ptr_dec(c); + // pr("interpreted: ", interp); + + Block* runtime_b = compile( + #include "runtime" + ); + B rtRes = m_funBlock(runtime_b, 0); ptr_dec(runtime_b); + B rtObj = TI(rtRes).get(rtRes,0); + B rtFinish = TI(rtRes).get(rtRes,1); + B* runtime = toHArr(rtObj)->a; + runtimeLen = c(Arr,rtObj)->ia; + for (usz i = 0; i < runtimeLen; i++) { + if (isVal(runtime[i])) v(runtime[i])->flags|= i+1; + } + c1(rtFinish, m_v2(inci(bi_decp), inci(bi_primInd))); + + // uncomment to use src/interp; needed for test.bqn + // Block* c = ca3( + // #include "interp" + // ); + // B interp = m_funBlock(c, 0); ptr_dec(c); + // pr("result: ", interp); + // exit(0); + + Block* comp_b = compile( + #include "compiler" + ); + B comp = m_funBlock(comp_b, 0); ptr_dec(comp_b); + + + // uncomment to self-compile and use that for the REPL; expects a copy of mlochbaum/BQN/src/c.bqn to be at the execution directory + // char* c_src = 0; + // u64 c_len; + // FILE* f = fopen("c.bqn", "rb"); + // if (f) { + // fseek(f, 0, SEEK_END); + // c_len = ftell(f); + // fseek(f, 0, SEEK_SET); + // c_src = malloc(c_len); + // if (c_src) fread(c_src, 1, c_len, f); + // fclose(f); + // } else { + // printf("couldn't read c.bqn\n"); + // exit(1); + // } + // if (c_src) { + // B cbc = c2(comp, inci(rtObj), fromUTF8(c_src, c_len)); + // Block* cbc_b = ca3(cbc); + // comp = m_funBlock(cbc_b, 0); + // free(c_src); + // } + + + while (true) { // exit by evaluating an empty expression + char* ln = NULL; + size_t gl = 0; + getline(&ln, &gl, stdin); + if (ln[0]==10) break; + B obj = fromUTF8(ln, strlen(ln)); + B cbc = c2(comp, inci(rtObj), obj); + free(ln); + Block* cbc_b = ca3(cbc); + pr("", m_funBlock(cbc_b, 0)); + } + + dec(rtRes); + dec(comp); + + #ifdef ALLOC_STAT + printf("ctrA←"); for (i64 j = 0; j < Type_MAX; j++) { if(j)printf("‿"); printf("%lu", ctr_a[j]); } printf("\n"); + printf("ctrF←"); for (i64 j = 0; j < Type_MAX; j++) { if(j)printf("‿"); printf("%lu", ctr_f[j]); } printf("\n"); + for(i64 i = 0; i < actrc; i++) { + u32* c = actrs[i]; + bool any = false; + for (i64 j = 0; j < Type_MAX; j++) if (c[j]) any=true; + if (any) { + printf("%ld", i); + for (i64 j = 0; j < Type_MAX; j++) printf("‿%u", c[j]); + printf("\n"); + } + } + #endif +} \ No newline at end of file diff --git a/src/md1.c b/src/md1.c new file mode 100644 index 00000000..bc71ebc0 --- /dev/null +++ b/src/md1.c @@ -0,0 +1,103 @@ +#include "h.h" + +B tbl_c1(B t, B f, B x) { + if (!isArr(x)) return err("⌜: argument was atom"); + usz ia = a(x)->ia; + HArr_p r = m_harrc(x); + BS2B xget = TI(x).get; + for (usz i = 0; i < ia; i++) r.a[i] = c1(f, xget(x,i)); + dec(x); + return r.b; +} +B tbl_c2(B t, B f, B w, B x) { + if (isArr(w) & isArr(x)) { + usz wia = a(w)->ia; ur wr = a(w)->rank; + usz xia = a(x)->ia; ur xr = a(x)->rank; + usz ria = wia*xia; ur rr = wr+xr; + if (rrsh, wr*sizeof(usz)); + memcpy(rsh+wr, a(x)->sh, xr*sizeof(usz)); + } + + BS2B wget = TI(w).get; + BS2B xget = TI(x).get; + usz ri = 0; + for (usz wi = 0; wi < wia; wi++) { + B cw = wget(w,wi); + for (usz xi = 0; xi < xia; xi++) { + r.a[ri++] = c2(f, inci(cw), xget(x,xi)); + } + dec(cw); + } + dec(w); dec(x); + return r.b; + } else return err("⌜: one argument was an atom"); +} + + +B scan_c1(B t, B f, B x) { + if (!isArr(x)) return err("`: argument cannot be a scalar"); + ur xr = a(x)->rank; + if (xr==0) return err("`: argument cannot be a scalar"); + HArr_p r = m_harrc(x); + usz ia = r.c->ia; + if (ia==0) return r.b; + BS2B xget = TI(x).get; + if (xr==1) { + r.a[0] = xget(x,0); + for (usz i = 1; i < ia; i++) r.a[i] = c2(f, inci(r.a[i-1]), xget(x,i)); + } else { + usz csz = arr_csz(x); + for (usz i = 0; i < csz; i++) r.a[i] = xget(x,i); + for (usz i = csz; i < ia; i++) r.a[i] = c2(f, inci(r.a[i-csz]), xget(x,i)); + } + dec(x); + return r.b; +} +B scan_c2(B t, B f, B w, B x) { + if (!isArr(x)) return err("`: 𝕩 cannot be a scalar"); + ur xr = a(x)->rank; usz* xsh = a(x)->sh; BS2B xget = TI(x).get; + if (isArr(w)) { + ur wr = a(w)->rank; usz* wsh = a(w)->sh; BS2B wget = TI(w).get; + if (xr==0) return err("`: 𝕩 cannot be a scalar"); + if (wr+1 != xr) return err("`: shape of 𝕨 must match the cell of 𝕩"); + if (memcmp(wsh, xsh+1, wr)) return err("`: shape of 𝕨 must match the cell of 𝕩"); + HArr_p r = m_harrc(x); + usz ia = r.c->ia; + if (ia==0) return r.b; + usz csz = arr_csz(x); + for (usz i = 0; i < csz; i++) r.a[i] = c2(f, wget(w,i), xget(x,i)); + for (usz i = csz; i < ia; i++) r.a[i] = c2(f, inci(r.a[i-csz]), xget(x,i)); + dec(w); + dec(x); + return r.b; + } else { + if (xr!=1) return err("`: if 𝕨 is scalar, 𝕩 must be a vector"); + HArr_p r = m_harrc(x); + usz ia = r.c->ia; + if (ia==0) return r.b; + B pr = r.a[0] = c2(f, w, xget(x,0)); + for (usz i = 1; i < ia; i++) r.a[i] = pr = c2(f, inci(pr), xget(x,i)); + dec(x); + return r.b; + } +} + + +#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1_def, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = NAME##_c2; c(Md1,bi_##NAME)->c1 = NAME##_c1 ; c(Md1,bi_##NAME)->id=pm1_##NAME; +#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1_def, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = NAME##_c2; c(Md1,bi_##NAME)->c1 = c1_invalid; c(Md1,bi_##NAME)->id=pm1_##NAME; +#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Md1), t_md1_def, ftag(MD1_TAG)); c(Md1,bi_##NAME)->c2 = c2_invalid;c(Md1,bi_##NAME)->c1 = NAME##_c1 ; c(Md1,bi_##NAME)->id=pm1_##NAME; + +void print_md1_def(B x) { printf("%s", format_pm1(c(Md1,x)->id)); } + +B bi_tbl, bi_scan; +void md1_init() { ba(tbl) ba(scan) + ti[t_md1_def].print = print_md1_def; +} + +#undef ba +#undef bd +#undef bm \ No newline at end of file diff --git a/src/md2.c b/src/md2.c new file mode 100644 index 00000000..12d6885b --- /dev/null +++ b/src/md2.c @@ -0,0 +1,20 @@ +#include "h.h" + + + +B val_c1(B t, B f, B g, B x) { return c1(f, x); } +B val_c2(B t, B f, B g, B w, B x) { return c2(g,w,x); } + +B fillBy_c1(B t, B f, B g, B x) { return c1(f, x); } +B fillBy_c2(B t, B f, B g, B w, B x) { return c2(f,w,x); } + +#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Md2), t_md2_def, ftag(MD2_TAG)); c(Md2,bi_##NAME)->c2 = NAME##_c2; c(Md2,bi_##NAME)->c1 = NAME##_c1; +#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Md2), t_md2_def, ftag(MD2_TAG)); c(Md2,bi_##NAME)->c2 = NAME##_c2; c(Md2,bi_##NAME)->c1 = c1_invalid; +#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Md2), t_md2_def, ftag(MD2_TAG)); c(Md2,bi_##NAME)->c2 = c2_invalid;c(Md2,bi_##NAME)->c1 = NAME##_c1; + +B bi_val, bi_fillBy; +void md2_init() { ba(val) ba(fillBy) } + +#undef ba +#undef bd +#undef bm \ No newline at end of file diff --git a/src/mm.c b/src/mm.c new file mode 100644 index 00000000..182d90b5 --- /dev/null +++ b/src/mm.c @@ -0,0 +1,50 @@ +#include "h.h" +#include + +#ifdef ALLOC_STAT +u64* ctr_a = 0; +u64* ctr_f = 0; +u64 actrc = 21000; +u32** actrs; +#endif + +void* aalloc(usz sz) { // actual allocate + void* p = malloc(sz); + return p; +} + +void* mm_allocN(usz sz, u8 type) { + Value* x = aalloc(sz); + #ifdef ALLOC_STAT + if (!actrs) { + actrs = malloc(sizeof(u32*)*actrc); + ctr_a = calloc(Type_MAX, sizeof(u64)); + ctr_f = calloc(Type_MAX, sizeof(u64)); + for (i32 i = 0; i < actrc; i++) actrs[i] = calloc(Type_MAX, sizeof(u32)); + } + assert(type=actrc? actrc-1 : (sz+3)/4][type]++; + ctr_a[type]++; + #endif + #ifdef DEBUG + memset(x, 'a', sz); + #endif + x->refc = 1; + x->flags = 0; + x->type = type; + return x; +} +B mm_alloc(usz sz, u8 type, u64 tag) { + assert(tag>1LL<<16); // make sure it's `ftag`ged :| + return b((u64)mm_allocN(sz,type) | tag); +} +void mm_free(Value* x) { + #ifdef ALLOC_STAT + ctr_f[x->type]++; + x->refc = 0x61616161; + #endif + free(x); +} +void mm_visit(B x) { + +} \ No newline at end of file diff --git a/src/sfns.c b/src/sfns.c new file mode 100644 index 00000000..72aad058 --- /dev/null +++ b/src/sfns.c @@ -0,0 +1,116 @@ +#include "h.h" + +B shape_c1(B t, B x) { + if (isArr(x)) { + usz ia = a(x)->ia; + if (reusable(x)) { + decSh(x); + arr_shVec(x, ia); + return x; + } + HArr_p r = m_harrv(ia); + BS2B xget = TI(x).get; + for (i32 i = 0; i < ia; i++) r.a[i] = xget(x,i); + dec(x); + return r.b; + } else return err("reshaping non-array"); +} +B shape_c2(B t, B w, B x) { + if (isArr(x)) { + if (!isArr(w)) return shape_c1(t, x); + BS2B wget = TI(w).get; + ur nr = a(w)->ia; + usz nia = a(x)->ia; + B r; + bool reuse = reusable(x); + if (reuse) { + r = x; + decSh(x); + } else { + HArr_p rg = m_harrp(nia); + BS2B xget = TI(x).get; + for (usz i = 0; i < nia; i++) rg.a[i] = xget(x,i); + r = rg.b; + } + usz* sh = arr_shAlloc(r, nia, nr); + if (sh) for (i32 i = 0; i < nr; i++) sh[i] = o2i(wget(w,i)); + if (!reuse) dec(x); + dec(w); + return r; + } else return err("reshaping non-array"); +} + +B pick_c1(B t, B x) { + if (!isArr(x)) return x; + // if (a(x)->ia==0) return err("⊑: called on empty array"); // no bounds check for now + B r = TI(x).get(x, 0); + dec(x); + return r; +} +B pick_c2(B t, B w, B x) { + usz wu = o2s(w); + if (isArr(x)) { + // if (wu >= a(x)->ia) err("⊑: 𝕨 is greater than length of 𝕩"); // no bounds check for now + B r = TI(x).get(x, wu); + dec(x); + return r; + } + dec(x); return err("n⊑atom"); +} + +B ud_c1(B t, B x) { + usz xu = o2s(x); + if (xurank; + usz* sh = a(x)->sh; + for (i32 i = 0; i < xr; i++) if (sh[i]>I32_MAX) { + HArr_p r = m_harrv(xr); + for (i32 j = 0; j < xr; j++) r.a[j] = m_f64(sh[j]); + dec(x); + return r.b; + } + B r = m_i32arrv(xr); i32* rp = i32arr_ptr(r); + for (i32 i = 0; i < xr; i++) rp[i] = sh[i]; + dec(x); + return r; + } else { + dec(x); + return m_i32arrv(0); + } +} + + +B lt_c1(B t, B x) { return x; } +B lt_c2(B t, B w, B x) { dec(x); return w; } +B rt_c1(B t, B x) { return x; } +B rt_c2(B t, B w, B x) { dec(w); return x; } + +#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME; +#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = c1_invalid; c(Fun,bi_##NAME)->id=pf_##NAME; +#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = c2_invalid;c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME; + +void print_fun_def(B x) { printf("%s", format_pf(c(Fun,x)->id)); } + +B bi_shape, bi_pick, bi_ud, bi_pair, bi_fne, bi_lt, bi_rt; +void sfns_init() { ba(shape) ba(pick) bm(ud) ba(pair) bm(fne) ba(lt) ba(rt) + ti[t_fun_def].print = print_fun_def; +} + +#undef ba +#undef bd +#undef bm \ No newline at end of file diff --git a/src/sysfn.c b/src/sysfn.c new file mode 100644 index 00000000..9cf7a71a --- /dev/null +++ b/src/sysfn.c @@ -0,0 +1,120 @@ +#include "h.h" + +B type_c1(B t, B x) { + i32 r = -1; + if (isArr(x)) r = 0; + else if (isI32(x)) r = 1; + else if (isF64(x)) r = 1; + else if (isC32(x)) r = 2; + else if (isFun(x)) r = 3; + else if (isMd1(x)) r = 4; + else if (isMd2(x)) r = 5; + dec(x); + if (r==-1) return err("getting type"); + return m_i32(r); +} + +B decp_c1(B t, B x) { + if (!isVal(x)) return m_v2(m_i32(-1), x); + if (v(x)->flags) return m_v2(m_i32(0), x); + return TI(x).decompose(x); +} + +usz runtimeLen; +B primInd_c1(B t, B x) { + if (!isVal(x)) return m_i32(runtimeLen); + if (v(x)->flags) return m_i32(v(x)->flags-1); + return m_i32(runtimeLen); +} + +B glyph_c1(B t, B x) { + return x; +} + +B fill_c1(B t, B x) { dec(x); return m_f64(0); } +B fill_c2(B t, B w, B x) { dec(w); return x; } + +B grLen_c1(B t, B x) { + i64 ria = -1; + usz ia = a(x)->ia; + BS2B xget = TI(x).get; + for (usz i = 0; i < ia; i++) { + i64 c = o2i64(xget(x, i)); + if (c>ria) ria = c; + } + ria++; + HArr_p r = m_harrv(ria); + for (usz i = 0; i < ria; i++) r.a[i] = m_f64(0); + for (usz i = 0; i < ia; i++) { + i64 n = o2i64(xget(x, i)); + if (n>=0) r.a[n].f++; + } + dec(x); + return r.b; +} +B grLen_c2(B t, B w, B x) { + i64 ria = o2s(w)-1; + usz ia = a(x)->ia; + BS2B xget = TI(x).get; + for (usz i = 0; i < ia; i++) { + i64 c = o2i64(xget(x, i)); + if (c>ria) ria = c; + } + ria++; + HArr_p r = m_harrv(ria); + for (usz i = 0; i < ria; i++) r.a[i] = m_f64(0); + for (usz i = 0; i < ia; i++) { + i64 n = o2i64(xget(x, i)); + if (n>=0) r.a[n].f++; + } + dec(x); + return r.b; +} + +B grOrd_c2(B t, B w, B x) { + usz wia = a(w)->ia; + usz xia = a(x)->ia; + if (wia==0) return c1(bi_ud, m_i32(0)); + if (xia==0) return x; + BS2B wget = TI(w).get; + BS2B xget = TI(x).get; + usz tmp[wia]; + tmp[0] = 0; + for (int i = 1; i < wia; i++) tmp[i] = tmp[i-1]+o2s(wget(w,i-1)); + usz ria = tmp[wia-1]+o2s(wget(w,wia-1)); + HArr_p r = m_harrv(ria); + for (usz i = 0; i < xia; i++) { + i64 c = o2i64(xget(x,i)); + if (c>=0) r.a[tmp[c]++] = m_usz(i); + } + dec(w); + dec(x); + return r.b; +} + +B asrt_c1(B t, B x) { + if (isI32(x) && 1==(i32)x.u) return x; + if (isF64(x) && 1==x.f) return x; + dec(x); + return err("assertion error"); +} +B asrt_c2(B t, B w, B x) { + if (isI32(x) && 1==(i32)x.u) return x; + if (isF64(x) && 1==x.f) return x; + dec(x); + printf("Assertion error: "); fflush(stdout); print(w); printf("\n"); + dec(w); + return err("assertion error with message"); +} + + +#define ba(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME; +#define bd(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = NAME##_c2; c(Fun,bi_##NAME)->c1 = c1_invalid; c(Fun,bi_##NAME)->id=pf_##NAME; +#define bm(NAME) bi_##NAME = mm_alloc(sizeof(Fun), t_fun_def, ftag(FUN_TAG)); c(Fun,bi_##NAME)->c2 = c2_invalid;c(Fun,bi_##NAME)->c1 = NAME##_c1 ; c(Fun,bi_##NAME)->id=pf_##NAME; + +B bi_type, bi_decp, bi_primInd, bi_glyph, bi_fill, bi_grLen, bi_grOrd, bi_asrt; +void sysfn_init() { bm(type) bm(decp) bm(primInd) bm(glyph) ba(fill) ba(grLen) bd(grOrd) ba(asrt) } + +#undef ba +#undef bd +#undef bm diff --git a/src/utf.c b/src/utf.c new file mode 100644 index 00000000..d8ea288a --- /dev/null +++ b/src/utf.c @@ -0,0 +1,27 @@ +i32 utf8_len(u8 ch) { + if (ch<128) return 1; + if ((ch>>5)== 0b110) return 2; + if ((ch>>4)== 0b1110) return 3; + if ((ch>>3)==0b11110) return 4; + return -1; +} +u32 utf8_p(u8* p) { + i32 len = utf8_len(*p); + switch (len) { default: UD; + case -1: return (u32)-1; + case 1: return *p; + case 2: return (0b11111&*p)<< 6 | (0b111111&p[1]); + case 3: return (0b1111 &*p)<<12 | (0b111111&p[2]) | (0b111111&p[1])<<6; + case 4: return (0b111 &*p)<<18 | (0b111111&p[3]) | (0b111111&p[2])<<6 | (0b111111&p[1])<<12; + } +} +B fromUTF8(char* s, u64 len) { + u64 sz = 0; + u64 j; + for (j = 0; j < len; j+= utf8_len(s[j])) sz++; + if (j!=len) return err("invalid UTF-8"); + HArr_p r = m_harrv(sz); + u64 p = 0; + for (u64 i = 0; i < len; i+= utf8_len(s[i])) r.a[p++] = m_c32(utf8_p((u8*)s+i)); // may read after end, eh + return r.b; +} \ No newline at end of file diff --git a/src/vm.c b/src/vm.c new file mode 100644 index 00000000..99b4e04c --- /dev/null +++ b/src/vm.c @@ -0,0 +1,467 @@ +#include "h.h" + +enum { + PUSH = 0, // N; push object from objs[N] + VARO = 1, // N; push variable with name strs[N] + VARM = 2, // N; push mutable variable with name strs[N] + ARRO = 3, // N; create a vector of top N items + ARRM = 4, // N; create a mutable vector of top N items + FN1C = 5, // monadic function call ⟨…,x,f ⟩ → F x + FN2C = 6, // dyadic function call ⟨…,x,f,w⟩ → w F x + OP1D = 7, // derive 1-modifier to function; ⟨…, _m,f⟩ → (f _m) + OP2D = 8, // derive 2-modifier to function; ⟨…,g,_m,f⟩ → (f _m_ g) + TR2D = 9, // derive 2-train aka atop; ⟨…, g,f⟩ → (f g) + TR3D = 10, // derive 3-train aka fork; ⟨…,h,g,f⟩ → (f g h) + SETN = 11, // set new; _ ←_; ⟨…,x, mut⟩ → mut←x + SETU = 12, // set upd; _ ↩_; ⟨…,x, mut⟩ → mut↩x + SETM = 13, // set mod; _ F↩_; ⟨…,x,F,mut⟩ → mut F↩x + POPS = 14, // pop object from stack + DFND = 15, // N; push dfns[N], derived to current scope + FN1O = 16, // optional monadic call (FN1C but checks for · at 𝕩) + FN2O = 17, // optional dyadic call (FN2C but checks for · at 𝕩 & 𝕨) + CHKV = 18, // throw error if top of stack is · + TR3O = 19, // TR3D but creates an atop if F is · + OP2H = 20, // derive 2-modifier to 1-modifier ⟨…,g,_m_⟩ → (_m_ g) + LOCO = 21, // N0,N1; push variable at depth N0 and position N1 + LOCM = 22, // N0,N1; push mutable variable at depth N0 and position N1 + VFYM = 23, // push a mutable version of ToS that fails if set to a non-equal value (for header assignment) + SETH = 24, // set header; acts like SETN, but it doesn't push to stack, and, instead of erroring in cases it would, it skips to the next body + RETN = 25, // returns top of stack + FLDO = 26, // N; get field objs[N] of ToS + FLDM = 27, // N; set field objs[N] from ToS + NSPM = 28, // N0,N1; create a destructible namespace from top N0 items, with the keys objs[N1] + RETD = 29, // return a namespace of exported items + SYSV = 30, // N; get system function N +}; + +i32* nextBC(i32* p) { + switch(*p) { + case PUSH: case DFND: case ARRO: case ARRM: + case VARO: case VARM: case FLDO: case FLDM: + case SYSV: + return p+2; + case FN1C: case FN2C: case FN1O: case FN2O: + case OP1D: case OP2D: case OP2H: + case TR2D: case TR3D: case TR3O: + case SETN: case SETU: case SETM: case SETH: + case POPS: case CHKV: case VFYM: case RETN: case RETD: + return p+1; + case LOCO: case LOCM: case NSPM: + return p+3; + default: return 0; + } +} +i32 stackDiff(i32* p) { + switch(*p) { + case PUSH: case VARO: case VARM: case DFND: case LOCO: case LOCM: case SYSV: + return 1; + case CHKV: case VFYM: case FLDO: case FLDM: case RETD: + return 0; + case FN1C: case OP1D: case TR2D: case SETN: case SETU: case POPS: case FN1O: case OP2H: case SETH: case RETN: + return -1; + case FN2C: case OP2D: case TR3D: case SETM: case FN2O: case TR3O: + return -2; + case ARRO: case ARRM: case NSPM: + return 1-p[1]; + default: return 9999999; + } +} +char* nameBC(i32* p) { + switch(*p) { default: return "(unknown)"; + case PUSH:return "PUSH";case VARO:return "VARO";case VARM:return "VARM";case ARRO:return "ARRO"; + case ARRM:return "ARRM";case FN1C:return "FN1C";case FN2C:return "FN2C";case OP1D:return "OP1D"; + case OP2D:return "OP2D";case TR2D:return "TR2D";case TR3D:return "TR3D";case SETN:return "SETN"; + case SETU:return "SETU";case SETM:return "SETM";case POPS:return "POPS";case DFND:return "DFND"; + case FN1O:return "FN1O";case FN2O:return "FN2O";case CHKV:return "CHKV";case TR3O:return "TR3O"; + case OP2H:return "OP2H";case LOCO:return "LOCO";case LOCM:return "LOCM";case VFYM:return "VFYM"; + case SETH:return "SETH";case RETN:return "RETN";case FLDO:return "FLDO";case FLDM:return "FLDM"; + case NSPM:return "NSPM";case RETD:return "RETD";case SYSV:return "SYSV"; + } +} +void printBC(i32* p) { + printf("%s", nameBC(p)); + i32* n = nextBC(p); + p++; + i32 am = n-p; + i32 len = 0; + for (i32 i = 0; i < am; i++) printf(" %d", p[i]); + while(p!=n) { + i32 c = *p++; + i32 pow = 10; + i32 log = 1; + while (pow<=c) { pow*=10; log++; } + len+= log+1; + } + len = 6-len; + while(len-->0) printf(" "); +} + +typedef struct Block Block; +typedef struct Body Body; +typedef struct Scope Scope; + +typedef struct Comp { + struct Value; + B bc; + HArr* objs; + Block* blocks[]; +} Comp; + +typedef struct Block { + struct Value; + bool imm; + u8 ty; + Body* body; +} Block; + +typedef struct Body { + struct Value; + Comp* comp; + // B* objs; + i32* bc; // pointer in comp->bc + u32 maxStack; + u16 varAm; + // HArr* vNames; +} Body; + +typedef struct Scope { + struct Value; + u64 bcInd; // DEBUG: place of this in bytecode array + u16 varAm; + Scope* psc; + B vars[]; +} Scope; + +typedef struct FunBlock { struct Fun; Scope* sc; Block* bl; } FunBlock; +typedef struct Md1Block { struct Md1; Scope* sc; Block* bl; } Md1Block; +typedef struct Md2Block { struct Md2; Scope* sc; Block* bl; } Md2Block; + + +Block* compile(B bcq, B objs, B blocks) { + usz bam = a(blocks)->ia; + + I32Arr* bca = toI32Arr(bcq); + i32* bc = bca->a; + usz bcl = bca->ia; + Comp* comp = mm_allocN(fsizeof(Comp,blocks,Block*,bam), t_comp); + comp->bc = tag(bca, ARR_TAG); + comp->objs = toHArr(objs); + B* blockDefs = toHArr(blocks)->a; + + for (usz i = 0; i < bam; i++) { + B cbld = blockDefs[i]; + if (a(cbld)->ia != 4) return c(Block,err("bad compile block")); // todo not cast errors here weirdly + BS2B bget = TI(cbld).get; + usz ty = o2s(bget(cbld,0)); if (ty<0|ty>2) return c(Block,err("bad block type")); + bool imm = o2s(bget(cbld,1)); // todo o2b or something + usz idx = o2s(bget(cbld,2)); if (idx>=bcl) return c(Block,err("oob bytecode index")); + usz vam = o2s(bget(cbld,3)); + i32* cbc = bc+idx; + + i32* scan = cbc; + i32 ssz = 0, mssz=0; + bool needsV0 = false; + while (*scan!=RETN & *scan!=RETD) { + ssz+= stackDiff(scan); + if (ssz>mssz) mssz = ssz; + if (*scan==LOCO|*scan==LOCM) { i32 d=scan[1]; i32 p=scan[2]; + if (d>U16_MAX) return c(Block,err("LOC_ too deep")); + if (d==0 & p==0) needsV0 = true; + } + scan = nextBC(scan); + if (scan-bc >= bcl) return c(Block,err("no RETN/RETD found at end of bytecode")); + } + + Body* body = mm_allocN(sizeof(Body), t_body); + body->comp = comp; + body->bc = cbc; + body->maxStack = mssz; + body->varAm = vam; + if (needsV0) body->flags|= 1; + + Block* bl = mm_allocN(sizeof(Block), t_block); + bl->body = body; + bl->imm = imm; + bl->ty = ty; + comp->blocks[i] = bl; + } + + Block* ret = c(Block,inci(tag(comp->blocks[0], OBJ_TAG))); + // TODO store blocks in each body, then decrement each of comp->blocks; also then move temp block list out of Comp as it's useless then + // for (usz i = 0; i < bam; i++) ptr_dec(comp->blocks[i]); + + dec(blocks); + return ret; +} + +Scope* scd(Scope* sc, u16 d) { + for (i32 i = 0; i < d; i++) sc = sc->psc; + return sc; +} + +B v_set(Scope* sc, B s, B x, bool upd) { // frees s, consumes x, returns previous value + if (isVar(s)) { + sc = scd(sc, (u16)(s.u>>32)); + B prev = sc->vars[(u32)s.u]; + if (upd) { + if (prev.u==bi_noVar.u) return err("updating undefined variable"); + dec(prev); + } else { + if (prev.u!=bi_noVar.u) return err("redefining variable"); + } + sc->vars[(u32)s.u] = x; + } else { + assert(isArr(s) && v(s)->type==t_harr); + if (!shEq(s, x)) return err("spread assignment: mismatched shape"); + usz ia = a(x)->ia; + B* sp = harr_ptr(s); + BS2B xget = TI(x).get; + for (u64 i = 0; i < ia; i++) v_set(sc, sp[i], xget(x,i), upd); + dec(s); dec(x); + } + return m_f64(0); +} +B v_get(Scope* sc, B s) { // get value representing s, replacing with bi_optOut; doesn't consume + if (isVar(s)) { + sc = scd(sc, (u16)(s.u>>32)); + B r = sc->vars[(u32)s.u]; + sc->vars[(u32)s.u] = bi_optOut; + return r; + } else { + assert(isArr(s) && v(s)->type==t_harr); + usz ia = a(s)->ia; + B* sp = harr_ptr(s); + HArr_p r = m_harrv(ia); + for (u64 i = 0; i < ia; i++) r.a[i] = v_get(sc, sp[i]); + return r.b; + } +} + +// none consume anything consume +B m_funBlock(Block* bl, Scope* psc); // may return evaluated result, whatever +B m_md1Block(Block* bl, Scope* psc); +B m_md2Block(Block* bl, Scope* psc); +#ifdef DEBUG_VM +i32 bcDepth=-2; +i32* vmStack; +i32 bcCtr = 0; +#endif +B evalBC(Body* b, Scope* sc) { + #ifdef DEBUG_VM + bcDepth+= 2; + if (!vmStack) vmStack = malloc(400); + i32 stackNum = bcDepth>>1; + vmStack[stackNum] = -1; + printf("new eval\n"); + #endif + B* objs = b->comp->objs->a; + Block** blocks = b->comp->blocks; + i32* bc = b->bc; + B stack[b->maxStack]; + i32 sh = 0; + #define POP stack[--sh] + #define P(N) B N=POP; + #define ADD stack[sh++] = + while(true) { + #ifdef DEBUG_VM + i32* sbc = bc; + i32 bcPos = sbc-c(I32Arr,b->comp->bc)->a; + vmStack[stackNum] = bcPos; + for(i32 i = 0; i < bcDepth; i++) printf(" "); + printBC(sbc); printf("@%d << ", bcPos); + for (i32 i = 0; i < sh; i++) { if(i)printf(" ⋄ "); print(stack[i]); } puts(""); fflush(stdout); + bcCtr++; + for (i32 i = 0; i < sc->varAm; i++) validate(sc->vars[i]); + #endif + switch(*bc++) { + case POPS: dec(POP); break; + case PUSH: { + ADD inci(objs[*bc++]); + break; + } + case FN1C: { P(f)P(x) + ADD c1(f, x); dec(f); + break; + } + case FN1O: { P(f)P(x) + ADD isNothing(x)? x : c1(f, x); dec(f); + break; + } + case FN2C: { P(w)P(f)P(x) + ADD c2(f, w, x); dec(f); + break; + } + case FN2O: { P(w)P(f)P(x) + if (isNothing(x)) { dec(w); ADD x; } + else ADD isNothing(w)? c1(f, x) : c2(f, w, x); + dec(f); + break; + } + case ARRO: case ARRM: { + i32 sz = *bc++; + HArr_p r = m_harrv(sz); + for (i32 i = 0; i < sz; i++) r.a[sz-i-1] = POP; + ADD r.b; + break; + } + case DFND: { + Block* bl = blocks[*bc++]; + switch(bl->ty) { default: UD; + case 0: ADD m_funBlock(bl, sc); break; + case 1: ADD m_md1Block(bl, sc); break; + case 2: ADD m_md2Block(bl, sc); break; + } + break; + } + case OP1D: { P(f)P(m) ADD m1_d (m,f ); break; } + case OP2D: { P(f)P(m)P(g) ADD m2_d (m,f,g); break; } + case OP2H: { P(m)P(g) ADD m2_h (m, g); break; } + case TR2D: { P(g)P(h) ADD m_atop( g,h); break; } + case TR3D: { P(f)P(g)P(h) ADD m_fork(f,g,h); break; } + case TR3O: { P(f)P(g)P(h) + if (isNothing(f)) { ADD m_atop(g,h); dec(f); } + else ADD m_fork(f,g,h); + break; + } + case LOCM: { i32 d = *bc++; i32 p = *bc++; + ADD tag((u64)d<<32 | p, VAR_TAG); + break; + } + case LOCO: { i32 d = *bc++; i32 p = *bc++; + ADD inci(scd(sc,d)->vars[p]); + break; + } + case SETN: { P(s) P(x) v_set(sc, s, inci(x), false); ADD x; break; } + case SETU: { P(s) P(x) v_set(sc, s, inci(x), true ); ADD x; break; } + case SETM: { P(s)P(f)P(x) + B w = v_get(sc, s); + B r = c2(f,w,x); dec(f); + v_set(sc, s, inci(r), true); + ADD r; + break; + } + // not implemented: VARO VARM CHKV VFYM SETH FLDO FLDM NSPM RETD SYSV + default: printf("todo %d\n", bc[-1]); bc++; break; + case RETN: goto end; + } + #ifdef DEBUG_VM + for(i32 i = 0; i < bcDepth; i++) printf(" "); + printBC(sbc); printf("@%ld: ", sbc-c(I32Arr,b->comp->bc)->a); + for (i32 i = 0; i < sh; i++) { if(i)printf(" ⋄ "); print(stack[i]); } puts(""); fflush(stdout); + #endif + } + #undef P + #undef ADD + #undef POP + end:; + #ifdef DEBUG_VM + bcDepth-= 2; + #endif + assert(sh==1); + return stack[0]; +} + +B actualExec(Block* bl, Scope* psc, u32 ga, ...) { + Body* bdy = bl->body; + Scope* sc = mm_allocN(fsizeof(Scope, vars, B, bdy->varAm), t_scope); + sc->psc = psc; if(psc)ptr_inc(psc); + u16 varAm = sc->varAm = bdy->varAm; + assert(varAm>=ga); + sc->bcInd = bdy->bc-c(I32Arr,bdy->comp->bc)->a; + i32 i = 0; + va_list vargs; + va_start(vargs, ga); + while (ivars[i++] = va_arg(vargs, B); + while (ivars[i++] = bi_noVar; + va_end(vargs); + // if (ga & !(bdy->flags&1)) { + // B v0 = sc->vars[0]; + // dec(v0); sc->vars[0] = bi_optOut; // prevent reference cycle; TODO more properly do this (or just remove, it doesn't seem to be doing much) + // } + B r = evalBC(bdy, sc); + ptr_dec(sc); + return r; +} + +B funBl_c1(B t, B x) { return actualExec(c(FunBlock, t)->bl, c(FunBlock, t)->sc, 3, inci(t), x, bi_nothing); } +B funBl_c2(B t, B w, B x) { return actualExec(c(FunBlock, t)->bl, c(FunBlock, t)->sc, 3, inci(t), x, w); } +B md1Bl_c1(B t, B f, B x) { return actualExec(c(Md1Block, t)->bl, c(Md1Block, t)->sc, 5, m_md1D(inci(t),inci(f) ), x, bi_nothing, inci(t), inci(f)); } +B md1Bl_c2(B t, B f, B w, B x) { return actualExec(c(Md1Block, t)->bl, c(Md1Block, t)->sc, 5, m_md1D(inci(t),inci(f) ), x, w , inci(t), inci(f)); } +B md2Bl_c1(B t, B f, B g, B x) { return actualExec(c(Md2Block, t)->bl, c(Md2Block, t)->sc, 6, m_md2D(inci(t),inci(f),inci(g)), x, bi_nothing, inci(t), inci(f), inci(g)); } +B md2Bl_c2(B t, B f, B g, B w, B x) { return actualExec(c(Md2Block, t)->bl, c(Md2Block, t)->sc, 6, m_md2D(inci(t),inci(f),inci(g)), x, w , inci(t), inci(f), inci(g)); } +B m_funBlock(Block* bl, Scope* psc) { + if (bl->imm) return actualExec(bl, psc, 0); + B r = mm_alloc(sizeof(FunBlock), t_fun_block, ftag(FUN_TAG)); + c(FunBlock, r)->bl = bl; ptr_inc(bl); + c(FunBlock, r)->sc = psc; ptr_inc(psc); + c(FunBlock, r)->c1 = funBl_c1; + c(FunBlock, r)->c2 = funBl_c2; + return r; +} +B m_md1Block(Block* bl, Scope* psc) { + B r = mm_alloc(sizeof(Md1Block), t_md1_block, ftag(MD1_TAG)); + c(Md1Block, r)->bl = bl; ptr_inc(bl); + c(Md1Block, r)->sc = psc; ptr_inc(psc); + c(Md1Block, r)->c1 = md1Bl_c1; + c(Md1Block, r)->c2 = md1Bl_c2; + return r; +} +B m_md2Block(Block* bl, Scope* psc) { + B r = mm_alloc(sizeof(Md2Block), t_md2_block, ftag(MD2_TAG)); + c(Md2Block, r)->bl = bl; ptr_inc(bl); + c(Md2Block, r)->sc = psc; ptr_inc(psc); + c(Md2Block, r)->c1 = md2Bl_c1; + c(Md2Block, r)->c2 = md2Bl_c2; + return r; +} + +void comp_free(B x) { Comp* c = c(Comp ,x); ptr_dec(c->objs); dec(c->bc); } +void body_free(B x) { Body* c = c(Body ,x); ptr_dec(c->comp); } +void block_free(B x) { Block* c = c(Block,x); ptr_dec(c->body); } +void scope_free(B x) { + Scope* c = c(Scope,x); + if (c->psc) ptr_dec(c->psc); + u16 am = c->varAm; + for (u32 i = 0; i < am; i++) dec(c->vars[i]); +} +void funBl_free(B x) { FunBlock* c = c(FunBlock,x); ptr_dec(c->sc); ptr_dec(c->bl); } +void md1Bl_free(B x) { Md1Block* c = c(Md1Block,x); ptr_dec(c->sc); ptr_dec(c->bl); } +void md2Bl_free(B x) { Md2Block* c = c(Md2Block,x); ptr_dec(c->sc); ptr_dec(c->bl); } + +void comp_print (B x) { printf("(%p: comp)",v(x)); } +void body_print (B x) { printf("(%p: body varam=%d)",v(x),c(Body,x)->varAm); } +void block_print(B x) { printf("(%p: block for %p)",v(x),c(Block,x)->body); } +void scope_print(B x) { printf("(%p: scope; vars:",v(x));Scope*sc=c(Scope,x);for(u64 i=0;ivarAm;i++){printf(" ");print(sc->vars[i]);}printf(")"); } + +// void funBl_print(B x) { printf("(%p: function"" block bl=%p sc=%p)",v(x),c(FunBlock,x)->bl,c(FunBlock,x)->sc); } +// void md1Bl_print(B x) { printf("(%p: 1-modifier block bl=%p sc=%p)",v(x),c(Md1Block,x)->bl,c(Md1Block,x)->sc); } +// void md2Bl_print(B x) { printf("(%p: 2-modifier block bl=%p sc=%p)",v(x),c(Md2Block,x)->bl,c(Md2Block,x)->sc); } +// void funBl_print(B x) { printf("(%p: function"" block @%ld)",v(x),c(FunBlock,x)->bl->body->bc-c(I32Arr,c(FunBlock,x)->bl->body->comp->bc)->a); } +// void md1Bl_print(B x) { printf("(%p: 1-modifier block @%ld)",v(x),c(Md1Block,x)->bl->body->bc-c(I32Arr,c(Md1Block,x)->bl->body->comp->bc)->a); } +// void md2Bl_print(B x) { printf("(%p: 2-modifier block @%ld)",v(x),c(Md2Block,x)->bl->body->bc-c(I32Arr,c(Md2Block,x)->bl->body->comp->bc)->a); } +void funBl_print(B x) { printf("{function""}"); } +void md1Bl_print(B x) { printf("{1-modifier}"); } +void md2Bl_print(B x) { printf("{2-modifier}"); } + +B block_decompose(B x) { return m_v2(m_i32(1), x); } + +B bl_m1d(B m, B f ) { Md1Block* c = c(Md1Block,m); return c->bl->imm? actualExec(c(Md1Block, m)->bl, c(Md1Block, m)->sc, 2, m, f ) : m_md1D(m,f ); } +B bl_m2d(B m, B f, B g) { Md2Block* c = c(Md2Block,m); return c->bl->imm? actualExec(c(Md2Block, m)->bl, c(Md2Block, m)->sc, 3, m, f, g) : m_md2D(m,f,g); } + +void comp_init() { + ti[t_comp ].free = comp_free; ti[t_comp ].print = comp_print; + ti[t_body ].free = body_free; ti[t_body ].print = body_print; + ti[t_block ].free = block_free; ti[t_block ].print = block_print; + ti[t_scope ].free = scope_free; ti[t_scope ].print = scope_print; + ti[t_fun_block].free = funBl_free; ti[t_fun_block].print = funBl_print; ti[t_fun_block].decompose = block_decompose; + ti[t_md1_block].free = md1Bl_free; ti[t_md1_block].print = md1Bl_print; ti[t_md1_block].decompose = block_decompose; ti[t_md1_block].m1_d=bl_m1d; + ti[t_md2_block].free = md2Bl_free; ti[t_md2_block].print = md2Bl_print; ti[t_md2_block].decompose = block_decompose; ti[t_md2_block].m2_d=bl_m2d; +} + +void print_vmStack() { + #ifdef DEBUG_VM + printf("vm stack:"); + for (i32 i = 0; i < (bcDepth>>1) + 1; i++) { printf(" %d", vmStack[i]); fflush(stdout); } + printf("\n"); fflush(stdout); + #endif +} \ No newline at end of file diff --git a/test.bqn b/test.bqn new file mode 100755 index 00000000..e7ea09a4 --- /dev/null +++ b/test.bqn @@ -0,0 +1,29 @@ +#! /usr/bin/env dbqn +"usage: test.bqn path/to/mlochbaum/BQN ""$PATH"" [optional expressions to evaluate]"!2≤≠•args +path←0⊑•args +envP←1⊑•args + +tests ← •FLines path∾"/test/cases/prim.bqn" +# tests ← •FLines path∾"/test/cases/identity.bqn" +# tests ← •FLines path∾"/test/cases/under.bqn" +# tests ← •FLines path∾"/test/cases/fill.bqn" +# tests ← •FLines "primLeft.bqn" +{tests↩𝕩}⍟(×≠) 2↓•args + +('#'≠ ·⊑ ∾⟜"#")◶@‿{ + '%'⊸∊◶{𝕤 + •Out 𝕩 + "src/interp" •FChars ⟨1,path,𝕩⟩ •Import "cc.bqn" + (×⊑)◶@‿{𝕤⋄•Out "############ Failed to compile! ############" ⋄ •Out¨1↓𝕩}{env⇐<"PATH="∾envP}•SH"./debugBuild" + code‿out‿err←•SH"./BQN" + •Out out + {𝕤⋄•Out"exit code "∾(⍕code) ⋄ •Out err}⍟(×code) err + }‿{𝕤 + # •Out 𝕩 + # "src/interp" •FChars ⟨1,path,3↓𝕩⟩ •Import "cc.bqn" + # (×⊑)◶@‿{𝕤⋄•Out "############ Failed to compile! ############" ⋄ •Out¨1↓𝕩}{env⇐<"PATH="∾envP}•SH"./debugBuild" + # code‿out‿err←•SH"./BQN" + # •Out out + # {𝕤⋄•Out"exit code "∾(⍕code) ⋄ •Out err}⍟(×code) err + } +}¨tests \ No newline at end of file