admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
3b9d1e4337d41b03bc46ff756c0c3b18afbda92a
LithosAnanake/v4/tests/test_foundation.c
T
rajamesandClaude Opus 5.5 3b9d1e4337 feat(v4.0.0): call-free UM/MOD loop for D-2 stack headroom 
The first UM/MOD was exact but called 0<, U<, SWAP and OR inside its
loop, so it left its caller only 3 return-stack entries. SM/REM pushes
two signs before calling it, so under /MOD, M/MOD or */MOD the caller's
return address would be silently overwritten (D-2 circular stacks).

The loop now makes no calls. It branches on hi's top bit with -if, does
the unsigned hi' >= d test as U< does but with in-line sign tests,
subtracts with `inv a + inv`, and sets the quotient bit with `1 +` on an
even lo'. The final SWAP is in line.

Measured on the golden model at 32- and 64-bit cells:
  headroom   data 3 -> 6 cells under args, return 3 -> 6 entries
  speed      ~1355-1605 -> ~227-313 instruction words per call
Still exact for every uhi < ud (edge-vector triples and 20000 random
cases, optimised and ASan+UBSan). Retargeting each of the four in-loop
branches to the wrong label fails more than 12000 checks each.

DECOMPOSITION.md: section 4 UM/MOD replaced, with its derivation and
stack limits.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-02 22:35:49 -04:00

439 lines
17 KiB
C
Raw Blame History

/* 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, the call-free version
* section 4 gives, 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 <stdio.h>
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
* -if L0
* 2* over -if L1 drop 1 + jump L2 L1: drop L2: push 2* pop
* jump SUB
* L0:
* 2* over -if L3 drop 1 + jump L4 L3: drop L4: push 2* pop
* dup a xor -if L5
* drop -if NOSUB jump SUB
* L5: drop dup inv a + inv -if L6
* drop jump NOSUB
* L6: push drop pop jump SETBIT
* SUB: inv a + inv
* SETBIT: push 1 + pop
* NOSUB:
* NEXT
* over push push drop pop pop ;
* No calls inside the loop, and SWAP is in line. */
{
v4_cell loop, l_sub, l_setbit, l_nosub;
v4_asm_ref r0, r1, r2, r3, r4, r5, r6, to_sub1, to_sub2, to_nosub1,
to_nosub2, to_setbit;
w_ummod = v4_asm_label(&as);
O(BANG_A); LIT(V4_CELL_BITS - 1); O(PUSH);
loop = v4_asm_label(&as);
r0 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
/* hi's top bit was set: shift, then subtract regardless */
O(TWO_STAR); O(OVER);
r1 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
O(DROP); LIT(1); O(ADD);
r2 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
v4_asm_resolve(&as, r1, v4_asm_label(&as));
O(DROP);
v4_asm_resolve(&as, r2, v4_asm_label(&as));
O(PUSH); O(TWO_STAR); O(RPOP);
to_sub1 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
/* L0: top bit clear: shift, then compare hi' with d */
v4_asm_resolve(&as, r0, v4_asm_label(&as));
O(TWO_STAR); O(OVER);
r3 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
O(DROP); LIT(1); O(ADD);
r4 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
v4_asm_resolve(&as, r3, v4_asm_label(&as));
O(DROP);
v4_asm_resolve(&as, r4, v4_asm_label(&as));
O(PUSH); O(TWO_STAR); O(RPOP);
O(DUP); O(PUSH_A); O(XOR);
r5 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
O(DROP);
to_nosub1 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
to_sub2 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
v4_asm_resolve(&as, r5, v4_asm_label(&as)); /* L5 */
O(DROP); O(DUP); O(INV); O(PUSH_A); O(ADD); O(INV);
r6 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
O(DROP);
to_nosub2 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
v4_asm_resolve(&as, r6, v4_asm_label(&as)); /* L6 */
O(PUSH); O(DROP); O(RPOP);
to_setbit = v4_asm_branch_fwd(&as, V4_OP_JUMP);
l_sub = v4_asm_label(&as);
O(INV); O(PUSH_A); O(ADD); O(INV);
l_setbit = v4_asm_label(&as);
O(PUSH); LIT(1); O(ADD); O(RPOP);
l_nosub = v4_asm_label(&as);
v4_asm_branch(&as, V4_OP_NEXT, loop);
O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI);
v4_asm_resolve(&as, to_sub1, l_sub);
v4_asm_resolve(&as, to_sub2, l_sub);
v4_asm_resolve(&as, to_setbit, l_setbit);
v4_asm_resolve(&as, to_nosub1, l_nosub);
v4_asm_resolve(&as, to_nosub2, l_nosub);
}
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;
}
Reference in New Issue View Git Blame Copy Permalink