LithosAnanake/v4/tests/test_foundation.c

/* 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.
 *
 * 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;

#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);

    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, 1000) > 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);
}

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");

    CHECK(v4_node_guards_intact(&n), "guards intact");

    printf("  %d checks, %d failures\n", checks, failures);
    return failures ? 1 : 0;
}