/* test_foundation.c -- the first DECOMPOSITION.md definitions, executed. * * Section 4 says of its colon definitions that each "has been traced by hand, * but none has been executed". This file assembles the helpers, the sign and * zero tests, U< and UM* exactly as written there (plus 2DUP and - from * section 5, which U< needs) and runs them on the golden model against the C * operation each one stands for. * * UM* is the full-range version that section 4 gives under D-3, and is checked * against the reference v4_umul over every pair of the edge vectors and 20000 * pseudo-random pairs at each cell width. UM/MOD is exactly as section 4 * gives it, checked against q*d + r = uhi:ulo, r < d over the edge vectors and * 20000 pseudo-random cases with uhi < ud. Both are also probed for how much * of the 10- and 9-deep circular stacks (D-2) they leave to their caller. * * Every call is made with a canary under the arguments, and the canary must * still be directly under the results afterwards: a definition that leaves * the right answer but an unbalanced stack is wrong. */ #include "v4/asm.h" #include "v4/testcode.h" #include "v4/umul.h" #include static int failures = 0, checks = 0; #define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0) #define CANARY ((v4_cell)0x0C0FFEE5) #define MAXU ((v4_ucell)~(v4_ucell)0) #define FLAG(c) ((c) ? V4_ALL_ONES : (v4_cell)0) static v4_node n; static v4_exec_state es; static v4_heat h; static v4_asm as; static v4_cell w_nip, w_swap, w_or, w_negate, w_rot, w_zless, w_zequal, w_2dup, w_minus, w_uless, w_umstar, w_ummod; #define O(name) v4_asm_op(&as, V4_OP_##name) #define LIT(v) v4_asm_lit(&as, (v4_cell)(v)) #define CALL(w) v4_asm_branch(&as, V4_OP_CALL, (w)) static void build(void) { v4_asm_ref ref; v4_node_reset(&n); v4_asm_begin(&as, &n, 16); /* : NIP push drop pop ; */ w_nip = v4_asm_label(&as); O(PUSH); O(DROP); O(RPOP); O(SEMI); /* : SWAP over push push drop pop pop ; */ w_swap = v4_asm_label(&as); O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI); /* : OR over inv and xor ; */ w_or = v4_asm_label(&as); O(OVER); O(INV); O(AND); O(XOR); O(SEMI); /* : NEGATE inv 1 + ; */ w_negate = v4_asm_label(&as); O(INV); LIT(1); O(ADD); O(SEMI); /* : ROT push SWAP pop SWAP ; */ w_rot = v4_asm_label(&as); O(PUSH); CALL(w_swap); O(RPOP); CALL(w_swap); O(SEMI); /* : 0< -if L1 drop -1 ; L1: drop 0 ; */ w_zless = v4_asm_label(&as); ref = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF); O(DROP); LIT(-1); O(SEMI); v4_asm_resolve(&as, ref, v4_asm_label(&as)); O(DROP); LIT(0); O(SEMI); /* : 0= if L1 drop 0 ; L1: drop -1 ; */ w_zequal = v4_asm_label(&as); ref = v4_asm_branch_fwd(&as, V4_OP_IF); O(DROP); LIT(0); O(SEMI); v4_asm_resolve(&as, ref, v4_asm_label(&as)); O(DROP); LIT(-1); O(SEMI); /* : 2DUP over over ; (section 5.1) */ w_2dup = v4_asm_label(&as); O(OVER); O(OVER); O(SEMI); /* : - NEGATE + ; (section 5.4), NEGATE in line */ w_minus = v4_asm_label(&as); O(INV); LIT(1); O(ADD); O(ADD); O(SEMI); /* : U< 2DUP xor 0< IF NIP 0< ELSE - 0< THEN ; * with section 2's IF: the flag is dropped on both arms. */ w_uless = v4_asm_label(&as); CALL(w_2dup); O(XOR); CALL(w_zless); ref = v4_asm_branch_fwd(&as, V4_OP_IF); O(DROP); CALL(w_nip); CALL(w_zless); O(SEMI); v4_asm_resolve(&as, ref, v4_asm_label(&as)); O(DROP); CALL(w_minus); CALL(w_zless); O(SEMI); /* : UM* ( u1 u2 -- ulo uhi ) section 4, D-3 * over 0< over and push R: m1 ? u2 : 0 * over over 0< and 1 and pop + push R: c_hi * over over and 1 and push R: c_hi c_lo * over 1 and NEGATE over 2/ and push R: c_hi c_lo t0 * a! 2/ pop s t0 A: u2 * 31 FOR +* UNEXT s hi A: lo * NIP a 2* pop + SWAP lo' hi * 2* a 0< NEGATE + pop + ; lo' hi' * NEGATE is placed in line. 31 is the cell width less one; the loop body * is the start of its own word so that unext restarts it. */ w_umstar = v4_asm_label(&as); O(OVER); CALL(w_zless); O(OVER); O(AND); O(PUSH); O(OVER); O(OVER); CALL(w_zless); O(AND); LIT(1); O(AND); O(RPOP); O(ADD); O(PUSH); O(OVER); O(OVER); O(AND); LIT(1); O(AND); O(PUSH); O(OVER); LIT(1); O(AND); O(INV); LIT(1); O(ADD); O(OVER); O(TWO_SLASH); O(AND); O(PUSH); O(BANG_A); O(TWO_SLASH); O(RPOP); LIT(V4_CELL_BITS - 1); O(PUSH); (void)v4_asm_label(&as); O(MUL_STEP); O(UNEXT); CALL(w_nip); O(PUSH_A); O(TWO_STAR); O(RPOP); O(ADD); CALL(w_swap); O(TWO_STAR); O(PUSH_A); CALL(w_zless); O(INV); LIT(1); O(ADD); O(ADD); O(RPOP); O(ADD); O(SEMI); /* : UM/MOD ( ulo uhi ud -- urem uquot ) section 4 * a! * 31 FOR * over 0< NEGATE push * dup 0< push * 2* pop pop SWAP push OR pop * push SWAP 2* SWAP pop * over a U< 0= OR * IF a - SWAP 1 OR SWAP THEN * NEXT * SWAP ; * NEGATE in line; IF as section 2 compiles it. */ { v4_cell loop; v4_asm_ref skip, done; w_ummod = v4_asm_label(&as); O(BANG_A); LIT(V4_CELL_BITS - 1); O(PUSH); loop = v4_asm_label(&as); O(OVER); CALL(w_zless); O(INV); LIT(1); O(ADD); O(PUSH); O(DUP); CALL(w_zless); O(PUSH); O(TWO_STAR); O(RPOP); O(RPOP); CALL(w_swap); O(PUSH); CALL(w_or); O(RPOP); O(PUSH); CALL(w_swap); O(TWO_STAR); CALL(w_swap); O(RPOP); O(OVER); O(PUSH_A); CALL(w_uless); CALL(w_zequal); CALL(w_or); skip = v4_asm_branch_fwd(&as, V4_OP_IF); O(DROP); O(PUSH_A); CALL(w_minus); CALL(w_swap); LIT(1); CALL(w_or); CALL(w_swap); done = v4_asm_branch_fwd(&as, V4_OP_JUMP); v4_asm_resolve(&as, skip, v4_asm_label(&as)); O(DROP); v4_asm_resolve(&as, done, v4_asm_label(&as)); v4_asm_branch(&as, V4_OP_NEXT, loop); CALL(w_swap); O(SEMI); } CHECK(v4_asm_ok(&as), "foundation words assemble"); } /* Call `word` with a canary and up to three arguments on fresh stacks. */ static int call(v4_cell word, unsigned argc, v4_cell a, v4_cell b, v4_cell c) { v4_dstack_reset(&n.ds); v4_rstack_reset(&n.rs); v4_exec_reset(&es); v4_heat_reset(&h); v4_dstack_push(&n.ds, CANARY); if (argc > 0) v4_dstack_push(&n.ds, a); if (argc > 1) v4_dstack_push(&n.ds, b); if (argc > 2) v4_dstack_push(&n.ds, c); return v4_test_call(&n, &es, &h, word, 100000) > 0; } /* The results, top first, then the canary. */ static int left1(v4_cell t) { return n.ds.t == t && n.ds.s == CANARY; } static int left2(v4_cell s, v4_cell t) { if (n.ds.t != t || n.ds.s != s) return 0; (void)v4_dstack_pop(&n.ds); return n.ds.s == CANARY; } static int left3(v4_cell third, v4_cell s, v4_cell t) { if (n.ds.t != t) return 0; (void)v4_dstack_pop(&n.ds); return left2(third, s); } static const v4_cell vec[] = { 0, 1, 2, 3, -1, -2, 12345, -12345, (v4_cell)(V4_MSB - 1u), (v4_cell)V4_MSB, (v4_cell)(V4_MSB + 1u), (v4_cell)(V4_MSB >> 1), (v4_cell)((V4_MSB >> 1) - 1u), (v4_cell)(MAXU / 3u), (v4_cell)(MAXU / 3u * 2u) }; #define NVEC (sizeof vec / sizeof vec[0]) /* Does UM* as written give the true product? */ static int umstar_exact(v4_ucell u1, v4_ucell u2) { v4_ucell lo, hi; v4_umul(u1, u2, &lo, &hi); return call(w_umstar, 2, (v4_cell)u1, (v4_cell)u2, 0) && left2((v4_cell)lo, (v4_cell)hi); } /* UM/MOD against the identity it must satisfy: q*d + r = uhi:ulo, r < d. * Checked through v4_umul (itself tested in test_umul.c) rather than against * a second division routine, so no C divider has to be trusted. */ static int ummod_exact(v4_ucell lo, v4_ucell hi, v4_ucell d) { v4_ucell r, q, plo, phi, slo; if (!call(w_ummod, 3, (v4_cell)lo, (v4_cell)hi, (v4_cell)d)) return 0; q = (v4_ucell)n.ds.t; r = (v4_ucell)n.ds.s; if (!left2((v4_cell)r, (v4_cell)q)) return 0; v4_umul(q, d, &plo, &phi); slo = plo + r; phi += (slo < plo); return r < d && slo == lo && phi == hi; } /* Stack headroom. Run `word` with `dfill` marked cells under the canary and * `rfill` marked cells under its return address, and report whether the * results, the canary and every marked cell come back intact. The F18 stacks * are circular (D-2), so a word that needs more depth than is free does not * fault: it silently overwrites the oldest cells, and this is how that shows. */ #define DFILL(i) ((v4_cell)(0x5A000000 + (i))) #define RFILL(i) ((v4_cell)(0x6B000000 + (i))) static int fits(v4_cell word, unsigned argc, const v4_cell *arg, unsigned nres, unsigned dfill, unsigned rfill) { v4_cell want[3]; unsigned i; v4_dstack_reset(&n.ds); v4_rstack_reset(&n.rs); v4_exec_reset(&es); for (i = 0; i < argc; i++) v4_dstack_push(&n.ds, arg[i]); if (v4_test_call(&n, &es, &h, word, 100000) <= 0) return 0; for (i = 0; i < nres; i++) want[i] = v4_dstack_pop(&n.ds); v4_dstack_reset(&n.ds); v4_rstack_reset(&n.rs); v4_exec_reset(&es); for (i = 0; i < dfill; i++) v4_dstack_push(&n.ds, DFILL(i)); v4_dstack_push(&n.ds, CANARY); for (i = 0; i < argc; i++) v4_dstack_push(&n.ds, arg[i]); for (i = 0; i < rfill; i++) v4_rstack_push(&n.rs, RFILL(i)); if (v4_test_call(&n, &es, &h, word, 100000) <= 0) return 0; for (i = 0; i < nres; i++) if (v4_dstack_pop(&n.ds) != want[i]) return 0; if (v4_dstack_pop(&n.ds) != CANARY) return 0; for (i = dfill; i-- > 0; ) if (v4_dstack_pop(&n.ds) != DFILL(i)) return 0; for (i = rfill; i-- > 0; ) if (v4_rstack_pop(&n.rs) != RFILL(i)) return 0; return 1; } /* The most marked cells that survive on each stack, over a set of argument * tuples chosen to take every branch. The data figure counts cells below the * canary, so the caller may hold canary + headroom cells under the arguments. */ static void headroom(const char *name, v4_cell word, unsigned argc, const v4_cell (*args)[3], unsigned nargs, unsigned nres, int *dh, int *rh) { int d, r; unsigned k; for (d = 0; d < V4_DATA_DEPTH; d++) { for (k = 0; k < nargs; k++) if (!fits(word, argc, args[k], nres, (unsigned)d + 1u, 0)) break; if (k < nargs) break; } for (r = 0; r < V4_RET_DEPTH; r++) { for (k = 0; k < nargs; k++) if (!fits(word, argc, args[k], nres, 0, (unsigned)r + 1u)) break; if (k < nargs) break; } *dh = d; *rh = r; printf(" %s headroom: data %d below canary, return %d below its return address\n", name, d, r); } int main(void) { printf("v4 foundation tests: V4_CELL_BITS=%d\n", V4_CELL_BITS); build(); for (unsigned i = 0; i < NVEC; i++) { v4_cell a = vec[i]; v4_ucell ua = (v4_ucell)a; CHECK(call(w_negate, 1, a, 0, 0) && left1((v4_cell)(0u - ua)), "NEGATE [%u]", i); CHECK(call(w_zless, 1, a, 0, 0) && left1(FLAG(ua & V4_MSB)), "0< [%u]", i); CHECK(call(w_zequal, 1, a, 0, 0) && left1(FLAG(a == 0)), "0= [%u]", i); for (unsigned j = 0; j < NVEC; j++) { v4_cell b = vec[j]; v4_ucell ub = (v4_ucell)b; CHECK(call(w_nip, 2, a, b, 0) && left1(b), "NIP [%u,%u]", i, j); CHECK(call(w_swap, 2, a, b, 0) && left2(b, a), "SWAP [%u,%u]", i, j); CHECK(call(w_or, 2, a, b, 0) && left1((v4_cell)(ua | ub)), "OR [%u,%u]", i, j); CHECK(call(w_2dup, 2, a, b, 0) && n.ds.t == b && n.ds.s == a && (v4_dstack_pop(&n.ds), v4_dstack_pop(&n.ds), left2(a, b)), "2DUP [%u,%u]", i, j); CHECK(call(w_minus, 2, a, b, 0) && left1((v4_cell)(ua - ub)), "- [%u,%u]", i, j); CHECK(call(w_uless, 2, a, b, 0) && left1(FLAG(ua < ub)), "U< [%u,%u]", i, j); for (unsigned k = 0; k < NVEC; k++) { v4_cell c = vec[k]; CHECK(call(w_rot, 3, a, b, c) && left3(b, c, a), "ROT [%u,%u,%u]", i, j, k); } CHECK(umstar_exact(ua, ub), "UM* [%u,%u]", i, j); } } /* UM* over the full range: products of pseudo-random operands, and of * operands chosen near the edges D-3 makes dangerous (top bit set, all * ones, just under a power of two). */ { v4_ucell x = (v4_ucell)0x9E3779B9u; for (unsigned i = 0; i < 20000; i++) { v4_ucell u1, u2; x ^= x << 13; x ^= x >> 7; x ^= x << 17; u1 = x; x ^= x << 13; x ^= x >> 7; x ^= x << 17; u2 = x; switch (i & 3u) { case 1: u1 |= V4_MSB; break; case 2: u1 |= V4_MSB; u2 |= V4_MSB; break; case 3: u1 = MAXU - (u1 & 7u); break; default: break; } CHECK(umstar_exact(u1, u2), "UM* random [%u]", i); } } /* The two cases that broke UM* as first written in section 4. */ CHECK(umstar_exact(MAXU, MAXU), "UM* MAX*MAX: carry out of T (D-3)"); CHECK(umstar_exact(V4_MSB - 1u, 3u), "UM* (2^(n-1)-1)*3"); /* UM/MOD over its defined range, uhi < ud. */ for (unsigned i = 0; i < NVEC; i++) for (unsigned j = 0; j < NVEC; j++) for (unsigned k = 0; k < NVEC; k++) { v4_ucell lo = (v4_ucell)vec[i], hi = (v4_ucell)vec[j], d = (v4_ucell)vec[k]; if (hi < d) CHECK(ummod_exact(lo, hi, d), "UM/MOD [%u,%u,%u]", i, j, k); } { v4_ucell x = (v4_ucell)0x2545F491u; for (unsigned i = 0; i < 20000; i++) { v4_ucell lo, hi, d; x ^= x << 13; x ^= x >> 7; x ^= x << 17; lo = x; x ^= x << 13; x ^= x >> 7; x ^= x << 17; d = x; x ^= x << 13; x ^= x >> 7; x ^= x << 17; hi = x; switch (i & 3u) { case 1: d |= V4_MSB; break; /* top bit of d set */ case 2: d >>= (unsigned)(x & 31u); break; /* small divisors */ case 3: d = MAXU - (d & 7u); break; /* d just under 2^n */ default: break; } if (d == 0) d = 1; hi %= d; /* uhi < ud */ CHECK(ummod_exact(lo, hi, d), "UM/MOD random [%u]", i); } } /* Stack headroom of the two longest definitions. */ { static const v4_cell umstar_args[][3] = { { 0, 0, 0 }, { -1, -1, 0 }, { 3, -1, 0 }, { -1, 3, 0 }, { 12345, -12345, 0 } }; static const v4_cell ummod_args[][3] = { { 0, 0, 1 }, { -1, -2, -1 }, { 12345, 0, 7 }, { -1, 0x7FFF, 0x8000 }, { 0, (v4_cell)(V4_MSB - 1u), (v4_cell)V4_MSB } }; int dh, rh; headroom("UM*", w_umstar, 2, umstar_args, 5, 2, &dh, &rh); CHECK(dh >= 0 && rh >= 0, "UM* runs at all"); headroom("UM/MOD", w_ummod, 3, ummod_args, 5, 2, &dh, &rh); CHECK(dh >= 0 && rh >= 0, "UM/MOD runs at all"); } CHECK(v4_node_guards_intact(&n), "guards intact"); printf(" %d checks, %d failures\n", checks, failures); return failures ? 1 : 0; }