~ chicken-core (chicken-5) 84391f76b2be6833c11bcf1d8e86f339ddc11d1b

commit 84391f76b2be6833c11bcf1d8e86f339ddc11d1b
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Mar 28 20:02:11 2015 +0100
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sun May 31 14:55:24 2015 +0200

    Re-implement variadic * in C, in order to avoid consing up rest lists.

diff --git a/c-platform.scm b/c-platform.scm
index b9b5b05a..c3c42bf3 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -654,6 +654,7 @@
 (rewrite '>= 13 #f "C_greater_or_equal_p" #t)
 (rewrite '<= 13 #f "C_less_or_equal_p" #t)
 
+(rewrite '* 13 #f "C_times" #t)
 (rewrite '+ 13 #f "C_plus" #t)
 (rewrite '- 13 '(1 . #f) "C_minus" #t)
 
diff --git a/library.scm b/library.scm
index 27ddfdd6..3be55736 100644
--- a/library.scm
+++ b/library.scm
@@ -954,6 +954,7 @@ EOF
 
 (define + (##core#primitive "C_plus"))
 (define - (##core#primitive "C_minus"))
+(define * (##core#primitive "C_times"))
 (define (add1 n) (+ n 1))
 (define (sub1 n) (- n 1))
 
@@ -1112,23 +1113,6 @@ EOF
 
 (define (abs x) (##core#inline_allocate ("C_s_a_i_abs" 10) x))
 
-(define (* . args)
-  (if (null? args) 
-      1
-      (let ((x (##sys#slot args 0))
-	    (args (##sys#slot args 1)))
-	(if (null? args)
-            (if (number? x) x (##sys#error-bad-number x '*))
-            (let loop ((args (##sys#slot args 1))
-                       (x (##core#inline_allocate
-			   ("C_s_a_i_times" 40) x (##sys#slot args 0))))
-              (if (null? args)
-                  x
-                  (loop (##sys#slot args 1)
-			(##core#inline_allocate
-			 ("C_s_a_i_times" 40)
-			 x (##sys#slot args 0))) ) )  ) ) ) )
-
 (define (/ arg1 . args)
   (if (null? args) 
       (##sys#/-2 1 arg1)
diff --git a/runtime.c b/runtime.c
index 65b92b0e..b0a728b9 100644
--- a/runtime.c
+++ b/runtime.c
@@ -7848,53 +7848,26 @@ bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp)
    return n;
 }
 
-
 void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
 {
+  C_word next_val, result = C_fix(1), prev_result = result;
+  C_word ab[2][C_SIZEOF_STRUCTURE(3) * 3 + C_SIZEOF_BIGNUM(2) * 4], *a;
   va_list v;
-  C_word x, y;
-  C_word iresult = C_fix(1);
-  double fresult;
-  C_alloc_flonum;
 
+  c -= 2; 
   va_start(v, k);
-  c -= 2;
-
-  while(c--) {
-    x = va_arg(v, C_word);
-    
-    if(x & C_FIXNUM_BIT) {
-      y = C_i_o_fixnum_times(iresult, x);
-
-      if(y == C_SCHEME_FALSE) {
-	fresult = (double)C_unfix(iresult) * (double)C_unfix(x);
-	goto flonum_result;
-      }
-      else iresult = y;
-    }
-    else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
-      fresult = (double)C_unfix(iresult) * C_flonum_magnitude(x);
-      goto flonum_result;
-    }
-    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
-  }
 
-  va_end(v);
-  C_kontinue(k, iresult);
-
- flonum_result:
-  while(c--) {
-    x = va_arg(v, C_word);
-
-    if(x & C_FIXNUM_BIT)
-      fresult *= (double)C_unfix(x);
-    else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)
-      fresult *= C_flonum_magnitude(x);
-    else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
+  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_times(&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_flonum(k, fresult);
+  C_kontinue(k, result);
 }