admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(v4.0.0): Q.FROM-INT and Q.TO-INT as +* double shifts

Browse Source 
DECOMPOSITION.md 5.26 described both words in prose only. They are now
written out, call-free, on one observation: +* with S = 0 never adds, so
each step is an exact arithmetic right shift of the double T:A.

  : Q.FROM-INT ( n -- q )  push 0 a! 0 pop  15 FOR +* UNEXT  push drop a pop ;
      T:A = n:0 is n * 2^N; N-16 shifts leave n * 2^16 (count 15 at
      32-bit cells, 47 at 64).
  : Q.TO-INT ( q -- n )    push a! 0 pop  15 FOR +* UNEXT  drop drop a ;
      16 shifts at every width; the low cell is left in A. Rounds toward
      minus infinity, as v3's arithmetic shift does.

Both clobber A; added to the section 2 list.

Checked at 32- and 64-bit cells, optimised and ASan+UBSan:
- Q.FROM-INT against n * 2^16 for edge values and 20000 pseudo-random n,
  and against v3's q48_from_u64 for n >= 0 (low cell at 64-bit, D-10).
- Q.TO-INT against v3's (int64_t)q >> 16 on the edge Q values and 20000
  pseudo-random Q values, and against a C double shift on 20000
  arbitrary doubles.
- Round trip Q.TO-INT(Q.FROM-INT(n)) = n.
Mutating either shift count or the S = 0 setup fails 40000+ checks.

Note: make sanitize prints UBSan reports but does not fail on them. One
was found here, in the test's own random shift amount (fixed); a grep of
the full sanitize output now shows no runtime errors.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-02 22:58:04 -04:00
co-authored by Claude Opus 5.5
parent d948e0c1a3
commit 981f4180ce
2 changed files with 100 additions and 5 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/tests/test_foundation.c
+97 -2
View File
@@ -17,7 +17,9 @@
* 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). Every word is
* 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. Every word is
* also probed for how much of the 10- and 9-deep circular stacks (D-2) it
* leaves to its caller.
*
@@ -46,7 +48,8 @@ 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_slashmod, w_mplus, w_dminus, w_d0equal, w_dequal,
w_qfromint, w_qtoint;
#define O(name) v4_asm_op(&as, V4_OP_##name)
#define LIT(v) v4_asm_lit(&as, (v4_cell)(v))
@@ -346,6 +349,31 @@ static void build(void)
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);
CHECK(v4_asm_ok(&as), "foundation words assemble");
}
@@ -521,6 +549,21 @@ static int q1_matches_v3(v4_cell word, uint64_t a, uint64_t v3)
#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;
}
/* 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
@@ -821,6 +864,58 @@ int main(void)
}
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];