From: Chris Hanson Date: Wed, 23 Apr 1997 07:29:15 +0000 (+0000) Subject: Dramatically improve the performance of EXACT->INEXACT on ratnums and X-Git-Tag: 20090517-FFI~5210 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0a76e9ab95eb585fd4d9d75e9e09d11d503d991f;p=mit-scheme.git 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 ffcb206f8..5d2b0d9f9 100644 --- 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. |# (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 b73966241..77550a5ce 100644 --- 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)