~ chicken-core (chicken-5) 9a89a61c0830bde5962b2c34153dbf28d4da38b6
commit 9a89a61c0830bde5962b2c34153dbf28d4da38b6
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Nov 25 06:03:20 2010 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Nov 25 06:03:20 2010 -0500
more efficient inline_allocate functions for string->number and exact->inexact
diff --git a/c-platform.scm b/c-platform.scm
index bca49ee7..d915ebde 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -783,6 +783,8 @@
(rewrite '+ 16 2 "C_a_i_plus" #t 4) ; words-per-flonum
(rewrite '- 16 2 "C_a_i_minus" #t 4) ; words-per-flonum
(rewrite '/ 16 2 "C_a_i_divide" #t 4) ; words-per-flonum
+(rewrite 'exact->inexact 16 1 "C_a_i_exact_to_inexact" #t 4) ; words-per-flonum
+
(rewrite '= 17 2 "C_i_nequalp")
(rewrite '> 17 2 "C_i_greaterp")
(rewrite '< 17 2 "C_i_lessp")
@@ -799,8 +801,6 @@
(rewrite '>= 13 "C_greater_or_equal_p" #t)
(rewrite '<= 13 "C_less_or_equal_p" #t)
-(rewrite 'exact->inexact 13 "C_exact_to_inexact" #t)
-(rewrite 'string->number 13 "C_string_to_number" #t)
(rewrite 'number->string 13 "C_number_to_string" #t)
(rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t)
(rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t)
@@ -842,6 +842,24 @@
(rewrite 'fpceiling 16 1 "C_a_i_flonum_truncate" 'specialized words-per-flonum)
(rewrite 'fpround 16 1 "C_a_i_flonum_truncate" 'specialized words-per-flonum)
+(rewrite
+ 'string->number 8
+ (lambda (db classargs cont callargs)
+ ;; (string->number X) -> (##core#inline_allocate ("C_a_i_string_to_number" 4) X 10)
+ ;; (string->number X Y) -> (##core#inline_allocate ("C_a_i_string_to_number" 4) X Y)
+ (define (build x y)
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node
+ '##core#inline_allocate
+ '("C_a_i_string_to_number" 4) ; words-per-flonum
+ (list x y)))))
+ (case (length callargs)
+ ((1) (build (first callargs) (qnode 10)))
+ ((2) (build (first callargs) (second callargs)))
+ (else #f))))
+
(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
(rewrite 'list 16 #f "C_a_i_list" #t '(3) #t)
diff --git a/chicken.h b/chicken.h
index 0167fd16..25cd834f 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1676,9 +1676,9 @@ C_fctexport void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C
C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
C_fctexport void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n) C_noret;
-C_fctexport void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n) C_noret; /*XXX left for binary compatibility */
C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
-C_fctexport void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...) C_noret;
+C_fctexport void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...) C_noret; /*XXX left for binary compatibility */
C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
C_fctexport void C_ccall C_get_argv(C_word c, C_word closure, C_word k) C_noret;
C_fctexport void C_ccall C_make_structure(C_word c, C_word closure, C_word k, C_word type, ...) C_noret;
@@ -1830,6 +1830,8 @@ C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def)
C_fctexport double C_fcall C_milliseconds(void) C_regparm;
C_fctexport double C_fcall C_cpu_milliseconds(void) C_regparm;
C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm;
+C_fctexport C_word C_fcall C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix) C_regparm;
+C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
diff --git a/library.scm b/library.scm
index 71fd37c7..9719e7d6 100644
--- a/library.scm
+++ b/library.scm
@@ -925,7 +925,7 @@ EOF
(else (if (##sys#exact? n) 0 0.0) ) ) )
;; hooks for numbers
-(define ##sys#exact->inexact (##core#primitive "C_exact_to_inexact"))
+(define (##sys#exact->inexact n) (##core#inline_allocate ("C_a_i_exact_to_inexact" 4) n))
(define (##sys#inexact->exact n) (##core#inline "C_i_inexact_to_exact" n))
(define exact->inexact ##sys#exact->inexact)
@@ -1059,7 +1059,9 @@ EOF
(##sys#lcm head (##sys#slot next 0))
(##sys#slot next 1)) #f) ) ) ) ) ) )
-(define ##sys#string->number (##core#primitive "C_string_to_number"))
+(define (##sys#string->number str #!optional (radix 10))
+ (##core#inline_allocate ("C_a_i_string_to_number" 4) str radix))
+
(define string->number ##sys#string->number)
(define ##sys#number->string (##core#primitive "C_number_to_string"))
(define number->string ##sys#number->string)
diff --git a/runtime.c b/runtime.c
index 13df40bb..7e20f67c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -763,7 +763,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_quotient);
C_pte(C_flonum_fraction);
C_pte(C_expt);
- C_pte(C_exact_to_inexact);
+ C_pte(C_exact_to_inexact); /*XXX left for binary compatbility */
C_pte(C_string_to_number);
C_pte(C_number_to_string);
C_pte(C_make_symbol);
@@ -7071,6 +7071,7 @@ void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n)
}
+/* XXX left for binary compatibility */
void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n)
{
C_alloc_flonum;
@@ -7087,6 +7088,18 @@ void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n)
}
+C_regparm C_word C_fcall
+C_a_i_exact_to_inexact(C_word **a, int c, C_word n)
+{
+ if(n & C_FIXNUM_BIT)
+ return C_flonum(a, (double)C_unfix(n));
+ else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact->inexact", n);
+
+ return n;
+}
+
+
/* this is different from C_a_i_flonum_round, for R5RS compatibility */
C_regparm C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)
{
@@ -7155,24 +7168,16 @@ void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2
}
-void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...)
+C_regparm C_word C_fcall
+C_a_i_string_to_number(C_word **a, int c, C_word str, C_word radix0)
{
int radix, radixpf = 0, sharpf = 0, ratp = 0, exactf, exactpf = 0, periodf = 0;
- C_word n1, n, *a = C_alloc(WORDS_PER_FLONUM);
+ C_word n1, n;
C_char *sptr, *eptr;
double fn1, fn;
- va_list v;
- if(c == 3) radix = 10; /* default radix is 10 */
- else if(c == 4) {
- va_start(v, str);
- radix = va_arg(v, C_word);
- va_end(v);
-
- if(radix & C_FIXNUM_BIT) radix = C_unfix(radix);
- else barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "string->number", radix);
- }
- else C_bad_argc(c, 3);
+ if(radix0 & C_FIXNUM_BIT) radix = C_unfix(radix0);
+ else barf(C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR, "string->number", radix0);
if(C_immediatep(str) || C_header_bits(str) != C_STRING_TYPE)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->number", str);
@@ -7254,7 +7259,7 @@ void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str,
case 1: /* fixnum */
if(sharpf || ratp || (exactpf && !exactf)) {
- n = C_flonum(&a, ratp ? fn1 / (double)n : (double)n);
+ n = C_flonum(a, ratp ? fn1 / (double)n : (double)n);
if(exactpf && exactf) n = C_i_inexact_to_exact(n);
}
@@ -7263,7 +7268,7 @@ void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str,
break;
case 2: /* flonum */
- n = C_flonum(&a, ratp ? fn1 / fn : fn);
+ n = C_flonum(a, ratp ? fn1 / fn : fn);
if(exactpf && exactf) n = C_i_inexact_to_exact(n);
@@ -7271,7 +7276,27 @@ void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str,
}
fini:
- C_kontinue(k, n);
+ return n;
+}
+
+
+/* only left for backwards-compatibility */
+void C_ccall
+C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...)
+{
+ va_list va;
+ C_word data[ C_SIZEOF_FLONUM + 2 ]; /* alignment */
+ C_word *a = data;
+ C_word radix = C_fix(10);
+
+ if(c == 4) {
+ va_start(va, str);
+ radix = va_arg(va, C_word);
+ va_end(va);
+ }
+ else if(c != 3) C_bad_argc(c, 3);
+
+ C_kontinue(k, C_a_i_string_to_number(&a, 2, str, radix));
}
Trap