suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sync simpler handling of tc U, V, W, X, Y

Browse Source 
They apparently don't need to be preserved across a GC.

original commit: 830d176bdaf0c19c44e5f4037da0de621d3d9957
This commit is contained in:
Matthew Flatt 2020-04-26 20:13:54 -06:00
parent ac6467fd8c
commit a9e37d0548
2 changed files with 44 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

100
c/number.c
View File

@ -25,7 +25,7 @@
#include "system.h"
/* locally defined functions */
static ptr copy_normalize PROTO((ptr tc, const bigit *p, iptr len, IBOOL sign, IBOOL clear_w));
static ptr copy_normalize PROTO((ptr tc, const bigit *p, iptr len, IBOOL sign));
static IBOOL abs_big_lt PROTO((ptr x, ptr y, iptr xl, iptr yl));
static IBOOL abs_big_eq PROTO((ptr x, ptr y, iptr xl, iptr yl));
static ptr big_negate PROTO((ptr tc, ptr x));
@ -164,7 +164,7 @@ ptr S_normalize_bignum(ptr x) {
return x;
}
static ptr copy_normalize(tc, p, len, sign, clear_w) ptr tc; const bigit *p; iptr len; IBOOL sign, clear_w; {
static ptr copy_normalize(tc, p, len, sign) ptr tc; const bigit *p; iptr len; IBOOL sign; {
bigit *p1; uptr n; ptr b;
for (;;) {
@ -199,10 +199,6 @@ static ptr copy_normalize(tc, p, len, sign, clear_w) ptr tc; const bigit *p; ipt
b = S_bignum(tc, len, sign);
for (p1 = &BIGIT(b, 0); len--;) *p1++ = *p++;
if (clear_w)
W(tc) = FIX(0);
return b;
}
@ -516,7 +512,7 @@ addition/subtraction
*/
static ptr big_negate(tc, x) ptr tc, x; {
return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x),0);
return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x));
}
ptr S_big_negate(x) ptr x; {
@ -542,7 +538,7 @@ static ptr big_add_pos(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
*zp = k;
return copy_normalize(tc, zp,xl+1,sign, 1);
return copy_normalize(tc, zp,xl+1,sign);
}
/* assumptions: x >= y */
@ -562,7 +558,7 @@ static ptr big_add_neg(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
for (; i-- > 0; )
*zp-- = *xp--;
return copy_normalize(tc, zp+1,xl,sign, 1);
return copy_normalize(tc, zp+1,xl,sign);
}
static ptr big_add(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL xs, ys; {
@ -652,7 +648,7 @@ static ptr big_mul(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign
*zpa = k;
}
return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign, 1);
return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign);
}
/* SHORTRANGE is -floor(sqrt(most_positive_fixnum))..floor(sqrt(most_positive_fixnum)).
@ -778,10 +774,8 @@ static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs,
for (i = xl, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i-- > 0; )
EDIV(k, *xp++, s, zp++, &k)
if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs, 0);
if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs, 0);
W(tc) = FIX(0);
if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs);
if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs);
}
static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
@ -807,7 +801,7 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
PREPARE_BIGNUM(tc, W(tc),m)
p = &BIGIT(W(tc),0);
for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(xp, yp, yl);
*q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs, 1);
*q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs);
}
if (r != (ptr *)NULL) {
@ -815,11 +809,8 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
if (d != 0) {
for (i = yl, p = xp, k = 0; i-- > 0; p++) ERSH(d,p,&k)
}
*r = copy_normalize(tc, xp, yl, rs, 0);
*r = copy_normalize(tc, xp, yl, rs);
}
U(tc) = FIX(0);
V(tc) = FIX(0);
}
static INT normalize(xp, yp, xl, yl) bigit *xp, *yp; iptr xl, yl; {
@ -919,7 +910,6 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
iptr i;
INT shft, asc;
bigit *p, *xp, *yp, k, b;
ptr ret;
/* Copy x to scratch bignum, with a leading zero */
PREPARE_BIGNUM(tc, U(tc),xl+1)
@ -982,19 +972,14 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
if (asc != 0) {
for (i = xl, p = xp, k = 0; i-- > 0; p++) ERSH(asc,p,&k)
}
return copy_normalize(tc, xp,xl,0, 0);
return copy_normalize(tc, xp,xl,0);
} else {
bigit d, r;
d = *yp;
for (r = 0; xl-- > 0; xp++) EDIV(r, *xp, d, xp, &r)
ret = uptr_gcd((uptr)(d>>asc), (uptr)(r>>asc));
return uptr_gcd((uptr)(d>>asc), (uptr)(r>>asc));
}
U(tc) = FIX(0);
V(tc) = FIX(0);
return ret;
}
ptr S_gcd(x, y) ptr x, y; {
@ -1099,7 +1084,6 @@ double S_random_double(m1, m2, m3, m4, scale) U32 m1, m2, m3, m4; double scale;
static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) {
iptr i;
bigit *xp, *zp, k;
double ret;
PREPARE_BIGNUM(tc, W(tc),enough+1)
@ -1113,17 +1097,12 @@ static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) {
/* then see if there's a bit set somewhere beyond */
while (k == 0 && i++ < xl) k = *xp++;
ret = floatify_normalize(&BIGIT(W(tc),0), xl*bigit_bits, sign, k != 0);
W(tc) = FIX(0);
return ret;
return floatify_normalize(&BIGIT(W(tc),0), xl*bigit_bits, sign, k != 0);
}
static double big_floatify(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign; {
iptr i, ul;
bigit *p, *xp, *yp, k;
double ret;
/* copy x to U(tc), scaling with added zero bigits as necessary */
ul = xl < yl + enough-1 ? yl + enough-1 : xl;
@ -1148,13 +1127,7 @@ static double big_floatify(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IB
k = 0;
for (i = ul + 1, xp = &BIGIT(U(tc),ul); k == 0 && i-- > 0; xp--) k = *xp;
ret = floatify_normalize(&BIGIT(W(tc),0), (xl-yl+1)*bigit_bits, sign, k != 0);
W(tc) = FIX(0);
U(tc) = FIX(0);
V(tc) = FIX(0);
return ret;
return floatify_normalize(&BIGIT(W(tc),0), (xl-yl+1)*bigit_bits, sign, k != 0);
}
/* come in with exactly 'enough' bigits */
@ -1374,7 +1347,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
}
}
return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign, 1);
return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign);
} else { /* shift to the left */
iptr xlplus, newxl;
@ -1400,7 +1373,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
}
*--p1 = k;
return copy_normalize(tc, p1, newxl, sign, 1);
return copy_normalize(tc, p1, newxl, sign);
}
}
@ -1496,7 +1469,7 @@ ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) {
for (i = wl; i > 0; i -= 1, p1 += 1) ERSH(start,p1,&k)
}
return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0, 1);
return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0);
}
/* logical operations simulate two's complement operations using the
@ -1562,7 +1535,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
PREPARE_BIGNUM(tc, W(tc),yl);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
for (i = yl; i > 0; i -= 1) *--zp = *--xp & *--yp;
return copy_normalize(tc, zp, yl, 0, 1);
return copy_normalize(tc, zp, yl, 0);
} else {
bigit yb;
@ -1577,7 +1550,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
/* yb must be 0, since high-order bigit >= 1. effectively, this
means ~t2 would be all 1's from here on out. */
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(tc, zp, xl, 0, 1);
return copy_normalize(tc, zp, xl, 0);
}
} else {
if (ys == 0) {
@ -1591,7 +1564,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
xb = t2 > t1;
*--zp = *--yp & ~t2;
}
return copy_normalize(tc, zp, yl, 0, 1);
return copy_normalize(tc, zp, yl, 0);
} else {
bigit xb, yb, k;
@ -1614,8 +1587,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, xl+1, 1, 1);
return copy_normalize(tc, zp, xl+1, 1);
}
}
}
@ -1726,7 +1698,7 @@ static ptr big_logbitp(n, x, xl, xs) ptr x; iptr n, xl; IBOOL xs; {
if (i < 0) return Sfalse;
n = n % bigit_bits;
return Sboolean(BIGIT(x,i) & ((U32)1 << n));
return Sboolean(BIGIT(x,i) & (1 << n));
} else {
bigit xb;
@ -1736,7 +1708,7 @@ static ptr big_logbitp(n, x, xl, xs) ptr x; iptr n, xl; IBOOL xs; {
xp = &BIGIT(x,xl); xb = 1;
for (i = xl; ; i -= 1) {
bigit t1 = *--xp, t2 = t1 - xb;
if (n < bigit_bits) return Sboolean(~t2 & ((U32)1 << n));
if (n < bigit_bits) return Sboolean(~t2 & (1 << n));
xb = t2 > t1;
n -= bigit_bits;
}
@ -1790,7 +1762,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
}
*--zp = *--xp & ~(1 << n);
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(tc, zp,xl,0, 1);
return copy_normalize(tc, zp,xl,0);
}
} else {
bigit xb, k, x1, x2, z1, z2;
@ -1816,7 +1788,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, zl, 1, 1);
return copy_normalize(tc, zp, zl, 1);
}
}
@ -1859,9 +1831,9 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
*--zp = x1;
n -= bigit_bits;
}
*--zp = x1 | ((U32)1 << n);
*--zp = x1 | (1 << n);
for (; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(tc, zp, zl, 0, 1);
return copy_normalize(tc, zp, zl, 0);
} else if (yl > xl) {
/* we'd just be setting a bit that's already (virtually) set */
return origx;
@ -1890,7 +1862,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, zl, 1, 1);
return copy_normalize(tc, zp, zl, 1);
}
}
@ -1941,7 +1913,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
for (i = yl; i > 0; i -= 1) *--zp = *--xp | *--yp;
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(tc, zp, xl, 0, 1);
return copy_normalize(tc, zp, xl, 0);
} else {
bigit yb, k;
@ -1956,7 +1928,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, yl+1, 1, 1);
return copy_normalize(tc, zp, yl+1, 1);
}
} else {
if (ys == 0) {
@ -1980,7 +1952,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, xl+1, 1, 1);
return copy_normalize(tc, zp, xl+1, 1);
} else {
bigit xb, yb, k;
@ -1996,7 +1968,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, yl+1, 1, 1);
return copy_normalize(tc, zp, yl+1, 1);
}
}
}
@ -2048,7 +2020,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
for (i = yl; i > 0; i -= 1) *--zp = *--xp ^ *--yp;
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(tc, zp, xl, 0, 1);
return copy_normalize(tc, zp, xl, 0);
} else {
bigit yb, k;
@ -2069,7 +2041,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, xl+1, 1, 1);
return copy_normalize(tc, zp, xl+1, 1);
}
} else {
if (ys == 0) {
@ -2093,7 +2065,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(tc, zp, xl+1, 1, 1);
return copy_normalize(tc, zp, xl+1, 1);
} else {
bigit xb, yb;
@ -2111,7 +2083,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
*--zp = x2;
}
return copy_normalize(tc, zp, xl, 0, 1);
return copy_normalize(tc, zp, xl, 0);
}
}
}

13
s/mkgc.ss
View File

@ -920,11 +920,14 @@
(trace-stack (cast uptr (tc-scheme-stack tc))
(cast uptr (SFP tc))
(cast uptr (FRAME tc 0)))
(trace (tc-U tc))
(trace (tc-V tc))
(trace (tc-W tc))
(trace (tc-X tc))
(trace (tc-Y tc))
(case-mode
[(sweep)
(set! (tc-U tc) 0)
(set! (tc-V tc) 0)
(set! (tc-W tc) 0)
(set! (tc-X tc) 0)
(set! (tc-Y tc) 0)]
[else])
(trace (tc-threadno tc))
(trace (tc-current-input tc))
(trace (tc-current-output tc))