rajamesandClaude Opus 5.5
8f37e15f8a
Q.* now forms its products in the order a1*b1 (low cell), a0*b1, a1*b0, a0*b0, dropping each input after its last use, with b0 waiting on the return stack. Each sign correction, (b1<0 ? a0 : 0) and (a1<0 ? b0 : 0), is folded into cell 2 as soon as its operands are adjacent, using -if rather than 0< calls. At most four live values sit under any UM* call. Headroom (data cells under args / return entries): 2/2 -> 3/3. Same checks as before at 32- and 64-bit cells, optimised and ASan+UBSan; dropping either sign correction fails about 9900 checks. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
1451 lines
62 KiB
C
1451 lines
62 KiB
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, 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 section 4's call-free
|
|
* version, checked against q*d + r = uhi:ulo, r < d over the edge vectors and
|
|
* 20000 pseudo-random cases with uhi < ud. SM/REM and DNEGATE are the
|
|
* call-free versions in sections 4 and 5.7; SM/REM is checked on dividends
|
|
* built as q*n + r. D+ is the call-free version in 5.7, checked against C
|
|
* over every quadruple of the edge vectors and pseudo-random pairs. /MOD,
|
|
* U>, ABS, S>D, DABS, M+, D-, D0= and D= are as written in section 5 and
|
|
* checked against C. Q.+, Q.-, Q.ABS and Q.NEG (section 5.26: the D+, D-,
|
|
* DABS and DNEGATE words) are checked against v3's 64-bit q48_add, q48_sub,
|
|
* q48_abs and 0 - q, with Q values two cells wide at both widths (D-10).
|
|
* Q.FROM-INT and Q.TO-INT are checked against n * 2^16 and q >> 16 in C and
|
|
* against v3's q48_from_u64 and q48_to_u64 where v4 keeps v3's meaning.
|
|
* <, =, D<, 2OVER, the call-free (D<), DMAX, DMIN and 2SWAP, and the Q
|
|
* comparisons on them, are checked against C, signed (D-8), and against v3
|
|
* where v3's unsigned Q comparisons agree. Q.* is checked against an independent limb-by-limb
|
|
* reference, signed, and against v3's q48_mul for non-negative operands. Every word is
|
|
* also probed for how much of the 10- and 9-deep circular stacks (D-2) it
|
|
* leaves to its 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 <stdint.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,
|
|
w_ugreater, w_abs, w_s2d, w_dplus, w_dnegate, w_dabs, w_smrem,
|
|
w_slashmod, w_mplus, w_dminus, w_d0equal, w_dequal,
|
|
w_qfromint, w_qtoint, w_less, w_equal, w_dless, w_2swap, w_2over,
|
|
w_dmax, w_dmin, w_qgt_doc, w_qgt, w_dltkeep, w_qstar;
|
|
|
|
#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))
|
|
|
|
/* Section 2's capsule IF ... THEN: the flag is dropped on both paths. */
|
|
static v4_asm_ref if_(void)
|
|
{
|
|
v4_asm_ref r = v4_asm_branch_fwd(&as, V4_OP_IF);
|
|
v4_asm_op(&as, V4_OP_DROP);
|
|
return r;
|
|
}
|
|
static void then_(v4_asm_ref r)
|
|
{
|
|
v4_asm_ref j = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, r, v4_asm_label(&as));
|
|
v4_asm_op(&as, V4_OP_DROP);
|
|
v4_asm_resolve(&as, j, v4_asm_label(&as));
|
|
}
|
|
|
|
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 1 and inv 1 + over 2/ and u1 u2 t0 t0 = u2 2/ if u1 odd
|
|
* over a! 31 push R: loop count (FOR's push, early)
|
|
* push over 2/ pop u1 u2 s t0 A: u2, s = u1 2/
|
|
* L: +* unext u1 u2 s hi A: lo
|
|
* push drop pop u1 u2 hi
|
|
* 2* a -if L0 drop 1 + jump L1 L0: drop L1: push R: 2hi + top bit of lo
|
|
* over -if L2 drop dup jump L3 L2: drop 0 L3: push R: + (u1<0 ? u2 : 0)
|
|
* dup -if L4 drop over 1 and jump L5 L4: drop 0 L5: u1 u2 (u2<0 ? u1&1 : 0)
|
|
* pop + pop + push u1 u2 R: hi'
|
|
* and 1 and a 2* + pop ; lo' hi'
|
|
* u1 and u2 wait on the data stack under the loop (+* touches only T, S
|
|
* and A), so the corrections are made afterwards and the return stack
|
|
* holds at most two temporaries. 31 is the cell width less one, pushed
|
|
* before s is made so the data stack never holds more than four; the loop
|
|
* body is the start of its own word so that unext restarts it. */
|
|
{
|
|
v4_asm_ref l0, l1, l2, l3, l4, l5;
|
|
w_umstar = v4_asm_label(&as);
|
|
O(OVER); LIT(1); O(AND); O(INV); LIT(1); O(ADD); O(OVER); O(TWO_SLASH); O(AND);
|
|
O(OVER); O(BANG_A); LIT(V4_CELL_BITS - 1); O(PUSH);
|
|
O(PUSH); O(OVER); O(TWO_SLASH); O(RPOP);
|
|
(void)v4_asm_label(&as);
|
|
O(MUL_STEP); O(UNEXT);
|
|
O(PUSH); O(DROP); O(RPOP);
|
|
O(TWO_STAR); O(PUSH_A);
|
|
l0 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); LIT(1); O(ADD);
|
|
l1 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l0, v4_asm_label(&as));
|
|
O(DROP);
|
|
v4_asm_resolve(&as, l1, v4_asm_label(&as));
|
|
O(PUSH);
|
|
O(OVER);
|
|
l2 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(DUP);
|
|
l3 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l2, v4_asm_label(&as));
|
|
O(DROP); LIT(0);
|
|
v4_asm_resolve(&as, l3, v4_asm_label(&as));
|
|
O(PUSH);
|
|
O(DUP);
|
|
l4 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(OVER); LIT(1); O(AND);
|
|
l5 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l4, v4_asm_label(&as));
|
|
O(DROP); LIT(0);
|
|
v4_asm_resolve(&as, l5, v4_asm_label(&as));
|
|
O(RPOP); O(ADD); O(RPOP); O(ADD); O(PUSH);
|
|
O(AND); LIT(1); O(AND); O(PUSH_A); O(TWO_STAR); O(ADD); O(RPOP);
|
|
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);
|
|
}
|
|
|
|
/* ---- section 5 words that SM/REM and /MOD rest on, as written there. */
|
|
|
|
/* : U> SWAP U< ; 5.5 */
|
|
w_ugreater = v4_asm_label(&as);
|
|
CALL(w_swap); CALL(w_uless); O(SEMI);
|
|
|
|
/* : ABS dup 0< IF NEGATE THEN ; 5.4 */
|
|
w_abs = v4_asm_label(&as);
|
|
O(DUP); CALL(w_zless); ref = if_(); CALL(w_negate); then_(ref); O(SEMI);
|
|
|
|
/* : S>D dup 0< ; 5.7 */
|
|
w_s2d = v4_asm_label(&as);
|
|
O(DUP); CALL(w_zless); O(SEMI);
|
|
|
|
/* : D+ ( d1 d2 -- d3 ) 5.7, call-free
|
|
* push over push push drop pop al bl R: bh ah
|
|
* over over xor -if L1 top bits of al, bl differ:
|
|
* drop + -if C1 jump C0 carry iff sum's top bit clear
|
|
* L1: drop over -if L2 same: carry iff both set
|
|
* drop + jump C1
|
|
* L2: drop +
|
|
* C0: pop pop + ;
|
|
* C1: pop pop + 1 + ; */
|
|
{
|
|
v4_asm_ref l1, l2, c1a, c1b, c0a;
|
|
v4_cell c0, c1;
|
|
|
|
w_dplus = v4_asm_label(&as);
|
|
O(PUSH); O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP);
|
|
O(OVER); O(OVER); O(XOR);
|
|
l1 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(ADD);
|
|
c1a = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
c0a = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l1, v4_asm_label(&as));
|
|
O(DROP); O(OVER);
|
|
l2 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(ADD);
|
|
c1b = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l2, v4_asm_label(&as));
|
|
O(DROP); O(ADD);
|
|
c0 = v4_asm_label(&as);
|
|
O(RPOP); O(RPOP); O(ADD); O(SEMI);
|
|
c1 = v4_asm_label(&as);
|
|
O(RPOP); O(RPOP); O(ADD); LIT(1); O(ADD); O(SEMI);
|
|
v4_asm_resolve(&as, c0a, c0);
|
|
v4_asm_resolve(&as, c1a, c1);
|
|
v4_asm_resolve(&as, c1b, c1);
|
|
}
|
|
|
|
/* : DNEGATE ( d -- -d ) 5.7, call-free
|
|
* inv over if L1 drop push inv 1 + pop ;
|
|
* L1: drop 1 + ;
|
|
* -d = ~d + 1: the + 1 carries into hi exactly when lo = 0. */
|
|
w_dnegate = v4_asm_label(&as);
|
|
O(INV); O(OVER); ref = v4_asm_branch_fwd(&as, V4_OP_IF);
|
|
O(DROP); O(PUSH); O(INV); LIT(1); O(ADD); O(RPOP); O(SEMI);
|
|
v4_asm_resolve(&as, ref, v4_asm_label(&as));
|
|
O(DROP); LIT(1); O(ADD); O(SEMI);
|
|
|
|
/* : DABS dup 0< IF DNEGATE THEN ; 5.7 */
|
|
w_dabs = v4_asm_label(&as);
|
|
O(DUP); CALL(w_zless); ref = if_(); CALL(w_dnegate); then_(ref); O(SEMI);
|
|
|
|
/* : SM/REM ( d n -- rem quot ) section 4
|
|
* over over xor push R: quotient sign (top bit)
|
|
* over push R: + remainder sign (of d)
|
|
* -if L0 inv 1 + L0: push R: + |n|
|
|
* -if L1 DNEGATE L1: |d|
|
|
* pop UM/MOD urem uquot
|
|
* pop -if L2 drop push inv 1 + pop jump L3 L2: drop L3:
|
|
* pop -if L4 drop inv 1 + ; L4: drop ;
|
|
* Sign tests are native -if, as in 0<; NEGATE is in line. */
|
|
{
|
|
v4_asm_ref l0, l1, l2, l3, l4;
|
|
w_smrem = v4_asm_label(&as);
|
|
O(OVER); O(OVER); O(XOR); O(PUSH); O(OVER); O(PUSH);
|
|
l0 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(INV); LIT(1); O(ADD);
|
|
v4_asm_resolve(&as, l0, v4_asm_label(&as));
|
|
O(PUSH);
|
|
l1 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
CALL(w_dnegate);
|
|
v4_asm_resolve(&as, l1, v4_asm_label(&as));
|
|
O(RPOP); CALL(w_ummod);
|
|
O(RPOP);
|
|
l2 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(PUSH); O(INV); LIT(1); O(ADD); O(RPOP);
|
|
l3 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l2, v4_asm_label(&as));
|
|
O(DROP);
|
|
v4_asm_resolve(&as, l3, v4_asm_label(&as));
|
|
O(RPOP);
|
|
l4 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(INV); LIT(1); O(ADD); O(SEMI);
|
|
v4_asm_resolve(&as, l4, v4_asm_label(&as));
|
|
O(DROP); O(SEMI);
|
|
}
|
|
|
|
/* : /MOD push S>D pop SM/REM ; 5.6 */
|
|
w_slashmod = v4_asm_label(&as);
|
|
O(PUSH); CALL(w_s2d); O(RPOP); CALL(w_smrem); O(SEMI);
|
|
|
|
/* : M+ S>D D+ ; 5.6 */
|
|
w_mplus = v4_asm_label(&as);
|
|
CALL(w_s2d); CALL(w_dplus); O(SEMI);
|
|
|
|
/* : D- DNEGATE D+ ; 5.7 */
|
|
w_dminus = v4_asm_label(&as);
|
|
CALL(w_dnegate); CALL(w_dplus); O(SEMI);
|
|
|
|
/* : D0= OR 0= ; 5.7 */
|
|
w_d0equal = v4_asm_label(&as);
|
|
CALL(w_or); CALL(w_zequal); O(SEMI);
|
|
|
|
/* : D= D- D0= ; 5.7 */
|
|
w_dequal = v4_asm_label(&as);
|
|
CALL(w_dminus); CALL(w_d0equal); O(SEMI);
|
|
|
|
/* +* with S = 0 never adds: each step is an exact arithmetic right shift
|
|
* of the double T:A by one bit. Both words below are built on that. */
|
|
|
|
/* : Q.FROM-INT ( n -- q ) 5.26
|
|
* push 0 a! 0 pop 15 FOR +* UNEXT push drop a pop ;
|
|
* T:A = n:0 is n * 2^N; shifted right N-16 bits it is n * 2^16. 15 is
|
|
* N-17 at 32-bit cells (47 at 64). Clobbers A. */
|
|
w_qfromint = v4_asm_label(&as);
|
|
O(PUSH); LIT(0); O(BANG_A); LIT(0); O(RPOP);
|
|
LIT(V4_CELL_BITS - 17); O(PUSH);
|
|
(void)v4_asm_label(&as);
|
|
O(MUL_STEP); O(UNEXT);
|
|
O(PUSH); O(DROP); O(PUSH_A); O(RPOP); O(SEMI);
|
|
|
|
/* : Q.TO-INT ( q -- n ) 5.26
|
|
* push a! 0 pop 15 FOR +* UNEXT drop drop a ;
|
|
* T:A = q shifted right 16 bits; the low cell is A. 15 at every cell
|
|
* width. Clobbers A. */
|
|
w_qtoint = v4_asm_label(&as);
|
|
O(PUSH); O(BANG_A); LIT(0); O(RPOP);
|
|
LIT(15); O(PUSH);
|
|
(void)v4_asm_label(&as);
|
|
O(MUL_STEP); O(UNEXT);
|
|
O(DROP); O(DROP); O(PUSH_A); O(SEMI);
|
|
|
|
/* : = xor 0= ; 5.5 */
|
|
w_equal = v4_asm_label(&as);
|
|
O(XOR); CALL(w_zequal); O(SEMI);
|
|
|
|
/* : < 2DUP xor 0< IF drop 0< ELSE - 0< THEN ; 5.5 */
|
|
w_less = v4_asm_label(&as);
|
|
O(OVER); O(OVER); O(XOR); CALL(w_zless);
|
|
ref = v4_asm_branch_fwd(&as, V4_OP_IF);
|
|
O(DROP); O(DROP); CALL(w_zless);
|
|
{
|
|
v4_asm_ref j = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, ref, v4_asm_label(&as));
|
|
O(DROP); CALL(w_minus); CALL(w_zless);
|
|
v4_asm_resolve(&as, j, v4_asm_label(&as));
|
|
}
|
|
O(SEMI);
|
|
|
|
/* : D< ROT 2DUP = IF 2DROP U< ELSE SWAP < NIP NIP THEN ; 5.7 */
|
|
w_dless = v4_asm_label(&as);
|
|
CALL(w_rot); O(OVER); O(OVER); CALL(w_equal);
|
|
ref = v4_asm_branch_fwd(&as, V4_OP_IF);
|
|
O(DROP); O(DROP); O(DROP); CALL(w_uless);
|
|
{
|
|
v4_asm_ref j = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, ref, v4_asm_label(&as));
|
|
O(DROP); CALL(w_swap); CALL(w_less); CALL(w_nip); CALL(w_nip);
|
|
v4_asm_resolve(&as, j, v4_asm_label(&as));
|
|
}
|
|
O(SEMI);
|
|
|
|
/* : 2SWAP ROT push ROT pop ; 5.7, call-free
|
|
* with ROT (push SWAP pop SWAP) and SWAP (over push push drop pop pop)
|
|
* written in line:
|
|
* push over push push drop pop pop pop over push push drop pop pop
|
|
* push
|
|
* push over push push drop pop pop pop over push push drop pop pop
|
|
* pop ; */
|
|
#define ROT_INLINE() do { O(PUSH); O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); \
|
|
O(RPOP); O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); } while (0)
|
|
w_2swap = v4_asm_label(&as);
|
|
ROT_INLINE(); O(PUSH); ROT_INLINE(); O(RPOP); O(SEMI);
|
|
#undef ROT_INLINE
|
|
|
|
/* : 2OVER push push 2DUP pop pop 2SWAP ; 5.7 */
|
|
w_2over = v4_asm_label(&as);
|
|
O(PUSH); O(PUSH); O(OVER); O(OVER); O(RPOP); O(RPOP); CALL(w_2swap); O(SEMI);
|
|
|
|
/* : (D<) ( d1 d2 -- d1 d2 flag ) 5.7, call-free
|
|
* Signed d1 < d2, leaving both doubles. Copies of ah and bh go on top;
|
|
* if they differ, flag comes from them, else from al U< bl. In every
|
|
* case the tested value has its top bit set exactly when d1 < d2:
|
|
* highs, signs differ: ah (d1 < d2 iff ah < 0)
|
|
* highs, signs agree: ah - bh (cannot overflow)
|
|
* lows, top bits differ: bl (al U< bl iff bl's is set)
|
|
* lows, top bits agree: al - bl
|
|
* x - y with y on top is `push inv pop + inv`.
|
|
*
|
|
* dup push push over pop al ah bl ah bh R: bh
|
|
* over over xor if TIE
|
|
* drop over over xor -if HS
|
|
* drop drop jump S1 al ah bl ah
|
|
* HS: drop push inv pop + inv al ah bl ah-bh
|
|
* S1: -if N1 drop -1 jump D1 N1: drop 0
|
|
* D1: pop over push push drop pop pop ; al ah bl bh f
|
|
* TIE: drop drop drop al ah bl R: bh
|
|
* dup push push over pop al ah al bl R: bh bl
|
|
* over over xor -if LS
|
|
* drop push drop pop jump S2 al ah bl
|
|
* LS: drop push inv pop + inv al ah al-bl
|
|
* S2: -if N2 drop -1 jump D2 N2: drop 0
|
|
* D2: pop pop al ah f bl bh
|
|
* push over push push drop pop pop pop over push push drop pop pop ; */
|
|
{
|
|
v4_asm_ref tie, hs, s1a, n1, d1, ls, s2a, n2, d2;
|
|
w_dltkeep = v4_asm_label(&as);
|
|
O(DUP); O(PUSH); O(PUSH); O(OVER); O(RPOP);
|
|
O(OVER); O(OVER); O(XOR);
|
|
tie = v4_asm_branch_fwd(&as, V4_OP_IF);
|
|
O(DROP); O(OVER); O(OVER); O(XOR);
|
|
hs = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(DROP);
|
|
s1a = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, hs, v4_asm_label(&as));
|
|
O(DROP); O(PUSH); O(INV); O(RPOP); O(ADD); O(INV);
|
|
v4_asm_resolve(&as, s1a, v4_asm_label(&as));
|
|
n1 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); LIT(-1);
|
|
d1 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, n1, v4_asm_label(&as));
|
|
O(DROP); LIT(0);
|
|
v4_asm_resolve(&as, d1, v4_asm_label(&as));
|
|
O(RPOP); O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI);
|
|
|
|
v4_asm_resolve(&as, tie, v4_asm_label(&as));
|
|
O(DROP); O(DROP); O(DROP);
|
|
O(DUP); O(PUSH); O(PUSH); O(OVER); O(RPOP);
|
|
O(OVER); O(OVER); O(XOR);
|
|
ls = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(PUSH); O(DROP); O(RPOP);
|
|
s2a = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, ls, v4_asm_label(&as));
|
|
O(DROP); O(PUSH); O(INV); O(RPOP); O(ADD); O(INV);
|
|
v4_asm_resolve(&as, s2a, v4_asm_label(&as));
|
|
n2 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); LIT(-1);
|
|
d2 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, n2, v4_asm_label(&as));
|
|
O(DROP); LIT(0);
|
|
v4_asm_resolve(&as, d2, v4_asm_label(&as));
|
|
O(RPOP); O(RPOP);
|
|
O(PUSH); O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP);
|
|
O(RPOP); O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); O(SEMI);
|
|
}
|
|
|
|
/* : DMAX ( d1 d2 -- d3 ) (D<) if L drop push push drop drop pop pop ;
|
|
* L: drop drop drop ; 5.7 */
|
|
w_dmax = v4_asm_label(&as);
|
|
CALL(w_dltkeep);
|
|
ref = v4_asm_branch_fwd(&as, V4_OP_IF);
|
|
O(DROP); O(PUSH); O(PUSH); O(DROP); O(DROP); O(RPOP); O(RPOP); O(SEMI);
|
|
v4_asm_resolve(&as, ref, v4_asm_label(&as));
|
|
O(DROP); O(DROP); O(DROP); O(SEMI);
|
|
|
|
/* : DMIN ( d1 d2 -- d3 ) (D<) if L drop drop drop ;
|
|
* L: drop push push drop drop pop pop ; 5.7 */
|
|
w_dmin = v4_asm_label(&as);
|
|
CALL(w_dltkeep);
|
|
ref = v4_asm_branch_fwd(&as, V4_OP_IF);
|
|
O(DROP); O(DROP); O(DROP); O(SEMI);
|
|
v4_asm_resolve(&as, ref, v4_asm_label(&as));
|
|
O(DROP); O(PUSH); O(PUSH); O(DROP); O(DROP); O(RPOP); O(RPOP); O(SEMI);
|
|
|
|
/* Q.> as 5.26 gives it, SWAP D<, and with 2SWAP. */
|
|
w_qgt_doc = v4_asm_label(&as);
|
|
CALL(w_swap); CALL(w_dless); O(SEMI);
|
|
w_qgt = v4_asm_label(&as);
|
|
CALL(w_2swap); CALL(w_dless); O(SEMI);
|
|
|
|
/* : Q.* ( a b -- c ) 5.26
|
|
* a = a0 a1, b = b0 b1. Cells 0..2 of the signed product a*b, then
|
|
* shifted right 16. The cell products are unsigned; reading a1 and b1
|
|
* as signed takes (a1<0 ? b0 : 0) + (b1<0 ? a0 : 0) off cell 2, the
|
|
* only cell above the unsigned product's that the result reaches.
|
|
* Products in the order a1*b1 (low cell), a0*b1, a1*b0, a0*b0, each
|
|
* input dropped after its last use; b0 waits on the return stack.
|
|
* SWAP push over over UM* drop a0 a1 b1 t3 R: b0
|
|
* push push over pop a0 a1 a0 b1 R: b0 t3
|
|
* -if L1 SWAP jump L2 L1: SWAP drop 0 L2: a0 a1 b1 c2
|
|
* pop SWAP - push a0 a1 b1 R: b0 t3-c2
|
|
* push over pop UM* pop + a0 a1 x0 x1 R: b0
|
|
* ROT pop dup push a0 x0 x1 a1 b0
|
|
* over -if L3 drop dup jump L4 L3: drop 0 L4: ... a1 b0 c1
|
|
* push UM* pop - D+ a0 X0 X1
|
|
* ROT pop UM* X0 X1 l00 h00
|
|
* SWAP push 0 D+ pop c1 c2 c0
|
|
* push over pop SWAP Q.TO-INT push Q.TO-INT pop SWAP ;
|
|
* SWAP and ROT in line. Clobbers A. */
|
|
#define SWAP_INLINE() do { O(OVER); O(PUSH); O(PUSH); O(DROP); O(RPOP); O(RPOP); } while (0)
|
|
#define ROT_INLINE() do { O(PUSH); SWAP_INLINE(); O(RPOP); SWAP_INLINE(); } while (0)
|
|
{
|
|
v4_asm_ref l1, l2, l3, l4;
|
|
w_qstar = v4_asm_label(&as);
|
|
SWAP_INLINE(); O(PUSH); O(OVER); O(OVER); CALL(w_umstar); O(DROP);
|
|
O(PUSH); O(PUSH); O(OVER); O(RPOP);
|
|
l1 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
SWAP_INLINE();
|
|
l2 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l1, v4_asm_label(&as));
|
|
SWAP_INLINE(); O(DROP); LIT(0);
|
|
v4_asm_resolve(&as, l2, v4_asm_label(&as));
|
|
O(RPOP); SWAP_INLINE(); CALL(w_minus); O(PUSH);
|
|
O(PUSH); O(OVER); O(RPOP); CALL(w_umstar); O(RPOP); O(ADD);
|
|
ROT_INLINE(); O(RPOP); O(DUP); O(PUSH);
|
|
O(OVER);
|
|
l3 = v4_asm_branch_fwd(&as, V4_OP_MINUS_IF);
|
|
O(DROP); O(DUP);
|
|
l4 = v4_asm_branch_fwd(&as, V4_OP_JUMP);
|
|
v4_asm_resolve(&as, l3, v4_asm_label(&as));
|
|
O(DROP); LIT(0);
|
|
v4_asm_resolve(&as, l4, v4_asm_label(&as));
|
|
O(PUSH); CALL(w_umstar); O(RPOP); CALL(w_minus); CALL(w_dplus);
|
|
ROT_INLINE(); O(RPOP); CALL(w_umstar);
|
|
SWAP_INLINE(); O(PUSH); LIT(0); CALL(w_dplus); O(RPOP);
|
|
O(PUSH); O(OVER); O(RPOP); SWAP_INLINE(); CALL(w_qtoint);
|
|
O(PUSH); CALL(w_qtoint); O(RPOP); SWAP_INLINE();
|
|
O(SEMI);
|
|
}
|
|
#undef ROT_INLINE
|
|
#undef SWAP_INLINE
|
|
|
|
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 same with four arguments. */
|
|
static int call4(v4_cell word, v4_cell a, v4_cell b, v4_cell c, v4_cell d)
|
|
{
|
|
v4_dstack_reset(&n.ds);
|
|
v4_rstack_reset(&n.rs);
|
|
v4_exec_reset(&es);
|
|
v4_dstack_push(&n.ds, CANARY);
|
|
v4_dstack_push(&n.ds, a);
|
|
v4_dstack_push(&n.ds, b);
|
|
v4_dstack_push(&n.ds, c);
|
|
v4_dstack_push(&n.ds, d);
|
|
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;
|
|
}
|
|
|
|
/* Doubles in C, as (lo, hi) with hi the high cell, for the section 5.7 and
|
|
* SM/REM checks. */
|
|
static void dadd(v4_ucell al, v4_ucell ah, v4_ucell bl, v4_ucell bh,
|
|
v4_ucell *rl, v4_ucell *rh)
|
|
{
|
|
*rl = al + bl;
|
|
*rh = ah + bh + (*rl < al);
|
|
}
|
|
static void dneg(v4_ucell l, v4_ucell h, v4_ucell *rl, v4_ucell *rh)
|
|
{
|
|
dadd(~l, ~h, 1u, 0u, rl, rh);
|
|
}
|
|
/* Signed q * n as a signed double. */
|
|
static void smul(v4_cell q, v4_cell nn, v4_ucell *rl, v4_ucell *rh)
|
|
{
|
|
v4_ucell uq = (v4_ucell)q, un = (v4_ucell)nn;
|
|
if (q < 0) uq = 0u - uq;
|
|
if (nn < 0) un = 0u - un;
|
|
v4_umul(uq, un, rl, rh);
|
|
if ((q < 0) != (nn < 0)) dneg(*rl, *rh, rl, rh);
|
|
}
|
|
|
|
/* SM/REM on the dividend d = q*n + r, built so that (r, q) is the
|
|
* truncating answer: |r| < |n|, and r is zero or has the sign of d. */
|
|
static int smrem_exact(v4_cell q, v4_cell nn, v4_cell r)
|
|
{
|
|
v4_ucell pl, ph, dl, dh;
|
|
smul(q, nn, &pl, &ph);
|
|
dadd(pl, ph, (v4_ucell)r, r < 0 ? MAXU : 0u, &dl, &dh);
|
|
return call(w_smrem, 3, (v4_cell)dl, (v4_cell)dh, nn) && left2(r, q);
|
|
}
|
|
|
|
/* Q48.16 (section 5.26). v3's Q.+ and Q.- are uint64_t a + b and a - b,
|
|
* wrapping (v3/include/q48_16.h). Here a Q value is a double: at 32-bit
|
|
* cells its two halves, at 64-bit cells the value sign-extended (D-8). */
|
|
static void qcells(uint64_t q, v4_cell *lo, v4_cell *hi)
|
|
{
|
|
#if V4_CELL_BITS == 32
|
|
*lo = (v4_cell)(v4_ucell)(q & 0xFFFFFFFFu);
|
|
*hi = (v4_cell)(v4_ucell)(q >> 32);
|
|
#else
|
|
*lo = (v4_cell)(v4_ucell)q;
|
|
*hi = (q >> 63) ? V4_ALL_ONES : 0;
|
|
#endif
|
|
}
|
|
|
|
/* Run Q.+ (the D+ word) or Q.- (the D- word) on a and b and compare with
|
|
* v3's 64-bit wrapping result. At 32-bit cells the double must equal v3's
|
|
* value bit for bit. At 64-bit cells the low cell must equal v3's value and
|
|
* the high cell must be the true sign of the unwrapped result. */
|
|
static int q_matches_v3(v4_cell word, uint64_t a, uint64_t b, uint64_t v3)
|
|
{
|
|
v4_cell al, ah, bl, bh, rl, rh;
|
|
qcells(a, &al, &ah);
|
|
qcells(b, &bl, &bh);
|
|
if (!call4(word, al, ah, bl, bh)) return 0;
|
|
#if V4_CELL_BITS == 32
|
|
qcells(v3, &rl, &rh);
|
|
return left2(rl, rh);
|
|
#else
|
|
{
|
|
v4_ucell xl, xh, nl, nh;
|
|
if (word == w_dminus) { dneg((v4_ucell)bl, (v4_ucell)bh, &nl, &nh); }
|
|
else { nl = (v4_ucell)bl; nh = (v4_ucell)bh; }
|
|
dadd((v4_ucell)al, (v4_ucell)ah, nl, nh, &xl, &xh);
|
|
rl = (v4_cell)(v4_ucell)v3;
|
|
rh = (v4_cell)xh;
|
|
return (v4_ucell)rl == xl && left2(rl, rh);
|
|
}
|
|
#endif
|
|
}
|
|
|
|
/* The same for the one-operand Q words: Q.ABS (the DABS word) and Q.NEG
|
|
* (the DNEGATE word). `wl`, `wh` is the exact double result, which at
|
|
* 64-bit cells may differ from v3 in the high cell only (D-10). */
|
|
static int q1_matches_v3(v4_cell word, uint64_t a, uint64_t v3)
|
|
{
|
|
v4_cell al, ah, rl, rh;
|
|
v4_ucell xl, xh;
|
|
qcells(a, &al, &ah);
|
|
if (!call(word, 2, al, ah, 0)) return 0;
|
|
#if V4_CELL_BITS == 32
|
|
(void)xl; (void)xh;
|
|
qcells(v3, &rl, &rh);
|
|
return left2(rl, rh);
|
|
#else
|
|
if (word == w_dnegate || ah < 0) dneg((v4_ucell)al, (v4_ucell)ah, &xl, &xh);
|
|
else { xl = (v4_ucell)al; xh = (v4_ucell)ah; }
|
|
rl = (v4_cell)(v4_ucell)v3;
|
|
rh = (v4_cell)xh;
|
|
return (v4_ucell)rl == xl && left2(rl, rh);
|
|
#endif
|
|
}
|
|
|
|
/* x shifted right `k` bits, arithmetic, without C's implementation-defined
|
|
* right shift of a negative value. */
|
|
static v4_ucell asr_u(v4_ucell x, unsigned k)
|
|
{
|
|
v4_ucell r = x >> k;
|
|
if (k && (x & V4_MSB)) r |= ~(MAXU >> k);
|
|
return r;
|
|
}
|
|
static uint64_t asr64(uint64_t x, unsigned k)
|
|
{
|
|
uint64_t r = x >> k;
|
|
if (k && (x >> 63)) r |= ~((~(uint64_t)0) >> k);
|
|
return r;
|
|
}
|
|
|
|
/* The k results, given bottom first, then the canary under them. */
|
|
static int leftk(const v4_cell *want, unsigned k)
|
|
{
|
|
while (k-- > 0)
|
|
if (v4_dstack_pop(&n.ds) != want[k]) return 0;
|
|
return v4_dstack_pop(&n.ds) == CANARY;
|
|
}
|
|
|
|
/* Signed double a < b, in C. */
|
|
static int dlt(v4_ucell al, v4_ucell ah, v4_ucell bl, v4_ucell bh)
|
|
{
|
|
if (ah != bh) return (v4_cell)ah < (v4_cell)bh;
|
|
return al < bl;
|
|
}
|
|
|
|
/* Q48.16 as v4 reads it (D-8: signed). */
|
|
static int64_t qs(uint64_t q)
|
|
{
|
|
return (q >> 63) ? -(int64_t)(~q) - 1 : (int64_t)q;
|
|
}
|
|
|
|
/* Reference Q.* for any cell width, by a different method from the FORTH:
|
|
* the Q values (two cells each) as signed integers in 16-bit limbs, the
|
|
* magnitudes multiplied schoolbook, the product negated if the signs differ,
|
|
* then shifted right 16 (one limb) and cut to two cells. Shifting the
|
|
* two's-complement product rounds toward minus infinity. */
|
|
#define QLIMBS (2 * V4_CELL_BITS / 16)
|
|
static void q_to_limbs(v4_ucell lo, v4_ucell hi, uint32_t *l, int *neg)
|
|
{
|
|
unsigned i;
|
|
*neg = (hi & V4_MSB) != 0;
|
|
if (*neg) dneg(lo, hi, &lo, &hi);
|
|
for (i = 0; i < QLIMBS / 2; i++) {
|
|
l[i] = (uint32_t)((lo >> (16 * i)) & 0xFFFFu);
|
|
l[i + QLIMBS / 2] = (uint32_t)((hi >> (16 * i)) & 0xFFFFu);
|
|
}
|
|
}
|
|
static void qmul_ref(v4_ucell al, v4_ucell ah, v4_ucell bl, v4_ucell bh,
|
|
v4_ucell *rl, v4_ucell *rh)
|
|
{
|
|
uint32_t a[QLIMBS], b[QLIMBS], p[2 * QLIMBS];
|
|
int an, bn;
|
|
unsigned i, j;
|
|
|
|
q_to_limbs(al, ah, a, &an);
|
|
q_to_limbs(bl, bh, b, &bn);
|
|
for (i = 0; i < 2 * QLIMBS; i++) p[i] = 0;
|
|
for (i = 0; i < QLIMBS; i++) {
|
|
uint32_t carry = 0;
|
|
for (j = 0; j < QLIMBS; j++) {
|
|
uint32_t t = a[i] * b[j] + p[i + j] + carry; /* < 2^32 */
|
|
p[i + j] = t & 0xFFFFu;
|
|
carry = t >> 16;
|
|
}
|
|
p[i + QLIMBS] = carry;
|
|
}
|
|
if (an != bn) { /* negate, 2's complement */
|
|
uint32_t carry = 1;
|
|
for (i = 0; i < 2 * QLIMBS; i++) {
|
|
uint32_t t = (~p[i] & 0xFFFFu) + carry;
|
|
p[i] = t & 0xFFFFu;
|
|
carry = t >> 16;
|
|
}
|
|
}
|
|
*rl = 0; *rh = 0; /* limbs 1 .. QLIMBS */
|
|
for (i = 0; i < QLIMBS / 2; i++) {
|
|
*rl |= (v4_ucell)p[1 + i] << (16 * i);
|
|
*rh |= (v4_ucell)p[1 + QLIMBS / 2 + i] << (16 * i);
|
|
}
|
|
}
|
|
|
|
/* v3's q48_mul: unsigned (a * b) >> 16, cut to 64 bits, as its __int128
|
|
* branch computes it on 64-bit gcc/clang hosts. This is the portable
|
|
* branch of v3/src/word_source/q48_16_words.c with its last line corrected:
|
|
* v3 returns (result_hi << 16) | (result_lo >> 16), which is wrong whenever
|
|
* the product reaches past bit 64 (the high cell must move up 48 bits, not
|
|
* 16). v3 uses that branch only on hosts without __int128. */
|
|
static uint64_t v3_q48_mul(uint64_t a, uint64_t b)
|
|
{
|
|
uint64_t a_hi = a >> 32;
|
|
uint64_t a_lo = a & 0xFFFFFFFFULL;
|
|
uint64_t b_hi = b >> 32;
|
|
uint64_t b_lo = b & 0xFFFFFFFFULL;
|
|
uint64_t p_ll = a_lo * b_lo;
|
|
uint64_t p_lh = a_lo * b_hi;
|
|
uint64_t p_hl = a_hi * b_lo;
|
|
uint64_t p_hh = a_hi * b_hi;
|
|
uint64_t carry = 0;
|
|
uint64_t mid = p_lh + p_hl;
|
|
uint64_t result_hi, result_lo;
|
|
if (mid < p_lh) carry++;
|
|
result_hi = p_hh + (mid >> 32) + (carry << 32);
|
|
result_lo = p_ll + ((mid & 0xFFFFFFFFULL) << 32);
|
|
if (result_lo < p_ll) result_hi++;
|
|
return (result_hi << 48) | (result_lo >> 16);
|
|
}
|
|
|
|
/* 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[V4_DATA_DEPTH];
|
|
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;
|
|
if (nres > V4_DATA_DEPTH) 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)[4], 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);
|
|
}
|
|
}
|
|
|
|
/* Section 5 words under SM/REM and /MOD, against their C meaning. */
|
|
for (unsigned i = 0; i < NVEC; i++) {
|
|
v4_cell a = vec[i];
|
|
v4_ucell ua = (v4_ucell)a;
|
|
CHECK(call(w_abs, 1, a, 0, 0) && left1(a < 0 ? (v4_cell)(0u - ua) : a), "ABS [%u]", i);
|
|
CHECK(call(w_s2d, 1, a, 0, 0) && left2(a, FLAG(a < 0)), "S>D [%u]", i);
|
|
for (unsigned j = 0; j < NVEC; j++) {
|
|
v4_cell b = vec[j];
|
|
v4_ucell ub = (v4_ucell)b, rl, rh;
|
|
CHECK(call(w_ugreater, 2, a, b, 0) && left1(FLAG(ua > ub)), "U> [%u,%u]", i, j);
|
|
dneg(ua, ub, &rl, &rh);
|
|
CHECK(call(w_dnegate, 2, a, b, 0) && left2((v4_cell)rl, (v4_cell)rh), "DNEGATE [%u,%u]", i, j);
|
|
if (b >= 0) { rl = ua; rh = ub; }
|
|
CHECK(call(w_dabs, 2, a, b, 0) && left2((v4_cell)rl, (v4_cell)rh), "DABS [%u,%u]", i, j);
|
|
for (unsigned k = 0; k < NVEC; k++)
|
|
for (unsigned l = 0; l < NVEC; l++) {
|
|
v4_ucell sl, sh;
|
|
dadd(ua, ub, (v4_ucell)vec[k], (v4_ucell)vec[l], &sl, &sh);
|
|
CHECK(call4(w_dplus, a, b, vec[k], vec[l])
|
|
&& left2((v4_cell)sl, (v4_cell)sh), "D+ [%u,%u,%u,%u]", i, j, k, l);
|
|
}
|
|
if (b != 0 && !(a == (v4_cell)V4_MSB && b == -1))
|
|
CHECK(call(w_slashmod, 2, a, b, 0) && left2(a % b, a / b), "/MOD [%u,%u]", i, j);
|
|
}
|
|
}
|
|
|
|
/* SM/REM: every quotient, divisor and in-range remainder sign drawn from
|
|
* the edge vectors, then pseudo-random. */
|
|
for (unsigned i = 0; i < NVEC; i++)
|
|
for (unsigned j = 0; j < NVEC; j++) {
|
|
v4_cell q = vec[i], nn = vec[j];
|
|
v4_ucell un = nn < 0 ? 0u - (v4_ucell)nn : (v4_ucell)nn;
|
|
int neg = (q < 0) != (nn < 0);
|
|
if (nn == 0) continue;
|
|
CHECK(smrem_exact(q, nn, 0), "SM/REM r=0 [%u,%u]", i, j);
|
|
if (un > 1u) {
|
|
v4_cell r = (v4_cell)(un - 1u);
|
|
if (q == 0) {
|
|
CHECK(smrem_exact(q, nn, r), "SM/REM r>0 q=0 [%u,%u]", i, j);
|
|
CHECK(smrem_exact(q, nn, (v4_cell)(0u - (v4_ucell)r)), "SM/REM r<0 q=0 [%u,%u]", i, j);
|
|
} else {
|
|
CHECK(smrem_exact(q, nn, neg ? (v4_cell)(0u - (v4_ucell)r) : r),
|
|
"SM/REM r=max [%u,%u]", i, j);
|
|
}
|
|
}
|
|
}
|
|
{
|
|
v4_ucell x = (v4_ucell)0x6C078965u;
|
|
for (unsigned i = 0; i < 20000; i++) {
|
|
v4_cell q, nn, r;
|
|
v4_ucell un, ur;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; q = (v4_cell)x;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; nn = (v4_cell)x;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; ur = x;
|
|
if (i & 1u) nn = (v4_cell)((v4_ucell)nn >> (x & 31u)); /* small divisors */
|
|
if (i & 2u) q = (v4_cell)((v4_ucell)q >> (x & 31u)); /* small quotients */
|
|
if (nn == 0) nn = 1;
|
|
un = nn < 0 ? 0u - (v4_ucell)nn : (v4_ucell)nn;
|
|
r = (v4_cell)(ur % un);
|
|
if (q == 0 ? (x & 4u) : ((q < 0) != (nn < 0))) r = (v4_cell)(0u - (v4_ucell)r);
|
|
CHECK(smrem_exact(q, nn, r), "SM/REM random [%u]", i);
|
|
}
|
|
}
|
|
|
|
/* D+ on pseudo-random doubles, weighted toward low cells whose top bits
|
|
* decide the carry. */
|
|
{
|
|
v4_ucell x = (v4_ucell)0x41C64E6Du, v[4], sl, sh;
|
|
for (unsigned i = 0; i < 20000; i++) {
|
|
for (unsigned k = 0; k < 4; k++) { x ^= x << 13; x ^= x >> 7; x ^= x << 17; v[k] = x; }
|
|
if (i & 1u) v[0] |= V4_MSB;
|
|
if (i & 2u) v[2] |= V4_MSB;
|
|
if (i & 4u) v[2] = 0u - v[0]; /* low sum wraps to 0 */
|
|
dadd(v[0], v[1], v[2], v[3], &sl, &sh);
|
|
CHECK(call4(w_dplus, (v4_cell)v[0], (v4_cell)v[1], (v4_cell)v[2], (v4_cell)v[3])
|
|
&& left2((v4_cell)sl, (v4_cell)sh), "D+ random [%u]", i);
|
|
}
|
|
}
|
|
|
|
/* M+, D-, D0= and D= against C: every edge-vector combination, then
|
|
* pseudo-random doubles. */
|
|
for (unsigned i = 0; i < NVEC; i++)
|
|
for (unsigned j = 0; j < NVEC; j++) {
|
|
v4_ucell ua = (v4_ucell)vec[i], ub = (v4_ucell)vec[j], rl, rh;
|
|
CHECK(call(w_d0equal, 2, vec[i], vec[j], 0) && left1(FLAG(ua == 0 && ub == 0)),
|
|
"D0= [%u,%u]", i, j);
|
|
for (unsigned k = 0; k < NVEC; k++) {
|
|
v4_cell c = vec[k];
|
|
dadd(ua, ub, (v4_ucell)c, c < 0 ? MAXU : 0u, &rl, &rh);
|
|
CHECK(call(w_mplus, 3, vec[i], vec[j], c) && left2((v4_cell)rl, (v4_cell)rh),
|
|
"M+ [%u,%u,%u]", i, j, k);
|
|
for (unsigned l = 0; l < NVEC; l++) {
|
|
v4_ucell nl, nh;
|
|
dneg((v4_ucell)vec[k], (v4_ucell)vec[l], &nl, &nh);
|
|
dadd(ua, ub, nl, nh, &rl, &rh);
|
|
CHECK(call4(w_dminus, vec[i], vec[j], vec[k], vec[l])
|
|
&& left2((v4_cell)rl, (v4_cell)rh), "D- [%u,%u,%u,%u]", i, j, k, l);
|
|
CHECK(call4(w_dequal, vec[i], vec[j], vec[k], vec[l])
|
|
&& left1(FLAG(i == k && j == l)), "D= [%u,%u,%u,%u]", i, j, k, l);
|
|
}
|
|
}
|
|
}
|
|
{
|
|
v4_ucell x = (v4_ucell)0x5851F42Du, v[4], rl, rh, nl, nh;
|
|
for (unsigned i = 0; i < 20000; i++) {
|
|
for (unsigned k = 0; k < 4; k++) { x ^= x << 13; x ^= x >> 7; x ^= x << 17; v[k] = x; }
|
|
if (i & 1u) v[2] = v[0]; /* equal low cells */
|
|
if (i & 2u) v[3] = v[1]; /* equal high cells */
|
|
if (i & 4u) v[2] = 0u - v[0]; /* low sum wraps */
|
|
dadd(v[0], v[1], v[2], (v4_cell)v[2] < 0 ? MAXU : 0u, &rl, &rh);
|
|
CHECK(call(w_mplus, 3, (v4_cell)v[0], (v4_cell)v[1], (v4_cell)v[2])
|
|
&& left2((v4_cell)rl, (v4_cell)rh), "M+ random [%u]", i);
|
|
dneg(v[2], v[3], &nl, &nh);
|
|
dadd(v[0], v[1], nl, nh, &rl, &rh);
|
|
CHECK(call4(w_dminus, (v4_cell)v[0], (v4_cell)v[1], (v4_cell)v[2], (v4_cell)v[3])
|
|
&& left2((v4_cell)rl, (v4_cell)rh), "D- random [%u]", i);
|
|
CHECK(call4(w_dequal, (v4_cell)v[0], (v4_cell)v[1], (v4_cell)v[2], (v4_cell)v[3])
|
|
&& left1(FLAG(v[0] == v[2] && v[1] == v[3])), "D= random [%u]", i);
|
|
CHECK(call(w_d0equal, 2, (v4_cell)(v[0] & v[2]), (v4_cell)(v[1] & v[3]), 0)
|
|
&& left1(FLAG((v[0] & v[2]) == 0 && (v[1] & v[3]) == 0)), "D0= random [%u]", i);
|
|
}
|
|
}
|
|
|
|
/* Q.+ and Q.- (section 5.26: the D+ and D- words) against v3. */
|
|
{
|
|
static const uint64_t qv[] = {
|
|
0, 1, 0x8000u, 0x10000u, 0x18000u, /* 0, ulp, 0.5, 1.0, 1.5 */
|
|
(uint64_t)0 - 0x10000u, (uint64_t)0 - 1u, /* -1.0, -ulp */
|
|
0xFFFFu, 0x10001u, 0xFFFFFFFFu, 0x100000000u, /* across the 32-bit seam */
|
|
((uint64_t)1 << 63) - 1u, (uint64_t)1 << 63, /* Q max, Q min */
|
|
(uint64_t)12345 << 16, (uint64_t)0 - ((uint64_t)12345 << 16)
|
|
};
|
|
const unsigned nq = sizeof qv / sizeof qv[0];
|
|
uint64_t x = 0x9E3779B97F4A7C15u;
|
|
unsigned over = 0;
|
|
|
|
for (unsigned i = 0; i < nq; i++)
|
|
for (unsigned j = 0; j < nq; j++) {
|
|
CHECK(q_matches_v3(w_dplus, qv[i], qv[j], qv[i] + qv[j]), "Q.+ [%u,%u]", i, j);
|
|
CHECK(q_matches_v3(w_dminus, qv[i], qv[j], qv[i] - qv[j]), "Q.- [%u,%u]", i, j);
|
|
}
|
|
for (unsigned i = 0; i < 20000; i++) {
|
|
uint64_t a, b;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; a = x;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; b = x;
|
|
if (i & 1u) a >>= (unsigned)(x & 63u); /* mixed magnitudes */
|
|
if (i & 2u) b = (uint64_t)0 - b;
|
|
if (((a + b) ^ a) & ((a + b) ^ b) & ((uint64_t)1 << 63)) over++;
|
|
CHECK(q_matches_v3(w_dplus, a, b, a + b), "Q.+ random [%u]", i);
|
|
CHECK(q_matches_v3(w_dminus, a, b, a - b), "Q.- random [%u]", i);
|
|
}
|
|
printf(" Q.+ random cases that overflow Q48.16: %u of 20000\n", over);
|
|
|
|
/* Q.FROM-INT: n * 2^16 as a signed double. v3 clamps n < 0 to 0
|
|
* (section 5.26 retires that) and wraps at 64 bits, so v3's value is
|
|
* checked only for n >= 0, and at 64-bit cells only in the low cell
|
|
* (D-10). */
|
|
for (unsigned i = 0; i < NVEC + 20000u; i++) {
|
|
v4_cell nn, el, eh;
|
|
if (i < NVEC) nn = vec[i];
|
|
else {
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17;
|
|
nn = (v4_cell)(v4_ucell)x;
|
|
if (i & 1u) nn = (v4_cell)asr_u((v4_ucell)nn, (unsigned)(x >> 58) % V4_CELL_BITS);
|
|
}
|
|
el = (v4_cell)((v4_ucell)nn << 16);
|
|
eh = (v4_cell)asr_u((v4_ucell)nn, V4_CELL_BITS - 16);
|
|
CHECK(call(w_qfromint, 1, nn, 0, 0) && left2(el, eh), "Q.FROM-INT [%u]", i);
|
|
if (nn >= 0) {
|
|
uint64_t v3 = (uint64_t)(v4_ucell)nn << 16;
|
|
v4_cell vl, vh;
|
|
qcells(v3, &vl, &vh);
|
|
CHECK(call(w_qfromint, 1, nn, 0, 0) && n.ds.s == vl
|
|
&& (V4_CELL_BITS == 64 || n.ds.t == vh), "Q.FROM-INT v3 [%u]", i);
|
|
}
|
|
/* and back */
|
|
CHECK(call(w_qfromint, 1, nn, 0, 0)
|
|
&& (v4_test_call(&n, &es, &h, w_qtoint, 100000) > 0) && left1(nn),
|
|
"Q.TO-INT Q.FROM-INT [%u]", i);
|
|
}
|
|
|
|
/* Q.TO-INT: v3's (int64_t)q >> 16, arithmetic. At 32-bit cells the
|
|
* result is its low cell; at 64-bit cells it is v3's value exactly. */
|
|
for (unsigned i = 0; i < nq + 20000u; i++) {
|
|
uint64_t q;
|
|
v4_cell ql, qh;
|
|
if (i < nq) q = qv[i];
|
|
else {
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; q = x;
|
|
if (i & 1u) q = asr64(q, (unsigned)(x >> 58));
|
|
}
|
|
qcells(q, &ql, &qh);
|
|
CHECK(call(w_qtoint, 2, ql, qh, 0) && left1((v4_cell)(v4_ucell)asr64(q, 16)),
|
|
"Q.TO-INT v3 [%u]", i);
|
|
}
|
|
/* and on any double, not only sign-extended ones */
|
|
for (unsigned i = 0; i < 20000; i++) {
|
|
v4_ucell lo, hi;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; lo = (v4_ucell)x;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; hi = (v4_ucell)x;
|
|
CHECK(call(w_qtoint, 2, (v4_cell)lo, (v4_cell)hi, 0)
|
|
&& left1((v4_cell)((lo >> 16) | (hi << (V4_CELL_BITS - 16)))),
|
|
"Q.TO-INT double [%u]", i);
|
|
}
|
|
|
|
/* Q.ABS and Q.NEG against v3's q48_abs and 0 - q. */
|
|
for (unsigned i = 0; i < nq; i++) {
|
|
uint64_t q = qv[i];
|
|
CHECK(q1_matches_v3(w_dabs, q, (q < ((uint64_t)1 << 63)) ? q : (uint64_t)0 - q),
|
|
"Q.ABS [%u]", i);
|
|
CHECK(q1_matches_v3(w_dnegate, q, (uint64_t)0 - q), "Q.NEG [%u]", i);
|
|
}
|
|
for (unsigned i = 0; i < 20000; i++) {
|
|
uint64_t q;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; q = x;
|
|
if (i & 1u) q >>= (unsigned)(x & 63u);
|
|
if (i & 2u) q = (uint64_t)0 - q;
|
|
CHECK(q1_matches_v3(w_dabs, q, (q < ((uint64_t)1 << 63)) ? q : (uint64_t)0 - q),
|
|
"Q.ABS random [%u]", i);
|
|
CHECK(q1_matches_v3(w_dnegate, q, (uint64_t)0 - q), "Q.NEG random [%u]", i);
|
|
}
|
|
}
|
|
|
|
/* <, =, D<, 2SWAP, 2OVER, DMAX and DMIN as written in section 5, against C. */
|
|
for (unsigned i = 0; i < NVEC; i++)
|
|
for (unsigned j = 0; j < NVEC; j++) {
|
|
v4_cell a = vec[i], b = vec[j];
|
|
CHECK(call(w_less, 2, a, b, 0) && left1(FLAG(a < b)), "< [%u,%u]", i, j);
|
|
CHECK(call(w_equal, 2, a, b, 0) && left1(FLAG(a == b)), "= [%u,%u]", i, j);
|
|
for (unsigned k = 0; k < NVEC; k++)
|
|
for (unsigned l = 0; l < NVEC; l++) {
|
|
v4_cell c = vec[k], d = vec[l];
|
|
int lt = dlt((v4_ucell)a, (v4_ucell)b, (v4_ucell)c, (v4_ucell)d);
|
|
v4_cell sw[4], ov[6], mx[2], mn[2];
|
|
sw[0] = c; sw[1] = d; sw[2] = a; sw[3] = b;
|
|
ov[0] = a; ov[1] = b; ov[2] = c; ov[3] = d; ov[4] = a; ov[5] = b;
|
|
mx[0] = lt ? c : a; mx[1] = lt ? d : b;
|
|
mn[0] = lt ? a : c; mn[1] = lt ? b : d;
|
|
CHECK(call4(w_dless, a, b, c, d) && left1(FLAG(lt)), "D< [%u,%u,%u,%u]", i, j, k, l);
|
|
{
|
|
v4_cell kp[5];
|
|
kp[0] = a; kp[1] = b; kp[2] = c; kp[3] = d; kp[4] = FLAG(lt);
|
|
CHECK(call4(w_dltkeep, a, b, c, d) && leftk(kp, 5), "(D<) [%u,%u,%u,%u]", i, j, k, l);
|
|
}
|
|
CHECK(call4(w_2swap, a, b, c, d) && leftk(sw, 4), "2SWAP [%u,%u,%u,%u]", i, j, k, l);
|
|
CHECK(call4(w_2over, a, b, c, d) && leftk(ov, 6), "2OVER [%u,%u,%u,%u]", i, j, k, l);
|
|
CHECK(call4(w_dmax, a, b, c, d) && leftk(mx, 2), "DMAX [%u,%u,%u,%u]", i, j, k, l);
|
|
CHECK(call4(w_dmin, a, b, c, d) && leftk(mn, 2), "DMIN [%u,%u,%u,%u]", i, j, k, l);
|
|
}
|
|
}
|
|
|
|
/* Q.=, Q.<, Q.>, Q.0=, Q.MAX, Q.MIN (section 5.26: D=, D<, 2SWAP D<, D0=,
|
|
* DMAX, DMIN) on Q values, signed (D-8). v3 compares Q values unsigned,
|
|
* so v3 agrees only when both have the same sign; that is checked too. */
|
|
{
|
|
static const uint64_t qc[] = {
|
|
0, 1, 0x8000u, 0x10000u, 0x18000u,
|
|
(uint64_t)0 - 0x10000u, (uint64_t)0 - 1u, (uint64_t)0 - 0x8000u,
|
|
0xFFFFFFFFu, 0x100000000u, (uint64_t)0 - 0x100000000u,
|
|
((uint64_t)1 << 63) - 1u, (uint64_t)1 << 63
|
|
};
|
|
const unsigned nc = sizeof qc / sizeof qc[0];
|
|
uint64_t x = 0x2545F4914F6CDD1Du;
|
|
unsigned doc_wrong = 0, doc_runs = 0;
|
|
|
|
for (unsigned i = 0; i < nc * nc + 20000u; i++) {
|
|
uint64_t a, b;
|
|
v4_cell al, ah, bl, bh, w[2];
|
|
int lt, gt, eq;
|
|
if (i < nc * nc) { a = qc[i / nc]; b = qc[i % nc]; }
|
|
else {
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; a = x;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; b = x;
|
|
if (i & 1u) b = a; /* ties */
|
|
if (i & 2u) b ^= (uint64_t)1 << (x >> 58); /* near */
|
|
}
|
|
qcells(a, &al, &ah);
|
|
qcells(b, &bl, &bh);
|
|
lt = qs(a) < qs(b); gt = qs(a) > qs(b); eq = a == b;
|
|
|
|
CHECK(call4(w_dequal, al, ah, bl, bh) && left1(FLAG(eq)), "Q.= [%u]", i);
|
|
CHECK(call4(w_dless, al, ah, bl, bh) && left1(FLAG(lt)), "Q.< [%u]", i);
|
|
CHECK(call4(w_qgt, al, ah, bl, bh) && left1(FLAG(gt)), "Q.> [%u]", i);
|
|
CHECK(call(w_d0equal, 2, al, ah, 0) && left1(FLAG(a == 0)), "Q.0= [%u]", i);
|
|
w[0] = lt ? bl : al; w[1] = lt ? bh : ah;
|
|
CHECK(call4(w_dmax, al, ah, bl, bh) && leftk(w, 2), "Q.MAX [%u]", i);
|
|
w[0] = lt ? al : bl; w[1] = lt ? ah : bh;
|
|
CHECK(call4(w_dmin, al, ah, bl, bh) && leftk(w, 2), "Q.MIN [%u]", i);
|
|
if ((a >> 63) == (b >> 63)) { /* v3 agrees here */
|
|
CHECK(lt == (a < b) && gt == (a > b), "Q compare v3 [%u]", i);
|
|
}
|
|
|
|
/* Q.> as section 5.26 writes it, SWAP D<: count wrong answers. */
|
|
doc_runs++;
|
|
if (!(call4(w_qgt_doc, al, ah, bl, bh) && left1(FLAG(gt)))) doc_wrong++;
|
|
}
|
|
printf(" Q.> as written (SWAP D<): %u wrong of %u\n", doc_wrong, doc_runs);
|
|
}
|
|
|
|
/* Q.* against the limb reference (signed, D-8), on edge Q values and
|
|
* pseudo-random ones, and against v3's q48_mul for non-negative
|
|
* operands, where v3's unsigned product agrees. */
|
|
{
|
|
static const uint64_t qm[] = {
|
|
0, 1, 0x8000u, 0x10000u, 0x18000u, 0x20000u, 0xFFFFu,
|
|
(uint64_t)0 - 0x10000u, (uint64_t)0 - 1u, (uint64_t)0 - 0x18000u,
|
|
0xFFFFFFFFu, 0x100000000u, 0x7FFFFFFFu, (uint64_t)0 - 0x100000000u,
|
|
((uint64_t)1 << 63) - 1u, (uint64_t)1 << 63, (uint64_t)1 << 47
|
|
};
|
|
const unsigned nm = sizeof qm / sizeof qm[0];
|
|
uint64_t x = 0xD1B54A32D192ED03u;
|
|
for (unsigned i = 0; i < nm * nm + 20000u; i++) {
|
|
uint64_t a, b;
|
|
v4_cell al, ah, bl, bh;
|
|
v4_ucell rl, rh;
|
|
if (i < nm * nm) { a = qm[i / nm]; b = qm[i % nm]; }
|
|
else {
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; a = x;
|
|
x ^= x << 13; x ^= x >> 7; x ^= x << 17; b = x;
|
|
if (i & 1u) a = asr64(a, (unsigned)(x >> 58));
|
|
if (i & 2u) b = asr64(b, (unsigned)(x >> 52) & 63u);
|
|
}
|
|
qcells(a, &al, &ah);
|
|
qcells(b, &bl, &bh);
|
|
qmul_ref((v4_ucell)al, (v4_ucell)ah, (v4_ucell)bl, (v4_ucell)bh, &rl, &rh);
|
|
CHECK(call4(w_qstar, al, ah, bl, bh) && left2((v4_cell)rl, (v4_cell)rh),
|
|
"Q.* [%u]", i);
|
|
if (!(a >> 63) && !(b >> 63)) {
|
|
v4_cell vl, vh;
|
|
qcells(v3_q48_mul(a, b), &vl, &vh);
|
|
CHECK(call4(w_qstar, al, ah, bl, bh) && n.ds.s == vl
|
|
&& (V4_CELL_BITS == 64 || n.ds.t == vh), "Q.* v3 [%u]", i);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* Stack headroom of the two longest definitions. */
|
|
{
|
|
static const v4_cell umstar_args[][4] = {
|
|
{ 0, 0, 0 }, { -1, -1, 0 }, { 3, -1, 0 }, { -1, 3, 0 }, { 12345, -12345, 0 }
|
|
};
|
|
static const v4_cell ummod_args[][4] = {
|
|
{ 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");
|
|
|
|
{
|
|
static const v4_cell one_args[][4] = { { 5, 0, 0 }, { -5, 0, 0 }, { 0, 0, 0 } };
|
|
static const v4_cell two_args[][4] = {
|
|
{ 5, 0, 0 }, { 0, -1, 0 }, { -5, -1, 0 }, { -1, 5, 0 }, { 0, 0, 0 }
|
|
};
|
|
static const v4_cell smrem_args[][4] = {
|
|
{ 7, 0, 2 }, { -7, -1, 2 }, { 7, 0, -2 }, { -7, -1, -2 }, { 0, 0, -3 }
|
|
};
|
|
static const v4_cell slashmod_args[][4] = {
|
|
{ 7, 2, 0 }, { -7, 2, 0 }, { 7, -2, 0 }, { -7, -2, 0 }
|
|
};
|
|
headroom("ABS", w_abs, 1, one_args, 3, 1, &dh, &rh);
|
|
headroom("U>", w_ugreater, 2, two_args, 5, 1, &dh, &rh);
|
|
static const v4_cell dplus_args[][4] = {
|
|
{ -1, 0, 1, 0 }, { 5, 7, 9, 11 }, { -1, -1, -1, -1 },
|
|
{ (v4_cell)V4_MSB, 0, 1, 0 }, { (v4_cell)V4_MSB, 0, (v4_cell)V4_MSB, 0 },
|
|
{ 1, 0, 2, 0 }
|
|
};
|
|
headroom("D+", w_dplus, 4, dplus_args, 6, 2, &dh, &rh);
|
|
CHECK(rh >= 5, "D+ leaves 5 return entries");
|
|
headroom("DNEGATE", w_dnegate, 2, two_args, 5, 2, &dh, &rh);
|
|
headroom("DABS", w_dabs, 2, two_args, 5, 2, &dh, &rh);
|
|
static const v4_cell mplus_args[][4] = {
|
|
{ -1, 0, 1, 0 }, { 5, 7, -9, 0 }, { 0, 0, -1, 0 }, { (v4_cell)V4_MSB, 0, (v4_cell)V4_MSB, 0 }
|
|
};
|
|
static const v4_cell dsub_args[][4] = {
|
|
{ 0, 0, 1, 0 }, { 5, 7, 9, 11 }, { -1, -1, -1, -1 }, { 0, 1, 0, 1 },
|
|
{ (v4_cell)V4_MSB, 0, (v4_cell)V4_MSB, 0 }, { 1, 0, 2, 0 }
|
|
};
|
|
headroom("M+", w_mplus, 3, mplus_args, 4, 2, &dh, &rh);
|
|
headroom("D-", w_dminus, 4, dsub_args, 6, 2, &dh, &rh);
|
|
headroom("D0=", w_d0equal, 2, two_args, 5, 1, &dh, &rh);
|
|
headroom("D=", w_dequal, 4, dsub_args, 6, 1, &dh, &rh);
|
|
CHECK(dh >= 0 && rh >= 0, "D= runs at all");
|
|
static const v4_cell cmp_args[][4] = {
|
|
{ 0, 0, 0, 0 }, { 1, 0, 2, 0 }, { 2, 0, 1, 0 }, { 0, -1, 0, 1 }, { 0, 1, 0, -1 },
|
|
{ 0, 5, 0, 7 }, { 0, 7, 0, 5 }, { -1, 0, 1, 0 }, { 1, 0, -1, 0 }
|
|
};
|
|
headroom("<", w_less, 2, two_args, 5, 1, &dh, &rh);
|
|
headroom("=", w_equal, 2, two_args, 5, 1, &dh, &rh);
|
|
headroom("D<", w_dless, 4, cmp_args, 9, 1, &dh, &rh);
|
|
headroom("(D<)", w_dltkeep, 4, cmp_args, 9, 5, &dh, &rh);
|
|
headroom("2SWAP", w_2swap, 4, cmp_args, 9, 4, &dh, &rh);
|
|
headroom("2OVER", w_2over, 4, cmp_args, 9, 6, &dh, &rh);
|
|
headroom("DMAX", w_dmax, 4, cmp_args, 9, 2, &dh, &rh);
|
|
CHECK(dh >= 2 && rh >= 2, "DMAX leaves room");
|
|
headroom("DMIN", w_dmin, 4, cmp_args, 9, 2, &dh, &rh);
|
|
CHECK(dh >= 2 && rh >= 2, "DMIN leaves room");
|
|
headroom("Q.> (2SWAP D<)", w_qgt, 4, cmp_args, 9, 1, &dh, &rh);
|
|
static const v4_cell qstar_args[][4] = {
|
|
{ 0, 1, 0, 1 }, { -1, -1, -1, -1 }, { 0, -1, 0, 1 }, { 5, 7, 9, 11 },
|
|
{ (v4_cell)V4_MSB, -1, 3, (v4_cell)V4_MSB }
|
|
};
|
|
headroom("Q.*", w_qstar, 4, qstar_args, 5, 2, &dh, &rh);
|
|
CHECK(dh >= 0 && rh >= 0, "Q.* runs at all");
|
|
headroom("SM/REM", w_smrem, 3, smrem_args, 5, 2, &dh, &rh);
|
|
CHECK(rh >= 1, "SM/REM leaves room for /MOD's return address");
|
|
headroom("/MOD", w_slashmod, 2, slashmod_args, 4, 2, &dh, &rh);
|
|
CHECK(dh >= 0 && rh >= 0, "/MOD runs at all");
|
|
}
|
|
}
|
|
|
|
CHECK(v4_node_guards_intact(&n), "guards intact");
|
|
|
|
printf(" %d checks, %d failures\n", checks, failures);
|
|
return failures ? 1 : 0;
|
|
}
|