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

* reimplemented bignum->flonum in Scheme now. ikrt_bignum_to_flonum 

is no longer used.
This commit is contained in:
Abdulaziz Ghuloum 2007-06-10 20:21:41 +03:00
parent 9a31a8f0d3
commit cde508d58c
4 changed files with 204 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
BUGS
View File

@ -1,3 +1,19 @@
Email Will Clinger regarding:
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD
Unix:unified)
> (exact->inexact #xFFFFFFFFFFFFFFFF)
9.223372036854776e18
> #xFFFFFFFFFFFFFFFF
18446744073709551615
======================================================================
* FIX: Error in generate-code: BUG: unhandles single rv. * FIX: Error in generate-code: BUG: unhandles single rv.
@ -13,6 +29,7 @@ Not applicable anymore:
Fixed: Fixed:
* Investigate what happens when an interrupt occurs during a write. * Investigate what happens when an interrupt occurs during a write.
@ -28,3 +45,5 @@ Fixed:
Two displays occurred at the end. Two displays occurred at the end.

BIN
src/ikarus.boot
View File

Binary file not shown.

186
src/ikarus.numerics.ss
View File

@ -71,6 +71,7 @@
exact->inexact floor ceiling log) exact->inexact floor ceiling log)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $flonums)
(ikarus system $ratnums) (ikarus system $ratnums)
(ikarus system $bignums) (ikarus system $bignums)
(ikarus system $chars) (ikarus system $chars)
@ -84,8 +85,189 @@
(define (fixnum->flonum x) (define (fixnum->flonum x)
(foreign-call "ikrt_fixnum_to_flonum" x)) (foreign-call "ikrt_fixnum_to_flonum" x))
(define (bignum->flonum x) (module (bignum->flonum)
(foreign-call "ikrt_bignum_to_flonum" x)) ; sbe f6 f5 f4 f3 f2 f1 f0
;SEEEEEEE|EEEEmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm|mmmmmmmm
; | | | | | | |
; v0 v1 v2 v3 v4 v5 v6 v7
(define ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)
(let ([v ($make-flonum)])
(let ([be (fx+ e 1075)])
(let ([sbe (if pos? be (fxlogor be (fxsll 1 11)))])
($flonum-set! v 0 (fxsra sbe 4))
($flonum-set! v 1 (fxlogor (fxsll sbe 4) (fxlogand f6 #b1111)))
($flonum-set! v 2 f5)
($flonum-set! v 3 f4)
($flonum-set! v 4 f3)
($flonum-set! v 5 f2)
($flonum-set! v 6 f1)
($flonum-set! v 7 f0)))
v))
(define ($flonum/c0 pos? e f6 f5 f4 f3 f2 f1 f0 c)
(define ($fxeven? x)
(fxzero? (fxlogand x 1)))
(define-syntax cond*
(syntax-rules (else)
[(_ [test conseq] [else val])
(if test conseq val)]
[(_ [test conseq] [var val] rest ...)
(if test conseq (let ([var val]) (cond* rest ...)))]))
(cond*
[($fxeven? c) ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)]
[f0 (fx+ (fxlogand f0 255) 1)]
[(fx< f0 256) ($flonum pos? e f6 f5 f4 f3 f2 f1 f0)]
[f1 (fx+ (fxlogand f1 255) 1)]
[(fx< f1 256) ($flonum pos? e f6 f5 f4 f3 f2 f1 0)]
[f2 (fx+ (fxlogand f2 255) 1)]
[(fx< f2 256) ($flonum pos? e f6 f5 f4 f3 f2 0 0)]
[f3 (fx+ (fxlogand f3 255) 1)]
[(fx< f3 256) ($flonum pos? e f6 f5 f4 f3 0 0 0)]
[f4 (fx+ (fxlogand f4 255) 1)]
[(fx< f4 256) ($flonum pos? e f6 f5 f4 0 0 0 0)]
[f5 (fx+ (fxlogand f5 255) 1)]
[(fx< f5 256) ($flonum pos? e f6 f5 0 0 0 0 0)]
[f6 (fx+ (fxlogand f6 #b1111) 1)]
[(fx< f6 16) ($flonum pos? e f6 0 0 0 0 0 0)]
[else ($flonum pos? (+ e 1) 0 0 0 0 0 0 0)]))
(define ($flonum/aux pos? e b7 b6 b5 b4 b3 b2 b1 b0)
(cond
[(fx>= b7 #x80)
($flonum/c0 pos? (fx+ e 3)
(fxsra b7 3)
(fxlogor (fxsll b7 5) (fxsra b6 3))
(fxlogor (fxsll b6 5) (fxsra b5 3))
(fxlogor (fxsll b5 5) (fxsra b4 3))
(fxlogor (fxsll b4 5) (fxsra b3 3))
(fxlogor (fxsll b3 5) (fxsra b2 3))
(fxlogor (fxsll b2 5) (fxsra b1 3))
(fxsra b1 2))]
[(fx>= b7 #x40)
($flonum/c0 pos? (fx+ e 2)
(fxsra b7 2)
(fxlogor (fxsll b7 6) (fxsra b6 2))
(fxlogor (fxsll b6 6) (fxsra b5 2))
(fxlogor (fxsll b5 6) (fxsra b4 2))
(fxlogor (fxsll b4 6) (fxsra b3 2))
(fxlogor (fxsll b3 6) (fxsra b2 2))
(fxlogor (fxsll b2 6) (fxsra b1 2))
(fxsra b1 1))]
[(fx>= b7 #x20)
($flonum/c0 pos? (fx+ e 1)
(fxsra b7 1)
(fxlogor (fxsll b7 7) (fxsra b6 1))
(fxlogor (fxsll b6 7) (fxsra b5 1))
(fxlogor (fxsll b5 7) (fxsra b4 1))
(fxlogor (fxsll b4 7) (fxsra b3 1))
(fxlogor (fxsll b3 7) (fxsra b2 1))
(fxlogor (fxsll b2 7) (fxsra b1 1))
b1)]
[(fx>= b7 #x10)
($flonum/c0 pos? e b7 b6 b5 b4 b3 b2 b1
(fxsra b0 7))]
[(fx>= b7 #x08)
($flonum/c0 pos? (fx- e 1)
(fxlogor (fxsll b7 1) (fxsra b6 7))
(fxlogor (fxsll b6 1) (fxsra b5 7))
(fxlogor (fxsll b5 1) (fxsra b4 7))
(fxlogor (fxsll b4 1) (fxsra b3 7))
(fxlogor (fxsll b3 1) (fxsra b2 7))
(fxlogor (fxsll b2 1) (fxsra b1 7))
(fxlogor (fxsll b1 1) (fxsra b0 7))
(fxsra b0 6))]
[(fx>= b7 #x04)
($flonum/c0 pos? (fx- e 2)
(fxlogor (fxsll b7 2) (fxsra b6 6))
(fxlogor (fxsll b6 2) (fxsra b5 6))
(fxlogor (fxsll b5 2) (fxsra b4 6))
(fxlogor (fxsll b4 2) (fxsra b3 6))
(fxlogor (fxsll b3 2) (fxsra b2 6))
(fxlogor (fxsll b2 2) (fxsra b1 6))
(fxlogor (fxsll b1 2) (fxsra b0 6))
(fxsra b0 5))]
[(fx>= b7 #x02)
($flonum/c0 pos? (fx- e 3)
(fxlogor (fxsll b7 3) (fxsra b6 5))
(fxlogor (fxsll b6 3) (fxsra b5 5))
(fxlogor (fxsll b5 3) (fxsra b4 5))
(fxlogor (fxsll b4 3) (fxsra b3 5))
(fxlogor (fxsll b3 3) (fxsra b2 5))
(fxlogor (fxsll b2 3) (fxsra b1 5))
(fxlogor (fxsll b1 3) (fxsra b0 5))
(fxsra b0 4))]
[(fx>= b7 #x01)
($flonum/c0 pos? (fx- e 4)
(fxlogor (fxsll b7 4) (fxsra b6 4))
(fxlogor (fxsll b6 4) (fxsra b5 4))
(fxlogor (fxsll b5 4) (fxsra b4 4))
(fxlogor (fxsll b4 4) (fxsra b3 4))
(fxlogor (fxsll b3 4) (fxsra b2 4))
(fxlogor (fxsll b2 4) (fxsra b1 4))
(fxlogor (fxsll b1 4) (fxsra b0 4))
(fxsra b0 3))]
[else (error '$float/aux "invalid b7=~s" b7)]))
(define (bignum->flonum x)
(define (bignum/4->flonum x)
($flonum/aux ($bignum-positive? x) -24
($bignum-byte-ref x 3)
($bignum-byte-ref x 2)
($bignum-byte-ref x 1)
($bignum-byte-ref x 0)
0 0 0 0))
(define (bignum/8->flonum x)
;;; bignum: [b0 b1 b2 b3 b4 b5 b6 b7]
(let ([b0 ($bignum-byte-ref x 0)]
[b1 ($bignum-byte-ref x 1)]
[b2 ($bignum-byte-ref x 2)]
[b3 ($bignum-byte-ref x 3)]
[b4 ($bignum-byte-ref x 4)]
[b5 ($bignum-byte-ref x 5)]
[b6 ($bignum-byte-ref x 6)]
[b7 ($bignum-byte-ref x 7)]
[pos? ($bignum-positive? x)])
(if (fx= b7 0)
(if (fx= b6 0)
(if (fx= b5 0)
(if (fx= b4 0)
(error 'bignum8->flonum "malformed bignum")
($flonum/aux pos? -16 b4 b3 b2 b1 b0 0 0 0))
($flonum/aux pos? -8 b5 b4 b3 b2 b1 b0 0 0))
($flonum/aux pos? 0 b6 b5 b4 b3 b2 b1 b0 0))
($flonum/aux pos? 8 b7 b6 b5 b4 b3 b2 b1 b0))))
(define (bignum/n->flonum x bytes)
(define (aux x b7 bytes)
($flonum/aux ($bignum-positive? x) (+ (* bytes 8) -48)
b7
($bignum-byte-ref x (fx- bytes 1))
($bignum-byte-ref x (fx- bytes 2))
($bignum-byte-ref x (fx- bytes 3))
($bignum-byte-ref x (fx- bytes 4))
($bignum-byte-ref x (fx- bytes 5))
($bignum-byte-ref x (fx- bytes 6))
($bignum-byte-ref x (fx- bytes 7))))
;;; bignum: [b0 b1 b2 b3 ... b_{bytes-1}]
(let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
(if (fx= bn 0)
(let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
(if (fx= bn 0)
(let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
(if (fx= bn 0)
(let* ([bytes (fxsub1 bytes)] [bn ($bignum-byte-ref x bytes)])
(if (fx= bn 0)
(error 'bignum/n->flonum "malformed bignum")
(aux x bn bytes)))
(aux x bn bytes)))
(aux x bn bytes)))
(aux x bn bytes))))
(unless (bignum? x)
(error 'bignum->flonum "~s is not a bignum" x))
(let ([bytes ($bignum-size x)])
(case bytes
[(4) (bignum/4->flonum x)]
[(8) (bignum/8->flonum x)]
[else (bignum/n->flonum x bytes)]))))
;(define (bignum->flonum x)
; (foreign-call "ikrt_bignum_to_flonum" x))
(define (ratnum->flonum x) (define (ratnum->flonum x)
(binary/ (exact->inexact ($ratnum-n x)) (binary/ (exact->inexact ($ratnum-n x))
(exact->inexact ($ratnum-d x)))) (exact->inexact ($ratnum-d x))))

2
src/pass-specify-rep-primops.ss
View File

@ -756,7 +756,7 @@
(unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7)) (unless (and (fixnum? i) (fx<= 0 i) (fx<= i 7))
(interrupt)) (interrupt))
(prm 'bset/h (T x) (prm 'bset/h (T x)
(K (+ (- 7 i) (- disp-bytevector-data bytevector-tag))) (K (+ (- 7 i) (- disp-flonum-data vector-tag)))
(prm 'sll (T v) (K (- 8 fx-shift))))] (prm 'sll (T v) (K (- 8 fx-shift))))]
[else (interrupt)])]) [else (interrupt)])])