Dramatically improve the performance of EXACT->INEXACT on ratnums and

(EXPT 2 x).  Slightly improve INTEGER-ROUND.  These changes require
two new primitives implemented in microcode 11.158.

Here are the results for EXACT->INEXACT.  These tests were run by
calling EXACT->INEXACT on a list of 100000 randomly-generated ratnums.
The numerator and denominator were each chosen using a modulus of
(EXPT 2 64), discarding zero denominators and integer quotients.

The machine was a dual Pentium Pro 200MHz / 512kB cache, 128MB RAM,
running SMP Linux 2.0.26 and libc 5.4.20.  Scheme was run using the
runtime.com band and a heap of 4000.  The machine was otherwise
quiescent.

Results for old EXACT->INEXACT:

    process time: 1750 (1470 RUN + 280 GC); real time: 37350
    process time: 1000 (780 RUN + 220 GC); real time: 37359
    process time: 900 (900 RUN + 0 GC); real time: 37345
    process time: 2460 (2060 RUN + 400 GC); real time: 37370

    average real time: 37356 msec

Results for new EXACT->INEXACT:

    process time: 580 (580 RUN + 0 GC); real time: 5825
    process time: 240 (240 RUN + 0 GC); real time: 5480
    process time: 910 (910 RUN + 0 GC); real time: 5450
    process time: 840 (540 RUN + 300 GC); real time: 5770

    average real time: 5631 msec

Average improvement is a factor of 6.6 in speed.

diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm
index ffcb206f87800d5c8ce719278d146b8b98e1a52c..5d2b0d9f9ac5a4c3a9918e26fe82b0fa94165128 100644 (file)
--- a/v7/src/runtime/arith.scm
+++ b/v7/src/runtime/arith.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: arith.scm,v 1.34 1996/04/24 03:03:16 cph Exp $
+$Id: arith.scm,v 1.35 1997/04/23 07:26:06 cph Exp $
 
-Copyright (c) 1989-96 Massachusetts Institute of Technology
+Copyright (c) 1989-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -47,7 +47,9 @@ MIT in each case. |#
 (define-primitives
   (listify-bignum 2)
   (integer->flonum 2)
-  (flo:denormalize flonum-denormalize 2))
+  (flo:denormalize flonum-denormalize 2)
+  (integer-length-in-bits 1)
+  (integer-shift-left 2))
 
 (define-integrable (int:bignum? object)
   (object-type? (ucode-type big-fixnum) object))
