~ chicken-core (chicken-5) ef6fe73f7e1c09aa752308c471fd2c55f134ac22
commit ef6fe73f7e1c09aa752308c471fd2c55f134ac22
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Mar 22 19:35:26 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:55:24 2015 +0200
Make dyadic bitwise operators inlineable again and restore compiler rewrites. Also move variadic versions of bitwise operators to C.
diff --git a/c-platform.scm b/c-platform.scm
index 48091d08..b6091cbe 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -548,6 +548,12 @@
(rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")
+(rewrite 'bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_s_a_i_bitwise_and" 6)
+(rewrite 'bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_s_a_i_bitwise_xor" 6)
+(rewrite 'bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_s_a_i_bitwise_ior" 6)
+
+(rewrite 'bitwise-not 22 1 "C_s_a_i_bitwise_not" #t 6 "C_fixnum_not")
+
(rewrite 'fp+ 16 2 "C_a_i_flonum_plus" #f words-per-flonum)
(rewrite 'fp- 16 2 "C_a_i_flonum_difference" #f words-per-flonum)
(rewrite 'fp* 16 2 "C_a_i_flonum_times" #f words-per-flonum)
diff --git a/chicken.h b/chicken.h
index 788fe305..4160d8a1 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1973,9 +1973,9 @@ C_fctexport void C_ccall C_u_integer_remainder(C_word c, C_word self, C_word k,
C_fctexport void C_ccall C_basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
C_fctexport void C_ccall C_u_integer_divrem(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
C_fctexport void C_ccall C_u_flo_to_int(C_word c, C_word self, C_word k, C_word x) C_noret;
-C_fctexport void C_ccall C_u_2_integer_bitwise_and(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
-C_fctexport void C_ccall C_u_2_integer_bitwise_ior(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
-C_fctexport void C_ccall C_u_2_integer_bitwise_xor(C_word c, C_word self, C_word k, C_word x, C_word y) C_noret;
+C_fctexport void C_ccall C_bitwise_and(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_bitwise_ior(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_bitwise_xor(C_word c, C_word closure, C_word k, ...) C_noret;
C_fctexport void C_ccall C_nequalp(C_word c, C_word closure, C_word k, ...) C_noret;
C_fctexport void C_ccall C_greaterp(C_word c, C_word closure, C_word k, ...) C_noret;
@@ -2190,6 +2190,10 @@ C_fctexport C_word C_fcall C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word
C_fctexport C_word C_fcall C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
C_fctexport C_word C_fcall C_s_a_u_i_bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end) C_regparm;
+C_fctexport C_word C_fcall C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
diff --git a/library.scm b/library.scm
index 352af4ba..3951d6fc 100644
--- a/library.scm
+++ b/library.scm
@@ -1578,9 +1578,8 @@ EOF
((s^ r^) (##sys#exact-integer-sqrt
(arithmetic-shift a (fxneg len/2))))
((mask) (- (arithmetic-shift 1 len/4) 1))
- ((a0) (##sys#integer-bitwise-and a mask))
- ((a1) (##sys#integer-bitwise-and
- (arithmetic-shift a (fxneg len/4)) mask))
+ ((a0) (bitwise-and a mask))
+ ((a1) (bitwise-and (arithmetic-shift a (fxneg len/4)) mask))
((q u) (##sys#integer-quotient&remainder
(+ (arithmetic-shift r^ len/4) a1)
(arithmetic-shift s^ 1)))
@@ -4374,62 +4373,15 @@ EOF
;; From SRFI-33
(define (integer-length x) (##core#inline "C_i_integer_length" x))
-
-(define ##sys#integer-bitwise-and (##core#primitive "C_u_2_integer_bitwise_and"))
-(define ##sys#integer-bitwise-ior (##core#primitive "C_u_2_integer_bitwise_ior"))
-(define ##sys#integer-bitwise-xor (##core#primitive "C_u_2_integer_bitwise_xor"))
-
-(define (bitwise-and . xs)
- (if (null? xs)
- -1
- (let ((x1 (##sys#slot xs 0)))
- (##sys#check-exact-integer x1 'bitwise-and)
- (let loop ((x x1) (xs (##sys#slot xs 1)))
- (if (null? xs)
- x
- (let ((xi (##sys#slot xs 0)))
- (##sys#check-exact-integer xi 'bitwise-and)
- (loop
- (##sys#integer-bitwise-and x xi)
- (##sys#slot xs 1) ) ) ) ))) )
-
-(define (bitwise-ior . xs)
- (if (null? xs)
- 0
- (let ((x1 (##sys#slot xs 0)))
- (##sys#check-exact-integer x1 'bitwise-ior)
- (let loop ((x x1) (xs (##sys#slot xs 1)))
- (if (null? xs)
- x
- (let ((xi (##sys#slot xs 0)))
- (##sys#check-exact-integer xi 'bitwise-ior)
- (loop
- (##sys#integer-bitwise-ior x xi)
- (##sys#slot xs 1) ) ) ) ))) )
-
-(define (bitwise-xor . xs)
- (if (null? xs)
- 0
- (let ((x1 (##sys#slot xs 0)))
- (##sys#check-exact-integer x1 'bitwise-xor)
- (let loop ((x x1) (xs (##sys#slot xs 1)))
- (if (null? xs)
- x
- (let ((xi (##sys#slot xs 0)))
- (##sys#check-exact-integer xi 'bitwise-xor)
- (loop
- (##sys#integer-bitwise-xor x xi)
- (##sys#slot xs 1) ) ) ) ))) )
-
-(define (bitwise-not n)
- (##sys#check-exact-integer n 'bitwise-not)
- (##core#inline_allocate ("C_s_a_u_i_integer_minus" 6) -1 n))
+(define (bit-set? n i) (##core#inline "C_i_bit_setp" n i))
+(define bitwise-and (##core#primitive "C_bitwise_and"))
+(define bitwise-ior (##core#primitive "C_bitwise_ior"))
+(define bitwise-xor (##core#primitive "C_bitwise_xor"))
+(define (bitwise-not n) (##core#inline_allocate ("C_s_a_i_bitwise_not" 6) n))
(define (arithmetic-shift n m)
(##core#inline_allocate ("C_s_a_i_arithmetic_shift" 6) n m))
-(define (bit-set? n i) (##core#inline "C_i_bit_setp" n i))
-
;;; String ports:
;
; - Port-slots:
diff --git a/runtime.c b/runtime.c
index 83be4c05..d2b8d7f5 100644
--- a/runtime.c
+++ b/runtime.c
@@ -512,9 +512,6 @@ static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word con
static C_ccall void values_continuation(C_word c, C_word closure, C_word dummy, ...) C_noret;
static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
static C_regparm int C_fcall C_in_new_heapp(C_word x);
-static void bignum_bitwise_and_2(C_word c, C_word self, C_word result) C_noret;
-static void bignum_bitwise_ior_2(C_word c, C_word self, C_word result) C_noret;
-static void bignum_bitwise_xor_2(C_word c, C_word self, C_word result) C_noret;
static void bignum_times_bignum_unsigned(C_word k, C_word x, C_word y, C_word negp) C_noret;
static void bignum_times_bignum_unsigned_2(C_word c, C_word self, C_word result) C_noret;
static void integer_times_2(C_word c, C_word self, C_word new_big) C_noret;
@@ -847,7 +844,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
{
/* IMPORTANT: hardcoded table size -
this must match the number of C_pte calls + 1 (NULL terminator)! */
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 72);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 73);
int i = 0;
if(pt == NULL)
@@ -924,9 +921,9 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_u_integer_quotient);
C_pte(C_u_integer_remainder);
C_pte(C_u_integer_divrem);
- C_pte(C_u_2_integer_bitwise_and);
- C_pte(C_u_2_integer_bitwise_ior);
- C_pte(C_u_2_integer_bitwise_xor);
+ C_pte(C_bitwise_and);
+ C_pte(C_bitwise_ior);
+ C_pte(C_bitwise_xor);
/* IMPORTANT: did you remember the hardcoded pte table size? */
pt[ i ].id = NULL;
@@ -6016,160 +6013,242 @@ C_regparm C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n)
else return C_flonum(a, nn);
}
-void C_ccall
-C_u_2_integer_bitwise_and(C_word c, C_word self, C_word k, C_word x, C_word y)
+C_regparm C_word C_fcall
+C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
- C_kontinue(k, C_u_fixnum_and(x, y));
+ return C_u_fixnum_and(x, y);
+ } else if (!C_truep(C_i_exact_integerp(x))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", x);
+ } else if (!C_truep(C_i_exact_integerp(y))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", y);
} else {
- C_word kab[C_SIZEOF_FIX_BIGNUM*2], *ka = kab, negp, size, k2;
- if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&ka, x);
- if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&ka, y);
+ C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;
+ C_uword *scanr, *endr, *scans1, *ends1, *scans2;
+
+ if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
+ if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
negp = C_mk_bool(C_bignum_negativep(x) && C_bignum_negativep(y));
/* Allow negative 1-bits to propagate */
if (C_bignum_negativep(x) || C_bignum_negativep(y))
- size = C_fix(nmax(C_bignum_size(x), C_bignum_size(y)) + 1);
+ size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;
else
- size = C_fix(nmin(C_bignum_size(x), C_bignum_size(y)));
+ size = nmin(C_bignum_size(x), C_bignum_size(y));
+
+ res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
+ scanr = C_bignum_digits(res);
+ endr = scanr + C_bignum_size(res);
+
+ if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
+ if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
- ka = C_alloc(C_SIZEOF_CLOSURE(4)); /* Why faster than static alloc? */
- k2 = C_closure(&ka, 4, (C_word)bignum_bitwise_and_2, k, x, y);
- C_allocate_bignum(5, (C_word)NULL, k2, C_fix(size), negp, C_SCHEME_FALSE);
+ if (C_bignum_size(x) < C_bignum_size(y)) {
+ scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
+ scans2 = C_bignum_digits(y);
+ } else {
+ scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
+ scans2 = C_bignum_digits(x);
+ }
+
+ while (scans1 < ends1) *scanr++ = *scans1++ & *scans2++;
+ C_memset(scanr, 0, C_wordstobytes(endr - scanr));
+
+ if (C_truep(nx)) free_tmp_bignum(nx);
+ if (C_truep(ny)) free_tmp_bignum(ny);
+ if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);
+
+ return C_bignum_simplify(res);
}
}
-static void bignum_bitwise_and_2(C_word c, C_word self, C_word result)
+void C_ccall C_bitwise_and(C_word c, C_word closure, C_word k, ...)
{
- C_word k = C_block_item(self, 1),
- x = C_block_item(self, 2),
- y = C_block_item(self, 3),
- size = C_bignum_size(result), nx, ny;
- C_uword *scanr = C_bignum_digits(result),
- *endr = scanr + C_bignum_size(result),
- *scans1, *ends1, *scans2;
-
- if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
- if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
-
- if (C_bignum_size(x) < C_bignum_size(y)) {
- scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
- scans2 = C_bignum_digits(y);
- } else {
- scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
- scans2 = C_bignum_digits(x);
- }
+ C_word next_val, result, prev_result;
+ C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
+ va_list v;
- while (scans1 < ends1) *scanr++ = *scans1++ & *scans2++;
- C_memset(scanr, 0, C_wordstobytes(endr - scanr));
+ c -= 2;
+ va_start(v, k);
- if (C_truep(nx)) free_tmp_bignum(nx);
- if (C_truep(ny)) free_tmp_bignum(ny);
- if (C_bignum_negativep(result)) bignum_digits_destructive_negate(result);
+ if (c == 0) C_kontinue(k, C_fix(-1));
- C_kontinue(k, C_bignum_simplify(result));
+ prev_result = result = va_arg(v, C_word);
+
+ if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-and", result);
+
+ while (c--) {
+ next_val = va_arg(v, C_word);
+ a = ab[c&1]; /* One may hold last iteration result, the other is unused */
+ result = C_s_a_i_bitwise_and(&a, 2, result, next_val);
+ result = move_buffer_object(&a, ab[(c+1)&1], result);
+ clear_buffer_object(ab[(c+1)&1], prev_result);
+ prev_result = result;
+ }
+
+ va_end(v);
+ C_kontinue(k, result);
}
-void C_ccall
-C_u_2_integer_bitwise_ior(C_word c, C_word self, C_word k, C_word x, C_word y)
+C_regparm C_word C_fcall
+C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
- C_kontinue(k, C_u_fixnum_or(x, y));
+ return C_u_fixnum_or(x, y);
+ } else if (!C_truep(C_i_exact_integerp(x))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", x);
+ } else if (!C_truep(C_i_exact_integerp(y))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", y);
} else {
- C_word kab[C_SIZEOF_FIX_BIGNUM*2], *ka = kab, negp, size, k2;
- if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&ka, x);
- if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&ka, y);
+ C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;
+ C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;
+
+ if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
+ if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
- ka = C_alloc(C_SIZEOF_CLOSURE(4)); /* Why faster than static alloc? */
- k2 = C_closure(&ka, 4, (C_word)bignum_bitwise_ior_2, k, x, y);
- size = C_fix(nmax(C_bignum_size(x), C_bignum_size(y)) + 1);
negp = C_mk_bool(C_bignum_negativep(x) || C_bignum_negativep(y));
- C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
+ size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;
+ res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
+ scanr = C_bignum_digits(res);
+ endr = scanr + C_bignum_size(res);
+
+ if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
+ if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
+
+ if (C_bignum_size(x) < C_bignum_size(y)) {
+ scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
+ scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);
+ } else {
+ scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
+ scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);
+ }
+
+ while (scans1 < ends1) *scanr++ = *scans1++ | *scans2++;
+ while (scans2 < ends2) *scanr++ = *scans2++;
+ if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */
+ assert(scanr == endr);
+
+ if (C_truep(nx)) free_tmp_bignum(nx);
+ if (C_truep(ny)) free_tmp_bignum(ny);
+ if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);
+
+ return C_bignum_simplify(res);
}
}
-static void bignum_bitwise_ior_2(C_word c, C_word self, C_word result)
+void C_ccall C_bitwise_ior(C_word c, C_word closure, C_word k, ...)
{
- C_word k = C_block_item(self, 1),
- x = C_block_item(self, 2),
- y = C_block_item(self, 3),
- size = C_bignum_size(result), nx, ny;
- C_uword *scanr = C_bignum_digits(result),
- *endr = scanr + C_bignum_size(result),
- *scans1, *ends1, *scans2, *ends2;
-
- if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
- if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
-
- if (C_bignum_size(x) < C_bignum_size(y)) {
- scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
- scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);
- } else {
- scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
- scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);
- }
+ C_word next_val, result, prev_result;
+ C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
+ va_list v;
- while (scans1 < ends1) *scanr++ = *scans1++ | *scans2++;
- while (scans2 < ends2) *scanr++ = *scans2++;
- if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */
- assert(scanr == endr);
+ c -= 2;
+ va_start(v, k);
- if (C_truep(nx)) free_tmp_bignum(nx);
- if (C_truep(ny)) free_tmp_bignum(ny);
- if (C_bignum_negativep(result)) bignum_digits_destructive_negate(result);
+ if (c == 0) C_kontinue(k, C_fix(0));
- C_kontinue(k, C_bignum_simplify(result));
+ prev_result = result = va_arg(v, C_word);
+
+ if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-ior", result);
+
+ while (c--) {
+ next_val = va_arg(v, C_word);
+ a = ab[c&1]; /* One may hold prev iteration result, the other is unused */
+ result = C_s_a_i_bitwise_ior(&a, 2, result, next_val);
+ result = move_buffer_object(&a, ab[(c+1)&1], result);
+ clear_buffer_object(ab[(c+1)&1], prev_result);
+ prev_result = result;
+ }
+
+ va_end(v);
+ C_kontinue(k, result);
}
-void C_ccall
-C_u_2_integer_bitwise_xor(C_word c, C_word self, C_word k, C_word x, C_word y)
+C_regparm C_word C_fcall
+C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
- C_kontinue(k, C_fixnum_xor(x, y));
+ return C_fixnum_xor(x, y);
+ } else if (!C_truep(C_i_exact_integerp(x))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", x);
+ } else if (!C_truep(C_i_exact_integerp(y))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", y);
} else {
- C_word kab[C_SIZEOF_FIX_BIGNUM*2], *ka = kab, size, k2, negp;
- if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&ka, x);
- if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&ka, y);
+ C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, negp, size, res, nx, ny;
+ C_uword *scanr, *endr, *scans1, *ends1, *scans2, *ends2;
+
+ if (x & C_FIXNUM_BIT) x = C_a_u_i_fix_to_big(&a, x);
+ if (y & C_FIXNUM_BIT) y = C_a_u_i_fix_to_big(&a, y);
- ka = C_alloc(C_SIZEOF_CLOSURE(4)); /* Why faster than static alloc? */
- k2 = C_closure(&ka, 4, (C_word)bignum_bitwise_xor_2, k, x, y);
- size = C_fix(nmax(C_bignum_size(x), C_bignum_size(y)) + 1);
+ size = nmax(C_bignum_size(x), C_bignum_size(y)) + 1;
negp = C_mk_bool(C_bignum_negativep(x) != C_bignum_negativep(y));
- C_allocate_bignum(5, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
+ res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
+ scanr = C_bignum_digits(res);
+ endr = scanr + C_bignum_size(res);
+
+ if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
+ if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
+
+ if (C_bignum_size(x) < C_bignum_size(y)) {
+ scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
+ scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);
+ } else {
+ scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
+ scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);
+ }
+
+ while (scans1 < ends1) *scanr++ = *scans1++ ^ *scans2++;
+ while (scans2 < ends2) *scanr++ = *scans2++;
+ if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */
+ assert(scanr == endr);
+
+ if (C_truep(nx)) free_tmp_bignum(nx);
+ if (C_truep(ny)) free_tmp_bignum(ny);
+ if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);
+
+ return C_bignum_simplify(res);
}
}
-static void bignum_bitwise_xor_2(C_word c, C_word self, C_word result)
+void C_ccall C_bitwise_xor(C_word c, C_word closure, C_word k, ...)
{
- C_word k = C_block_item(self, 1),
- x = C_block_item(self, 2),
- y = C_block_item(self, 3),
- size = C_bignum_size(result), nx, ny;
- C_uword *scanr = C_bignum_digits(result),
- *endr = scanr + C_bignum_size(result),
- *scans1, *ends1, *scans2, *ends2;
-
- if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
- if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
-
- if (C_bignum_size(x) < C_bignum_size(y)) {
- scans1 = C_bignum_digits(x); ends1 = scans1 + C_bignum_size(x);
- scans2 = C_bignum_digits(y); ends2 = scans2 + C_bignum_size(y);
- } else {
- scans1 = C_bignum_digits(y); ends1 = scans1 + C_bignum_size(y);
- scans2 = C_bignum_digits(x); ends2 = scans2 + C_bignum_size(x);
- }
+ C_word next_val, result, prev_result;
+ C_word ab[2][C_SIZEOF_STRUCTURE(3) * 3 + C_SIZEOF_FIX_BIGNUM * 4], *a;
+ va_list v;
- while (scans1 < ends1) *scanr++ = *scans1++ ^ *scans2++;
- while (scans2 < ends2) *scanr++ = *scans2++;
- if (scanr < endr) *scanr++ = 0; /* Only done when result is positive */
- assert(scanr == endr);
+ c -= 2;
+ va_start(v, k);
- if (C_truep(nx)) free_tmp_bignum(nx);
- if (C_truep(ny)) free_tmp_bignum(ny);
- if (C_bignum_negativep(result)) bignum_digits_destructive_negate(result);
+ if (c == 0) C_kontinue(k, C_fix(0));
- C_kontinue(k, C_bignum_simplify(result));
+ prev_result = result = va_arg(v, C_word);
+
+ if (c-- == 1 && !C_truep(C_i_exact_integerp(result)))
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-xor", result);
+
+ while (c--) {
+ next_val = va_arg(v, C_word);
+ a = ab[c&1]; /* One may hold prev iteration result, the other is unused */
+ result = C_s_a_i_bitwise_xor(&a, 2, result, next_val);
+ result = move_buffer_object(&a, ab[(c+1)&1], result);
+ clear_buffer_object(ab[(c+1)&1], prev_result);
+ prev_result = result;
+ }
+
+ va_end(v);
+ C_kontinue(k, result);
+}
+
+C_regparm C_word C_fcall
+C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)
+{
+ if (!C_truep(C_i_exact_integerp(x))) {
+ barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bitwise-not", x);
+ } else {
+ return C_s_a_u_i_integer_minus(ptr, 2, C_fix(-1), x);
+ }
}
/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
diff --git a/types.db b/types.db
index 840cc12f..2574dae5 100644
--- a/types.db
+++ b/types.db
@@ -882,25 +882,24 @@
((fixnum) (fixnum) #(1))
((integer) #(1))
((fixnum fixnum) (fixnum) (##core#inline "C_u_fixnum_and" #(1) #(2)))
- ((integer integer) (##sys#integer-bitwise-and #(1) #(2))))
+ ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_and" 6) #(1) #(2))))
(bitwise-ior (#(procedure #:clean #:enforce #:foldable) bitwise-ior (#!rest integer) integer)
(() '0)
((fixnum) (fixnum) #(1))
((integer) #(1))
((fixnum fixnum) (fixnum) (##core#inline "C_u_fixnum_or" #(1) #(2)))
- ((integer integer) (##sys#integer-bitwise-ior #(1) #(2))))
+ ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_ior" 6) #(1) #(2))))
(bitwise-xor (#(procedure #:clean #:enforce #:foldable) bitwise-xor (#!rest integer) integer)
(() '0)
((fixnum) (fixnum) #(1))
((integer) #(1))
((fixnum fixnum) (fixnum) (##core#inline "C_fixnum_xor" #(1) #(2)))
- ((integer integer) (##sys#integer-bitwise-xor #(1) #(2))))
+ ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_xor" 6) #(1) #(2))))
(bitwise-not (#(procedure #:clean #:enforce #:foldable) bitwise-not (integer) integer)
- ((integer)
- (##core#inline_allocate ("C_s_a_u_i_integer_minus" 6) '1 #(1))))
+ ((* *) (##core#inline_allocate ("C_s_a_i_bitwise_not" 6) #(1))))
(blob->string (#(procedure #:clean #:enforce) blob->string (blob) string))
Trap