conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* changed implementation of $flonum->exact.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-14 20:45:37 -05:00
parent f3e412ae9c
commit 4c632e435b
3 changed files with 6815 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
benchmarks.larceny/results.Larceny-r6rs
View File

@ -8554,3 +8554,23 @@ Words allocated: 220925448
Words reclaimed: 0
Elapsed time...: 20757 ms (User: 10967 ms; System: 9775 ms)
Elapsed GC time: 179 ms (CPU: 176 in 843 collections.)
****************************
Benchmarking Larceny-r6rs on Wed Nov 14 20:44:56 EST 2007 under Darwin Vesuvius.local 8.10.1 Darwin Kernel Version 8.10.1: Wed May 23 16:33:00 PDT 2007; root:xnu-792.22.5~1/RELEASE_I386 i386 i386
Testing ray under Larceny-r6rs
Compiling...
Larceny v0.95 "First Safety" (Nov 8 2007 04:30:20, precise:BSD Unix:unified)
larceny.heap, built on Thu Nov 8 04:39:44 EST 2007
>
>
Running...
Larceny v0.95 "First Safety" (Nov 8 2007 04:30:20, precise:BSD Unix:unified)
larceny.heap, built on Thu Nov 8 04:39:44 EST 2007
>
Words allocated: 220925448
Words reclaimed: 0
Elapsed time...: 20776 ms (User: 10963 ms; System: 9734 ms)
Elapsed GC time: 164 ms (CPU: 166 in 843 collections.)

6742
benchmarks/timelog
View File

File diff suppressed because it is too large Load Diff

79
scheme/ikarus.numerics.ss
View File

@ -100,7 +100,7 @@
#f]
[else ($fl= x ($flround x))])))
(define ($flonum->integer x)
(module ($flonum->integer $flonum->exact)
(define ($flonum-signed-mantissa x)
(let ([b0 ($flonum-u8-ref x 0)])
(let ([m0 ($fx+ ($flonum-u8-ref x 7)
@ -119,21 +119,59 @@
(+ (bitwise-arithmetic-shift-left
($fx- 0 ($fxlogor m1 ($fxsll m2 24))) 24)
($fx- 0 m0))))))
(let ([sbe ($flonum-sbe x)])
(let ([be ($fxlogand sbe #x7FF)])
(cond
[($fx= be 2047) #f] ;;; nans/infs
[($fx>= be 1075) ;;; magnitude large enough to be an integer
(bitwise-arithmetic-shift-left
($flonum-signed-mantissa x)
(- be 1075))]
[else
(let ([x0 ($fl* x 5e-324)])
(cond
[($fl= x ($fl/ x0 5e-324)) ;;; x == round(x)
($flonum-signed-mantissa x0)]
[else #f]))]))))
(define ($flonum->integer x)
(let ([sbe ($flonum-sbe x)])
(let ([be ($fxlogand sbe #x7FF)])
(cond
[($fx= be 2047) #f] ;;; nans/infs
[($fx>= be 1075) ;;; magnitude large enough to be an integer
(bitwise-arithmetic-shift-left
($flonum-signed-mantissa x)
(- be 1075))]
[else
(let ([x0 ($fl* x 5e-324)])
(cond
[($fl= x ($fl/ x0 5e-324)) ;;; x == round(x)
($flonum-signed-mantissa x0)]
[else #f]))]))))
(define ($flonum->exact x)
(let ([sbe ($flonum-sbe x)])
(let ([be ($fxlogand sbe #x7FF)])
(cond
[($fx= be 2047) #f] ;;; nans/infs
[($fx>= be 1075) ;;; magnitude large enough to be an integer
(bitwise-arithmetic-shift-left
($flonum-signed-mantissa x)
(- be 1075))]
[else
(let* ([x0 ($fl* x 5e-324)]
[x1 ($fl/ x0 5e-324)])
(cond
[($fl= x x1) ;;; x == round(x)
($flonum-signed-mantissa x0)]
[($fx= be 0) ;;; denormal
(/ ($flonum-signed-mantissa x)
(bitwise-arithmetic-shift-left 1 1074))]
[else ;;; x has a fraction
(let ([v ($flonum-signed-mantissa x)])
(let ([bits (- 1075 be)])
(let ([int (bitwise-arithmetic-shift-right v bits)]
[frac
(let ([e (bitwise-arithmetic-shift-left 1 bits)])
(/ (bitwise-and v (- e 1)) e))])
(+ int frac))))]))])))))
;;;OLD (define ($flonum->exact x)
;;;OLD ;;; this really needs to get optimized.
;;;OLD (let-values ([(pos? be m) (flonum-parts x)])
;;;OLD (cond
;;;OLD [(<= 1 be 2046) ; normalized flonum
;;;OLD (* (if pos? 1 -1)
;;;OLD (* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
;;;OLD [(= be 0)
;;;OLD (* (if pos? 1 -1)
;;;OLD (* m (expt 2 -1074)))]
;;;OLD [else #f])))
(define (flnumerator x)
(unless (flonum? x)
@ -217,17 +255,6 @@
(let ([b0 ($flonum-u8-ref x 0)])
(fx> b0 127)))
(define ($flonum->exact x)
;;; this really needs to get optimized.
(let-values ([(pos? be m) (flonum-parts x)])
(cond
[(<= 1 be 2046) ; normalized flonum
(* (if pos? 1 -1)
(* (+ m (expt 2 52)) (expt 2 (- be 1075))))]
[(= be 0)
(* (if pos? 1 -1)
(* m (expt 2 -1074)))]
[else #f])))