@@ -292,11 +294,13 @@ MIT in each case. |#
 (define (int:round n d)
   (let ((positive-case
         (lambda (n d)
-          (let ((c (int:divide (int:+ (int:* 2 n) d) (int:* 2 d))))
-            (let ((q (integer-divide-quotient c)))
-              (if (and (int:zero? (integer-divide-remainder c))
-                       (not (int:zero? (int:remainder q 2))))
-                  (int:-1+ q)
+          (let ((qr (int:divide n d)))
+            (let ((q (integer-divide-quotient qr))
+                  (2r (int:* 2 (integer-divide-remainder qr))))
+              (if (or (int:> 2r d)
+                      (and (int:= 2r d)
+                           (fix:zero? (int:remainder q 2))))
+                  (int:1+ q)
                   q))))))
     (if (int:negative? n)
        (if (int:negative? d)
@@ -308,21 +312,24 @@ MIT in each case. |#
 \f
 (define (int:expt b e)
   (cond ((int:positive? e)
-        (if (or (int:= 1 e)
-                (int:zero? b)
-                (int:= 1 b))
-            b
-            (let loop ((b b) (e e) (answer 1))
-              (let ((qr (int:divide e 2)))
-                (let ((b (int:* b b))
-                      (e (integer-divide-quotient qr))
-                      (answer
-                       (if (int:zero? (integer-divide-remainder qr))
-                           answer
-                           (int:* answer b))))
-                  (if (int:= 1 e)
-                      (int:* answer b)
-                      (loop b e answer)))))))
+        (cond ((or (int:= 1 e)
+                   (int:zero? b)
+                   (int:= 1 b))
+               b)
+              ((int:= 2 b)
+               (integer-shift-left 1 e))
+              (else
+               (let loop ((b b) (e e) (answer 1))
+                 (let ((qr (int:divide e 2)))
+                   (let ((b (int:* b b))
+                         (e (integer-divide-quotient qr))
+                         (answer
+                          (if (fix:= 0 (integer-divide-remainder qr))
+                              answer
+                              (int:* answer b))))
+                     (if (int:= 1 e)
+                         (int:* answer b)
+                         (loop b e answer))))))))
        ((int:zero? e) 1)
        (else (error:bad-range-argument e 'EXPT))))
 
@@ -803,56 +810,34 @@ MIT in each case. |#
 (define (ratnum->flonum q)
   (let ((q>0
         (lambda (n d)
-          (let ((u int:flonum-integer-limit))
-            (let ((g (int:gcd n u)))
-              (let ((n (int:quotient n g))
-                    (d (int:* d (int:quotient u g)))
-                    (finish
-                     (lambda (n d e)
-                       (let ((c
-                              (lambda (n e)
-                                (flo:denormalize (integer->flonum n #b11) e)))
-                             (n
-                              (let ((g (int:gcd d u)))
-                                (int:round
-                                 (int:* n (int:quotient u g))
-                                 (int:quotient d g)))))
-                         (if (int:= n u)
-                             (c (int:quotient n 2) (int:1+ e))
-                             (c n e))))))
-                (if (int:< n d)
-                    (let scale-up ((n n) (e 0))
-                      (let ((n*2 (int:* n 2)))
-                        (if (int:< n*2 d)
-                            (let loop
-                                ((n n*2) (n*r (int:* n*2 2)) (r 4) (m 1))
-                              (if (int:< n*r d)
-                                  (loop n*r
-                                        (int:* n*r r)
-                                        (int:* r r)
-                                        (int:* 2 m))
-                                  (scale-up n (int:- e m))))
-                            (finish n d e))))
-                    (let scale-down ((d d) (e 0))
-                      (let ((d (int:* d 2)))
-                        (cond ((int:> n d)
-                               (let loop ((d d) (d*r (int:* d 2)) (r 4) (m 1))
-                                 (cond ((int:> n d*r)
-                                        (loop d*r
-                                              (int:* d*r r)
-                                              (int:* r r)
-                                              (int:* 2 m)))
-                                       ((int:< n d*r)
-                                        (scale-down d (int:+ e m)))
-                                       (else
-                                        (finish
-                                         n
-                                         (int:* d*r 2)
-                                         (int:1+ (int:+ e (int:* 2 m))))))))
-                              ((int:< n d)
-                               (finish n d (int:1+ e)))
-                              (else
-                               (finish n (int:* d 2) (int:+ e 2)))))))))))))
+          (let ((k
+                 (int:- (integer-length-in-bits n)
+                        (integer-length-in-bits d)))
+                (p flo:significand-digits-base-2))
+            (letrec
+                ((step1
+                  (lambda (n d)
+                    ;; (assert (< (expt 2 (- k 1)) (/ n d) (expt 2 (+ k 1))))
+                    (if (int:< k 0)
+                        (step2 (integer-shift-left n (int:- 0 k)) d)
+                        (step2 n (integer-shift-left d k)))))
+                 (step2
+                  (lambda (n d)
+                    ;; (assert (< 1/2 (/ n d) 2))
+                    (if (int:< n d)
+                        (step3 n d (int:- k p))
+                        (step3 n (int:* 2 d) (int:- (int:+ k 1) p)))))
+                 (step3
+                  (lambda (n d e)
+                    ;; (assert (and (<= 1/2 (/ n d)) (< (/ n d) 1)))
+                    (let ((n (int:round (integer-shift-left n p) d)))
+                      (if (int:= n int:flonum-integer-limit)
+                          (step4 (int:quotient n 2) (int:1+ e))
+                          (step4 n e)))))
+                 (step4
+                  (lambda (n e)
+                    (flo:denormalize (integer->flonum n #b11) e))))
+              (step1 n d))))))
     (let ((n (ratnum-numerator q))
          (d (ratnum-denominator q)))
       (cond ((int:positive? n) (q>0 n d))

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index b73966241156eac72963eb1b54e06873d268f62b..77550a5ce765eb91bd9dba1ab8d7375d4ab78ef9 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: version.scm,v 14.172 1997/01/05 23:44:06 cph Exp $
+$Id: version.scm,v 14.173 1997/04/23 07:29:15 cph Exp $
 
 Copyright (c) 1988-97 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 172))
+  (add-identification! "Runtime" 14 173))
 
 (define microcode-system)