~ chicken-core (chicken-5) 12a921b5dc3d512c6f41b2d6a008e996f956c4bc
commit 12a921b5dc3d512c6f41b2d6a008e996f956c4bc
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Sun Feb 1 20:20:52 2015 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:17:21 2015 +0200
Teach C backend about bignums, so that literals will be encoded/decoded correctly in binaries.
Currently, bignums are decoded into statically allocated memory, just like strings.
This simplifies things a bit, and ensures we won't run out of stack in case of truly
huge bignums.
Remember, ratnums and compnums are represented internally as structures, so these
are correctly serialized "for free".
diff --git a/c-backend.scm b/c-backend.scm
index 7f269ebc..9440c848 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -680,23 +680,27 @@
(bomb "type of literal not supported" lit) )
(define (literal-size lit)
- (cond [(immediate? lit) 0]
- [(string? lit) 0]
- [(number? 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)))]
- [(vector? lit) (+ 1 (vector-length lit) (foldl + 0 (map literal-size (vector->list lit))))]
- [(block-variable-literal? lit) 0]
- [(##sys#immediate? lit) (bad-literal lit)]
- [(##core#inline "C_lambdainfop" lit) 0]
- [(##sys#bytevector? lit) (+ 2 (bytes->words (##sys#size lit))) ] ; drops "permanent" property!
- [(##sys#generic-structure? lit)
+ (cond ((immediate? lit) 0)
+ ((big-fixnum? lit) 0) ; immediate or statically allocated
+ ((string? lit) 0) ; statically allocated
+ ((bignum? lit) 0) ; 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))))
+ ((vector? lit)
+ (+ 1 (vector-length lit)
+ (foldl + 0 (map literal-size (vector->list lit)))))
+ ((block-variable-literal? lit) 0) ; excluded from generated code
+ ((##sys#immediate? lit) (bad-literal lit))
+ ((##core#inline "C_lambdainfop" lit) 0) ; statically allocated
+ ((##sys#bytevector? lit) (+ 2 (bytes->words (##sys#size lit))) ) ; drops "permanent" property!
+ ((##sys#generic-structure? lit)
(let ([n (##sys#size lit)])
(let loop ([i 0] [s (+ 2 n)])
(if (>= i n)
s
- (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) ]
- [else (bad-literal lit)] ) )
+ (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) )
+ (else (bad-literal lit))) )
(define (gen-lit lit to)
;; we do simple immediate literals directly to avoid a function call:
@@ -1410,16 +1414,21 @@ return((C_header_bits(lit) >> 24) & 0xff);
((null? lit) "\xff\x0e")
((eof-object? lit) "\xff\x3e")
((eq? (void) lit) "\xff\x1e")
- ((fixnum? lit)
- (if (not (big-fixnum? lit))
- (string-append
- "\xff\x01"
- (string (integer->char (bitwise-and #xff (arithmetic-shift lit -24)))
- (integer->char (bitwise-and #xff (arithmetic-shift lit -16)))
- (integer->char (bitwise-and #xff (arithmetic-shift lit -8)))
- (integer->char (bitwise-and #xff lit)) ) )
- (string-append "\xff\x55" (number->string lit) "\x00") ) )
- ((number? lit)
+ ;; The big-fixnum? check can probably be simplified
+ ((and (fixnum? lit) (not (big-fixnum? lit)))
+ (string-append
+ "\xff\x01"
+ (string (integer->char (bitwise-and #xff (arithmetic-shift lit -24)))
+ (integer->char (bitwise-and #xff (arithmetic-shift lit -16)))
+ (integer->char (bitwise-and #xff (arithmetic-shift lit -8)))
+ (integer->char (bitwise-and #xff lit)) ) ) )
+ ((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.
+ (let ((str (number->string lit 16)))
+ (string-append "\x46" (encode-size (string-length str)) str)))
+ ((flonum? lit)
(string-append "\x55" (number->string lit) "\x00") )
((symbol? lit)
(let ((str (##sys#slot lit 1)))
@@ -1443,4 +1452,4 @@ return((C_header_bits(lit) >> 24) & 0xff);
(encode-size len)
(list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))
""))))) )
-)
\ No newline at end of file
+)
diff --git a/chicken.h b/chicken.h
index 86407329..2fac5074 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1810,6 +1810,7 @@ C_fctexport C_word C_resize_trace_buffer(C_word size);
C_fctexport C_word C_fetch_trace(C_word start, C_word buffer);
C_fctexport C_word C_fcall C_string(C_word **ptr, int len, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_static_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str) C_regparm;
C_fctexport C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
diff --git a/runtime.c b/runtime.c
index 41c4091e..8639cf62 100644
--- a/runtime.c
+++ b/runtime.c
@@ -2535,6 +2535,28 @@ C_regparm C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str)
return strblock;
}
+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;
+
+ if (*str == '+' || *str == '-') {
+ negp = ((*str++) == '-') ? 1 : 0;
+ --len;
+ }
+ size = C_BIGNUM_BITS_TO_DIGITS(len << 2);
+
+ dptr = (C_word *)C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(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);
+
+ retval = str_to_bignum(bignum, str, str + len, 16);
+ if (retval & C_FIXNUM_BIT) C_free(dptr); /* Might have been simplified */
+ return retval;
+}
C_regparm C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str)
{
@@ -11259,6 +11281,14 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
bits = C_FLONUM_TYPE;
break;
+#ifdef C_SIXTY_FOUR
+ case (C_BIGNUM_TYPE >> (24 + 32)) & 0xff:
+#else
+ case (C_BIGNUM_TYPE >> 24) & 0xff:
+#endif
+ bits = C_BIGNUM_TYPE;
+ break;
+
default:
panic(C_text("invalid encoded special literal"));
}
@@ -11282,6 +11312,11 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
panic(C_text("invalid encoded numeric literal"));
break;
+ /* XXX OBSOLETE: remove when we get rid of convert_string_to_number,
+ * which can be done after recompilation when we know bignums are
+ * always encoded as bignums. Then this can be moved to the switch()
+ * below.
+ */
case 1: /* fixnum */
val = C_fix(ln);
break;
@@ -11327,6 +11362,13 @@ 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;
Trap