diff options
Diffstat (limited to 'docs/history/15-o3/code/src')
| -rw-r--r-- | docs/history/15-o3/code/src/compiler.zc | 2832 | ||||
| -rw-r--r-- | docs/history/15-o3/code/src/rt.zc | 290 |
2 files changed, 0 insertions, 3122 deletions
diff --git a/docs/history/15-o3/code/src/compiler.zc b/docs/history/15-o3/code/src/compiler.zc deleted file mode 100644 index 6e2388b..0000000 --- a/docs/history/15-o3/code/src/compiler.zc +++ /dev/null @@ -1,2832 +0,0 @@ -// ============================================================================ -// compiler.zc: the resident zc compiler. it lives in the genome next to the -// runtime, compiles source straight to vm words in memory, and is visible to -// the programs it compiles: every function and global here can be called or -// patched by name, and parse words (immediate fns) run inside it. -// ============================================================================ - -// ---- compiler data region (fixed addresses, 0xA0100 .. 0xBE100) ---- -const IHN = 8192; -const R_IH = 0xA0100; // intern hash table -const R_POOL = 0xA2100; // interned strings: [symbol head] chars 0 -const R_POOLEND = 0xAC000; -const NS = 4096; // symbol table, one array per field -const R_SYM = 0xAC100; -const sname = 0xAC100, skind = 0xAD100, sval = 0xAE100, ssig = 0xAF100; -const sflag = 0xB0100, sfix = 0xB1100, snext = 0xB2100; -const NL = 512; // locals, one array per field -const lname = 0xB3100, lslot = 0xB3300, lhome = 0xB3500, lstate = 0xB3700; -const lowner = 0xB3900, lused = 0xB3B00, larr = 0xB3D00, lown = 0xB3F00; // lown: has owned an object -const NF = 8192; // patch nodes: a site and a link -const fsite = 0xB4100, fnext = 0xB6100; -const R_SNAP = 0xB8100; // analyzer snapshots -const R_QBUF = 0xBA100; // token buffer for quote and grab -const R_SRC = 0xBC100; // input source stack, 32 words per frame -const R_SEQ = 0xBC500; // operator code sequences -const bname = 0xBCD00, bprec = 0xBCD40, bseq = 0xBCD80, blen = 0xBCDC0; // binary operators -const uname = 0xBCE00, useq = 0xBCE20, ulen = 0xBCE40; // unary operators -const aname = 0xBCE60, abin = 0xBCEA0; // compound assignment -const kops = 0xBCF00; // every operator spelling the lexer knows -const R_CTX = 0xBD100; // saved compiler contexts for nested compiles -const R_LOOP = 0xBD900; // loop stack, 8 words per loop or switch -const R_ASM = 0xBDD00; // asm block labels - -// ---- token kinds, symbol kinds and flags ---- -const T_EOF = 0, T_NUM = 1, T_ID = 2, T_STR = 3, T_OP = 4; -const K_FN = 1, K_GVAR = 2, K_GARR = 3, K_CONST = 4, K_KW = 5, K_ENH = 6, K_TYPE = 7; -const F_DEF = 1, F_SIG = 2, F_UNTYPED = 4, F_STMT = 8, F_EXPR = 16, F_TOP = 32, F_FALLBACK = 64, F_GEN = 128, F_PRE = 256; -// variable states for the lifetime analyzer -const S_PLAIN = 0, S_M = 1, S_U = 2, S_D = 3, S_DEAD = 4, S_CHILD = 5, S_BORROW = 6; -// expression classes: plain word, a new object, or a bare variable (C_VAR + index) -const C_PLAIN = 0, C_FRESH = 1, C_VAR = 2; -// lvalue kinds -const LV_NONE = 0, LV_LOCAL = 1, LV_GLOBAL = 2, LV_ELEM = 3, LV_OTHER = 4; -// opcodes -const O_Q = 0, O_LD = 1, O_ST = 2, O_PICK = 3, O_DROP = 4, O_SWAP = 5, O_CALL = 6, O_JMP = 7; -const O_JZ = 8, O_RET = 9, O_ADD = 13, O_SUB = 14, O_LT = 20; -const XOP0 = 22; // first enhancement opcode -const SEQREF = -2; // in an operator sequence: the next word names a symbol - -// ---- state ---- -let nenh, pooltop, nsym, ubase, vislo, nfixu, fixfree; -let nbin, nun, nasg, nkop, seqtop; -let mnem = "q@!$_~cjzr,?.+-*&|^><%"; -let check_on = 1; // set to 0 to switch the analyzer off for what follows -let tk, tv, tglue, tline, line = 1, ch, chkind, chptr, chbase, qdone, isp = -1; -let tbuf[1100]; -let pk_tk, pk_tv, pq_n, pq_tk[4], pq_tv[4], pq_gl[4], pq_ln[4]; // up to 4 tokens of lookahead -let here, hdelta, hlimit, ptop; -let nloc, lbase, fdepth, fslots, fchk, fret, live, bxdepth, epichain, fframe, infn; -let lsp, loopbase, ctxsp, snaptop; -let lv, lvk, lvi, kw_expr, xcls, fty; -// interned spellings the parser compares against -let s_lp, s_rp, s_lb, s_rb, s_lk, s_rk, s_comma, s_semi, s_eq, s_arrow, s_inc, s_dec; -let s_star, s_amp, s_colon, s_hash, s_minus, s_andand, s_oror; -let s_dot, s_fn, s_var, s_const, s_else, s_as, s_unchecked, s_immediate, s_m, s_d, s_u; -let s_q, s_case, s_default, s_fovf, s_start, s_main, s_free, s_own, s_qnew, s_enhance, s_micro, s_vm; - -// ---- types: kinds, tables and parser state (see the types section) ---- -const TY_WORD = 0, TY_INT = 1, TY_CHAR = 2, TY_BOOL = 3, TY_VOID = 4, TY_PTR = 5, TY_ARR = 6; -const TY_FN = 7, TY_STRUCT = 8, TY_VAR = 9, TY_GEN = 10, TY_DYN = 11; // dyn: []T, a = element, n = 1 if fixed -const R_TY = 0x9C000, R_TYEND = 0xA0000, NTL = 1024; // the first NTL words list every record -const ltype = 0xBE100, ltag = 0xBE300, stype = 0xBE500; // type per local, declared tag per local, type per symbol -let tytop, ntl, tword, tint, tchar, tbool, tvoid; -let tc_on; // the optional typechecker, off unless a program says typecheck on; -let xty, xzero, dry; // type of the last expression, was it a literal 0, and dry runs (typeof) -let tpn[8], ntp; // type parameters in scope -let dty, dtag; // result of dtype() -let s_lt, s_gt, s_shr, s_le, s_ge, s_eqeq, s_ne, s_plus, s_struct, s_type, s_typecheck, s_on, s_off, s_new, s_new_t; -let s_o3, s_lfa, s_outside, s_new_raw, s_oob; -let o3on, o3nxt, o3one, o3sl[8], no3sl, o3pend[200], no3pend, o3dsc[16]; // o3: in an o3 region; the promoted slots; o3 blocks waiting for the function's end -let numops[12], nnumops, s_fixed, s_dlen, s_dcap, s_dnew, s_dat, s_dpush, s_dpop, s_dresize, xconst, xcval; -let gbind[8], ngbind; // explicit type arguments for the next call: f<int>(...) - -// ---- errors ---- -// the compiler reports up to 20 errors before it stops. a syntax error -// (die) skips the token it happened on and sets panic, which skips ahead to -// the next ; or } (or the next top-level item) and keeps quiet until then. -// other errors (serr) just report: the parse is still in step. -let nerr, panic; -fn errat() { puts("zc: line "); putn(tline); puts(": "); nerr++; return 0; } -fn errend() { putc(10); if (nerr >= 20) { puts("zc: too many errors, stopping\n"); halt(); } return 0; } -fn giveup() { puts("zc: "); putn(nerr); if (nerr == 1) puts(" error\n"); else puts(" errors\n"); halt(); return 0; } -fn fatal(msg) { errat(); puts(msg); putc(10); halt(); return 0; } -fn serr(msg) { if (!panic && !dry) { errat(); puts(msg); errend(); } return 0; } -fn serrn(name, msg) { if (!panic && !dry) { errat(); puts(name); puts(": "); puts(msg); errend(); } return 0; } -fn die(msg) { serr(msg); panic = 1; if (tk == T_EOF) giveup(); next(); return 0; } -fn dien(name, msg) { serrn(name, msg); panic = 1; if (tk == T_EOF) giveup(); next(); return 0; } -// analyzer errors only count in checked, reachable code -fn cerr(msg) { if (fchk && live) serr(msg); return 0; } -fn cerrn(i, msg) { if (fchk && live) serrn(lname[i], msg); return 0; } - -// ---- interning ---- -fn hashs(s) { let h = 0; while (*s) { h = h * 31 + *s; s++; } return h & (IHN - 1); } -fn intern(s) -{ - let h = hashs(s), p, n; - while (1) { - p = R_IH[h]; - if (!p) break; - if (streq(p, s)) return p; - h = (h + 1) & (IHN - 1); - } - n = strlen(s); - if (pooltop + n + 2 >= R_POOLEND) fatal("string pool full"); - pooltop[0] = 0; - p = pooltop + 1; - wcopy(p, s, n + 1); - pooltop = pooltop + n + 2; - R_IH[h] = p; - return p; -} - -// ---- symbols ---- -// each interned name keeps the index (+1) of its newest symbol in p[-1], and -// each symbol links to the one it shadows, so lookup is one step. -fn addsym(name, kind, val) -{ - let i = nsym; - if (nsym >= NS) fatal("symbol table full"); - nsym++; - sname[i] = name; skind[i] = kind; sval[i] = val; ssig[i] = 0; sflag[i] = F_DEF; sfix[i] = 0; stype[i] = 0; - snext[i] = name[-1]; - name[-1] = i + 1; - return i; -} -// while an image builds, names below vislo are hidden, except keywords -fn lookup(name) -{ - let i = name[-1] - 1; - while (i >= 0) { - if (i >= vislo || skind[i] == K_KW || skind[i] == K_TYPE) return i; - i = snext[i] - 1; - } - return -1; -} -fn popsyms(to) { while (nsym > to) { nsym--; sname[nsym][-1] = snext[nsym]; } return 0; } -fn lookups(s) { return lookup(intern(s)); } - -// patch nodes -fn fixnew(site, link) -{ - let i = fixfree; - if (i) fixfree = fnext[i]; - else { nfixu++; i = nfixu; if (i >= NF) fatal("too many forward references"); } - fsite[i] = site; fnext[i] = link; - return i; -} -// patch every lit in a chain to point at v, and recycle the nodes -fn fixall(head, v) -{ - let n; - while (head) { setlit(fsite[head], v); n = fnext[head]; fnext[head] = fixfree; fixfree = head; head = n; } - return 0; -} - -// ---- code emission ---- -fn emit(w) { if (dry) return 0; if (here >= hlimit) fatal("program too big"); *(here + hdelta) = w; here++; return 0; } -fn lit(v) { emit(v + v + 1); return 0; } -fn op(k) { emit(k + k); return 0; } -fn setlit(at, v) { if (dry) return 0; *(at + hdelta) = v + v + 1; return 0; } -fn jmp(t) { lit(t); op(O_JMP); return 0; } -// a lit that will be patched later; returns its address -fn hole() { let a = here; lit(MW - 1); return a; } -fn fwdfn(name) { let s = addsym(name, K_FN, tline); sflag[s] = 0; return s; } // the line of the first use, until it's defined -fn fnref(s) -{ - if (sflag[s] & F_DEF) { lit(sval[s]); return 0; } - if (dry) return 0; - sfix[s] = fixnew(here, sfix[s]); - lit(MW - 1); // a jump to MW-1 halts if it ever runs unpatched - return 0; -} -fn callname(name) { let s = lookup(name); if (s < 0) s = fwdfn(name); fnref(s); op(O_CALL); return 0; } -fn laddr(k) { lit(ZFP); op(O_LD); if (k) { lit(k); op(O_ADD); } return 0; } -// an o3 variable's address: lfa(k) is fp + k as one enhancement, which the -// jit specializes on the literal k -fn vaddr(i) -{ - let s; - if (ltag[i] & 16) { s = lookup(s_lfa); if (s >= 0 && skind[s] == K_ENH) { lit(lslot[i]); op(XOP0 + sval[s]); return 0; } } - return laddr(lslot[i]); -} -// the slots an o3 region keeps in registers (the cpu takes 7) -fn addsl(k) -{ - let i = 0; - while (i < no3sl) { if (o3sl[i] == k) return 0; i++; } - if (no3sl < 7) { o3sl[no3sl] = k; no3sl++; } - return 0; -} -// hands a region to the cpu: install kind 2 is [-, 2, lo, hi, n, slots...] -fn o3region(lo, hi, sl, n) -{ - if (hdelta || lo >= hi) return 0; - o3dsc[0] = 0; o3dsc[1] = 2; o3dsc[2] = lo; o3dsc[3] = hi; o3dsc[4] = n; - wcopy(o3dsc + 5, sl, n); - install(o3dsc); - return 0; -} -// o3 blocks go to the cpu once their function is done, so every jump in them is final -fn o3flush() -{ - let i = 0, p; - while (i < no3pend) { p = o3pend + i * 10; o3region(p[0], p[1], p + 3, p[2]); i++; } - no3pend = 0; - return 0; -} -fn strlit(s) -{ - let j = hole(), a; - op(O_JMP); - a = here; - while (*s) { emit(*s); s++; } - emit(0); - setlit(j, here); - lit(a); - return 0; -} - -// ---- input sources ---- -// frame: 0 kind (0 stdin, 1 token list, 2 string) 1 object 2 index 3 end -// 4 transparent 5..7 saved token 8..10 saved char state 11 owned 12 saved line -// 13 saved token line 14 saved lookahead count 15..30 saved lookahead 31 saved char buffer -fn nextch() -{ - if (chkind == 0) { - if (qdone || eof()) { ch = -1; return 0; } - ch = getc() & 255; - if (ch == 96) { qdone = 1; ch = -1; return 0; } // a backtick ends the source - } else if (chkind == 3) { - ch = (chbase[chptr >> 2] >> ((chptr & 3) * 8)) & 255; - if (ch) chptr++; else ch = -1; - } else { - ch = *chptr & 255; - if (ch) chptr++; else ch = -1; - } - if (ch == 10) line++; - return 0; -} -fn src_push(kind, obj, trans, owned) -{ - let f, i; - isp++; - if (isp >= 32) fatal("sources nested too deeply"); - f = R_SRC + isp * 32; - f[0] = kind; f[1] = obj; f[2] = 0; f[3] = 0; f[4] = trans; f[11] = owned; - f[5] = tk; f[6] = tv; f[7] = tglue; f[8] = ch; f[9] = chkind; f[10] = chptr; - f[12] = line; f[13] = tline; f[14] = pq_n; f[31] = chbase; - i = 0; while (i < pq_n) { f[15 + i * 4] = pq_tk[i]; f[16 + i * 4] = pq_tv[i]; f[17 + i * 4] = pq_gl[i]; f[18 + i * 4] = pq_ln[i]; i++; } - pq_n = 0; - if (kind == 1) f[3] = obj[0]; - if (kind == 0) { chkind = 0; qdone = 0; line = 1; nextch(); } - if (kind == 2) { chkind = 2; chptr = obj; line = 1; nextch(); } - if (kind == 3) { chkind = 3; chbase = obj; chptr = 0; line = 1; nextch(); } - return 0; -} -fn src_pop() -{ - let f = R_SRC + isp * 32, i = 0; - tk = f[5]; tv = f[6]; tglue = f[7]; ch = f[8]; chkind = f[9]; chptr = f[10]; - line = f[12]; tline = f[13]; pq_n = f[14]; chbase = f[31]; - while (i < pq_n) { pq_tk[i] = f[15 + i * 4]; pq_tv[i] = f[16 + i * 4]; pq_gl[i] = f[17 + i * 4]; pq_ln[i] = f[18 + i * 4]; i++; } - isp--; - if (f[11]) free(f[1]); - return 0; -} -fn isopch(c) -{ - let s = "+-*/%=<>!&|^~?:.@#$"; - while (*s) { if (*s == c) return 1; s++; } - return 0; -} -// is buf[0..n) followed by c the start of some operator the lexer knows? -fn opprefix(n, c) -{ - let i = 0, k, j; - while (i < nkop) { - k = kops[i]; - j = 0; - while (j < n && k[j] == tbuf[j]) j++; - if (j == n && k[n] == c) return 1; - i++; - } - return 0; -} -fn isdig(c) { return c >= '0' && c <= '9'; } -fn isal(c) { return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c == '_'; } -fn hexv(c) -{ - if (isdig(c)) return c - '0'; - if (c >= 'a' && c <= 'f') return c - 'a' + 10; - if (c >= 'A' && c <= 'F') return c - 'A' + 10; - return -1; -} -fn escch() -{ - let c = ch; - nextch(); - if (c != 92) return c; - c = ch; - nextch(); - if (c == 'n') return 10; - if (c == 't') return 9; - if (c == 'r') return 13; - if (c == '0') return 0; - if (c == 'e') return 27; - return c; -} -fn oplex(n) -{ - while (ch >= 0 && isopch(ch) && opprefix(n, ch)) { tbuf[n] = ch; n++; nextch(); } - tbuf[n] = 0; - tk = T_OP; tv = intern(tbuf); - return 0; -} -fn lex() -{ - let n = 0, v, dg; - tglue = 1; - while (1) { - while (ch == 32 || ch == 9 || ch == 10 || ch == 13) { nextch(); tglue = 0; } - if (ch != '/') break; - nextch(); - if (ch == '/') { while (ch >= 0 && ch != 10) nextch(); tglue = 0; continue; } - if (ch == '*') { - nextch(); - while (ch >= 0) { if (ch == '*') { nextch(); if (ch == '/') break; } else nextch(); } - nextch(); tglue = 0; continue; - } - tline = line; tbuf[0] = '/'; oplex(1); return 0; - } - tline = line; - if (ch < 0) { tk = T_EOF; tv = 0; return 0; } - if (isdig(ch)) { - v = 0; - if (ch == '0') { - nextch(); - if (ch == 'x' || ch == 'X') { - nextch(); - while ((dg = hexv(ch)) >= 0) { v = v * 16 + dg; nextch(); } - tk = T_NUM; tv = v; return 0; - } - } - while (isdig(ch)) { v = v * 10 + ch - '0'; nextch(); } - tk = T_NUM; tv = v; return 0; - } - if (isal(ch)) { - while (isal(ch) || isdig(ch)) { if (n < 1000) { tbuf[n] = ch; n++; } nextch(); } - tbuf[n] = 0; - tk = T_ID; tv = intern(tbuf); return 0; - } - if (ch == 39) { nextch(); tv = escch(); if (ch != 39) die("bad character literal"); nextch(); tk = T_NUM; return 0; } - if (ch == 34) { - nextch(); - while (ch >= 0 && ch != 34) { v = escch(); if (n < 1000) { tbuf[n] = v; n++; } } - nextch(); - tbuf[n] = 0; - tk = T_STR; tv = intern(tbuf); return 0; - } - tbuf[0] = ch; - nextch(); - if (isopch(tbuf[0])) return oplex(1); - tbuf[1] = 0; - tk = T_OP; tv = intern(tbuf); - return 0; -} -// one token of lookahead: peek() fills pk_*, next() takes it first -fn next() -{ - let i = 1; - if (pq_n) { - tk = pq_tk[0]; tv = pq_tv[0]; tglue = pq_gl[0]; tline = pq_ln[0]; - while (i < pq_n) { pq_tk[i - 1] = pq_tk[i]; pq_tv[i - 1] = pq_tv[i]; pq_gl[i - 1] = pq_gl[i]; pq_ln[i - 1] = pq_ln[i]; i++; } - pq_n--; - return 0; - } - return next0(); -} -// the k-th token after the current one (k from 0 to 3), into pk_tk and pk_tv -fn peekat(k) -{ - let a, b, c, e; - while (pq_n <= k) { - a = tk; b = tv; c = tglue; e = tline; - next0(); - pq_tk[pq_n] = tk; pq_tv[pq_n] = tv; pq_gl[pq_n] = tglue; pq_ln[pq_n] = tline; pq_n++; - tk = a; tv = b; tglue = c; tline = e; - } - pk_tk = pq_tk[k]; pk_tv = pq_tv[k]; - return 0; -} -fn peek() { return peekat(0); } -fn next0() -{ - let f, q, i; - f = R_SRC + isp * 32; - if (f[0] != 1) { lex(); return 0; } - i = f[2]; - if (i < f[3]) { q = f[1]; tk = q[1 + i * 3]; tv = q[2 + i * 3]; tline = q[3 + i * 3]; tglue = 0; f[2] = i + 1; return 0; } - if (!f[4]) { tk = T_EOF; tv = 0; return 0; } - src_pop(); // a fed list ran out: continue with the token that followed it - return 0; -} -fn is_op(s) { return tk == T_OP && tv == s; } -fn is_id(s) { return tk == T_ID && tv == s; } -fn accept(s) { if ((tk == T_OP || tk == T_ID) && tv == s) { next(); return 1; } return 0; } -fn expect(s) { if (!accept(s)) { if (!panic && !dry) { errat(); puts("expected "); puts(s); errend(); } panic = 1; if (tk == T_EOF) giveup(); } return 0; } -fn name() -{ - let n = tv; - if (tk != T_ID) die("expected a name"); - next(); - return n; -} - -// ---- operator tables ---- -// a sequence is written like asm: one-char mnemonics, numbers, and names -// (resolved when the operator is used, so image builds stay self-contained) -fn seqasm(s) -{ - let start = seqtop, n, neg, v, k, c; - while (1) { - while (*s == 32) s++; - if (!*s) break; - n = 0; - while (s[n] && s[n] != 32) { tbuf[n] = s[n]; n++; } - tbuf[n] = 0; - s = s + n; - neg = tbuf[0] == '-' && isdig(tbuf[1]); - if (isdig(tbuf[neg])) { - v = 0; k = neg; - while (tbuf[k]) { v = v * 10 + tbuf[k] - '0'; k++; } - if (neg) v = 0 - v; - R_SEQ[seqtop] = v + v + 1; seqtop++; - } else if (n == 1 && (c = mnemidx(tbuf[0])) >= 0) { - R_SEQ[seqtop] = c + c; seqtop++; - } else { - R_SEQ[seqtop] = SEQREF; R_SEQ[seqtop + 1] = intern(tbuf); seqtop = seqtop + 2; - } - } - return start; -} -fn mnemidx(c) { let i = 0; while (mnem[i]) { if (mnem[i] == c) return i; i++; } return -1; } -fn emitseq(a, n) -{ - let e = a + n, s; - while (a < e) { - if (R_SEQ[a] == SEQREF) { - s = lookup(R_SEQ[a + 1]); - if (s < 0) s = fwdfn(R_SEQ[a + 1]); - if (skind[s] == K_FN) fnref(s); else if (skind[s] == K_ENH) op(XOP0 + sval[s]); else lit(sval[s]); - a = a + 2; - } else { emit(R_SEQ[a]); a++; } - } - return 0; -} -fn addkop(p) { let i = 0; while (i < nkop) { if (kops[i] == p) return 0; i++; } kops[nkop] = p; nkop++; return 0; } -fn binfind(p) { let i = nbin; while (i) { i--; if (bname[i] == p) return i; } return -1; } -fn unfind(p) { let i = nun; while (i) { i--; if (uname[i] == p) return i; } return -1; } -fn asgfind(p) { let i = nasg; while (i) { i--; if (aname[i] == p) return i; } return -1; } -// add or replace a binary operator. code is a sequence string, or 0 for the -// built-in && (prec 2) and || (prec 1) behaviour, chosen by -1 / -2 in prec. -fn add_binop(nm, prec, code) -{ - let p = intern(nm), i = binfind(p), a, n; - if (i < 0) { i = nbin; nbin++; } - bname[i] = p; bprec[i] = prec; - if (prec < 0) { bprec[i] = 0 - prec; blen[i] = prec; bseq[i] = 0; addkop(p); return i; } - bseq[i] = seqasm(code); blen[i] = seqtop - bseq[i]; - addkop(p); - // and its compound assignment, x op= y - n = strlen(nm); - wcopy(tbuf + 1000, nm, n); - tbuf[1000 + n] = '='; tbuf[1001 + n] = 0; - a = intern(tbuf + 1000); - if (prec >= 8 || prec == 5 || prec == 4 || prec == 3) { - if (asgfind(a) < 0) { aname[nasg] = a; nasg++; } - abin[asgfind(a)] = i; - addkop(a); - } - return i; -} -fn add_unop(nm, code) -{ - let p = intern(nm), i = unfind(p); - if (i < 0) { i = nun; nun++; } - uname[i] = p; useq[i] = seqasm(code); ulen[i] = seqtop - useq[i]; - addkop(p); - return i; -} -fn add_kw(nm, handler, flags) { let s = addsym(intern(nm), K_KW, handler); sflag[s] = F_DEF | flags; return s; } - -// ---- locals and the analyzer's view of them ---- -fn findloc(n) { let i = nloc; while (i > lbase) { i--; if (lname[i] == n) return i; } return -1; } -fn newloc(n) -{ - let i = nloc; - if (nloc >= NL) fatal("too many locals"); - nloc++; - lname[i] = n; lslot[i] = fslots; lhome[i] = fdepth; lstate[i] = S_PLAIN; - lowner[i] = 0; lused[i] = 0; larr[i] = 0; lown[i] = 0; ltype[i] = tword; ltag[i] = 0; - return i; -} -fn lroot(i) { while (lstate[i] == S_CHILD) i = lowner[i]; return i; } -fn tracked(i) { return lstate[i] != S_PLAIN; } -// a use that doesn't give the object away -fn touch(i) -{ - let r; - lused[i] = 1; - if (!fchk) return 0; - r = lroot(i); - lused[r] = 1; - if (lstate[r] == S_DEAD) { cerrn(i, "used after it was given away"); return 0; } - // a d object that shows up in a deeper block is given to that block - if (lstate[r] == S_D && lhome[r] < fdepth) { lhome[r] = fdepth; lstate[r] = S_M; lown[r] = 1; } - return 0; -} -fn plainuse(c) -{ - if (c == C_FRESH) cerr("a new object can't be used as a plain value; bind it to a name first"); - if (c >= C_VAR) touch(c - C_VAR); - return C_PLAIN; -} -fn freevar(i) { laddr(lslot[i]); op(O_LD); callname(s_free); op(O_DROP); return 0; } -// leaving every block deeper than or equal to dep: free what is owned, and -// complain about what should have left already. final means the block really -// ends here rather than an early exit. -fn exit_vars(dep, final) -{ - let i = nloc, st; - if (!fchk || !live) return 0; - while (i > lbase) { - i--; - if (lhome[i] < dep) continue; - st = lstate[i]; - if (st == S_M) freevar(i); else if (st == S_U) cerrn(i, "u object must leave this block (block value, assignment to the enclosing block, or return)"); - else if (st == S_D) cerrn(i, "d object was never given away"); - } - return 0; -} -// an m object has to be used somewhere in the block that owns it, on any path -fn unused_check(from) -{ - while (from < nloc) { if (fchk && lown[from] && !lused[from]) serrn(lname[from], "m object is never used"); from++; } - return 0; -} -fn block_close(save) -{ - let i = lbase; - unused_check(save); - exit_vars(fdepth, 1); - while (i < save) { if (lhome[i] >= fdepth) { lstate[i] = S_DEAD; lhome[i] = fdepth - 1; } i++; } - nloc = save; - return 0; -} - -// snapshots: [lbase] [nloc] then state, owner, home per local -fn snap_push() -{ - let b = snaptop, i = lbase, p; - p = R_SNAP + b; - p[0] = lbase; p[1] = nloc; - p = p + 2; - while (i < nloc) { p[0] = lstate[i]; p[1] = lowner[i]; p[2] = lhome[i]; p = p + 3; i++; } - snaptop = p - R_SNAP; - if (snaptop >= 8000) fatal("nesting too deep for the analyzer"); - return b; -} -fn snap_pop(b) { snaptop = b; return 0; } -fn snap_restore(b) -{ - let p = R_SNAP + b, i = p[0], e = p[1]; - if (e > nloc) e = nloc; - p = p + 2; - while (i < e) { lstate[i] = p[0]; lowner[i] = p[1]; lhome[i] = p[2]; p = p + 3; i++; } - return 0; -} -fn empty(s) { return s == S_PLAIN || s == S_DEAD; } -// compare the current states with a snapshot: -1 if they agree, else the -// first local that differs. plain and dead agree and merge to dead. -fn snap_cmp(b) -{ - let p = R_SNAP + b, i = p[0], e = p[1], s; - if (e > nloc) e = nloc; - p = p + 2; - while (i < e) { - s = lstate[i]; - if (empty(s) && empty(p[0])) { if (p[0] == S_DEAD) lstate[i] = S_DEAD; } - else if (s != p[0] || lhome[i] != p[2] || (s == S_CHILD && lowner[i] != p[1])) return i; - p = p + 3; i++; - } - return -1; -} -fn statename(s) -{ - if (s == S_PLAIN) return "empty"; - if (s == S_M) return "m"; - if (s == S_U) return "u"; - if (s == S_D) return "d"; - if (s == S_DEAD) return "given away"; - if (s == S_CHILD) return "owned by a container"; - return "borrowed"; -} -fn merge_err(i, sa, what) -{ - if (!fchk || panic || dry) return 0; - errat(); puts(lname[i]); puts(": "); puts(what); - puts(" (one path leaves it "); puts(statename(sa)); puts(", another "); puts(statename(lstate[i])); puts(")"); - errend(); - return 0; -} -// after an if: the current state is the else path, sa is the then path - -// ---- joins ---- -// where control flow comes back together (after an if, a loop, a switch or -// ?:) every variable has to agree across the paths that reach the join. one -// exception: a variable that became d, or was given away, on some path is dead -// after the join, and the paths where it's still alive free it on the way in -// (fixups). u objects and borrows don't get this treatment: a u object still -// has to leave, and a borrow never changes. -const R_EXIT = 0xBF500, R_EXITEND = 0xBFF00; // exit records: the states at each break -let extop, jps[64], njps; // the paths being joined: [lbase, nloc, triples] -fn jst(p, i) { if (i >= p[1]) return S_PLAIN; return p[2 + 3 * (i - p[0])]; } -fn jow(p, i) { return p[3 + 3 * (i - p[0])]; } -fn jhm(p, i) { return p[4 + 3 * (i - p[0])]; } -// the states at a break, with the jump to patch: [site] then a snapshot -fn exit_rec(site) -{ - let p = R_EXIT + extop, i = lbase, q; - if (extop + 3 + 3 * (nloc - lbase) >= R_EXITEND - R_EXIT) fatal("too many breaks for the analyzer"); - p[0] = site; p[1] = lbase; p[2] = nloc; - q = p + 3; - while (i < nloc) { q[0] = lstate[i]; q[1] = lowner[i]; q[2] = lhome[i]; q = q + 3; i++; } - extop = q - R_EXIT; - return p; -} -fn jadd(p) { if (njps >= 64) fatal("too many paths for the analyzer"); jps[njps] = p; njps++; return 0; } -fn jsame(p, q, i) -{ - let s = jst(p, i), t = jst(q, i); - if (empty(s) && empty(t)) return 1; - return s == t && jhm(p, i) == jhm(q, i) && (s != S_CHILD || jow(p, i) == jow(q, i)); -} -// join the paths in jps over the locals [lbase, n0) into the current states -fn join(n0, what) -{ - let i = lbase, j, p, s, s0, dead, okdead, bad; - if (!njps) return 0; - while (i < n0) { - p = jps[0]; s0 = jst(p, i); - dead = 0; okdead = 1; bad = -1; - j = 0; - while (j < njps) { - s = jst(jps[j], i); - if (s == S_DEAD || s == S_D) dead = 1; - if (s == S_U || s == S_BORROW) okdead = 0; - if (!jsame(p, jps[j], i)) bad = j; - j++; - } - lstate[i] = s0; lowner[i] = jow(p, i); lhome[i] = jhm(p, i); - if (bad < 0) { - if (empty(s0)) { j = 0; while (j < njps) { if (jst(jps[j], i) == S_DEAD) lstate[i] = S_DEAD; j++; } } - } else if (dead && okdead) lstate[i] = S_DEAD; - else if (fchk && !panic && !dry) { - errat(); puts(lname[i]); puts(": "); puts(what); - puts(" (one path leaves it "); puts(statename(s0)); puts(", another "); puts(statename(jst(jps[bad], i))); puts(")"); - errend(); - } - i++; - } - return 0; -} -// on path p: count (and with doit, emit) the frees for what the join made dead but p still owns -fn fixups(p, n0, doit) -{ - let i = lbase, n = 0, s; - if (!fchk) return 0; - while (i < n0) { - s = jst(p, i); - if (lstate[i] == S_DEAD && (s == S_M || s == S_D)) { n++; if (doit) freevar(i); } - i++; - } - return n; -} -// a jump back to the top of a loop: whatever the loop owns has to be as it was -fn backedge(s0) -{ - let p = R_SNAP + s0, i = p[0], e = p[1], s; - if (!fchk || !live) return 0; - if (e > nloc) e = nloc; - while (i < e) { - s = lstate[i]; - if (empty(s) && empty(jst(p, i))) { if (jst(p, i) == S_DEAD) lstate[i] = S_DEAD; } - else if (s != jst(p, i) || lhome[i] != jhm(p, i) || (s == S_CHILD && lowner[i] != jow(p, i))) { - if (s == S_DEAD || s == S_D) cerrn(i, "is given away inside a loop that comes back around to it; give it away on a path that leaves the loop"); - else if (!panic && !dry) { - errat(); puts(lname[i]); puts(": changes state inside a loop; each pass has to leave it as it found it (it went from "); - puts(statename(jst(p, i))); puts(" to "); puts(statename(s)); puts(")"); errend(); - } - } - i++; - } - return 0; -} -// joins two paths that end at the same point, like the branches of if/else: -// path a jumped (through the hole at ja) and path b falls through to here -fn join2(sa, livea, ja, livebv, n0, what) -{ - let sb, nt, cj; - sb = snap_push(); - njps = 0; if (livea) jadd(R_SNAP + sa); if (livebv) jadd(R_SNAP + sb); - join(n0, what); - if (livebv) fixups(R_SNAP + sb, n0, 1); - nt = 0; if (livea) nt = fixups(R_SNAP + sa, n0, 0); - if (nt) { cj = hole(); op(O_JMP); setlit(ja, here); fixups(R_SNAP + sa, n0, 1); setlit(cj, here); } - else setlit(ja, here); - live = livea || livebv; - return 0; -} - -// ---- analyzer rules for the places values flow ---- -// recast: x as u / x as d / x as m -fn recast(c, t) -{ - let i, st; - if (!fchk) return c; - if (c < C_VAR) { cerr("only a named owned object can be recast"); return c; } - i = c - C_VAR; - st = lstate[i]; - lused[i] = 1; - if (st == S_CHILD) cerrn(i, "belongs to a container; recast the container instead"); - else if (st == S_BORROW) cerrn(i, "is borrowed and can't be recast"); - else if (st == S_PLAIN) cerrn(i, "isn't an owned object"); - else if (st == S_DEAD) cerrn(i, "used after it was given away"); - else if (t == S_M && st != S_M) cerrn(i, "can't be recast back to m"); - else lstate[i] = t; - return c; -} -// an argument for a parameter tagged t (0 plain, 1 m, 2 d) -fn argcheck(c, t) -{ - let i, st; - if (!fchk) return 0; - if (c == C_FRESH) { if (t != 2) cerr("a new object can only go straight to a d parameter; bind it to a name first"); return 0; } - if (c < C_VAR || !tracked(c - C_VAR)) return 0; - i = c - C_VAR; - st = lstate[i]; - if (lstate[lroot(i)] == S_DEAD) { cerrn(i, "used after it was given away"); return 0; } - if (t <= 1) { // untagged parameters are m: a lend - if (st == S_D) { cerrn(i, "is d; pass it to a d parameter (lending it would lose it)"); return 0; } - touch(i); - return 0; - } - if (st == S_D) { lstate[i] = S_DEAD; lused[i] = 1; return 0; } - if (st == S_M) cerrn(i, "is m; write d*x to give it away"); - else if (st == S_U) cerrn(i, "is u; write d*x to give it away instead of returning it"); - else if (st == S_CHILD) cerrn(i, "belongs to a container and can't be given away alone"); - else cerrn(i, "is borrowed and can't be given away"); - return 0; -} -fn emitown(p) -{ - laddr(lslot[p]); op(O_LD); - if (ltype[p][0] == TY_DYN) { lit(2); op(O_ADD); op(O_LD); } // a []T's elements live in its items object - callname(s_own); - return 0; -} -// a store of class rc into an lvalue of kind k (local or container index i) -fn assigncheck(k, i, rc) -{ - let st, j, r, js; - if (!fchk) return C_PLAIN; - j = -1; - if (rc >= C_VAR && tracked(rc - C_VAR)) j = rc - C_VAR; - if (j >= 0 && lstate[lroot(j)] == S_DEAD) { cerrn(j, "used after it was given away"); return C_PLAIN; } - if (k == LV_LOCAL) { - st = lstate[i]; - if (j < 0 && rc != C_FRESH) { - if (!empty(st)) cerrn(i, "still owns an object; overwriting it would leak it"); - else lstate[i] = S_PLAIN; - return C_PLAIN; - } - if (!empty(st)) { cerrn(i, "still owns an object; overwriting it would leak it"); return C_PLAIN; } - if (rc == C_FRESH) { lstate[i] = S_M; lused[i] = 0; lown[i] = 1; if (ltag[i] & 15) lstate[i] = ltag[i] & 15; return C_PLAIN; } - js = lstate[j]; - if (js == S_U && lhome[i] == lhome[j] - 1) { // handing a u object up one block - lstate[i] = S_M; lused[i] = 0; lown[i] = 1; lstate[j] = S_DEAD; lused[j] = 1; if (ltag[i] & 15) lstate[i] = ltag[i] & 15; - return C_PLAIN; - } - if (js == S_U) cerrn(j, "is u; it can only be handed to a variable of the enclosing block, or returned"); - else cerrn(j, "is an owned object and can't be copied into another variable"); - return C_PLAIN; - } - if (k == LV_ELEM) { - r = lroot(i); - st = lstate[r]; - touch(i); - if (rc == C_FRESH) { emitown(i); return C_PLAIN; } - if (j < 0) return C_PLAIN; - js = lstate[j]; - if (js == S_CHILD) cerrn(j, "already belongs to a container"); - else if (js == S_BORROW) cerrn(j, "is borrowed and can't be stored"); - else if (st == S_BORROW) { - if (js == S_U) cerrn(j, "is u; it has to leave through the block above, not into a borrowed object"); - else { lstate[j] = S_DEAD; lused[j] = 1; emitown(i); } // storing it gives it away - } else if (js != st) cerrn(j, "its tag doesn't match its container's (both have to be m, u or d)"); - else if (lhome[j] < lhome[r]) cerrn(j, "lives in an outer block than the container it's stored into"); - else { lstate[j] = S_CHILD; lowner[j] = i; lused[j] = 1; emitown(i); } - return C_PLAIN; - } - // a global, or memory the analyzer doesn't track: the collector takes it - if (j >= 0) { - if (lstate[j] == S_D) { lstate[j] = S_DEAD; lused[j] = 1; } - else cerrn(j, "must be d to be stored in a global or in untracked memory (the collector takes it over)"); - } - return C_PLAIN; -} -fn retcheck(c) -{ - let i; - if (!fchk) return 0; - i = -1; - if (c >= C_VAR && tracked(c - C_VAR)) i = c - C_VAR; - if (i >= 0 && lstate[lroot(i)] == S_DEAD) { cerrn(i, "used after it was given away"); return 0; } - if (fret) { - if (i >= 0) { - if (lstate[i] == S_U) { lstate[i] = S_DEAD; lused[i] = 1; } - else cerrn(i, "has to be u to be returned; write 'return u*x'"); - } - return 0; - } - if (c == C_FRESH) cerr("returns a new object; give the function a .u return type"); - else if (i >= 0) cerrn(i, "is owned and can't be returned from a function whose return type isn't .u"); - return 0; -} -// the last expression of a block expression -fn handup(c) -{ - let i; - if (!fchk) return C_PLAIN; - if (c == C_FRESH) return C_FRESH; - if (c < C_VAR || !tracked(c - C_VAR)) return C_PLAIN; - i = c - C_VAR; - if (lstate[i] == S_U && lhome[i] == fdepth) { lstate[i] = S_DEAD; lused[i] = 1; return C_FRESH; } - if (lstate[i] == S_U) cerrn(i, "only a u object of this block can be its value"); - else cerrn(i, "has to be u to be handed up as the block's value"); - return C_PLAIN; -} -fn discard(c) -{ - if (c == C_FRESH) cerr("a new object (or a u result) can't be thrown away"); - else if (c >= C_VAR) touch(c - C_VAR); - return 0; -} - -// ---- types ---- -// types are a compiler primitive: records in the type area, hash-consed so -// the same type is always the same pointer and comparing types is comparing -// words. untyped code is typed word, which goes with anything. the records -// stay in memory after compiling, so programs can inspect them. -// t[0] kind t[1] size in words t[2] name t[3] n t[4] a t[5] b t[6] c t[7..] extra -// ptr: a = element arr: a = element, n = length -// fn: a = return type, n = parameter count, b = signature (u m d tags), extra = parameter types -// struct: n = field count (-1 until laid out), a = fields (name, type, offset), -// b = generic template, c = type arguments [n, t1, t2 ...] -// var: a type parameter, n = its index -// gen: a generic struct: n = parameter count, a = fields (name, type), b = field count, c = parameter names - - -fn talloc(n) { let p = tytop; if (tytop + n >= R_TYEND) fatal("the type area is full"); tytop = tytop + n; wfill(p, 0, n); return p; } -fn tnew(kind, size, nm, extra) -{ - let t = talloc(7 + extra); - t[0] = kind; t[1] = size; t[2] = nm; - if (ntl >= NTL) fatal("too many types"); - R_TY[ntl] = t; ntl++; - return t; -} -fn tptr(e) -{ - let i = 0, t; - while (i < ntl) { t = R_TY[i]; if (t[0] == TY_PTR && t[4] == e) return t; i++; } - t = tnew(TY_PTR, 1, 0, 0); t[4] = e; - return t; -} -fn tarr(e, n) -{ - let i = 0, t; - while (i < ntl) { t = R_TY[i]; if (t[0] == TY_ARR && t[4] == e && t[3] == n) return t; i++; } - t = tnew(TY_ARR, n * tsz(e), 0, 0); t[4] = e; t[3] = n; - return t; -} -fn tfn(ret, np, ps, sig) -{ - let i = 0, j, t; - while (i < ntl) { - t = R_TY[i]; - if (t[0] == TY_FN && t[4] == ret && t[3] == np && t[5] == sig) { - j = 0; while (j < np && t[7 + j] == ps[j]) j++; - if (j == np) return t; - } - i++; - } - t = tnew(TY_FN, 1, 0, np); t[4] = ret; t[3] = np; t[5] = sig; - wcopy(t + 7, ps, np); - return t; -} -// []T, or fixed []T -fn tdyn(e, f) -{ - let i = 0, t; - while (i < ntl) { t = R_TY[i]; if (t[0] == TY_DYN && t[4] == e && t[3] == f) return t; i++; } - t = tnew(TY_DYN, 1, 0, 0); t[4] = e; t[3] = f; - return t; -} -fn tvar(i, nm) -{ - let k = 0, t; - while (k < ntl) { t = R_TY[k]; if (t[0] == TY_VAR && t[3] == i) return t; k++; } - t = tnew(TY_VAR, 1, nm, 0); t[3] = i; - return t; -} -fn tinst(g, args, n) -{ - let i = 0, j, t, v; - while (i < ntl) { - t = R_TY[i]; - if (t[0] == TY_STRUCT && t[5] == g) { - v = t[6]; j = 0; while (j < n && v[1 + j] == args[j]) j++; - if (j == n) return t; - } - i++; - } - v = talloc(n + 1); v[0] = n; wcopy(v + 1, args, n); - t = tnew(TY_STRUCT, 0, g[2], 0); t[3] = -1; t[5] = g; t[6] = v; - return t; -} -// lay out a generic instance on first use -fn tresolve(t) -{ - let g, f, n, i, fs, off = 0, ft, bs[8]; - if (t[0] != TY_STRUCT || t[3] >= 0) return t; - if (t[3] == -2) { serr("a struct can't contain itself by value"); t[3] = 0; return t; } - t[3] = -2; - g = t[5]; n = g[5]; f = g[4]; - wfill(bs, 0, 8); wcopy(bs, t[6] + 1, t[6][0]); - fs = talloc(n * 3 + 1); - i = 0; - while (i < n) { - ft = subst(f[i + i + 1], bs); - fs[i * 3] = f[i + i]; fs[i * 3 + 1] = ft; fs[i * 3 + 2] = off; - off = off + tsz(ft); - i++; - } - t[4] = fs; t[1] = off; t[3] = n; - return t; -} -fn tsz(t) { if (t[0] == TY_STRUCT && t[3] < 0) tresolve(t); return t[1]; } -// replace type parameters with what they were bound to (unbound ones become word) -fn subst(t, bs) -{ - let k = t[0], i, n, v[24], vec; - if (k == TY_VAR) { if (bs[t[3]]) return bs[t[3]]; return tword; } - if (k == TY_PTR) return tptr(subst(t[4], bs)); - if (k == TY_ARR) return tarr(subst(t[4], bs), t[3]); - if (k == TY_FN) { n = t[3]; i = 0; while (i < n) { v[i] = subst(t[7 + i], bs); i++; } return tfn(subst(t[4], bs), n, v, t[5]); } - if (k == TY_STRUCT && t[5]) { vec = t[6]; n = vec[0]; i = 0; while (i < n) { v[i] = subst(vec[1 + i], bs); i++; } return tinst(t[5], v, n); } - return t; -} -fn isnum(t) { return t[0] == TY_INT || t[0] == TY_CHAR || t[0] == TY_BOOL; } -fn isagg(t) { return t[0] == TY_ARR || t[0] == TY_STRUCT; } -fn isptr(t) { return t[0] == TY_PTR || t[0] == TY_ARR; } -fn decay(t) { if (t[0] == TY_ARR) return tptr(t[4]); return t; } -fn telem(t) { if (t[0] == TY_PTR || t[0] == TY_ARR) return t[4]; return tword; } -// can a value of type src go where dst is expected? -fn compat(dst, src) -{ - if (dst == src || dst == tword || src == tword) return 1; - if (isnum(dst) && isnum(src)) return 1; - src = decay(src); - if (dst[0] == TY_PTR && src[0] == TY_PTR) { - if (dst[4] == tword || src[4] == tword || dst[4] == tvoid || src[4] == tvoid) return 1; - return dst[4] == src[4]; - } - if ((dst[0] == TY_PTR || dst[0] == TY_FN || dst[0] == TY_DYN) && xzero) return 1; // a literal 0 is a null pointer - if (dst[0] == TY_DYN && src[0] == TY_DYN && dst[4] == src[4]) return dst[3] || !src[3]; // a growable array can't hold a fixed one - return dst == src; -} -fn unify(p, a, bs) -{ - let i, n, pv, av; - if (p[0] == TY_VAR) { i = p[3]; if (!bs[i]) { bs[i] = a; return 1; } return compat(bs[i], a); } - a = decay(a); - if (p[0] == TY_PTR && a[0] == TY_PTR) { if (a[4] == tword) return 1; return unify(p[4], a[4], bs); } - if (p[0] == TY_STRUCT && p[5] && a[0] == TY_STRUCT && a[5] == p[5]) { - pv = p[6]; av = a[6]; n = pv[0]; i = 0; - while (i < n) { if (!unify(pv[1 + i], av[1 + i], bs)) return 0; i++; } - return 1; - } - return compat(p, a); -} -fn tprint(t) -{ - let k = t[0], i, v; - if (k == TY_PTR) { putc('*'); return tprint(t[4]); } - if (k == TY_DYN) { if (t[3]) puts("fixed "); puts("[]"); return tprint(t[4]); } - if (k == TY_ARR) { putc('['); putn(t[3]); putc(']'); return tprint(t[4]); } - if (k == TY_FN) { - if (t[4] == tword) puts("fn"); else tprint(t[4]); - if (t[5] & 1) puts(".u"); - putc('('); - i = 0; - while (i < t[3]) { - if (i) puts(", "); - tprint(t[7 + i]); - if (i < 12 && tparamtag(t, i) == 1) puts(".m"); - if (i < 12 && tparamtag(t, i) == 2) puts(".d"); - i++; - } - putc(')'); - return 0; - } - if (t[2]) puts(t[2]); else puts("?"); - if (k == TY_STRUCT && t[5]) { - v = t[6]; putc('<'); - i = 0; while (i < v[0]) { if (i) puts(", "); tprint(v[1 + i]); i++; } - putc('>'); - } - return 0; -} -fn tcerr(what, want, got) -{ - if (!tc_on || !live || dry || panic) return 0; - errat(); puts("type error: "); puts(what); - puts(": expected "); tprint(want); puts(", got "); tprint(got); - errend(); - return 0; -} -fn tcneed(ok, what, got) -{ - if (ok || !tc_on || !live || dry || panic) return 0; - errat(); puts("type error: "); puts(what); puts(", got "); tprint(got); - errend(); - return 0; -} -fn tpfind(n) { let i = ntp; while (i) { i--; if (tpn[i] == n) return i; } return -1; } -fn istypename(n) -{ - let s; - if (n == s_fixed) return 1; - if (tpfind(n) >= 0) return 1; - if (findloc(n) >= 0) return 0; - s = lookup(n); - return s >= 0 && skind[s] == K_TYPE; -} -// the closing > of a type argument list; splits >> in two -fn closeangle() -{ - if (is_op(s_shr)) { tv = s_gt; return 0; } - expect(s_gt); - return 0; -} -// a type, then any number of (params) after it: int(int, int) is a function -// returning int, fn(int) one returning a plain word -fn ptype() -{ - let t = ptype0(), np, ps[24]; - while (is_op(s_lp)) { - next(); np = 0; - if (!is_op(s_rp)) { while (1) { if (np >= 24) fatal("too many parameters"); ps[np] = ptype(); np++; if (!accept(s_comma)) break; } } - expect(s_rp); - t = tfn(t, np, ps, np + np); - } - return t; -} -fn ptype0() -{ - let n, s, t, args[8], na = 0, i; - if (accept(s_star)) return tptr(ptype0()); - if (accept(s_lk)) { - if (accept(s_rk)) return tdyn(ptype0(), 0); // []T: grows - n = cexpr(); expect(s_rk); t = ptype0(); if (n < 0) serr("a negative array length"); return tarr(t, n); - } - if (is_id(s_fixed)) { // fixed []T can't grow; fixed [n]T says what [n]T already means - next(); t = ptype0(); - if (t[0] == TY_DYN) return tdyn(t[4], 1); - if (t[0] != TY_ARR) serr("only arrays can be fixed"); - return t; - } - if (is_id(s_fn)) { next(); if (!is_op(s_lp)) die("fn as a type needs its parameters: fn(int)"); return tword; } - if (tk != T_ID) { die("expected a type"); return tword; } - n = tv; - i = tpfind(n); - if (i >= 0) { next(); return tvar(i, n); } - s = lookup(n); - if (s < 0 || skind[s] != K_TYPE) { dien(n, "isn't a type"); return tword; } - next(); - t = sval[s]; - if (t[0] != TY_GEN) return t; - expect(s_lt); - while (1) { - if (na >= 8) die("too many type arguments"); - args[na] = ptype(); - if (tsz(args[na]) != 1) serr("type arguments have to be one word (a pointer, a number, or a parameter)"); - na++; - if (!accept(s_comma)) break; - } - closeangle(); - if (na != t[3]) serrn(n, "wrong number of type arguments"); - return tinst(t, args, na); -} -// does a declaration start here? (a type, or a bare .tag) -fn tstart() -{ - let k; - if (tk == T_OP) { - if (tv == s_lk || tv == s_dot) return 1; - if (tv == s_star) { // *T name, **T name ...: look past the stars - k = 0; - while (k < 3) { peekat(k); if (!(pk_tk == T_OP && pk_tv == s_star)) break; k++; } - peekat(k); - return (pk_tk == T_ID && (istypename(pk_tv) || pk_tv == s_fn)) || (pk_tk == T_OP && pk_tv == s_lk); - } - return 0; - } - if (tk != T_ID) return 0; - return tv == s_fn || istypename(tv); -} -// [type] [.tag] -fn dtype() -{ - dty = 0; dtag = 0; - if (!is_op(s_dot)) dty = ptype(); - if (accept(s_dot)) { - if (tv == s_m) dtag = S_M; else if (tv == s_u) dtag = S_U; else if (tv == s_d) dtag = S_D; else die("a tag is .u, .m or .d"); - next(); - } - return 0; -} -// struct name { type field, ... } or struct name<A, B> { ... } -fn kw_struct() -{ - let n, t, s, nf = 0, buf = R_QBUF, i, fs, off = 0, gen = 0, ft; - next(); - n = name(); - if (is_op(s_lt)) { // generic - next(); ntp = 0; - while (1) { if (ntp >= 8) die("too many type parameters"); tpn[ntp] = name(); ntp++; if (!accept(s_comma)) break; } - closeangle(); - gen = 1; - t = tnew(TY_GEN, 0, n, 0); t[3] = ntp; - fs = talloc(ntp); wcopy(fs, tpn, ntp); t[6] = fs; - } else { t = tnew(TY_STRUCT, 0, n, 0); t[3] = -2; } // -2 while its fields are read - s = addsym(n, K_TYPE, t); - expect(s_lb); - while (!is_op(s_rb)) { - ft = ptype(); - while (1) { - if (nf >= 1000) fatal("too many fields"); - buf[nf + nf] = name(); buf[nf + nf + 1] = ft; nf++; - if (!accept(s_comma)) break; - } - expect(s_semi); - } - next(); - if (gen) { - fs = talloc(nf + nf); wcopy(fs, buf, nf + nf); - t[4] = fs; t[5] = nf; - ntp = 0; - } else { - fs = talloc(nf * 3 + 1); - i = 0; - while (i < nf) { - ft = buf[i + i + 1]; - if (ft == t) { serr("a struct can't contain itself by value; use a pointer"); ft = tword; } - fs[i * 3] = buf[i + i]; fs[i * 3 + 1] = ft; fs[i * 3 + 2] = off; - off = off + tsz(ft); - i++; - } - t[4] = fs; t[1] = off; t[3] = nf; - } - accept(s_semi); - return s; -} -// type name = T; -fn kw_type() { let n; next(); n = name(); expect(s_eq); addsym(n, K_TYPE, ptype()); expect(s_semi); return 0; } -// typecheck on; / typecheck off; -fn kw_typecheck() -{ - next(); - if (is_id(s_on)) tc_on = 1; else if (is_id(s_off)) tc_on = 0; else die("typecheck on or typecheck off"); - next(); expect(s_semi); - return 0; -} -// the field of a struct type, or -1 -fn tfindfield(t, n) { let i = 0; tresolve(t); while (i < t[3]) { if (t[4][i * 3] == n) return i; i++; } return -1; } -// sizeof(T or expr), typeof(T or expr): the expression form is compiled dry, so it never runs -fn typearg() -{ - let t, sb, c; - expect(s_lp); - if (tstart() && !is_op(s_dot)) t = ptype(); - else { - sb = snap_push(); dry++; - c = expr(); rval(); - t = xty; - dry--; snap_restore(sb); snap_pop(sb); - } - expect(s_rp); - return t; -} -// len(a), cap(a), push(a, x), pop(a), resize(a, n): growable arrays. -// len of a [n]T is just n. -fn arrarg() -{ - let c; - expect(s_lp); c = expr(); rval(); plainuse(c); - return xty; -} -fn nogrow(t) { if (t[0] == TY_DYN && t[3]) serr("a fixed array can't grow or shrink"); return 0; } -fn kw_len() -{ - let t; - next(); t = arrarg(); expect(s_rp); - if (t[0] == TY_ARR) { op(O_DROP); lit(t[3]); } - else { tcneed(t[0] == TY_DYN || t == tword, "len needs an array", t); if (o3on && t[0] == TY_DYN) op(O_LD); else callname(s_dlen); } - xty = tint; - return 0; -} -fn kw_cap() { let t; next(); t = arrarg(); expect(s_rp); tcneed(t[0] == TY_DYN || t == tword, "cap needs a []T", t); callname(s_dcap); xty = tint; return 0; } -fn kw_push() -{ - let t, c; - next(); t = arrarg(); nogrow(t); - if (t[0] == TY_DYN && tsz(t[4]) != 1) serr("push takes one-word elements; use resize for structs"); - expect(s_comma); c = expr(); rval(); argcheck(c, 2); - if (t[0] == TY_DYN && !compat(t[4], xty)) tcerr("push", t[4], xty); - expect(s_rp); - callname(s_dpush); xty = tint; - return 0; -} -fn kw_pop() { let t; next(); t = arrarg(); nogrow(t); expect(s_rp); callname(s_dpop); xty = telem(t); if (t[0] == TY_DYN) xty = t[4]; return 0; } -fn kw_resize() { let t, c; next(); t = arrarg(); nogrow(t); expect(s_comma); c = expr(); rval(); plainuse(c); expect(s_rp); callname(s_dresize); xty = tint; return 0; } -fn kw_sizeof() { let t; next(); t = typearg(); lit(tsz(t)); xty = tint; return 0; } -fn kw_typeof() { let t; next(); t = typearg(); lit(t); xty = tword; return 0; } -fn types_init() -{ - tytop = R_TY + NTL; ntl = 0; - tword = tnew(TY_WORD, 1, intern("word"), 0); - tint = tnew(TY_INT, 1, intern("int"), 0); - tchar = tnew(TY_CHAR, 1, intern("char"), 0); - tbool = tnew(TY_BOOL, 1, intern("bool"), 0); - tvoid = tnew(TY_VOID, 0, intern("void"), 0); - addsym(tword[2], K_TYPE, tword); addsym(tint[2], K_TYPE, tint); addsym(tchar[2], K_TYPE, tchar); - addsym(tbool[2], K_TYPE, tbool); addsym(tvoid[2], K_TYPE, tvoid); - s_lt = intern("<"); s_gt = intern(">"); s_shr = intern(">>"); s_le = intern("<="); s_ge = intern(">="); - s_eqeq = intern("=="); s_ne = intern("!="); s_plus = intern("+"); - s_struct = intern("struct"); s_type = intern("type"); s_typecheck = intern("typecheck"); - s_on = intern("on"); s_off = intern("off"); s_new = intern("new"); s_new_t = intern("new_t"); - s_o3 = intern("o3"); s_lfa = intern("lfa"); s_outside = intern("outside"); s_new_raw = intern("new_raw"); s_oob = intern("oob"); - s_fixed = intern("fixed"); s_dlen = intern("dlen"); s_dcap = intern("dcap"); s_dnew = intern("dnew"); s_dat = intern("dat"); - s_dpush = intern("dpush"); s_dpop = intern("dpop"); s_dresize = intern("dresize"); - numops[0] = intern("*"); numops[1] = intern("/"); numops[2] = intern("%"); numops[3] = intern("&"); - numops[4] = intern("|"); numops[5] = intern("^"); numops[6] = intern("<<"); numops[7] = s_shr; nnumops = 8; - return 0; -} -fn isnumop(o) { let i = 0; while (i < nnumops) { if (numops[i] == o) return 1; i++; } return 0; } -// the type of a binary operation, checking it when the typechecker is on -fn bintype(b, lt, rt) -{ - let o = bname[b]; - lt = decay(lt); rt = decay(rt); - if (blen[b] < 0) { tcneed(!isagg(lt) && !isagg(rt), "&& and || need scalars", lt); return tbool; } - if (o == s_eqeq || o == s_ne) { if (!compat(lt, rt) && !compat(rt, lt)) tcerr("comparison", lt, rt); return tbool; } - if (o == s_lt || o == s_gt || o == s_le || o == s_ge) { - if (!(lt == tword || rt == tword || (isnum(lt) && isnum(rt)) || (lt[0] == TY_PTR && rt[0] == TY_PTR))) tcerr("comparison", lt, rt); - return tbool; - } - if (o == s_plus) { - if (lt[0] == TY_PTR && (isnum(rt) || rt == tword)) return lt; - if (rt[0] == TY_PTR && isnum(lt)) return rt; - if (lt == tword || rt == tword) return tword; - if (isnum(lt) && isnum(rt)) return tint; - tcerr("+", lt, rt); return tword; - } - if (o == s_minus) { - if (lt[0] == TY_PTR && rt[0] == TY_PTR) return tint; - if (lt[0] == TY_PTR && (isnum(rt) || rt == tword)) return lt; - if (lt == tword || rt == tword) return tword; - if (isnum(lt) && isnum(rt)) return tint; - tcerr("-", lt, rt); return tword; - } - if (isnumop(o)) { - if (lt == tword || rt == tword) return tword; - if (isnum(lt) && isnum(rt)) return tint; - if (isnum(lt)) lt = rt; - tcneed(0, "arithmetic needs numbers", lt); return tword; - } - return tword; // operators a program added -} - -// ---- reflection ---- -// for programs (and parse words) looking at types at runtime -fn tkind(t) { return t[0]; } -fn tsize(t) { return tsz(t); } -fn tname(t) { return t[2]; } -fn tlen(t) { return t[3]; } -fn tnfields(t) { tresolve(t); return t[3]; } -fn tfname(t, i) { tresolve(t); return t[4][i * 3]; } -fn tftype(t, i) { tresolve(t); return t[4][i * 3 + 1]; } -fn tfoff(t, i) { tresolve(t); return t[4][i * 3 + 2]; } -fn tret(t) { return t[4]; } -fn tnparams(t) { return t[3]; } -fn tparam(t, i) { return t[7 + i]; } -fn tparamtag(t, i) { return ((t[5] >> 6) >> (i + i)) & 3; } // 0 untagged (m), 1 .m, 2 .d -fn tretu(t) { return t[5] & 1; } -fn tnargs(t) { if (t[0] != TY_STRUCT || !t[5]) return 0; return t[6][0]; } -fn targ(t, i) { return t[6][1 + i]; } -// the type of a function, by address. untyped functions get one made from their signature -fn sigof(f) -{ - let i = nsym, s = -1, ws[24], n, k; - while (i) { i--; if (skind[i] == K_FN && sval[i] == f && (sflag[i] & F_DEF)) { s = i; break; } } - if (s < 0) return 0; - if (stype[s]) return stype[s]; - n = (ssig[s] >> 1) & 31; k = 0; - while (k < n) { ws[k] = tword; k++; } - return tfn(tword, n, ws, ssig[s]); -} -fn sigofs(nm) { let s = lookups(nm); if (s < 0 || skind[s] != K_FN) return 0; return sigof(sval[s]); } - -// ---- expressions ---- -// every expression leaves its value on the stack, returns its analyzer class, -// and sets xty to its type. lv means the stack holds an address that hasn't -// been loaded yet; structs and arrays are never loaded, their address is -// their value. -fn rval() { if (lv) { if (!isagg(xty)) op(O_LD); lv = 0; } return 0; } -fn kwcall(s, e) -{ - let f = sval[s], old = kw_expr, c; - kw_expr = e; xcls = C_PLAIN; xty = tword; xzero = 0; - f(); - kw_expr = old; - c = xcls; - lv = 0; lvk = LV_NONE; - return c; -} -fn stmtonly() { if (kw_expr) serr("this can't be used inside an expression"); return 0; } -// the arguments of a call. ft is the callee's type (or 0), bs the generic bindings -fn args(tags, ft, bs) -{ - let np = 0, c, pt; - expect(s_lp); - if (!is_op(s_rp)) { - while (1) { - c = expr(); rval(); - argcheck(c, (tags >> (np + np)) & 3); - if (ft && np < ft[3]) { pt = ft[7 + np]; if (!unify(pt, xty, bs)) tcerr("argument", subst(pt, bs), xty); } - np++; - if (!accept(s_comma)) break; - } - } - expect(s_rp); - return np; -} -// new(T) and new(T, count): a typed object, its type stamped into the header -fn newtyped() -{ - let t, c; - t = ptype(); - if (t[0] == TY_DYN) { // a growable array: element size, length, type - lit(tsz(t[4])); - if (accept(s_comma)) { c = expr(); rval(); plainuse(c); } - else { lit(0); if (t[3]) serr("a fixed array needs its length: new(fixed []T, n)"); } - lit(t); - expect(s_rp); - callname(s_dnew); - lv = 0; lvk = LV_NONE; xty = t; xzero = 0; - return C_FRESH; - } - if (o3on) { // o3: new_raw(words), no stamp, no zeroing - if (accept(s_comma)) { c = expr(); rval(); plainuse(c); if (tsz(t) != 1) { lit(tsz(t)); op(15); } } - else lit(tsz(t)); - expect(s_rp); - callname(s_new_raw); - lv = 0; lvk = LV_NONE; xty = tptr(t); xzero = 0; - return C_FRESH; - } - if (accept(s_comma)) { - c = expr(); rval(); plainuse(c); - if (tsz(t) != 1) { lit(tsz(t)); op(15); } - lit(tarr(t, 0)); - } else { lit(tsz(t)); lit(t); } - expect(s_rp); - callname(s_new_t); - lv = 0; lvk = LV_NONE; xty = tptr(t); xzero = 0; - return C_FRESH; -} -fn call(s) -{ - let np, tags = 0, ret = 0, ft = stype[s], bs[8]; - if (sname[s] == s_new && skind[s] == K_FN) { - peek(); - if (pk_tk == T_OP && (pk_tv == s_star || pk_tv == s_lk)) { next(); return newtyped(); } - if (pk_tk == T_ID && (istypename(pk_tv) || pk_tv == s_fn)) { next(); return newtyped(); } - } - if (o3on && sname[s] == s_new) { tags = lookup(s_new_raw); if (tags >= 0) s = tags; tags = 0; } - if (sflag[s] & F_SIG) { tags = ssig[s] >> 6; ret = ssig[s] & 1; } - else sflag[s] = sflag[s] | F_UNTYPED; - wfill(bs, 0, 8); - if (ngbind) { wcopy(bs, gbind, ngbind); ngbind = 0; } - np = args(tags, ft, bs); - if ((sflag[s] & F_SIG) && np != ((ssig[s] >> 1) & 31)) serrn(sname[s], "wrong number of arguments"); - fnref(s); op(O_CALL); - lv = 0; lvk = LV_NONE; xzero = 0; - xty = tword; - if (ft) xty = subst(ft[4], bs); - if (ret) return C_FRESH; - return C_PLAIN; -} -// an enhancement used like a function: the arguments, then its one opcode -fn enhcall(s) -{ - let nin = ssig[s] & 15, nout = (ssig[s] >> 4) & 15, n = 0, c; - expect(s_lp); - if (!is_op(s_rp)) { while (1) { c = expr(); rval(); plainuse(c); n++; if (!accept(s_comma)) break; } } - expect(s_rp); - if (n != nin) serrn(sname[s], "wrong number of inputs"); - lv = 0; lvk = LV_NONE; xty = tword; xzero = 0; - if (sflag[s] & F_FALLBACK) { fnref(sfix[s] - 1); op(O_CALL); return C_PLAIN; } - op(XOP0 + sval[s]); - if (nout == 0) lit(0); - if (nout > 1) serrn(sname[s], "leaves several values; use it from asm"); - return C_PLAIN; -} -fn primary() -{ - let n, i, s, c; - lv = 0; lvk = LV_NONE; xzero = 0; - xconst = 0; - if (tk == T_NUM) { lit(tv); xzero = tv == 0; xconst = 1; xcval = tv; xty = tint; next(); return C_PLAIN; } - if (tk == T_STR) { strlit(tv); next(); xty = tptr(tchar); return C_PLAIN; } - if (tk == T_OP) { - if (tv == s_lp) { next(); c = expr(); expect(s_rp); return c; } - if (tv == s_lb) return blockexpr(); - die("expected an expression"); lit(0); xty = tword; return C_PLAIN; - } - if (tk != T_ID) { die("expected an expression"); lit(0); xty = tword; return C_PLAIN; } - n = tv; - i = findloc(n); - if (i >= 0) { - next(); - if (!fchk && tracked(i)) serrn(n, "is tracked by the analyzer and can't be used in unchecked code"); - vaddr(i); - xty = ltype[i]; - if (larr[i]) return C_PLAIN; - lv = 1; lvk = LV_LOCAL; lvi = i; - if (tracked(i)) return C_VAR + i; - return C_PLAIN; - } - s = lookup(n); - if (s >= 0 && skind[s] == K_KW) { - if (!(sflag[s] & F_EXPR)) dien(n, "can't be used inside an expression"); - return kwcall(s, 1); - } - if (s >= 0 && skind[s] == K_TYPE) { dien(n, "is a type, not a value"); lit(0); xty = tword; return C_PLAIN; } - next(); - xty = tword; - if (s >= 0 && skind[s] == K_CONST) { lit(sval[s]); xty = tint; xzero = sval[s] == 0; xconst = 1; xcval = sval[s]; return C_PLAIN; } - if (s >= 0 && skind[s] == K_GVAR) { lit(sval[s]); if (stype[s]) xty = stype[s]; lv = 1; lvk = LV_GLOBAL; return C_PLAIN; } - if (s >= 0 && skind[s] == K_GARR) { lit(sval[s]); if (stype[s]) xty = stype[s]; return C_PLAIN; } - if (s >= 0 && skind[s] == K_ENH) return enhcall(s); - if (s < 0) s = fwdfn(n); - if (is_op(s_lt) && (sflag[s] & F_GEN)) { // f<int, *char>(...) - next(); ngbind = 0; - while (1) { if (ngbind >= 8) die("too many type arguments"); gbind[ngbind] = ptype(); ngbind++; if (!accept(s_comma)) break; } - closeangle(); - if (!is_op(s_lp)) die("expected ( after the type arguments"); - } - if (is_op(s_lp)) return call(s); - fnref(s); - if (stype[s]) xty = stype[s]; - return C_PLAIN; -} -// ++ and -- on the address at the top of the stack -fn incdec(post, dlt) -{ - if (!lv) die("++ and -- need something to assign to"); - if (lvk == LV_LOCAL && fchk && tracked(lvi)) cerrn(lvi, "owns an object and can't be incremented"); - tcneed(isnum(xty) || xty[0] == TY_PTR || xty == tword, "++ and -- need a number or a pointer", xty); - lv = 0; lvk = LV_NONE; xzero = 0; - lit(0); op(O_PICK); op(O_LD); - if (post) { lit(0); op(O_PICK); lit(dlt); op(O_ADD); lit(2); op(O_PICK); op(O_ST); } - else { lit(dlt); op(O_ADD); lit(0); op(O_PICK); lit(2); op(O_PICK); op(O_ST); } - op(O_SWAP); op(O_DROP); - return C_PLAIN; -} -// p.x and p->x: a field of a struct, or of the struct a pointer points at -fn field(c) -{ - let n, st, i, b = -1; - next(); - n = name(); - rval(); - if (c == C_FRESH) cerr("use a field of a new object only after binding it to a name"); - else if (c >= C_VAR) { touch(c - C_VAR); b = c - C_VAR; } - st = xty; - if (st[0] == TY_PTR) st = st[4]; - if (st[0] != TY_STRUCT) { - if (!panic && !dry) { errat(); putc('.'); puts(n); puts(": that's a "); tprint(xty); puts(", not a struct or a pointer to one"); errend(); } - xty = tword; lv = 1; lvk = LV_OTHER; return C_PLAIN; - } - i = tfindfield(st, n); - if (i < 0) { - if (!panic && !dry) { errat(); tprint(st); puts(" has no field "); puts(n); errend(); } - xty = tword; lv = 1; lvk = LV_OTHER; return C_PLAIN; - } - if (st[4][i * 3 + 2]) { lit(st[4][i * 3 + 2]); op(O_ADD); } - xty = st[4][i * 3 + 1]; - lv = 1; xzero = 0; - if (b >= 0) { lvk = LV_ELEM; lvi = b; } else lvk = LV_OTHER; - return C_PLAIN; -} -fn postfix() -{ - let c = primary(), b, n, t, et, ft, bs[8], k; - while (1) { - if (tk == T_ID && tv == s_as) { // e as T: same bits, another type - next(); t = ptype(); rval(); xty = t; lvk = LV_NONE; - continue; - } - if (tk != T_OP) return c; - if (tv == s_lk) { - next(); - rval(); - b = -1; - if (c == C_FRESH) cerr("index a new object only after binding it to a name"); - else if (c >= C_VAR) { touch(c - C_VAR); b = c - C_VAR; } - if (xty[0] == TY_DYN) { // a growable array: bounds-checked, through the runtime - et = xty[4]; - c = expr(); rval(); plainuse(c); - tcneed(isnum(xty) || xty == tword, "an index has to be a number", xty); - expect(s_rk); - k = lookup(s_outside); - if (o3on && k >= 0 && skind[k] == K_ENH) { // h i: check i against h[0], then h[2] + i * size - lit(0); op(O_PICK); lit(2); op(O_PICK); op(O_LD); op(XOP0 + sval[k]); - k = hole(); op(O_JZ); - lit(1); op(O_PICK); op(O_LD); callname(s_oob); - setlit(k, here); - op(O_SWAP); lit(2); op(O_ADD); op(O_LD); op(O_SWAP); - if (tsz(et) != 1) { lit(tsz(et)); op(15); } - op(O_ADD); - } else callname(s_dat); - } else { - tcneed(isptr(xty) || xty == tword, "only pointers and arrays can be indexed", xty); - et = telem(xty); - n = 0 - 1; if (xty[0] == TY_ARR && xty[3] > 0) n = xty[3]; - xconst = 0; - c = expr(); rval(); plainuse(c); - if (n >= 0 && xconst && (xcval < 0 || xcval >= n)) serr("the index is out of range for this array"); - tcneed(isnum(xty) || xty == tword, "an index has to be a number", xty); - expect(s_rk); - if (tsz(et) != 1) { lit(tsz(et)); op(15); } - op(O_ADD); - } - lv = 1; xty = et; xzero = 0; - if (b >= 0) { lvk = LV_ELEM; lvi = b; } else lvk = LV_OTHER; - c = C_PLAIN; - continue; - } - if (tv == s_dot || tv == s_arrow) { c = field(c); continue; } - if (tv == s_lp) { // call through a value - rval(); plainuse(c); - ft = 0; - if (xty[0] == TY_FN) ft = xty; - else tcneed(xty == tword, "only functions can be called", xty); - wfill(bs, 0, 8); - n = args(0, ft, bs); - lit(n); op(O_PICK); op(O_CALL); op(O_SWAP); op(O_DROP); - lv = 0; lvk = LV_NONE; c = C_PLAIN; xzero = 0; - xty = tword; - if (ft) xty = subst(ft[4], bs); - continue; - } - if (tv == s_inc) { next(); c = incdec(1, 1); continue; } - if (tv == s_dec) { next(); c = incdec(1, -1); continue; } - return c; - } - return c; -} -fn unary() -{ - let c, un, t; - if (tk == T_ID && (tv == s_u || tv == s_m || tv == s_d)) { // u*x, d*x, m*x: recast - t = S_M; if (tv == s_u) t = S_U; if (tv == s_d) t = S_D; - next(); expect(s_star); - c = unary(); rval(); - lvk = LV_NONE; - return recast(c, t); - } - if (tk == T_OP) { - if (tv == s_star) { - next(); c = unary(); rval(); plainuse(c); - tcneed(xty[0] == TY_PTR || xty == tword, "only pointers can be dereferenced", xty); - xty = telem(xty); - lv = 1; lvk = LV_OTHER; xzero = 0; - return C_PLAIN; - } - if (tv == s_amp) { - next(); c = unary(); - if (!lv && !isagg(xty)) die("& needs something addressable"); - if (lv && lvk == LV_LOCAL && (ltag[lvi] & 16)) serr("an o3 variable has no address"); - if (c >= C_VAR) touch(c - C_VAR); - lv = 0; lvk = LV_NONE; xzero = 0; - xty = tptr(xty); - return C_PLAIN; - } - if (tv == s_inc) { next(); unary(); return incdec(0, 1); } - if (tv == s_dec) { next(); unary(); return incdec(0, -1); } - un = unfind(tv); - if (un >= 0) { - next(); c = unary(); rval(); plainuse(c); - emitseq(useq[un], ulen[un]); - xconst = 0; - if (un <= 1) xty = tbool; - else if (xty != tword) { tcneed(isnum(xty), "this operator needs a number", xty); xty = tint; } - lv = 0; lvk = LV_NONE; xzero = 0; - return C_PLAIN; - } - } - return postfix(); -} -fn bin(minp) -{ - let c = unary(), b, p, a, j, lt; - while (tk == T_OP) { - b = binfind(tv); - if (b < 0) return c; - p = bprec[b]; - if (p < minp) return c; - next(); rval(); plainuse(c); - lt = xty; - if (blen[b] == -1) { // && : 0 if the left side is 0, else the right side as 0 or 1 - a = hole(); op(O_JZ); - c = bin(p + 1); rval(); plainuse(c); - emitseq(useq[1], ulen[1]); // !! normalizes - j = hole(); op(O_JMP); - setlit(a, here); lit(0); setlit(j, here); - } else if (blen[b] == -2) { // || : 1 if the left side isn't 0, else the right side as 0 or 1 - a = hole(); op(O_JZ); - lit(1); j = hole(); op(O_JMP); - setlit(a, here); - c = bin(p + 1); rval(); plainuse(c); - emitseq(useq[1], ulen[1]); - setlit(j, here); - } else { - c = bin(p + 1); rval(); plainuse(c); - emitseq(bseq[b], blen[b]); - } - xty = bintype(b, lt, xty); - lv = 0; lvk = LV_NONE; c = C_PLAIN; xzero = 0; xconst = 0; - } - return c; -} -// [addr v] -> [v], storing v at addr -fn storekeep() { op(O_SWAP); lit(1); op(O_PICK); op(O_SWAP); op(O_ST); return 0; } -// c ? a : b -fn ternary(c) -{ - let a, b, s0, sa, livea, live0 = live, n0 = nloc, ca, cb, ta; - rval(); plainuse(c); - next(); - a = hole(); op(O_JZ); - s0 = snap_push(); - ca = expr(); rval(); ta = xty; - if (ca != C_FRESH) plainuse(ca); - livea = live; sa = snap_push(); - b = hole(); op(O_JMP); - expect(s_colon); - setlit(a, here); - snap_restore(s0); live = live0; - cb = expr(); rval(); - if (cb != C_FRESH) plainuse(cb); - join2(sa, livea, b, live, n0, "ends the two sides of ?: in different states"); - snap_pop(s0); - if (!compat(ta, xty) && !compat(xty, ta)) tcerr("the two sides of ?:", ta, xty); - if (ta != tword) xty = ta; - lv = 0; lvk = LV_NONE; xzero = 0; - if (ca == C_FRESH && cb == C_FRESH) return C_FRESH; - if (ca == C_FRESH || cb == C_FRESH) cerr("both sides of ?: have to be new objects, or neither"); - return C_PLAIN; -} -fn expr() -{ - let c = bin(1), k, i, a, rc, lt; - if (tk != T_OP) return c; - if (tv == s_q) return ternary(c); - if (tv == s_eq) { - if (!lv) die("this can't be assigned to"); - k = lvk; i = lvi; lt = xty; - if (isagg(lt)) serr("a whole struct or array can't be assigned; assign its fields"); - next(); - a = o3on && k == LV_LOCAL && (ltag[i] & 16) && !larr[i]; - if (a) op(O_DROP); // an o3 variable: its address comes after the value, so it never waits on the stack across a branch - rc = expr(); rval(); - if (!compat(lt, xty)) tcerr("assignment", lt, xty); - if (a) { lit(0); op(O_PICK); vaddr(i); op(O_ST); } else storekeep(); - lv = 0; lvk = LV_NONE; xty = lt; xzero = 0; - return assigncheck(k, i, rc); - } - a = asgfind(tv); - if (a >= 0) { - if (!lv) die("this can't be assigned to"); - if (lvk == LV_LOCAL && fchk && tracked(lvi)) cerrn(lvi, "owns an object; compound assignment would lose it"); - lt = xty; - next(); - i = o3on && lvk == LV_LOCAL && (ltag[lvi] & 16) && !larr[lvi]; - if (i) { i = lvi; op(O_DROP); vaddr(i); op(O_LD); i = i + 1; } - else { lit(0); op(O_PICK); op(O_LD); } - lv = 0; - rc = expr(); rval(); plainuse(rc); - emitseq(bseq[abin[a]], blen[abin[a]]); - k = bintype(abin[a], lt, xty); - if (!compat(lt, k)) tcerr("compound assignment", lt, k); - if (i) { lit(0); op(O_PICK); vaddr(i - 1); op(O_ST); } else storekeep(); - lv = 0; lvk = LV_NONE; xty = lt; xzero = 0; - return C_PLAIN; - } - return c; -} -// does the current token start a statement rather than an expression? -fn stmtstart() -{ - let s; - if (tk == T_OP) return tv == s_semi || tv == s_lb || tstart(); - if (tk != T_ID || findloc(tv) >= 0) return 0; - if (tstart()) return 1; - s = lookup(tv); - return s >= 0 && skind[s] == K_KW && !(sflag[s] & F_EXPR); -} -// { stmts; tail } as an expression: its value is the tail, or 0 -fn blockexpr() -{ - let save = nloc, c = C_PLAIN, tail = 0, t = tint; - next(); - fdepth++; bxdepth++; - while (!is_op(s_rb)) { - if (tk == T_EOF) die("missing }"); - if (stmtstart()) { stmt(); continue; } - c = expr(); rval(); - if (accept(s_semi)) { op(O_DROP); discard(c); c = C_PLAIN; continue; } - if (!is_op(s_rb)) die("expected ; or } after an expression"); - tail = 1; t = xty; - } - next(); - if (tail) c = handup(c); else lit(0); - block_close(save); - fdepth--; bxdepth--; - lv = 0; lvk = LV_NONE; xty = t; xzero = 0; - return c; -} - -// ---- constant expressions ---- -fn cprim() -{ - let v, s; - if (tk == T_NUM) { v = tv; next(); return v; } - if (accept(s_minus)) return 0 - cprim(); - if (tk == T_OP && tv == uname[2]) { next(); return ~cprim(); } - if (accept(s_lp)) { v = cexpr(); expect(s_rp); return v; } - if (tk == T_ID) { - s = lookup(tv); - if (s >= 0 && (skind[s] == K_CONST || skind[s] == K_GARR || (skind[s] == K_FN && (sflag[s] & F_DEF)) || skind[s] == K_GVAR)) { next(); return sval[s]; } - } - die("expected a constant"); - return 0; -} -fn cexpr() -{ - let v = cprim(), o; - while (tk == T_OP) { - o = tv; - if (o == bname[3]) { next(); v = v + cprim(); } - else if (o == bname[4]) { next(); v = v - cprim(); } - else if (o == bname[0]) { next(); v = v * cprim(); } - else if (o == bname[15]) { next(); v = v | cprim(); } - else if (o == bname[13]) { next(); v = v & cprim(); } - else if (o == bname[5]) { next(); v = v << cprim(); } - else if (o == bname[6]) { next(); v = v >> cprim(); } - else return v; - } - return v; -} - -// ---- statements ---- -// after a syntax error: skip to the end of the statement -fn resync() -{ - while (tk != T_EOF && !is_op(s_semi) && !is_op(s_rb)) next(); - if (is_op(s_semi)) next(); - panic = 0; - return 0; -} -fn stmt() -{ - let s, c; - if (panic) return resync(); - if (tk == T_ID && findloc(tv) < 0) { - s = lookup(tv); - if (s >= 0 && skind[s] == K_KW && (sflag[s] & F_STMT)) { kwcall(s, 0); return 0; } - } - if (tstart()) { localdecl(1); return 0; } - if (tk == T_OP) { - if (tv == s_semi) { next(); return 0; } - if (tv == s_lb) { block(); return 0; } - } - c = expr(); rval(); op(O_DROP); - expect(s_semi); - discard(c); - return 0; -} -fn block() -{ - let save = nloc; - expect(s_lb); - fdepth++; - while (!is_op(s_rb)) { if (tk == T_EOF) die("missing }"); stmt(); } - block_close(save); // before the }, so its line is the one reported - next(); - fdepth--; - return 0; -} -// the body of if/while/for: its own block, even without braces -fn substmt() -{ - let save = nloc; - if (is_op(s_lb)) return block(); - fdepth++; - stmt(); - block_close(save); - fdepth--; - return 0; -} -// let a = e, b[10]; or, typed: int a = 1, b; *node.m p = new(node); .u r; -// let infers pointer, struct and function types from the initializer and -// keeps numbers as plain words. -fn localdecl(typed) -{ - let n, i, c, k, t = 0, tg = 0; - if (typed) { dtype(); t = dty; tg = dtag; if (t == tvoid) serr("a variable can't be void"); } - if ((o3on || o3one) && !typed) serr("o3 variables need a type"); - while (1) { - n = name(); - i = newloc(n); - ltag[i] = tg; - if (o3on || o3one) ltag[i] = tg | 16; - if (accept(s_lk)) { - k = cexpr(); expect(s_rk); - if (!t) t = tword; - larr[i] = 1; ltype[i] = tarr(t, k); fslots = fslots + tsz(ltype[i]); - } else if (t && isagg(t)) { larr[i] = 1; ltype[i] = t; fslots = fslots + tsz(t); } - else { fslots++; if (t) ltype[i] = t; if (o3on) addsl(lslot[i]); } - if (accept(s_eq)) { - if (larr[i]) serr("an array or a struct can't be initialized with ="); - c = expr(); rval(); vaddr(i); op(O_ST); - if (t) { if (!compat(t, xty)) tcerr("initializer", t, xty); } - else if (!isnum(xty)) ltype[i] = xty; - assigncheck(LV_LOCAL, i, c); - } - if (!accept(s_comma)) break; - } - expect(s_semi); - return 0; -} -fn kw_var() { stmtonly(); next(); return localdecl(0); } -fn kw_if() -{ - let a, b, c, s0, sa, live0, livea, n0 = nloc, nt, cj; - stmtonly(); - next(); - expect(s_lp); c = expr(); rval(); plainuse(c); expect(s_rp); - a = hole(); op(O_JZ); - live0 = live; - s0 = snap_push(); - substmt(); - livea = live; sa = snap_push(); - if (is_id(s_else)) { - next(); - b = hole(); op(O_JMP); - setlit(a, here); - snap_restore(s0); live = live0; - substmt(); - join2(sa, livea, b, live, n0, "ends the branches of an if in different states"); - } else { - // the path that skips the then branch still has the states from before it - njps = 0; if (livea) jadd(R_SNAP + sa); if (live0) jadd(R_SNAP + s0); - join(n0, "ends the branches of an if in different states"); - if (livea) fixups(R_SNAP + sa, n0, 1); - nt = 0; if (live0) nt = fixups(R_SNAP + s0, n0, 0); - if (nt) { cj = hole(); op(O_JMP); setlit(a, here); fixups(R_SNAP + s0, n0, 1); setlit(cj, here); } - else setlit(a, here); - live = livea || live0; - } - snap_pop(s0); - return 0; -} -// loop frame: 0 continue target 1 break chain 2 depth 3 snapshot 4 block-expression depth -// loop frame: 0 continue target (-1 for a switch) 2 depth 3 snapshot at the top -// 4 block-expression depth 5 locals at the start 6 its first exit record -fn loop_push(cont, s0) -{ - let f = R_LOOP + lsp * 8; - if (lsp >= 60) fatal("loops nested too deeply"); - f[0] = cont; f[1] = 0; f[2] = fdepth; f[3] = s0; f[4] = bxdepth; f[5] = nloc; f[6] = extop; - lsp++; - return 0; -} -// the end of a loop or switch: join its exits (the fall-out path sc through -// the jump at a, if there is one, and every break) and lay out each path's -// fixups on its way to the end -fn loop_end(a, sc) -{ - let f, p, e, n0, outs = 0; - lsp--; - f = R_LOOP + lsp * 8; - n0 = f[5]; - njps = 0; - if (sc >= 0) jadd(R_SNAP + sc); - p = R_EXIT + f[6]; e = R_EXIT + extop; - while (p < e) { jadd(p + 1); p = p + 3 + 3 * (p[2] - p[1]); } - join(n0, "leaves the loop in different states on different paths"); - live = njps > 0; - p = R_EXIT + f[6]; - while (p < e) { - if (fixups(p + 1, n0, 0)) { setlit(p[0], here); fixups(p + 1, n0, 1); outs = fixnew(hole(), outs); op(O_JMP); } - else outs = fixnew(p[0], outs); - p = p + 3 + 3 * (p[2] - p[1]); - } - if (a >= 0) setlit(a, here); - if (sc >= 0) fixups(R_SNAP + sc, n0, 1); - fixall(outs, here); - extop = f[6]; - return 0; -} -fn kw_while() -{ - let c0 = here, a, s0, sc = -1, c, inf = 0; - stmtonly(); - next(); - s0 = snap_push(); - expect(s_lp); - if (tk == T_NUM && tv) { peek(); if (pk_tk == T_OP && pk_tv == s_rp) inf = 1; } // while (1): no way out but break - c = expr(); rval(); plainuse(c); expect(s_rp); - a = hole(); op(O_JZ); - if (!inf && live) sc = snap_push(); - loop_push(c0, s0); - substmt(); - backedge(s0); - jmp(c0); - loop_end(a, sc); - snap_pop(s0); - return 0; -} -fn kw_for() -{ - let save = nloc, s0, sc = -1, c0, a, b, st, c, inf = 0; - stmtonly(); - next(); - expect(s_lp); - fdepth++; - if (is_id(s_var)) kw_var(); - else if (tstart()) localdecl(1); - else { if (!is_op(s_semi)) { c = expr(); rval(); op(O_DROP); discard(c); } expect(s_semi); } - s0 = snap_push(); - c0 = here; - if (!is_op(s_semi)) { - if (tk == T_NUM && tv) { peek(); if (pk_tk == T_OP && pk_tv == s_semi) inf = 1; } - c = expr(); rval(); plainuse(c); - } else { lit(1); inf = 1; } - expect(s_semi); - a = hole(); op(O_JZ); - if (!inf && live) sc = snap_push(); - b = hole(); op(O_JMP); - st = here; - if (!is_op(s_rp)) { c = expr(); rval(); op(O_DROP); discard(c); } - expect(s_rp); - jmp(c0); - setlit(b, here); - loop_push(st, s0); - substmt(); - backedge(s0); - jmp(st); - loop_end(a, sc); - snap_pop(s0); - block_close(save); - fdepth--; - return 0; -} -fn kw_break() -{ - let f; - stmtonly(); - next(); expect(s_semi); - if (lsp <= loopbase) { serr("break outside a loop or a switch"); return 0; } - f = R_LOOP + (lsp - 1) * 8; - if (f[4] != bxdepth) { serr("break can't leave a block expression"); return 0; } - exit_vars(f[2] + 1, 0); - if (live) exit_rec(hole()); else hole(); - op(O_JMP); - live = 0; - return 0; -} -fn kw_continue() -{ - let j = lsp - 1, f; - stmtonly(); - next(); expect(s_semi); - while (j >= loopbase && R_LOOP[j * 8] == -1) j--; // past any switch - if (j < loopbase) { serr("continue outside a loop"); return 0; } - f = R_LOOP + j * 8; - if (f[4] != bxdepth) { serr("continue can't leave a block expression"); return 0; } - backedge(f[3]); - exit_vars(f[2] + 1, 0); - jmp(f[0]); - live = 0; - return 0; -} -// switch (e) { case 1, 2: ... case 'x': ... default: ... } -// cases don't fall through: each one ends where the next begins, and break -// leaves the switch early. case labels are constants. -fn casebody(s0, live0) -{ - let save = nloc; - snap_restore(s0); live = live0; - fdepth++; - while (!is_op(s_rb) && !is_id(s_case) && !is_id(s_default)) { if (tk == T_EOF) { die("missing }"); break; } stmt(); } - block_close(save); - fdepth--; - if (live) { exit_rec(hole()); op(O_JMP); } // the end of a case leaves the switch - live = 0; - return 0; -} -fn kw_switch() -{ - let save = nloc, tmp, c, s0, live0, defent = -1, skip, nxt, bj, v, a = -1; - stmtonly(); - next(); - expect(s_lp); c = expr(); rval(); plainuse(c); expect(s_rp); - fdepth++; - tmp = newloc(0); fslots++; // a hidden local holds the value - laddr(lslot[tmp]); op(O_ST); - live0 = live; - s0 = snap_push(); - loop_push(-1, s0); - expect(s_lb); - while (!is_op(s_rb)) { - if (tk == T_EOF) { die("missing }"); break; } - if (is_id(s_case)) { - next(); - bj = 0; - while (1) { - v = cexpr(); - laddr(lslot[tmp]); op(O_LD); lit(v); op(O_SUB); - bj = fixnew(hole(), bj); op(O_JZ); - if (!accept(s_comma)) break; - } - expect(s_colon); - nxt = hole(); op(O_JMP); - fixall(bj, here); - casebody(s0, live0); - setlit(nxt, here); - } else if (is_id(s_default)) { - next(); expect(s_colon); - if (defent >= 0) serr("a switch has one default"); - skip = hole(); op(O_JMP); // only reached when nothing matched - defent = here; - casebody(s0, live0); - setlit(skip, here); - } else die("expected case or default"); - } - next(); - snap_restore(s0); live = live0; - if (defent >= 0) { jmp(defent); loop_end(-1, -1); } - else { a = hole(); op(O_JMP); loop_end(a, s0); } // nothing matched: out with the states from the top - snap_pop(s0); - block_close(save); - fdepth--; - return 0; -} -fn kw_return() -{ - let c; - stmtonly(); - next(); - if (!infn) serr("return outside a function"); - if (bxdepth) serr("return can't leave a block expression"); - if (is_op(s_semi)) { lit(0); c = C_PLAIN; } - else { - c = expr(); rval(); - if (fty == tvoid) tcerr("return value", tvoid, xty); - else if (fty && !compat(fty, xty)) tcerr("return value", fty, xty); - } - expect(s_semi); - retcheck(c); - exit_vars(1, 0); - epichain = fixnew(here, epichain); - lit(MW - 1); op(O_JMP); - live = 0; - return 0; -} -// o3 { ... }: an optimized region. o3 T x = e;: one o3 variable -fn kw_o3() -{ - let lo, i, p; - stmtonly(); - next(); - if (!is_op(s_lb)) { o3one = 1; localdecl(1); o3one = 0; return 0; } - if (o3on || !infn) return block(); - lo = here + 2; lit(lo); op(O_JMP); - o3on = 1; no3sl = 0; - i = lbase; - while (i < nloc) { if ((ltag[i] & 16) && !larr[i]) addsl(lslot[i]); i++; } // o3 variables declared outside - block(); - o3on = 0; - if (no3pend < 20) { p = o3pend + no3pend * 10; p[0] = lo; p[1] = here; p[2] = no3sl; wcopy(p + 3, o3sl, no3sl); no3pend++; } - return 0; -} -fn kw_unchecked() -{ - let old = fchk; - stmtonly(); - next(); - fchk = 0; - substmt(); - fchk = old; - return 0; -} - -// ---- asm blocks: raw vm words, one per token ---- -// numbers push, -n pushes a negative number, #n emits a raw word, one-char -// tokens from the mnemonic table are opcodes, names push the address of a -// variable or function, :name defines a label for this block. -fn asmblock() -{ - let nl = 0, nr = 0, i, k, c, s, ln = R_ASM, la = R_ASM + 64, rn = R_ASM + 128, ra = R_ASM + 384; - expect(s_lb); - while (!is_op(s_rb)) { - if (tk == T_EOF) die("unterminated asm block"); - if (tk == T_NUM) { lit(tv); next(); continue; } - if (tk == T_STR) { strlit(tv); next(); continue; } - if (is_op(s_hash)) { next(); if (tk != T_NUM) die("# needs a number"); emit(tv); next(); continue; } - if (is_op(s_minus)) { next(); if (tk == T_NUM && tglue) { lit(0 - tv); next(); } else op(O_SUB); continue; } - if (is_op(s_colon)) { next(); if (nl >= 64) fatal("too many asm labels"); ln[nl] = name(); la[nl] = here; nl++; continue; } - if (tv[0] && !tv[1] && (c = mnemidx(tv[0])) >= 0) { op(c); next(); continue; } - if (tk != T_ID) die("bad token in asm"); - i = findloc(tv); - if (i >= 0 && (ltag[i] & 16) && !larr[i]) serr("asm can't reach an o3 variable"); - if (i >= 0) { lused[i] = 1; laddr(lslot[i]); next(); continue; } - k = -1; i = 0; - while (i < nl) { if (ln[i] == tv) k = i; i++; } - if (k >= 0) { lit(la[k]); next(); continue; } - s = lookup(tv); - if (s >= 0 && skind[s] == K_ENH) { op(XOP0 + sval[s]); next(); continue; } - if (s >= 0 && skind[s] != K_FN && skind[s] != K_KW) { lit(sval[s]); next(); continue; } - if (s >= 0 && skind[s] == K_FN) { fnref(s); next(); continue; } - if (nr >= 250) fatal("too many asm label references"); - rn[nr] = tv; ra[nr] = hole(); nr++; next(); // a label further down this block - } - next(); - i = 0; - while (i < nr) { - k = -1; c = 0; - while (c < nl) { if (ln[c] == rn[i]) k = c; c++; } - if (k < 0) serrn(rn[i], "unknown name in asm"); - setlit(ra[i], la[k]); - i++; - } - return 0; -} -fn kw_asm() { next(); asmblock(); xcls = C_PLAIN; return 0; } - -// ---- quote: code as data ---- -// a token list is an object: [n] then kind, value, line for each token. names, -// strings and operators are interned pointers. -.u grab() -{ - let n = 0, depth = 0, q; - if (!is_op(s_lb)) die("expected {"); - next(); - while (1) { - if (tk == T_EOF) die("unterminated quote"); - if (is_op(s_lb)) depth++; - if (is_op(s_rb)) { if (!depth) break; depth--; } - if (n >= 2700) fatal("quote too long"); - R_QBUF[n * 3] = tk; R_QBUF[n * 3 + 1] = tv; R_QBUF[n * 3 + 2] = tline; n++; - next(); - } - next(); - q = new(n * 3 + 1); - q[0] = n; - wcopy(q + 1, R_QBUF, n * 3); - return u*q; -} -unchecked .u qnew(src) { let n = src[0] * 3 + 1, q = new(n); wcopy(q, src, n); return q; } -.u qdup(.m q) { let n = q[0] * 3 + 1, r = new(n); wcopy(r, q, n); return u*r; } -fn wcopyto(.m q, n) { let i = 0; while (i < n) { emit(q[i]); i++; } return 0; } -fn kw_quote() -{ - let q, j, a, n; - next(); - q = grab(); - j = hole(); op(O_JMP); - a = here; - n = q[0] * 3 + 1; - wcopyto(q, n); - free(d*q); - setlit(j, here); - lit(a); - callname(s_qnew); - xcls = C_FRESH; - return 0; -} -// tokens of a string, as a token list -.u tokens(s) -{ - let n = 0, q; - src_push(2, s, 0, 0); - next(); - while (tk != T_EOF) { - if (n >= 2700) fatal("too many tokens"); - R_QBUF[n * 3] = tk; R_QBUF[n * 3 + 1] = tv; R_QBUF[n * 3 + 2] = tline; n++; - next(); - } - src_pop(); - q = new(n * 3 + 1); - q[0] = n; - wcopy(q + 1, R_QBUF, n * 3); - return u*q; -} -// feed a token list into the input: the parser reads it next, then carries -// on where it was. the list is freed once it has been read. -unchecked fn feed(.d q) { src_push(1, q, 1, 1); next(); return 0; } - -// ---- reading a unit and scanning it for signatures ---- -// a unit from stdin is read whole first (4 chars to a word), then scanned -// once for function signatures, so a function's tags are known before its first -// call even when it's defined further down. -unchecked fn readsrc() -{ - let cap = 4090, b = new(4090), n = 0, c, nb, w; - while (!eof()) { - c = getc() & 255; - if (c == 96) break; - if ((n >> 2) + 2 >= cap) { nb = new(cap + cap + 6); wcopy(nb, b, cap); free(b); b = nb; cap = cap + cap + 6; } - w = n >> 2; - if (!(n & 3)) b[w] = 0; - b[w] = b[w] | (c << ((n & 3) * 8)); - n++; - } - b[n >> 2] = b[n >> 2] & (pow2[(n & 3) * 8] - 1); // the 0 at the end - if ((n & 3) == 0) b[n >> 2] = 0; - b[(n >> 2) + 1] = 0; - return b; -} -// skip a <...> group (type parameters) -fn pskipangle() -{ - let dp = 0; - while (tk != T_EOF) { - if (is_op(s_lt)) dp++; - else if (is_op(s_gt)) dp--; - else if (is_op(s_shr)) dp = dp - 2; - next(); - if (dp <= 0) return 0; - } - return 0; -} -// at the name after fn: read the signature's tags and record them -fn prescan_fn(ret) -{ - let n = tv, np = 0, tags = 0, t = 0, dp, s; - next(); - next(); // the ( - if (!is_op(s_rp)) { - np = 1; dp = 1; - while (tk != T_EOF) { - if (is_op(s_lp)) dp++; - else if (is_op(s_rp)) { dp--; if (!dp) break; } - else if (dp == 1 && is_op(s_comma)) { if (np <= 12) tags = tags + (t << (np + np - 2)); np++; t = 0; } - else if (dp == 1 && is_op(s_dot)) { next(); if (is_id(s_m)) t = 1; else if (is_id(s_d)) t = 2; continue; } - next(); - } - if (np <= 12) tags = tags + (t << (np + np - 2)); - } - next(); - if (!is_op(s_lb) && !is_op(s_semi)) return 0; // not a function: an enhancement, a call in a parse word... - s = lookup(n); - if (s < 0 || s < ubase || skind[s] != K_FN || (sflag[s] & F_DEF)) s = fwdfn(n); - if (!(sflag[s] & F_SIG)) { ssig[s] = ret + np + np + tags * 64; sflag[s] = sflag[s] | F_SIG | F_PRE; } - return 0; -} -fn prescan(kind, obj) -{ - let depth = 0, sp = panic, sn = nerr, pend = 0; - dry++; - src_push(kind, obj, 0, 0); - next(); - while (tk != T_EOF) { - if (is_op(s_lb)) depth++; - else if (is_op(s_rb)) { depth--; pend = 0; } - else if (depth <= 0) { - if (is_op(s_semi)) pend = 0; - else if (is_op(s_dot)) { peek(); if (pk_tk == T_ID && pk_tv == s_u) pend = 1; } - else if (tk == T_ID) { peek(); if (pk_tk == T_OP && pk_tv == s_lp) { prescan_fn(pend); pend = 0; continue; } } - } - next(); - } - src_pop(); - dry--; panic = sp; nerr = sn; - return 0; -} -// compile a whole unit from stdin -fn unit_stdin() -{ - let src = readsrc(); - prescan(3, src); - src_push(3, src, 0, 0); - next(); - unit_top(); - unit_end(ubase); - src_pop(); - free(src); - return 0; -} - -// ---- nested compiles ---- -// compile() and load() can run while another function is being compiled (from -// a parse word). the function context is saved, the new code is emitted in -// place with a jump around it, and then everything is put back. -fn ctx_push() -{ - let f = R_CTX + ctxsp * 24; - if (ctxsp >= 30) fatal("compiles nested too deeply"); - ctxsp++; - f[0] = nloc; f[1] = lbase; f[2] = fdepth; f[3] = fslots; f[4] = fchk; f[5] = fret; f[6] = live; - f[7] = bxdepth; f[8] = epichain; f[9] = fframe; f[10] = infn; f[11] = lsp; f[12] = loopbase; - f[13] = lv; f[14] = lvk; f[15] = lvi; f[16] = kw_expr; f[17] = xcls; f[18] = snaptop; - f[19] = fty; f[20] = ntp; f[21] = xty; wcopy(f + 22, tpn, 2); - return 0; -} -fn ctx_pop() -{ - let f; - ctxsp--; - f = R_CTX + ctxsp * 24; - nloc = f[0]; lbase = f[1]; fdepth = f[2]; fslots = f[3]; fchk = f[4]; fret = f[5]; live = f[6]; - bxdepth = f[7]; epichain = f[8]; fframe = f[9]; infn = f[10]; lsp = f[11]; loopbase = f[12]; - lv = f[13]; lvk = f[14]; lvi = f[15]; kw_expr = f[16]; xcls = f[17]; snaptop = f[18]; - fty = f[19]; ntp = f[20]; xty = f[21]; wcopy(tpn, f + 22, 2); - return 0; -} - -// ---- functions and the top level ---- -fn fn_begin(chk, ret) -{ - lbase = nloc; fdepth = 1; fslots = 0; fchk = chk && check_on; fret = ret; fty = 0; - live = 1; bxdepth = 0; epichain = 0; infn = 1; loopbase = lsp; lv = 0; lvk = LV_NONE; - return 0; -} -// fp -= frame size, then check the frame stack: past FBOT, reset fp and stop -fn prologue() -{ - let k; - lit(ZFP); op(O_LD); fframe = hole(); op(O_SUB); lit(ZFP); op(O_ST); - if (o3on) return 0; // o3 gave up the frame check - lit(ZFP); op(O_LD); lit(FBOT); op(O_LT); k = hole(); op(O_JZ); - lit(FTOP); lit(ZFP); op(O_ST); callname(s_fovf); - setlit(k, here); - return 0; -} -fn epilogue() -{ - lit(0); - fixall(epichain, here); - lit(ZFP); op(O_LD); lit(fslots); op(O_ADD); lit(ZFP); op(O_ST); op(O_RET); - setlit(fframe, fslots); - infn = 0; - nloc = lbase; - return 0; -} -fn body() -{ - expect(s_lb); - while (!is_op(s_rb)) { if (tk == T_EOF) die("missing } at the end of a function"); stmt(); } - unused_check(lbase); - if (fchk && live) { exit_vars(1, 1); if (fret) cerr("a function returning .u has to end with a return"); } - next(); - return 0; -} -// the rest of a function, after its return type and name: -// int f(int a, *node.m n, .d x, b) { ... } <T> *list<T>.u mk(int n) { ... } -// rty is 0 for fn (a plain word), ret is 1 for a .u return -fn fndef(chk, rty, ret, n) -{ - let s, np = 0, tags = 0, t, sig, i, pn[24], pt[24], pty[24], typed = 0, ft, o3f = o3nxt, lo, hi; - o3nxt = 0; - if (rty || ntp) typed = 1; - s = lookup(n); - if (s < 0 || s < ubase || skind[s] != K_FN || (sflag[s] & F_DEF)) { s = addsym(n, K_FN, 0); sflag[s] = 0; } - expect(s_lp); - if (!is_op(s_rp)) { - while (1) { - t = 0; - pty[np] = tword; - if (!is_op(s_dot) && ((tk == T_OP && (tv == s_star || tv == s_lk)) || (tk == T_ID && (tv == s_fn || istypename(tv))))) { - pty[np] = ptype(); typed = 1; - if (isagg(pty[np])) serr("structs and arrays are passed by pointer"); - } - if (accept(s_dot)) { // .m lends, .d takes over - if (tv == s_m) t = 1; else if (tv == s_d) t = 2; else die("a parameter tag is .m or .d"); - next(); - } - pn[np] = name(); - if (o3f && pty[np] == tword) serr("o3 parameters need a type"); - if (np >= 12 && t) die("only the first 12 parameters can be tagged"); - pt[np] = t; - if (np < 12) tags = tags + (t << (np + np)); - np++; - if (np >= 24) die("too many parameters"); - if (!accept(s_comma)) break; - } - } - expect(s_rp); - sig = ret + np + np + tags * 64; - if ((sflag[s] & F_SIG) && !(sflag[s] & F_PRE)) { if (ssig[s] != sig) serrn(n, "doesn't match its earlier declaration"); } - else if ((sflag[s] & F_UNTYPED) && (tags || ret)) serrn(n, "was called before its tags were declared; put a prototype above the first call"); - ssig[s] = sig; - sflag[s] = (sflag[s] | F_SIG) - (sflag[s] & F_PRE); - if (ntp) sflag[s] = sflag[s] | F_GEN; - if (typed) { - if (!rty) rty = tword; - ft = tfn(rty, np, pty, sig); - if (stype[s] && stype[s] != ft) serrn(n, "doesn't match its earlier declaration"); - stype[s] = ft; - } - if (accept(s_semi)) { ntp = 0; return s; } - if (sflag[s] & F_DEF) serrn(n, "is defined twice"); - sval[s] = here; - sflag[s] = sflag[s] | F_DEF; - fixall(sfix[s], here); sfix[s] = 0; - fn_begin(chk, ret); - if (typed) fty = rty; - no3pend = 0; - if (o3f) { o3on = 1; no3sl = 0; } - prologue(); - i = 0; - while (i < np) { - t = newloc(pn[i]); fslots++; - ltype[t] = pty[i]; - if (o3f) { ltag[t] = 16; addsl(lslot[t]); } - if (fchk && pt[i] == 1) lstate[t] = S_BORROW; - if (fchk && pt[i] == 2) { lstate[t] = S_M; lown[t] = 1; } - i++; - } - i = np; - while (i) { i--; laddr(i); op(O_ST); } - if (o3f) { lo = here + 2; lit(lo); op(O_JMP); } // the region starts here: a jump, so the cpu enters it - body(); - hi = here; - epilogue(); - if (o3f) { o3on = 0; o3region(lo, hi, o3sl, no3sl); } - o3flush(); - ntp = 0; - return s; -} -// let g = 1, buf[10]; int g = 3; [10]int buf; point origin; -fn gdecl(typed) { next(); return gdecl2(0, 0, name()); } -fn gdecl2(t, tg, n) -{ - let a, k, s; - if (tg) serr("tags go on locals and parameters, not globals"); - if (t == tvoid) serr("a variable can't be void"); - while (1) { - if (accept(s_lk)) { - k = cexpr(); expect(s_rk); - s = addsym(n, K_GARR, here); - if (!t) t = tword; - stype[s] = tarr(t, k); - k = tsz(stype[s]); - while (k) { emit(0); k--; } - } else if (t && isagg(t)) { - s = addsym(n, K_GARR, here); stype[s] = t; - k = tsz(t); - while (k) { emit(0); k--; } - } else { - a = here; - s = addsym(n, K_GVAR, a); - if (t) stype[s] = t; - emit(0); - if (accept(s_eq)) { - if (tk == T_STR) { *(a + hdelta) = here; k = tv; while (*k) { emit(*k); k++; } emit(0); next(); } - else *(a + hdelta) = cexpr(); - } - } - if (!accept(s_comma)) break; - n = name(); - } - expect(s_semi); - return 0; -} -fn gconst() -{ - let n; - next(); - while (1) { n = name(); expect(s_eq); addsym(n, K_CONST, cexpr()); if (!accept(s_comma)) break; } - expect(s_semi); - return 0; -} -// enhance [n] name(a, b) micro "recipe" [else fn]; n outputs, 1 if left out -// enhance [n] name(a, b) vm { asm } [else fn]; -// lays out the descriptor the install opcode reads, and wires it in right -// away (an image wires its own in when it boots). -fn enhdef() -{ - let n, np = 0, nout = 1, dsc, na, pay, len = 0, kind = 0, i, p, s, slot, r, pn[8]; - next(); - if (tk == T_NUM) { if (tv < 0 || tv > 8) serr("an enhancement has at most 8 outputs"); nout = tv; next(); } // enhance 2 divmod(a, b) - n = name(); - expect(s_lp); - if (!is_op(s_rp)) { while (1) { if (np == 8) die("an enhancement takes at most 8 inputs"); pn[np] = name(); np++; if (!accept(s_comma)) break; } } - expect(s_rp); - dsc = here; i = 0; while (i < 7) { emit(0); i++; } - na = here; i = 0; while (i < np) { emit(0); i++; } - i = 0; - while (i < np) { *(na + i + hdelta) = here; p = pn[i]; while (*p) { emit(*p); p++; } emit(0); i++; } - if (accept(s_micro)) { - pay = here; - if (tk != T_STR) die("expected the recipe as a string"); - while (tk == T_STR) { p = tv; while (*p) { emit(*p); p++; } next(); } - emit(0); - } else if (accept(s_vm)) { pay = here; asmblock(); op(O_RET); len = here - pay; kind = 1; } - else die("expected micro or vm"); - slot = nenh; - if (slot >= 512) fatal("all 512 enhancement slots are taken"); - nenh++; - p = dsc + hdelta; - p[0] = slot; p[1] = kind; p[2] = np; p[3] = nout; p[4] = pay; p[5] = len; p[6] = na; - s = addsym(n, K_ENH, slot); - ssig[s] = np + nout * 16 + dsc * 256; - if (accept(s_else)) { r = lookup(tv); if (r < 0) r = fwdfn(tv); next(); sfix[s] = r + 1; } - expect(s_semi); - if (!hdelta) { - r = install(dsc); - if (r < 0) { - if (!sfix[s]) serrn(n, "the enhancement didn't install (see install's codes in core.c)"); - sflag[s] = sflag[s] | F_FALLBACK; - } - } - return 0; -} -// after a syntax error at the top level: skip to something that starts a declaration -fn topsync() -{ - let depth = 0; - while (tk != T_EOF) { - if (is_op(s_lb)) depth++; - else if (is_op(s_rb)) { depth--; if (depth < 0) depth = 0; } - else if (!depth && tk == T_ID && (tv == s_fn || tv == s_var || tv == s_const || tv == s_struct || tv == s_type - || tv == s_enhance || tv == s_typecheck || tv == s_unchecked || tv == s_immediate || tv == s_o3)) break; - next(); - } - panic = 0; - return 0; -} -fn fndone(s, imm) -{ - let k; - ntp = 0; - if (imm) { - if (hdelta) serr("parse words can't be defined while building an image"); - k = addsym(sname[s], K_KW, sval[s]); - sflag[k] = F_DEF | F_STMT | F_EXPR | F_TOP; - } - return 0; -} -fn topitem() -{ - let chk = 1, imm = 0, s, k, n; - if (panic) return topsync(); - if (is_id(s_unchecked)) { - next(); - if (accept(s_semi)) { check_on = 0; return 0; } // unchecked; switches the analyzer off from here on - chk = 0; - } - if (is_id(s_immediate)) { next(); imm = 1; } - o3nxt = 0; - if (is_id(s_o3)) { next(); o3nxt = 1; } - ntp = 0; - if (is_op(s_lt)) { // <T, U> before a generic function - next(); - while (1) { if (ntp >= 8) fatal("too many type parameters"); tpn[ntp] = name(); ntp++; if (!accept(s_comma)) break; } - closeangle(); - } - if (is_id(s_fn)) { peek(); if (!(pk_tk == T_OP && pk_tv == s_lp)) { next(); n = name(); return fndone(fndef(chk, 0, 0, n), imm); } } - if (ntp || !chk || imm || o3nxt) { // has to be a function, with a return type - dtype(); n = name(); - if (dtag && dtag != S_U) serr("the only return tag is .u"); - if (!is_op(s_lp)) { die("expected a function"); return 0; } - return fndone(fndef(chk, dty, dtag == S_U, n), imm); - } - if (is_id(s_var)) return gdecl(0); - if (is_id(s_struct)) { kw_struct(); return 0; } - if (is_id(s_type)) return kw_type(); - if (is_id(s_typecheck)) return kw_typecheck(); - if (is_id(s_enhance)) return enhdef(); - if (is_id(s_const)) return gconst(); - if (tk == T_ID) { - s = lookup(tv); - if (s >= 0 && skind[s] == K_KW && (sflag[s] & F_TOP)) { kwcall(s, 0); return 0; } - } - if (tstart()) { // int f(...) { } or int g = 1; - dtype(); n = name(); - if (is_op(s_lp)) { - if (dtag && dtag != S_U) serr("the only return tag is .u"); - return fndone(fndef(chk, dty, dtag == S_U, n), 0); - } - return gdecl2(dty, dtag, n); - } - die("expected a declaration"); - return 0; -} -fn unit_top() { while (tk != T_EOF) topitem(); return 0; } -fn unit_end(from) -{ - let i = from; - panic = 0; - while (i < nsym) { - if (skind[i] == K_FN && !(sflag[i] & F_DEF) && sfix[i]) { tline = sval[i]; serrn(sname[i], "is used but never defined"); } - i++; - } - if (nerr) giveup(); - return 0; -} - -// compile a token list as the body of a new function, or (top) as top-level -// declarations. returns the entry address of the function. -unchecked fn compile_list(q, top) -{ - let hop = -1, entry = 0, from = nsym; - ctx_push(); - if (infn) { hop = hole(); op(O_JMP); } - if (top) prescan(1, q); - src_push(1, q, 0, 0); - next(); - if (top) unit_top(); - else { - entry = here; - fn_begin(1, 0); - prologue(); - while (tk != T_EOF) stmt(); - unused_check(lbase); - if (fchk && live) exit_vars(1, 1); - epilogue(); - } - src_pop(); - unit_end(from); - if (hop >= 0) setlit(hop, here); - if (here > ptop) ptop = here; - ctx_pop(); - return entry; -} -fn compile(q) { return compile_list(q, 0); } -fn load(q) { compile_list(q, 1); return 0; } -fn eval(q) { let f = compile_list(q, 0); return f(); } -fn evals(s) { let q = tokens(s), r = eval(q); free(d*q); return r; } - -// ---- symbol blob ---- -// an image ends with its own symbol table so the genome knows its names: -// kind, value, signature, name chars, 0 ... then a 0 kind. -fn blob_emit(from) -{ - let i = from, p; - while (i < nsym) { - if ((skind[i] >= K_FN && skind[i] <= K_CONST) || skind[i] == K_ENH) { - emit(skind[i]); emit(sval[i]); emit(ssig[i]); - p = sname[i]; - while (*p) { emit(*p); p++; } - emit(0); - } - i++; - } - emit(0); - return 0; -} -fn blob_load(p) -{ - let s, n; - while (*p) { - n = intern(p + 3); - s = addsym(n, p[0], p[1]); - ssig[s] = p[2]; - sflag[s] = F_DEF | F_SIG; - if (p[0] == K_ENH) { if (p[1] >= nenh) nenh = p[1] + 1; install(p[2] >> 8); } - p = p + 3 + strlen(p + 3) + 1; - } - return 0; -} -// compile the rest of stdin as a genome image that will run at org, writing -// it to dst. only the source's own names are visible while it compiles. -// returns the image length in words. -fn build_image(org, dst) -{ - let sh = here, sd = hdelta, sl = hlimit, sub = ubase, svl = vislo, sns = nsym, sen = nenh, n; - ubase = nsym; vislo = nsym; nenh = 0; - here = org; hdelta = dst - org; hlimit = org + 0x30000; - lit(FTOP); lit(ZFP); op(O_ST); fnref(fwdfn(s_start)); op(O_JMP); emit(0); emit(0); - unit_stdin(); - *(dst + 5) = here; - blob_emit(ubase); - *(dst + 6) = here; - n = here - org; - popsyms(sns); - ubase = sub; vislo = svl; here = sh; hdelta = sd; hlimit = sl; nenh = sen; - return n; -} - -// ---- setup ---- -fn gc_roots() -{ - markrange(0, ptop); - if (!hdelta && here > ptop) markrange(ptop, here); // globals of a unit still compiling - markrange(GORG, GORG[6]); - markrange(R_SRC, R_SRC + 1024); - markrange(*ZFP, FTOP); - markrange(DSLO, DSHI); - return 0; -} -fn zc_init() -{ - pooltop = R_POOL; - wfill(R_IH, 0, IHN); - nsym = 0; nfixu = 0; fixfree = 0; nbin = 0; nun = 0; nasg = 0; nkop = 0; seqtop = 0; - lsp = 0; ctxsp = 0; snaptop = 0; nloc = 0; lbase = 0; - s_lp = intern("("); s_rp = intern(")"); s_lb = intern("{"); s_rb = intern("}"); - s_lk = intern("["); s_rk = intern("]"); s_comma = intern(","); s_semi = intern(";"); - s_eq = intern("="); s_arrow = intern("->"); s_inc = intern("++"); s_dec = intern("--"); - s_star = intern("*"); s_amp = intern("&"); s_colon = intern(":"); s_hash = intern("#"); - s_minus = intern("-"); s_dot = intern("."); s_q = intern("?"); s_case = intern("case"); s_default = intern("default"); s_andand = intern("&&"); s_oror = intern("||"); - s_fn = intern("fn"); s_var = intern("let"); s_const = intern("const"); s_else = intern("else"); - s_as = intern("as"); s_unchecked = intern("unchecked"); s_immediate = intern("immediate"); - s_m = intern("m"); s_d = intern("d"); s_u = intern("u"); - s_start = intern("start"); s_main = intern("main"); s_free = intern("free"); - s_own = intern("own"); s_qnew = intern("qnew"); s_fovf = intern("frame_overflow"); - s_enhance = intern("enhance"); s_micro = intern("micro"); s_vm = intern("vm"); - return 0; -} -// operators and keywords. these are plain tables in memory: a program can -// add operators, change precedences or replace keywords with its own. -fn zc_tables() -{ - add_unop("!", "0 $ 0 ~ - | 31 > 1 +"); // index 0 - add_unop("!!", "0 $ 0 ~ - | 31 > 0 ~ -"); // index 1: normalize to 0 or 1 - add_unop("~", "-1 ^"); // index 2 - add_unop("-", "0 ~ -"); - add_binop("*", 10, "*"); // the first few indexes are used by cexpr - add_binop("/", 10, "idiv"); // native divide, wired in by rt.zc - add_binop("%", 10, "imod"); - add_binop("+", 9, "+"); // 3 - add_binop("-", 9, "-"); // 4 - add_binop("<<", 8, "ishl"); // 5 - add_binop(">>", 8, ">"); // 6 - add_binop("<", 7, "<"); - add_binop(">", 7, "~ <"); - add_binop("<=", 7, "~ < 1 ^"); - add_binop(">=", 7, "< 1 ^"); - add_binop("==", 6, "- 0 $ 0 ~ - | 31 > 1 +"); - add_binop("!=", 6, "- 0 $ 0 ~ - | 31 > 0 ~ -"); - add_binop("&", 5, "&"); // 13 - add_binop("^", 4, "^"); - add_binop("|", 3, "|"); // 15 - add_binop("&&", -1, 0); - add_binop("||", -2, 0); - addkop(s_eq); addkop(s_arrow); addkop(s_inc); addkop(s_dec); - add_kw("let", kw_var, F_STMT); - add_kw("if", kw_if, F_STMT); - add_kw("while", kw_while, F_STMT); - add_kw("for", kw_for, F_STMT); - add_kw("switch", kw_switch, F_STMT); - add_kw("break", kw_break, F_STMT); - add_kw("continue", kw_continue, F_STMT); - add_kw("return", kw_return, F_STMT); - add_kw("unchecked", kw_unchecked, F_STMT); - add_kw("asm", kw_asm, F_STMT | F_EXPR); - add_kw("quote", kw_quote, F_EXPR); - add_kw("sizeof", kw_sizeof, F_EXPR); - add_kw("typeof", kw_typeof, F_EXPR); - add_kw("o3", kw_o3, F_STMT); - add_kw("len", kw_len, F_EXPR); - add_kw("cap", kw_cap, F_EXPR); - add_kw("push", kw_push, F_EXPR); - add_kw("pop", kw_pop, F_EXPR); - add_kw("resize", kw_resize, F_EXPR); - return 0; -} -fn start() -{ - let s, f; - heap_init(); - zc_init(); - blob_load(GORG[5]); - zc_tables(); - types_init(); - here = 0; hdelta = 0; hlimit = HEAP_LO; ptop = 0; - ubase = nsym; vislo = 0; - unit_stdin(); - if (here > ptop) ptop = here; - s = lookup(s_main); - if (s >= 0 && skind[s] == K_FN && (sflag[s] & F_DEF)) { f = sval[s]; f(); } - halt(); - return 0; -} diff --git a/docs/history/15-o3/code/src/rt.zc b/docs/history/15-o3/code/src/rt.zc deleted file mode 100644 index d85ba8e..0000000 --- a/docs/history/15-o3/code/src/rt.zc +++ /dev/null @@ -1,290 +0,0 @@ -// ============================================================================ -// rt.zc: the runtime half of the genome. memory map, i/o, arithmetic helpers, -// the heap (size-class free lists) and the mark-sweep collector. -// ============================================================================ - -// ---- memory map (words) ---- -const MW = 0x100000; // 1m words of memory -const HEAP_LO = 0x40000; // heap: 0x40000 .. 0xA0000 -const HEAP_HI = 0xA0000; -const ZFP = 0xA0000; // frame pointer word, used by every prologue -const GORG = 0xC0000; // the genome (this code) lives here -const FBOT = 0xE0000; // frame stack: FBOT .. FTOP, grows down -const FTOP = 0xF0000; -const RS0 = 0xF0000; // return stack grows up from here -const MARK0 = 0xF8000; // mark stack for the collector -const MARKN = 0x4000; -const DSLO = 0xFC000; // data stack: DSLO .. MW-16, grows down -const DSHI = 0xFFFF0; -const MAGIC = 0x2B7E1516; - -// ---- virtual enhancements ---- -// install(desc) wires a custom opcode into the cpu (the % opcode). these three -// give the language native division and left shift (zdiv, zmod and zshl -// below are the same thing done in software). they come first, since the -// compiler resolves / % and << to them by name. -fn install(desc) { return asm { desc @ % }; } -enhance idiv(a, b) micro "a = sdiv a b"; -enhance imod(a, b) micro "a = srem a b"; -enhance ishl(a, b) micro "a = shl a b"; -// for o3: an o3 variable's address (fp + k), and a bounds check (1 if i isn't in 0..n-1) -enhance lfa(k) micro "r1 = ld 655360; k = add r1 k"; -enhance outside(i, n) micro "i = ltu i n; i = xor i 1"; - -// ---- i/o ---- -fn putc(ch) { asm { ch @ . } return 0; } -fn getc() { return asm { , }; } -fn eof() { return asm { ? }; } -fn halt() { asm { q } return 0; } -fn puts(s) { let i = 0; while (s[i]) { putc(s[i]); i++; } return 0; } -fn putn(n) -{ - let b[12], i = 0; - if (n < 0) { putc('-'); n = 0 - n; } - if (n < 0) { puts("2147483648"); return 0; } - while (1) { b[i++] = '0' + n % 10; n = n / 10; if (!n) break; } - while (i) putc(b[--i]); - return 0; -} -fn strlen(s) { let n = 0; while (s[n]) n++; return n; } -fn streq(a, b) { let i = 0; while (a[i] && a[i] == b[i]) i++; return a[i] == b[i]; } -fn wcopy(dst, src, n) { let i = 0; while (i < n) { dst[i] = src[i]; i++; } return 0; } -fn wfill(dst, v, n) { let i = 0; while (i < n) { dst[i] = v; i++; } return 0; } - -// ---- arithmetic the hardware doesn't have ---- -let pow2[32]; -let zrem; -fn zudiv(n, dv) -{ - let q = 0, r = 0, i = 30; - if (n < dv) { zrem = n; return 0; } - while (i >= 0) { - r = r + r + ((n >> i) & 1); - q = q + q; - if (r >= dv) { r = r - dv; q++; } - i--; - } - zrem = r; - return q; -} -fn zdiv(a, b) -{ - let s = 0, q; - if (b == 0) { zrem = a; return 0; } - if (a < 0) { a = 0 - a; s = 1; } - if (b < 0) { b = 0 - b; s = s ^ 1; } - q = zudiv(a, b); - if (s) return 0 - q; - return q; -} -fn zmod(a, b) { let neg = a < 0; if (b == 0) return a; zdiv(a, b); if (neg) return 0 - zrem; return zrem; } -fn zshl(a, b) { return a * pow2[b & 31]; } - -// ---- heap ---- -// a buddy allocator. the heap is cut into aligned power-of-two chunks, every -// block is a power of two words, and a freed block merges with its buddy -// (the other half of the block they were split from) whenever that one is -// free too, so freed space can be reused at any size. every block has a 6 -// word header before the pointer the program sees: -// p[-6] block size p[-5] size class p[-4] flags (0 free, 1 live, 3 marked) -// p[-3] p ^ MAGIC p[-2] owner (the container that owns it, or 0) -// p[-1] its type (a type record from new(T), or 0 from new(n)) -// free blocks sit on a doubly linked list per class, linked through p[0], p[1]. -const HDR = 6; -let hbump, freel[32], gc_runs, gc_freed, gc_auto = 1; - -// the size of the top-level chunk holding heap offset off -fn topsize(off) -{ - let h = HEAP_HI - HEAP_LO, base = 0, sz; - while (h) { - sz = 1; - while (sz + sz <= h) sz = sz + sz; - if (off < base + sz) return sz; - base = base + sz; h = h - sz; - } - return 0; -} -fn fpush(b, k) { b[2] = 0; b[6] = freel[k]; b[7] = 0; if (freel[k]) freel[k][7] = b; freel[k] = b; return 0; } -fn funlink(b, k) -{ - if (b[7]) b[7][6] = b[6]; else freel[k] = b[6]; - if (b[6]) b[6][7] = b[7]; - return 0; -} -fn mkblock(b, k) { b[0] = pow2[k]; b[1] = k; b[2] = 0; b[3] = 0; b[4] = 0; b[5] = 0; return b; } -fn heap_init() -{ - let i = 1, b = HEAP_LO, sz, k; - pow2[0] = 1; - while (i < 32) { pow2[i] = pow2[i - 1] + pow2[i - 1]; i++; } - hbump = HEAP_HI; - wfill(freel, 0, 32); - while (b < HEAP_HI) { - sz = topsize(b - HEAP_LO); k = 0; - while (pow2[k] < sz) k++; - fpush(mkblock(b, k), k); - b = b + sz; - } - return 0; -} -// a free block of class k, split down from a bigger one if needed; 0 if none -fn balloc(k) -{ - let j = k, b, h; - while (j < 32 && !freel[j]) j++; - if (j >= 32) return 0; - b = freel[j]; - funlink(b, j); - while (j > k) { j--; h = b + pow2[j]; fpush(mkblock(h, j), j); } - mkblock(b, k); - return b; -} -let fend; // end of the block bfree last made, for the sweep -// put block b back, merging it with its buddy as long as it can -fn bfree(b) -{ - let k = b[1], sz = pow2[k], off, bud; - while (1) { - off = b - HEAP_LO; - if (sz >= topsize(off)) break; - bud = HEAP_LO + (off ^ sz); - if (bud[2] != 0 || bud[1] != k || bud[0] != sz) break; - funlink(bud, k); - if (bud < b) { b[0] = 0; b[3] = 0; b = bud; } // the upper header is inside the merged block now - else { bud[0] = 0; bud[3] = 0; } - k++; sz = sz + sz; - mkblock(b, k); - } - fpush(mkblock(b, k), k); - fend = b + sz; - return 0; -} -fn isobj(x) { return x >= HEAP_LO + HDR && x < hbump && x[-3] == (x ^ MAGIC) && (x[-4] & 1); } - -// every prologue checks the frame stack; on overflow it resets the frame -// pointer (so this can run at all) and stops -fn frame_overflow() { puts("zy: frame stack overflow\n"); halt(); return 0; } -fn oom() { puts("zc: out of heap memory\n"); halt(); return 0; } -// n words, untyped and not zeroed: what new gives o3 code -unchecked .u new_raw(n) -{ - let need = n + HDR, k = 3, b, p; - if (n < 0) need = HDR; - while (pow2[k] < need) k++; - b = balloc(k); - if (!b && gc_auto) { gc(); b = balloc(k); } - if (!b) oom(); - p = b + HDR; - b[2] = 1; b[3] = p ^ MAGIC; b[4] = 0; b[5] = 0; - return p; -} -// n words typed t, zeroed -unchecked .u new_t(n, t) -{ - let p = new_raw(n); - p[-1] = t; - wfill(p, 0, p[-6] - HDR); - return p; -} -unchecked .u new(n) { return new_t(n, 0); } -fn osize(p) { if (!isobj(p)) return 0; return p[-6] - HDR; } -fn typeof_obj(p) { if (!isobj(p)) return 0; return p[-1]; } - -// frees p and, recursively, every object p owns -fn release(p) -{ - let b = p - HDR, n = b[0] - HDR, i = 0, w; - b[2] = 2; // going: not live, and not free yet either, so a child's buddy check can't merge into it - while (i < n) { w = p[i]; if (isobj(w) && w[-2] == p) release(w); i++; } - bfree(b); - return 0; -} -unchecked fn free(.d p) { if (isobj(p)) release(p); return 0; } -fn own(c, p) { if (isobj(c)) c[-2] = p; return c; } - -// ---- growable arrays ---- -// a []T is a handle: [len, cap, items, element size]. items is an object the -// handle owns; growing swaps it for a bigger one and moves its children over. -unchecked .u dnew(es, n, t) -{ - let h = new_t(4, t), c = n, it; - if (c < 4) c = 4; - it = new(c * es); - h[0] = n; h[1] = c; h[2] = own(it, h); h[3] = es; - return h; -} -unchecked fn dgrow(h, need) -{ - let c = h[1], it, old = h[2], i = 0, w, n; - if (need <= c) return 0; - while (c < need) c = c + c; - it = new(c * h[3]); - n = h[0] * h[3]; - wcopy(it, old, n); - while (i < n) { w = it[i]; if (isobj(w) && w[-2] == old) w[-2] = it; i++; } // the children move with the elements - h[2] = own(it, h); h[1] = c; - free(old); - return 0; -} -fn oob(i, n) { puts("zy: index "); putn(i); puts(" out of range (length "); putn(n); puts(")\n"); halt(); return 0; } -unchecked fn dat(h, i) { if (i < 0 || i >= h[0]) oob(i, h[0]); return h[2] + i * h[3]; } -unchecked fn dpush(h, .d x) { dgrow(h, h[0] + 1); h[2][h[0]] = x; own(x, h[2]); h[0] = h[0] + 1; return 0; } -unchecked fn dpop(h) { if (!h[0]) oob(-1, 0); h[0] = h[0] - 1; return h[2][h[0]]; } -unchecked fn dresize(h, n) -{ - let old = h[0] * h[3]; - if (n < 0) n = 0; - dgrow(h, n); - if (n * h[3] > old) wfill(h[2] + old, 0, n * h[3] - old); - h[0] = n; - return 0; -} -fn dlen(h) { return h[0]; } -fn dcap(h) { return h[1]; } - -// ---- mark-sweep ---- -// conservative and non-moving. roots: the program area (globals live -// between functions), the genome's globals, the compiler's input stack, -// the live part of the frame stack and the whole data stack region. -let ms_top, ms_over, gc_lo, gc_hi; -fn mark(w) -{ - if (!isobj(w) || (w[-4] & 2)) return 0; - w[-4] = w[-4] | 2; - if (ms_top < MARKN) { MARK0[ms_top] = w; ms_top++; } else ms_over = 1; - return 0; -} -fn markrange(a, b) { while (a < b) { mark(*a); a++; } return 0; } -fn drain() -{ - let p; - while (ms_top) { ms_top--; p = MARK0[ms_top]; markrange(p, p + p[-6] - HDR); } - return 0; -} -fn gc_roots(); -unchecked fn gc() -{ - let b, sz, n = 0; - ms_top = 0; ms_over = 0; - gc_roots(); - drain(); - while (ms_over) { // the mark stack overflowed: rescan marked objects - ms_over = 0; - b = HEAP_LO; - while (b < HEAP_HI) { if (b[2] == 3) markrange(b + HDR, b + b[0]); b = b + b[0]; drain(); } - } - b = HEAP_LO; - while (b < HEAP_HI) { - sz = b[0]; - if (b[2] == 1) { bfree(b); n++; b = fend; } // merging may swallow what follows - else { if (b[2] == 3) b[2] = 1; b = b + sz; } - } - gc_runs++; - gc_freed = gc_freed + n; - return n; -} -// number of live objects, for tests -fn live_objects() { let b = HEAP_LO, n = 0; while (b < HEAP_HI) { if (b[2] & 1) n++; b = b + b[0]; } return n; } -// the biggest block that's free right now, in words -fn largest_free() { let k = 31; while (k > 0 && !freel[k]) k--; if (!freel[k]) return 0; return pow2[k]; } |