~ chicken-core (chicken-5) f2315e8e883b0db3e22292727bc6e6eba8c103da
commit f2315e8e883b0db3e22292727bc6e6eba8c103da
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Feb 22 15:44:05 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:55:23 2015 +0200
Convert bignum representation to be a string wrapped in a structure.
This is exactly the same representation as the numbers egg uses. This
will allow us to store the data block in a different place in memory.
diff --git a/c-backend.scm b/c-backend.scm
index 0ef353b0..f010355a 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -681,9 +681,9 @@
(define (literal-size lit)
(cond ((immediate? lit) 0)
- ((big-fixnum? lit) 0) ; immediate or statically allocated
+ ((big-fixnum? lit) 3) ; immediate if fixnum, bignum see below
((string? lit) 0) ; statically allocated
- ((bignum? lit) 0) ; statically allocated
+ ((bignum? lit) 3) ; internal vector statically allocated
((flonum? lit) words-per-flonum)
((symbol? lit) 10) ; size of symbol, and possibly a bucket
((pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit))))
@@ -1435,9 +1435,12 @@ return((C_header_bits(lit) >> 24) & 0xff);
((exact-integer? lit)
;; Encode as hex to save space and get exact size
;; calculation. We could encode as base 32 to save more
- ;; space, but that makes debugging harder.
+ ;; space, but that makes debugging harder. The type tag is
+ ;; a bit of a hack: we encode as "GC forwarded" string to
+ ;; get a unique new type, as bignums don't have their own
+ ;; type tag (they're encoded as structures).
(let ((str (number->string lit 16)))
- (string-append "\x46" (encode-size (string-length str)) str)))
+ (string-append "\xc2" (encode-size (string-length str)) str)))
((flonum? lit)
(string-append "\x55" (number->string lit) "\x00") )
((symbol? lit)
diff --git a/chicken.h b/chicken.h
index df145825..d470d9af 100644
--- a/chicken.h
+++ b/chicken.h
@@ -470,7 +470,7 @@ static inline int isinf_ld (long double x)
# define C_PAIR_TYPE (0x0300000000000000L)
# define C_CLOSURE_TYPE (0x0400000000000000L | C_SPECIALBLOCK_BIT)
# define C_FLONUM_TYPE (0x0500000000000000L | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
-# define C_BIGNUM_TYPE (0x0600000000000000L | C_BYTEBLOCK_BIT)
+/* unused (0x0600000000000000L ...) */
# define C_PORT_TYPE (0x0700000000000000L | C_SPECIALBLOCK_BIT)
# define C_STRUCTURE_TYPE (0x0800000000000000L)
# define C_POINTER_TYPE (0x0900000000000000L | C_SPECIALBLOCK_BIT)
@@ -500,7 +500,7 @@ static inline int isinf_ld (long double x)
# else
# define C_FLONUM_TYPE (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
# endif
-# define C_BIGNUM_TYPE (0x06000000 | C_BYTEBLOCK_BIT)
+/* unused (0x06000000 ...) */
# define C_PORT_TYPE (0x07000000 | C_SPECIALBLOCK_BIT)
# define C_STRUCTURE_TYPE (0x08000000)
# define C_POINTER_TYPE (0x09000000 | C_SPECIALBLOCK_BIT)
@@ -533,9 +533,12 @@ static inline int isinf_ld (long double x)
#define C_SIZEOF_PORT 16
#define C_SIZEOF_STRUCTURE(n) ((n)+1)
#define C_SIZEOF_CLOSURE(n) ((n)+1)
-#define C_SIZEOF_BIGNUM(n) ((n)+2)
+#define C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n) (C_SIZEOF_VECTOR((n)+1))
+#define C_internal_bignum_vector(b) (C_block_item(b,1))
+
/* This is for convenience and allows flexibility in representation */
#define C_SIZEOF_FIX_BIGNUM C_SIZEOF_BIGNUM(1)
+#define C_SIZEOF_BIGNUM(n) (C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n)+C_SIZEOF_STRUCTURE(2))
/* Fixed size types have pre-computed header tags */
#define C_PAIR_TAG (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
@@ -546,6 +549,7 @@ static inline int isinf_ld (long double x)
#define C_SYMBOL_TAG (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
#define C_FLONUM_TAG (C_FLONUM_TYPE | sizeof(double))
#define C_STRUCTURE3_TAG (C_STRUCTURE_TYPE | 3)
+#define C_STRUCTURE2_TAG (C_STRUCTURE_TYPE | 2)
/* Locative subtypes */
#define C_SLOT_LOCATIVE 0
@@ -1117,7 +1121,7 @@ extern double trunc(double);
#define C_set_block_item(x,i,y) (C_block_item(x, i) = (y))
#define C_header_bits(bh) (C_block_header(bh) & C_HEADER_BITS_MASK)
#define C_header_size(bh) (C_block_header(bh) & C_HEADER_SIZE_MASK)
-#define C_bignum_size(b) (C_bytestowords(C_header_size(b))-1)
+#define C_bignum_size(b) (C_bytestowords(C_header_size(C_internal_bignum_vector(b)))-1)
#define C_make_header(type, size) ((C_header)(((type) & C_HEADER_BITS_MASK) | ((size) & C_HEADER_SIZE_MASK)))
#define C_symbol_value(x) (C_block_item(x, 0))
#define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
@@ -1159,11 +1163,11 @@ extern double trunc(double);
#define C_mk_nbool(x) ((x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
#define C_port_file(p) C_CHECKp(p,C_portp(C_VAL1(p)),(C_FILEPTR)C_block_item(C_VAL1(p), 0))
#define C_data_pointer(b) C_CHECKp(b,C_blockp((C_word)C_VAL1(b)),(void *)(((C_SCHEME_BLOCK *)(C_VAL1(b)))->data))
-#define C_bignum_negativep(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(C_block_item(b,0)!=0))
-#define C_bignum_digits(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(((C_uword *)C_data_pointer(C_VAL1(b)))+1))
+#define C_bignum_negativep(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(C_block_item(C_internal_bignum_vector(C_VAL1(b)),0)!=0))
+#define C_bignum_digits(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(((C_uword *)C_data_pointer(C_internal_bignum_vector(C_VAL1(b))))+1))
#define C_fitsinbignumhalfdigitp(n)(C_BIGNUM_DIGIT_HI_HALF(n) == 0)
#define C_bignum_negated_fitsinfixnump(b) (C_bignum_size(b) == 1 && (C_bignum_negativep(b) ? C_ufitsinfixnump(*C_bignum_digits(b)) : !(*C_bignum_digits(b) & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)*C_bignum_digits(b))))
-#define C_bignum_mutate_size(b,s) (C_block_header(b) = (C_BIGNUM_TYPE | C_wordstobytes((s)+1)))
+#define C_bignum_mutate_size(b, s) (C_block_header(C_internal_bignum_vector(b)) = (C_STRING_TYPE | C_wordstobytes((s)+1)))
#define C_fitsinfixnump(n) (((n) & C_INT_SIGN_BIT) == (((n) & C_INT_TOP_BIT) << 1))
#define C_ufitsinfixnump(n) (((n) & (C_INT_SIGN_BIT | (C_INT_SIGN_BIT >> 1))) == 0)
#define C_and(x, y) (C_truep(x) ? (y) : C_SCHEME_FALSE)
@@ -1236,7 +1240,7 @@ extern double trunc(double);
#define C_forwardedp(x) C_mk_bool((C_block_header(x) & C_GC_FORWARDING_BIT) != 0)
#define C_immp(x) C_mk_bool(C_immediatep(x))
#define C_flonump(x) C_mk_bool(C_block_header(x) == C_FLONUM_TAG)
-#define C_bignump(x) C_mk_bool(C_header_bits(x) == C_BIGNUM_TYPE)
+#define C_bignump(x) C_mk_bool(C_block_header(x) == C_STRUCTURE2_TAG && C_block_item(x, 0) == C_bignum_type_tag)
#define C_stringp(x) C_mk_bool(C_header_bits(x) == C_STRING_TYPE)
#define C_symbolp(x) C_mk_bool(C_block_header(x) == C_SYMBOL_TAG)
#define C_pairp(x) C_mk_bool(C_block_header(x) == C_PAIR_TAG)
@@ -1752,6 +1756,7 @@ C_varextern C_TLS C_word
*C_temporary_stack_bottom,
*C_temporary_stack_limit,
*C_stack_limit,
+ C_bignum_type_tag,
C_ratnum_type_tag,
C_cplxnum_type_tag;
C_varextern C_TLS C_long
@@ -2293,29 +2298,147 @@ C_inline C_word C_double_to_number(C_word n)
else return n;
}
+C_inline C_word C_a_i_record1(C_word **ptr, int n, C_word x1)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 1;
+ *(p++) = x1;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record2(C_word **ptr, int n, C_word x1, C_word x2)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 2;
+ *(p++) = x1;
+ *(p++) = x2;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 3;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 4;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 5;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 6;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 7;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *(p++) = x7;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_inline C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
+ C_word x5, C_word x6, C_word x7, C_word x8)
+{
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | 8;
+ *(p++) = x1;
+ *(p++) = x2;
+ *(p++) = x3;
+ *(p++) = x4;
+ *(p++) = x5;
+ *(p++) = x6;
+ *(p++) = x7;
+ *(p++) = x8;
+ *ptr = p;
+ return (C_word)p0;
+}
+
/* Silly (this is not normalized) but in some cases needed internally */
C_inline C_word C_bignum0(C_word **ptr)
{
C_word *p = *ptr, p0 = (C_word)p;
- /* Not using C_a_i_vector4, to make it easier to rewrite later */
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(1);
+ *(p++) = C_STRING_TYPE | C_wordstobytes(1);
*(p++) = 0; /* zero is always positive */
*ptr = p;
- return p0;
+ return C_a_i_record2(ptr, 2, C_bignum_type_tag, p0);
}
C_inline C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
{
C_word *p = *ptr, p0 = (C_word)p;
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(2);
+ *(p++) = C_STRING_TYPE | C_wordstobytes(2);
*(p++) = negp;
*(p++) = d1;
*ptr = p;
- return p0;
+ return C_a_i_record2(ptr, 2, C_bignum_type_tag, p0);
}
/* Here d1, d2, ... are low to high (ie, little endian)! */
@@ -2323,15 +2446,23 @@ C_inline C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
{
C_word *p = *ptr, p0 = (C_word)p;
- *(p++) = C_BIGNUM_TYPE | C_wordstobytes(3);
+ *(p++) = C_STRING_TYPE | C_wordstobytes(3);
*(p++) = negp;
*(p++) = d1;
*(p++) = d2;
*ptr = p;
- return p0;
+ return C_a_i_record2(ptr, 2, C_bignum_type_tag, p0);
}
+C_inline C_word C_i_bignump(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) &&
+ C_block_header(x) == C_STRUCTURE2_TAG &&
+ C_block_item(x, 0) == C_bignum_type_tag);
+}
+
+
/* XXX TODO OBSOLETE: This can be removed after recompiling c-platform.scm */
C_inline C_word C_fits_in_int_p(C_word x)
@@ -2340,7 +2471,7 @@ C_inline C_word C_fits_in_int_p(C_word x)
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
- if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
+ if(C_truep(C_i_bignump(x))) {
return C_mk_bool(C_bignum_size(x) == 1 &&
(!C_bignum_negativep(x) ||
!(C_bignum_digits(x)[0] & C_INT_SIGN_BIT)));
@@ -2357,10 +2488,7 @@ C_inline C_word C_fits_in_unsigned_int_p(C_word x)
double n, m;
if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
-
- if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
- return C_mk_bool(C_bignum_size(x) == 1);
- }
+ if(C_truep(C_i_bignump(x))) return C_mk_bool(C_bignum_size(x) == 1);
/* XXX OBSOLETE remove on the next round, remove check above */
n = C_flonum_magnitude(x);
@@ -2384,7 +2512,7 @@ C_inline C_word C_num_to_int(C_word x)
{
if(x & C_FIXNUM_BIT) {
return C_unfix(x);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
if (C_bignum_negativep(x)) return -(C_word)C_bignum_digits(x)[0];
else return (C_word)C_bignum_digits(x)[0]; /* should never be larger */
} else {
@@ -2398,7 +2526,7 @@ C_inline C_s64 C_num_to_int64(C_word x)
{
if(x & C_FIXNUM_BIT) {
return (C_s64)C_unfix(x);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
C_s64 num = C_bignum_digits(x)[0];
#ifndef C_SIXTY_FOUR
if (C_bignum_size(x) > 1) num |= ((C_s64)C_bignum_digits(x)[1]) << 32;
@@ -2416,7 +2544,7 @@ C_inline C_u64 C_num_to_uint64(C_word x)
{
if(x & C_FIXNUM_BIT) {
return (C_u64)C_unfix(x);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
C_u64 num = C_bignum_digits(x)[0];
#ifndef C_SIXTY_FOUR
if (C_bignum_size(x) > 1) num |= ((C_u64)C_bignum_digits(x)[1]) << 32;
@@ -2433,7 +2561,7 @@ C_inline C_uword C_num_to_unsigned_int(C_word x)
{
if(x & C_FIXNUM_BIT) {
return (C_uword)C_unfix(x);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_bignum_digits(x)[0]; /* should never be larger */
} else {
/* XXX OBSOLETE remove on the next round, remove check above */
@@ -2577,8 +2705,10 @@ C_inline C_word basic_eqvp(C_word x, C_word y)
((C_block_header(x) == C_FLONUM_TAG &&
C_flonum_magnitude(x) == C_flonum_magnitude(y)) ||
-
- (C_header_bits(x) == C_BIGNUM_TYPE &&
+
+ (C_block_header(x) == C_STRUCTURE2_TAG &&
+ C_block_item(x, 0) == C_bignum_type_tag &&
+ C_block_item(y, 0) == C_bignum_type_tag &&
C_i_bignum_cmp(x, y) == C_fix(0)))));
}
@@ -2636,17 +2766,12 @@ C_inline C_word C_i_closurep(C_word x)
return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
}
-C_inline C_word C_i_bignump(C_word x)
-{
- return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE);
-}
-
C_inline C_word C_i_numberp(C_word x)
{
return C_mk_bool((x & C_FIXNUM_BIT) ||
(!C_immediatep(x) &&
(C_block_header(x) == C_FLONUM_TAG ||
- C_header_bits(x) == C_BIGNUM_TYPE ||
+ C_truep(C_bignump(x)) ||
(C_block_header(x) == C_STRUCTURE3_TAG &&
(C_block_item(x, 0) == C_ratnum_type_tag ||
C_block_item(x, 0) == C_cplxnum_type_tag)))));
@@ -2658,8 +2783,8 @@ C_inline C_word C_i_realp(C_word x)
return C_mk_bool((x & C_FIXNUM_BIT) ||
(!C_immediatep(x) &&
(C_block_header(x) == C_FLONUM_TAG ||
- C_header_bits(x) == C_BIGNUM_TYPE ||
- (C_header_bits(x) == C_STRUCTURE_TYPE &&
+ C_truep(C_bignump(x)) ||
+ (C_block_header(x) == C_STRUCTURE3_TAG &&
C_block_item(x, 0) == C_ratnum_type_tag))));
}
@@ -2674,8 +2799,8 @@ C_inline C_word C_i_rationalp(C_word x)
double n = C_flonum_magnitude(x);
return C_mk_bool(!C_isinf(n) && !C_isnan(n));
} else {
- return C_mk_bool(C_header_bits(x) == C_BIGNUM_TYPE ||
- (C_header_bits(x) == C_STRUCTURE_TYPE &&
+ return C_mk_bool(C_truep(C_bignump(x)) ||
+ (C_block_header(x) == C_STRUCTURE3_TAG &&
C_block_item(x, 0) == C_ratnum_type_tag));
}
}
@@ -2702,8 +2827,7 @@ C_inline int C_ub_i_fpintegerp(double x)
C_inline C_word C_i_exact_integerp(C_word x)
{
- return C_mk_bool((x) & C_FIXNUM_BIT ||
- (!C_immediatep(x) && (C_header_bits(x) == C_BIGNUM_TYPE)));
+ return C_mk_bool((x) & C_FIXNUM_BIT || C_truep(C_i_bignump(x)));
}
C_inline C_word C_u_i_exactp(C_word x)
@@ -2746,11 +2870,10 @@ C_inline C_word C_i_integerp(C_word x)
{
double dummy, val;
- if (x & C_FIXNUM_BIT ||
- (!C_immediatep(x) && (C_header_bits(x) == C_BIGNUM_TYPE)))
- return C_SCHEME_TRUE;
+ if (x & C_FIXNUM_BIT || C_truep(C_i_bignump(x)))
+ return C_SCHEME_TRUE;
if (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
- return C_SCHEME_FALSE;
+ return C_SCHEME_FALSE;
val = C_flonum_magnitude(x);
if(C_isnan(val) || C_isinf(val)) return C_SCHEME_FALSE;
@@ -3310,125 +3433,6 @@ C_inline C_word C_a_i_list8(C_word **a, int n, C_word x1, C_word x2, C_word x3,
}
-C_inline C_word C_a_i_record1(C_word **ptr, int n, C_word x1)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 1;
- *(p++) = x1;
- *ptr = p;
- return (C_word)p0;
-}
-
-
-C_inline C_word C_a_i_record2(C_word **ptr, int n, C_word x1, C_word x2)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 2;
- *(p++) = x1;
- *(p++) = x2;
- *ptr = p;
- return (C_word)p0;
-}
-
-
-C_inline C_word C_a_i_record3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 3;
- *(p++) = x1;
- *(p++) = x2;
- *(p++) = x3;
- *ptr = p;
- return (C_word)p0;
-}
-
-
-C_inline C_word C_a_i_record4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 4;
- *(p++) = x1;
- *(p++) = x2;
- *(p++) = x3;
- *(p++) = x4;
- *ptr = p;
- return (C_word)p0;
-}
-
-
-C_inline C_word C_a_i_record5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
- C_word x5)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 5;
- *(p++) = x1;
- *(p++) = x2;
- *(p++) = x3;
- *(p++) = x4;
- *(p++) = x5;
- *ptr = p;
- return (C_word)p0;
-}
-
-
-C_inline C_word C_a_i_record6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
- C_word x5, C_word x6)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 6;
- *(p++) = x1;
- *(p++) = x2;
- *(p++) = x3;
- *(p++) = x4;
- *(p++) = x5;
- *(p++) = x6;
- *ptr = p;
- return (C_word)p0;
-}
-
-
-C_inline C_word C_a_i_record7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
- C_word x5, C_word x6, C_word x7)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 7;
- *(p++) = x1;
- *(p++) = x2;
- *(p++) = x3;
- *(p++) = x4;
- *(p++) = x5;
- *(p++) = x6;
- *(p++) = x7;
- *ptr = p;
- return (C_word)p0;
-}
-
-
-C_inline C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
- C_word x5, C_word x6, C_word x7, C_word x8)
-{
- C_word *p = *ptr, *p0 = p;
-
- *(p++) = C_STRUCTURE_TYPE | 8;
- *(p++) = x1;
- *(p++) = x2;
- *(p++) = x3;
- *(p++) = x4;
- *(p++) = x5;
- *(p++) = x6;
- *(p++) = x7;
- *(p++) = x8;
- *ptr = p;
- return (C_word)p0;
-}
-
/*
* From Hacker's Delight by Henry S. Warren
* based on a modified nlz() from section 5-3 (fig. 5-7)
diff --git a/library.scm b/library.scm
index e1d83657..35da3b7f 100644
--- a/library.scm
+++ b/library.scm
@@ -199,7 +199,7 @@ EOF
(define return-to-host (##core#primitive "C_return_to_host"))
(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))
(define ##sys#memory-info (##core#primitive "C_get_memory_info"))
-(define (current-milliseconds) (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f))
+(define (current-milliseconds) (##core#inline_allocate ("C_a_i_current_milliseconds" 7) #f))
(define (current-gc-milliseconds) (##sys#fudge 31))
(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
(define get-environment-variable (foreign-lambda c-string "C_getenv" c-string))
@@ -232,7 +232,7 @@ EOF
(##sys#setslot x i y) )
(define (current-seconds)
- (##core#inline_allocate ("C_a_get_current_seconds" 4) #f))
+ (##core#inline_allocate ("C_a_get_current_seconds" 7) #f))
(define cpu-time
(let ((buf (vector #f #f)))
@@ -5456,7 +5456,7 @@ EOF
(define (##sys#bytevector? x) (##core#inline "C_bytevectorp" x))
(define (##sys#string->pbytevector s) (##core#inline "C_string_to_pbytevector" s))
(define (##sys#permanent? x) (##core#inline "C_permanentp" x))
-(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 4) x))
+(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 6) x))
(define (##sys#locative? x) (##core#inline "C_locativep" x))
(define (##sys#srfi-4-vector? x)
(and (##core#inline "C_blockp" x)
@@ -5478,8 +5478,8 @@ EOF
ptr) )
(define (##sys#pointer->address ptr)
- ;;XXX '4' is platform dependent!
- (##core#inline_allocate ("C_a_unsigned_int_to_num" 4) (##sys#slot ptr 0)) )
+ ;;XXX '6' is platform dependent!
+ (##core#inline_allocate ("C_a_unsigned_int_to_num" 6) (##sys#slot ptr 0)) )
(define (##sys#make-c-string str #!optional (loc '##sys#make-c-string))
(let* ([len (##sys#size str)]
diff --git a/lolevel.scm b/lolevel.scm
index 159e2ab6..ededa8fc 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -347,25 +347,25 @@ EOF
(define pointer-u32-ref
(getter-with-setter
- (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u32_ref" 3) p)) ;XXX hardcoded size
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u32_ref" 6) p)) ;XXX hardcoded size
pointer-u32-set!
"(pointer-u32-ref p)"))
(define pointer-s32-ref
(getter-with-setter
- (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s32_ref" 3) p)) ;XXX hardcoded size
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s32_ref" 6) p)) ;XXX hardcoded size
pointer-s32-set!
"(pointer-s32-ref p)"))
(define pointer-u64-ref
(getter-with-setter
- (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u64_ref" 4) p)) ;XXX hardcoded size
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_u64_ref" 7) p)) ;XXX hardcoded size
pointer-u64-set!
"(pointer-u64-ref p)"))
(define pointer-s64-ref
(getter-with-setter
- (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s64_ref" 4) p)) ;XXX hardcoded size
+ (lambda (p) (##core#inline_allocate ("C_a_u_i_pointer_s64_ref" 7) p)) ;XXX hardcoded size
pointer-s64-set!
"(pointer-s64-ref p)"))
diff --git a/manual/Data representation b/manual/Data representation
index efc29df7..129e7058 100644
--- a/manual/Data representation
+++ b/manual/Data representation
@@ -86,13 +86,6 @@ a flat closure representation is used).
64 bit architectures) contain a 64-bit floating-point number, in the
representation used by the host system's C compiler.
-'''bignums''': byte-vector objects with type bits {{C_BIGNUM_TYPE}},
-currently 0110. The first word of the data element contains 0 if the
-number is positive or 1 if it is negative. The remaining data encodes
-the bignum's digits (sometimes called "bigits" or "limbs"), which are
-accessed as machine words. The internal byte representation will be
-stored in the endianness of the host machine.
-
'''ports''': special vector objects with type bits
{{C_PORT_TYPE}}, currently 0111. The first slot contains a pointer to a file-
stream, if this is a file-pointer, or NULL if not. The other slots
diff --git a/posix-common.scm b/posix-common.scm
index 65e77b92..b4fc8c7a 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -329,7 +329,7 @@ EOF
(lambda (port)
(let ((pos (cond ((port? port)
(if (eq? (##sys#slot port 7) 'stream)
- (##core#inline_allocate ("C_ftell" 4) port)
+ (##core#inline_allocate ("C_ftell" 7) port)
-1) )
((fixnum? port)
(##core#inline "C_lseek" port 0 _seek_cur) )
@@ -579,7 +579,7 @@ EOF
(let ((tm-size (foreign-value "sizeof(struct tm)" int)))
(lambda (tm)
(check-time-vector 'local-time->seconds tm)
- (let ((t (##core#inline_allocate ("C_a_mktime" 4) tm (##sys#make-string tm-size #\nul))))
+ (let ((t (##core#inline_allocate ("C_a_mktime" 7) tm (##sys#make-string tm-size #\nul))))
(if (fp= -1.0 t)
(##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm)
t)))))
diff --git a/posixunix.scm b/posixunix.scm
index fa65e1a1..61514e8e 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1443,7 +1443,7 @@ EOF
(let ((tm-size (foreign-value "sizeof(struct tm)" int)))
(lambda (tm)
(check-time-vector 'utc-time->seconds tm)
- (let ((t (##core#inline_allocate ("C_a_timegm" 4) tm (##sys#make-string tm-size #\nul))))
+ (let ((t (##core#inline_allocate ("C_a_timegm" 7) tm (##sys#make-string tm-size #\nul))))
(if (fp= -1.0 t)
(##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm)
t)))))
diff --git a/runtime.c b/runtime.c
index bc8b66f0..bd885e5b 100644
--- a/runtime.c
+++ b/runtime.c
@@ -327,6 +327,7 @@ C_TLS C_word
*C_temporary_stack_bottom,
*C_temporary_stack_limit,
*C_stack_limit,
+ C_bignum_type_tag,
C_ratnum_type_tag,
C_cplxnum_type_tag;
C_TLS C_long
@@ -1084,6 +1085,7 @@ void initialize_symbol_table(void)
for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);
/* Obtain reference to hooks for later: */
+ C_bignum_type_tag = C_intern2(C_heaptop, C_text("\003sysbignum"));
C_ratnum_type_tag = C_intern2(C_heaptop, C_text("\003sysratnum"));
C_cplxnum_type_tag = C_intern2(C_heaptop, C_text("\003syscplxnum"));
interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook"));
@@ -2542,7 +2544,7 @@ C_regparm C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str)
C_regparm C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str)
{
- C_word *dptr, bignum, retval, size, negp = 0;
+ C_word *dptr, bignum, bigvec, retval, size, negp = 0;
if (*str == '+' || *str == '-') {
negp = ((*str++) == '-') ? 1 : 0;
@@ -2550,16 +2552,19 @@ C_regparm C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str)
}
size = C_BIGNUM_BITS_TO_DIGITS(len << 2);
- dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(size)));
+ dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(size)));
if(dptr == NULL)
panic(C_text("out of memory - cannot allocate static bignum"));
- bignum = (C_word)dptr;
- C_block_header_init(bignum, C_BIGNUM_TYPE | C_wordstobytes(size + 1));
- C_set_block_item(bignum, 0, negp);
+ bigvec = (C_word)dptr;
+ C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(size + 1));
+ C_set_block_item(bigvec, 0, negp);
+ /* This needs to be allocated at ptr, not dptr, because GC moves type tag */
+ bignum = C_a_i_record2(ptr, 2, C_bignum_type_tag, bigvec);
retval = str_to_bignum(bignum, str, str + len, 16);
- if (retval & C_FIXNUM_BIT) C_free(dptr); /* Might have been simplified */
+ if (retval & C_FIXNUM_BIT)
+ C_free(dptr); /* Might have been simplified */
return retval;
}
@@ -3244,6 +3249,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
C_regparm void C_fcall mark_system_globals(void)
{
+ mark(&C_bignum_type_tag);
mark(&C_ratnum_type_tag);
mark(&C_cplxnum_type_tag);
mark(&interrupt_hook_symbol);
@@ -3584,6 +3590,7 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
C_regparm void C_fcall remark_system_globals(void)
{
+ remark(&C_bignum_type_tag);
remark(&C_ratnum_type_tag);
remark(&C_cplxnum_type_tag);
remark(&interrupt_hook_symbol);
@@ -4837,7 +4844,7 @@ C_regparm C_word C_fcall C_i_nanp(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "nan?", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
return C_u_i_flonum_nanp(x);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_SCHEME_FALSE;
} else if (C_block_header(x) == C_STRUCTURE3_TAG) {
if (C_block_item(x, 0) == C_ratnum_type_tag)
@@ -4860,7 +4867,7 @@ C_regparm C_word C_fcall C_i_finitep(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "finite?", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
return C_u_i_flonum_finitep(x);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_SCHEME_TRUE;
} else if (C_block_header(x) == C_STRUCTURE3_TAG) {
if (C_block_item(x, 0) == C_ratnum_type_tag)
@@ -4883,7 +4890,7 @@ C_regparm C_word C_fcall C_i_infinitep(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "infinite?", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
return C_u_i_flonum_infinitep(x);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_SCHEME_FALSE;
} else if (C_block_header(x) == C_STRUCTURE3_TAG) {
if (C_block_item(x, 0) == C_ratnum_type_tag)
@@ -4906,7 +4913,7 @@ C_regparm C_word C_fcall C_i_exactp(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "exact?", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
return C_SCHEME_FALSE;
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_SCHEME_TRUE;
} else if (C_block_header(x) == C_STRUCTURE3_TAG) {
if (C_block_item(x, 0) == C_ratnum_type_tag)
@@ -4929,7 +4936,7 @@ C_regparm C_word C_fcall C_i_inexactp(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "inexact?", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
return C_SCHEME_TRUE;
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_SCHEME_FALSE;
} else if (C_block_header(x) == C_STRUCTURE3_TAG) {
if (C_block_item(x, 0) == C_ratnum_type_tag)
@@ -4952,8 +4959,8 @@ C_regparm C_word C_fcall C_i_zerop(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "zero?", x);
} else if (C_block_header(x) == C_FLONUM_TAG) {
return C_mk_bool(C_flonum_magnitude(x) == 0.0);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE ||
- (C_block_header(x) == C_STRUCTURE3_TAG &&
+ } else if (C_truep(C_bignump(x)) ||
+ (C_block_header(x) == C_STRUCTURE3_TAG &&
(C_block_item(x, 0) == C_ratnum_type_tag ||
C_block_item(x, 0) == C_cplxnum_type_tag))) {
return C_SCHEME_FALSE;
@@ -4980,7 +4987,7 @@ C_regparm C_word C_fcall C_i_positivep(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);
else if (C_block_header(x) == C_FLONUM_TAG)
return C_mk_bool(C_flonum_magnitude(x) > 0.0);
- else if (C_header_bits(x) == C_BIGNUM_TYPE)
+ else if (C_truep(C_bignump(x)))
return C_mk_nbool(C_bignum_negativep(x));
else if (C_block_header(x) == C_STRUCTURE3_TAG &&
(C_block_item(x, 0) == C_ratnum_type_tag))
@@ -5013,7 +5020,7 @@ C_regparm C_word C_fcall C_i_negativep(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "negative?", x);
else if (C_block_header(x) == C_FLONUM_TAG)
return C_mk_bool(C_flonum_magnitude(x) < 0.0);
- else if (C_header_bits(x) == C_BIGNUM_TYPE)
+ else if (C_truep(C_bignump(x)))
return C_mk_bool(C_bignum_negativep(x));
else if (C_block_header(x) == C_STRUCTURE3_TAG &&
(C_block_item(x, 0) == C_ratnum_type_tag))
@@ -5052,7 +5059,7 @@ C_regparm C_word C_fcall C_i_evenp(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
else
return C_mk_bool(fmod(val, 2.0) == 0.0);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_mk_nbool(C_bignum_digits(x)[0] & 1);
} else { /* No need to try extended number */
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "even?", x);
@@ -5085,7 +5092,7 @@ C_regparm C_word C_fcall C_i_oddp(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
else
return C_mk_bool(fmod(val, 2.0) != 0.0);
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
return C_mk_bool(C_bignum_digits(x)[0] & 1);
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "odd?", x);
@@ -5503,7 +5510,7 @@ void C_ccall C_abs(C_word c, C_word self, C_word k, C_word x)
} else if (C_block_header(x) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_a_i_flonum_abs(&a, 1, x));
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
C_u_integer_abs(3, (C_word)NULL, k, x);
} else {
try_extended_number("\003sysextended-abs", 2, k, x);
@@ -5533,7 +5540,7 @@ void C_ccall C_signum(C_word c, C_word self, C_word k, C_word x)
} else if (C_block_header(x) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_a_u_i_flonum_signum(&a, 1, x));
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
C_kontinue(k, C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));
} else {
try_extended_number("\003sysextended-signum", 2, k, x);
@@ -5562,7 +5569,7 @@ void C_ccall C_negate(C_word c, C_word self, C_word k, C_word x)
} else if (C_block_header(x) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_a_i_flonum_negate(&a, 1, x));
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
C_u_integer_negate(3, (C_word)NULL, k, x);
} else {
try_extended_number("\003sysextended-negate", 2, k, x);
@@ -5745,8 +5752,7 @@ C_regparm C_word C_fcall C_i_bit_setp(C_word n, C_word i)
if (!C_truep(C_i_exact_integerp(n))) {
barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bit-set?", n);
} else if (!(i & C_FIXNUM_BIT)) {
- if (!C_immediatep(i) && (C_header_bits(i) == C_BIGNUM_TYPE) &&
- !C_bignum_negativep(i)) {
+ if (!C_immediatep(i) && C_truep(C_bignump(i)) && !C_bignum_negativep(i)) {
return C_i_integer_negativep(n); /* A bit silly, but strictly correct */
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, "bit-set?", i);
@@ -6668,7 +6674,7 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
if((x & C_FIXNUM_BIT) != 0) return x;
- if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
+ if(C_truep(C_i_bignump(x))) {
if (C_bignum_size(x) == 1) return x;
else barf(C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION, NULL, x);
}
@@ -6691,7 +6697,7 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x)
if((x & C_FIXNUM_BIT) != 0) return x;
- if(!C_immediatep(x) && C_header_bits(x) == C_BIGNUM_TYPE) {
+ if(C_truep(C_i_bignump(x))) {
#ifdef C_SIXTY_FOUR
if (C_bignum_size(x) == 1) return x;
#else
@@ -7092,7 +7098,7 @@ C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y)
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_flonum(&a, (double)C_unfix(x) * C_flonum_magnitude(y)));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_u_2_integer_times(4, (C_word)NULL, k, x, y);
} else {
try_extended_number("\003sysextended-times", 3, k, x, y);
@@ -7107,12 +7113,12 @@ C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "*", y);
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_kontinue(k, C_a_i_flonum_times(&a, 2, x, y));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x)*C_bignum_to_double(y)));
} else {
try_extended_number("\003sysextended-times", 3, k, x, y);
}
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
if (y & C_FIXNUM_BIT) {
C_u_2_integer_times(4, (C_word)NULL, k, x, y);
} else if (C_immediatep(y)) {
@@ -7120,7 +7126,7 @@ C_2_basic_times(C_word c, C_word self, C_word k, C_word x, C_word y)
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_flonum(&a, C_bignum_to_double(x)*C_flonum_magnitude(y)));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_u_2_integer_times(4, (C_word)NULL, k, x, y);
} else {
try_extended_number("\003sysextended-times", 3, k, x, y);
@@ -7373,7 +7379,7 @@ C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_flonum(&a, (double)C_unfix(x) + C_flonum_magnitude(y)));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_u_2_integer_plus(4, (C_word)NULL, k, x, y);
} else {
try_extended_number("\003sysextended-plus", 3, k, x, y);
@@ -7388,12 +7394,12 @@ C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "+", y);
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_kontinue(k, C_a_i_flonum_plus(&a, 2, x, y));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x)+C_bignum_to_double(y)));
} else {
try_extended_number("\003sysextended-plus", 3, k, x, y);
}
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
if (y & C_FIXNUM_BIT) {
C_u_2_integer_plus(4, (C_word)NULL, k, x, y);
} else if (C_immediatep(y)) {
@@ -7401,7 +7407,7 @@ C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_flonum(&a, C_bignum_to_double(x)+C_flonum_magnitude(y)));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_u_2_integer_plus(4, (C_word)NULL, k, x, y);
} else {
try_extended_number("\003sysextended-plus", 3, k, x, y);
@@ -7585,7 +7591,7 @@ C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_flonum(&a, (double)C_unfix(x) - C_flonum_magnitude(y)));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_u_2_integer_minus(4, (C_word)NULL, k, x, y);
} else {
try_extended_number("\003sysextended-minus", 3, k, x, y);
@@ -7600,12 +7606,12 @@ C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "-", y);
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_kontinue(k, C_a_i_flonum_difference(&a, 2, x, y)); /* XXX NAMING! */
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x)-C_bignum_to_double(y)));
} else {
try_extended_number("\003sysextended-minus", 3, k, x, y);
}
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
if (y & C_FIXNUM_BIT) {
C_u_2_integer_minus(4, (C_word)NULL, k, x, y);
} else if (C_immediatep(y)) {
@@ -7613,7 +7619,7 @@ C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
} else if (C_block_header(y) == C_FLONUM_TAG) {
C_word *a = C_alloc(C_SIZEOF_FLONUM);
C_kontinue(k, C_flonum(&a, C_bignum_to_double(x)-C_flonum_magnitude(y)));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_u_2_integer_minus(4, (C_word)NULL, k, x, y);
} else {
try_extended_number("\003sysextended-minus", 3, k, x, y);
@@ -7875,7 +7881,7 @@ basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_
x = C_a_i_fix_to_flo(&a, 1, x);
RETURN_Q_AND_OR_R(C_a_i_flonum_actual_quotient_checked(&a, 2, x, y),
C_a_i_flonum_remainder_checked(&a, 2, x, y));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
integer_divrem(6, (C_word)NULL, k, x, y, return_q, return_r);
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
@@ -7900,7 +7906,7 @@ basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_
RETURN_Q_AND_OR_R(C_a_i_flonum_actual_quotient_checked(&a, 2, x, y),
C_a_i_flonum_remainder_checked(&a, 2, x, y));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_word k2, ab[C_SIZEOF_CLOSURE(3)], *a = ab;
x = flo_to_tmp_bignum(x);
k2 = C_closure(&a, 3, (C_word)divrem_intflo_2, k, x);
@@ -7908,7 +7914,7 @@ basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
}
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
if (y & C_FIXNUM_BIT) {
integer_divrem(6, (C_word)NULL, k, x, y, return_q, return_r);
} else if (C_immediatep(y)) {
@@ -7924,7 +7930,7 @@ basic_divrem(C_word c, C_word self, C_word k, C_word x, C_word y, C_word return_
k2 = C_closure(&a, 3, (C_word)divrem_intflo_2, k, y);
integer_divrem(6, (C_word)NULL, k2, x, y, return_q, return_r);
}
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
bignum_divrem(6, (C_word)NULL, k, x, y, return_q, return_r);
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, DIVREM_LOC, y);
@@ -8214,7 +8220,7 @@ static C_word rat_cmp(C_word x, C_word y)
}
/* Extract components x=x1/x2 and y=y1/y2 */
- if (x & C_FIXNUM_BIT || (C_header_bits(x) == C_BIGNUM_TYPE)) {
+ if (x & C_FIXNUM_BIT || C_truep(C_bignump(x))) {
x1 = x;
x2 = C_fix(1);
} else {
@@ -8222,7 +8228,7 @@ static C_word rat_cmp(C_word x, C_word y)
x2 = C_block_item(x, 2);
}
- if (y & C_FIXNUM_BIT || (C_header_bits(y) == C_BIGNUM_TYPE)) {
+ if (y & C_FIXNUM_BIT || C_truep(C_bignump(y))) {
y1 = y;
y2 = C_fix(1);
} else {
@@ -8526,7 +8532,7 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
} else if (C_block_header(y) == C_FLONUM_TAG) {
return int_flo_cmp(x, y);
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
return C_i_bignum_cmp(C_a_u_i_fix_to_big(&a, x), y);
} else if (C_block_header(y) == C_STRUCTURE3_TAG) {
@@ -8553,7 +8559,7 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
double a = C_flonum_magnitude(x), b = C_flonum_magnitude(y);
if (C_isnan(a) || C_isnan(b)) return C_SCHEME_FALSE; /* "mu" */
else return C_fix((a < b) ? -1 : ((a > b) ? 1 : 0));
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
return flo_int_cmp(x, y);
} else if (C_block_header(y) == C_STRUCTURE3_TAG) {
if (C_block_item(y, 0) == C_ratnum_type_tag) {
@@ -8567,7 +8573,7 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
} else {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
}
- } else if (C_header_bits(x) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(x))) {
if (y & C_FIXNUM_BIT) {
C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
return C_i_bignum_cmp(x, C_a_u_i_fix_to_big(&a, y));
@@ -8575,7 +8581,7 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
} else if (C_block_header(y) == C_FLONUM_TAG) {
return int_flo_cmp(x, y);
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
return C_i_bignum_cmp(x, y);
} else if (C_block_header(y) == C_STRUCTURE3_TAG) {
if (C_block_item(y, 0) == C_ratnum_type_tag) {
@@ -8599,7 +8605,7 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
} else if (C_block_header(y) == C_FLONUM_TAG) {
return rat_flo_cmp(x, y);
- } else if (C_header_bits(y) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(y))) {
if (eqp) return C_SCHEME_FALSE;
else return rat_cmp(x, y);
} else if (C_block_header(y) == C_STRUCTURE3_TAG &&
@@ -8629,9 +8635,9 @@ static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp)
} else if (C_immediatep(y)) {
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, loc, y);
} else if (C_block_header(y) == C_FLONUM_TAG ||
- C_header_bits(y) == C_BIGNUM_TYPE ||
+ C_truep(C_bignump(x)) ||
(C_block_header(y) == C_STRUCTURE3_TAG &&
- (C_block_item(y, 0) == C_ratnum_type_tag))) {
+ C_block_item(y, 0) == C_ratnum_type_tag)) {
return C_SCHEME_FALSE;
} else if (C_block_header(y) == C_STRUCTURE3_TAG &&
(C_block_item(y, 0) == C_cplxnum_type_tag)) {
@@ -9073,12 +9079,12 @@ void allocate_vector_2(void *dummy)
void C_ccall
C_allocate_bignum(C_word c, C_word self, C_word k, C_word size, C_word negp, C_word initp)
{
- C_uword bytes = C_wordstobytes(C_unfix(size) + 1); /* add slot for negp */
+ C_uword bytes = C_wordstobytes(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(C_unfix(size)));
if(bytes > C_HEADER_SIZE_MASK)
barf(C_OUT_OF_RANGE_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));
- bytes += sizeof(C_word); /* header slot */
+ bytes += C_wordstobytes(C_SIZEOF_STRUCTURE(2)); /* Add wrapper struct */
C_save(k);
C_save(negp);
@@ -9105,7 +9111,7 @@ static void allocate_bignum_2(void *dummy)
C_word initp = C_restore;
C_word negp = C_restore;
C_word k = C_restore;
- C_word *v0, v;
+ C_word *v0, *v1, bigvec;
if(C_truep(mode)) {
while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {
@@ -9122,31 +9128,34 @@ static void allocate_bignum_2(void *dummy)
}
else v0 = C_alloc(C_bytestowords(bytes));
- v = (C_word)v0;
+ v1 = v0 + C_SIZEOF_STRUCTURE(2);
+ bigvec = (C_word)v1;
+ bytes -= C_wordstobytes(C_SIZEOF_STRUCTURE(2));
+ bytes -= sizeof(C_word); /* internal bignum vector's header */
- *(v0++) = C_BIGNUM_TYPE | (bytes-sizeof(C_word)); /* subtract header again */
+ *(v1++) = C_STRING_TYPE | bytes;
- *(v0++) = C_truep(negp);
- if(C_truep(initp)) C_memset(v0, '\0', bytes - sizeof(C_word));
+ *(v1++) = C_truep(negp);
+ if(C_truep(initp)) C_memset(v1, '\0', bytes - sizeof(C_word));
- C_kontinue(k, v);
+ C_kontinue(k, C_a_i_record2(&v0, 2, C_bignum_type_tag, bigvec));
}
static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)
{
C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),
- bignum = (C_word)mem;
+ bigvec = (C_word)(mem + C_SIZEOF_STRUCTURE(2));
if (mem == NULL) abort(); /* TODO: panic */
- C_block_header_init(bignum, C_BIGNUM_TYPE | C_wordstobytes(C_unfix(size)+1));
- C_set_block_item(bignum, 0, C_truep(negp));
+ C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(C_unfix(size)+1));
+ C_set_block_item(bigvec, 0, C_truep(negp));
if (C_truep(initp)) {
- C_memset(((C_uword *)C_data_pointer(bignum))+1,
+ C_memset(((C_uword *)C_data_pointer(bigvec))+1,
0, C_wordstobytes(C_unfix(size)));
}
- return bignum;
+ return C_a_i_record2(&mem, 2, C_bignum_type_tag, bigvec);
}
/* Simplification: scan trailing zeroes, then return a fixnum if the
@@ -10011,7 +10020,7 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);
} else if(C_block_header(num) == C_FLONUM_TAG) {
C_flonum_to_string(4, (C_word)NULL, k, num, radix);
- } else if (C_header_bits(num) == C_BIGNUM_TYPE) {
+ } else if (C_truep(C_bignump(num))) {
C_integer_to_string(4, (C_word)NULL, k, num, radix);
} else {
try_extended_number("\003sysextended-number->string", 3, k, num, radix);
@@ -11326,11 +11335,11 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
break;
#ifdef C_SIXTY_FOUR
- case (C_BIGNUM_TYPE >> (24 + 32)) & 0xff:
+ case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:
#else
- case (C_BIGNUM_TYPE >> 24) & 0xff:
+ case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:
#endif
- bits = C_BIGNUM_TYPE;
+ bits = (C_STRING_TYPE | C_GC_FORWARDING_BIT);
break;
default:
@@ -11380,6 +11389,13 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
size = decode_size(str);
switch(bits) {
+ /* This cannot be encoded as a blob due to endianness differences */
+ case (C_STRING_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */
+ /* bignums are also allocated statically */
+ val = C_static_bignum(ptr, size, *str);
+ *str += size;
+ break;
+
case C_STRING_TYPE:
/* strings are always allocated statically */
val = C_static_string(ptr, size, *str);
@@ -11406,13 +11422,6 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
*str += size;
break;
- /* This cannot be encoded as a blob due to endianness differences */
- case C_BIGNUM_TYPE:
- /* bignums are also allocated statically */
- val = C_static_bignum(ptr, size, *str);
- *str += size;
- break;
-
default:
*((*ptr)++) = C_make_header(bits, size);
data = *ptr;
diff --git a/scheduler.scm b/scheduler.scm
index 1dc78821..0193ef6d 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -176,7 +176,7 @@ EOF
(let loop1 ()
;; Unblock threads waiting for timeout:
(unless (null? ##sys#timeout-list)
- (let ((now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
+ (let ((now (##core#inline_allocate ("C_a_i_current_milliseconds" 7) #f)))
(let loop ((lst ##sys#timeout-list))
(if (null? lst)
(set! ##sys#timeout-list '())
@@ -440,7 +440,7 @@ EOF
(rq? (pair? ready-queue-head))
(tmo (if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
(let* ((tmo1 (caar ##sys#timeout-list))
- (now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
+ (now (##core#inline_allocate ("C_a_i_current_milliseconds" 7) #f)))
(max 0 (- tmo1 now)) )
0.0) ) ) ; otherwise immediate timeout.
(dbg "waiting for I/O with timeout " tmo)
diff --git a/srfi-4.scm b/srfi-4.scm
index c4f5f476..50d05d92 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -238,7 +238,7 @@ EOF
(##sys#check-structure x 'u32vector 'u32vector-ref)
(let ((len (##core#inline "C_u_i_u32vector_length" x)))
(check-range i 0 len 'u32vector-ref)
- (##core#inline_allocate ("C_a_u_i_u32vector_ref" 3) x i)))
+ (##core#inline_allocate ("C_a_u_i_u32vector_ref" 6) x i)))
u32vector-set!
"(u32vector-ref v i)"))
@@ -248,7 +248,7 @@ EOF
(##sys#check-structure x 's32vector 's32vector-ref)
(let ((len (##core#inline "C_u_i_s32vector_length" x)))
(check-range i 0 len 's32vector-ref)
- (##core#inline_allocate ("C_a_u_i_s32vector_ref" 3) x i)))
+ (##core#inline_allocate ("C_a_u_i_s32vector_ref" 6) x i)))
s32vector-set!
"(s32vector-ref v i)"))
@@ -258,7 +258,7 @@ EOF
(##sys#check-structure x 'u64vector 'u64vector-ref)
(let ((len (##core#inline "C_u_i_u64vector_length" x)))
(check-range i 0 len 'u64vector-ref)
- (##core#inline_allocate ("C_a_u_i_u64vector_ref" 4) x i)))
+ (##core#inline_allocate ("C_a_u_i_u64vector_ref" 7) x i)))
u64vector-set!
"(u64vector-ref v i)"))
@@ -268,7 +268,7 @@ EOF
(##sys#check-structure x 's64vector 's64vector-ref)
(let ((len (##core#inline "C_u_i_s64vector_length" x)))
(check-range i 0 len 's64vector-ref)
- (##core#inline_allocate ("C_a_u_i_s64vector_ref" 4) x i)))
+ (##core#inline_allocate ("C_a_u_i_s64vector_ref" 7) x i)))
s64vector-set!
"(s64vector-ref v i)"))
diff --git a/types.db b/types.db
index 14d36cb7..dd350439 100644
--- a/types.db
+++ b/types.db
@@ -317,14 +317,14 @@
((float float) (float)
(##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2)))
((fixnum fixnum) (integer)
- (##core#inline_allocate ("C_a_i_fixnum_plus" 3) #(1) #(2)))
+ (##core#inline_allocate ("C_a_i_fixnum_plus" 6) #(1) #(2)))
((integer integer) (integer)
(##sys#integer-plus #(1) #(2)))
((* *) (number)
(##sys#+-2 #(1) #(2))))
(- (#(procedure #:clean #:enforce #:foldable) - (number #!rest number) number)
- ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_negate" 3) #(1)))
+ ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_negate" 6) #(1)))
((integer) (integer) (##sys#integer-negate #(1)))
((float) (float) (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1)))
((number) (number) (##sys#negate #(1)))
@@ -341,7 +341,7 @@
((float float) (float)
(##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) #(2)))
((fixnum fixnum) (integer)
- (##core#inline_allocate ("C_a_i_fixnum_difference" 3) #(1) #(2)))
+ (##core#inline_allocate ("C_a_i_fixnum_difference" 6) #(1) #(2)))
((integer integer) (integer)
(##sys#integer-minus #(1) #(2)))
((* *) (number)
@@ -369,7 +369,7 @@
((float float) (float)
(##core#inline_allocate ("C_a_i_flonum_times" 4) #(1) #(2)))
((fixnum fixnum) (integer)
- (##core#inline_allocate ("C_a_i_fixnum_times" 4) #(1) #(2)))
+ (##core#inline_allocate ("C_a_i_fixnum_times" 7) #(1) #(2)))
((integer integer) (integer)
(##sys#integer-times #(1) #(2)))
((* *) (number)
@@ -440,7 +440,7 @@
(##core#inline_allocate
("C_a_i_flonum_actual_quotient_checked" 4) #(1) #(2)))
((fixnum fixnum) (integer)
- (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 3)
+ (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 6)
#(1) #(2)))
((integer integer) (integer)
(##sys#integer-quotient #(1) #(2))))
@@ -469,7 +469,7 @@
(let ((#(tmp1) #(1)))
(let ((#(tmp2) #(2)))
(##sys#values
- (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 3)
+ (##core#inline_allocate ("C_a_i_fixnum_quotient_checked" 6)
#(tmp1) #(tmp2))
(##core#inline
"C_i_fixnum_remainder_checked" #(tmp1) #(tmp2))))))
@@ -497,7 +497,7 @@
(##sys#lcm (#(procedure #:clean #:enforce #:foldable) ##sys#lcm (number number) number))
(abs (#(procedure #:clean #:enforce #:foldable) abs (number) number)
- ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 3) #(1)))
+ ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 6) #(1)))
((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1)))
((integer) (integer) (##sys#integer-abs #(1))))
@@ -792,7 +792,7 @@
((cplxnum) (##sys#slot #(1) '2)))
(magnitude (#(procedure #:clean #:enforce #:foldable) magnitude (number) number)
- ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 3) #(1)))
+ ((fixnum) (integer) (##core#inline_allocate ("C_a_i_fixnum_abs" 6) #(1)))
((integer) (##sys#integer-abs #(1)))
((float) (float) (##core#inline_allocate ("C_a_i_flonum_abs" 4) #(1)))
(((or fixnum float bignum ratnum)) (abs #(1))))
Trap