Major work towards the AMD64 port. Most important of which is that
continuations work, more assembly instructions are testing in 64-bit mode, and some arithmetic operations (shift-right, etc.) have been fixed by removing some 32-bit dependencies.
This commit is contained in:
Abdulaziz Ghuloum
parent
0ef81aa13e
commit
01c4afa320
4
c64
4
c64
|
|
@ -2,8 +2,8 @@
|
|||
|
||||
cp configure.64.ac configure.ac && \
|
||||
autoconf && \
|
||||
./configure CFLAGS="-m64 -I/Users/ikarus/.opt64/include" \
|
||||
LDFLAGS="-m64 -L/Users/ikarus/.opt64/lib" \
|
||||
./configure CFLAGS="-m64 -g -I/Users/ikarus/.opt64/include" \
|
||||
LDFLAGS="-m64 -g -L/Users/ikarus/.opt64/lib" \
|
||||
&& make clean \
|
||||
&& make
|
||||
|
||||
|
|
|
|||
|
|
@ -44,5 +44,5 @@ CLEANFILES=$(nodist_pkglib_DATA) ikarus.config.ss
|
|||
MAINTAINERCLEANFILES=last-revision
|
||||
|
||||
ikarus.boot: $(EXTRA_DIST) ikarus.config.ss
|
||||
../src/ikarus -b ./ikarus.boot.prebuilt -O2 --r6rs-script makefile.ss
|
||||
../src/ikarus -b ./ikarus.boot.prebuilt --r6rs-script makefile.ss
|
||||
|
||||
|
|
|
|||
|
|
@ -379,7 +379,7 @@ ikarus.config.ss: Makefile last-revision ../config.h
|
|||
echo '(define wordsize $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g"))' >>$@
|
||||
|
||||
ikarus.boot: $(EXTRA_DIST) ikarus.config.ss
|
||||
../src/ikarus -b ./ikarus.boot.prebuilt -O2 --r6rs-script makefile.ss
|
||||
../src/ikarus -b ./ikarus.boot.prebuilt --r6rs-script makefile.ss
|
||||
# Tell versions [3.59,3.63) of GNU make to not export all variables.
|
||||
# Otherwise a system limit (for SysV at least) may be exceeded.
|
||||
.NOEXPORT:
|
||||
|
|
|
|||
|
|
@ -2369,12 +2369,13 @@
|
|||
[else (error who "invalid effect" (unparse x))]))
|
||||
(define (check-disp-arg x k)
|
||||
(cond
|
||||
[(mem? x)
|
||||
[(small-operand? x)
|
||||
(k x)]
|
||||
[else
|
||||
(let ([u (mku)])
|
||||
(make-seq
|
||||
(E (make-asm-instr 'move u x))
|
||||
(k u)))]
|
||||
[else (k x)]))
|
||||
(k u)))]))
|
||||
(define (check-disp x k)
|
||||
(struct-case x
|
||||
[(disp a b)
|
||||
|
|
@ -2564,7 +2565,7 @@
|
|||
[(constant i)
|
||||
(unless (fixnum? i)
|
||||
(error who "invalid R/cl" x))
|
||||
(fxlogand i 31)]
|
||||
(fxlogand i (- (* wordsize 8) 1))]
|
||||
[else
|
||||
(if (eq? x ecx)
|
||||
'%cl
|
||||
|
|
|
|||
|
|
@ -508,13 +508,19 @@
|
|||
[(4) (CODE c ac)]
|
||||
[else (REX.R 0 (CODE c ac))]))
|
||||
|
||||
(define (trace-ac ac1 ac2)
|
||||
(printf "~s\n"
|
||||
(let f ([ls ac2])
|
||||
(cond
|
||||
[(eq? ls ac1) '()]
|
||||
[else (cons (car ls) (f (cdr ls)))])))
|
||||
ac2)
|
||||
(define trace-ac
|
||||
(let ([cache '()])
|
||||
(lambda (ac1 what ac2)
|
||||
(when (assembler-output)
|
||||
(let ([diff
|
||||
(let f ([ls ac2])
|
||||
(cond
|
||||
[(eq? ls ac1) '()]
|
||||
[else (cons (car ls) (f (cdr ls)))]))])
|
||||
(unless (member diff cache)
|
||||
(set! cache (cons diff cache))
|
||||
(printf "~s => ~s\n" what diff))))
|
||||
ac2)))
|
||||
|
||||
(define (CR c r ac)
|
||||
(REX+r r (CODE+r c r ac)))
|
||||
|
|
@ -529,8 +535,8 @@
|
|||
(CODE c0 (CODE+r c1 r ac)))
|
||||
;(REX+r r (CODE c0 (CODE+r c1 r ac))))
|
||||
(define (CCCR* c0 c1 c2 r rm ac)
|
||||
(CODE c0 (CODE c1 (CODE c2 (RM r rm ac)))))
|
||||
;(REX+RM r rm (CODE c0 (CODE c1 (CODE c2 (RM r rm ac))))))
|
||||
;(CODE c0 (CODE c1 (CODE c2 (RM r rm ac)))))
|
||||
(REX+RM r rm (CODE c0 (CODE c1 (CODE c2 (RM r rm ac))))))
|
||||
|
||||
|
||||
(define (CCI32 c0 c1 i32 ac)
|
||||
|
|
@ -547,15 +553,16 @@
|
|||
|
||||
(add-instructions instr ac
|
||||
[(ret) (CODE #xC3 ac)]
|
||||
[(cltd) (CODE #x99 ac)]
|
||||
[(cltd) (C #x99 ac)]
|
||||
[(movl src dst)
|
||||
(trace-ac ac `(movl ,src ,dst)
|
||||
(cond
|
||||
[(and (imm? src) (reg? dst)) (CR #xB8 dst (IMM src ac))]
|
||||
[(and (imm? src) (mem? dst)) (CR* #xC7 '/0 dst (IMM32 src ac))]
|
||||
[(and (reg? src) (reg? dst)) (CR* #x89 src dst ac)]
|
||||
[(and (reg? src) (mem? dst)) (CR* #x89 src dst ac)]
|
||||
[(and (mem? src) (reg? dst)) (CR* #x8B dst src ac)]
|
||||
[else (die who "invalid" instr)])]
|
||||
[else (die who "invalid" instr)]))]
|
||||
[(mov32 src dst)
|
||||
;;; FIXME
|
||||
(cond
|
||||
|
|
@ -570,7 +577,7 @@
|
|||
[(and (mem? src) (reg? dst))
|
||||
(if (= wordsize 4)
|
||||
(CR* #x8B dst src ac)
|
||||
(CCR* #x0F #xB7 dst src ac))]
|
||||
(CR*-no-rex #x8B dst src ac))]
|
||||
[else (die who "invalid" instr)])]
|
||||
[(movb src dst)
|
||||
(cond
|
||||
|
|
@ -583,10 +590,12 @@
|
|||
[(and (imm8? src) (reg? dst)) (CR* #x83 '/0 dst (IMM8 src ac))]
|
||||
[(and (imm32? src) (eq? dst '%eax)) (C #x05 (IMM32 src ac))]
|
||||
[(and (imm32? src) (reg? dst)) (CR* #x81 '/0 dst (IMM32 src ac))]
|
||||
[(and (reg? src) (reg? dst)) (CR* #x01 src dst ac)]
|
||||
[(and (reg? src) (reg? dst))
|
||||
(trace-ac ac `(addl ,src ,dst) (CR* #x01 src dst ac))]
|
||||
[(and (mem? src) (reg? dst)) (CR* #x03 dst src ac)]
|
||||
[(and (imm32? src) (mem? dst)) (CR* #x81 '/0 dst (IMM32 src ac))]
|
||||
[(and (reg? src) (mem? dst)) (CR* #x01 src dst ac)]
|
||||
[(and (reg? src) (mem? dst))
|
||||
(trace-ac ac `(addl ,src ,dst) (CR* #x01 src dst ac))]
|
||||
[else (die who "invalid" instr)])]
|
||||
[(subl src dst)
|
||||
(cond
|
||||
|
|
@ -615,14 +624,16 @@
|
|||
[(and (eq? src '%cl) (mem? dst)) (CR* #xD3 '/5 dst ac)]
|
||||
[else (die who "invalid" instr)])]
|
||||
[(sarl src dst)
|
||||
(trace-ac ac `(sarl ,src ,dst)
|
||||
(cond
|
||||
[(and (equal? 1 src) (reg? dst)) (CR* #xD1 '/7 dst ac)]
|
||||
[(and (imm8? src) (reg? dst)) (CR* #xC1 '/7 dst (IMM8 src ac))]
|
||||
[(and (imm8? src) (mem? dst)) (CR* #xC1 '/7 dst (IMM8 src ac))]
|
||||
[(and (imm8? src) (mem? dst)) (CR* #xC1 '/7 dst (IMM8 src ac))]
|
||||
[(and (eq? src '%cl) (reg? dst)) (CR* #xD3 '/7 dst ac)]
|
||||
[(and (eq? src '%cl) (mem? dst)) (CR* #xD3 '/7 dst ac)]
|
||||
[else (die who "invalid" instr)])]
|
||||
[(and (eq? src '%cl) (mem? dst)) (CR* #xD3 '/7 dst ac)]
|
||||
[else (die who "invalid" instr)]))]
|
||||
[(andl src dst)
|
||||
(trace-ac ac `(andl ,src ,dst)
|
||||
(cond
|
||||
[(and (imm32? src) (mem? dst)) (CR* #x81 '/4 dst (IMM32 src ac))]
|
||||
[(and (imm8? src) (reg? dst)) (CR* #x83 '/4 dst (IMM8 src ac))]
|
||||
|
|
@ -631,7 +642,7 @@
|
|||
[(and (reg? src) (reg? dst)) (CR* #x21 src dst ac)]
|
||||
[(and (reg? src) (mem? dst)) (CR* #x21 src dst ac)]
|
||||
[(and (mem? src) (reg? dst)) (CR* #x23 dst src ac)]
|
||||
[else (die who "invalid" instr)])]
|
||||
[else (die who "invalid" instr)]))]
|
||||
[(orl src dst)
|
||||
(cond
|
||||
[(and (imm32? src) (mem? dst)) (CR* #x81 '/1 dst (IMM32 src ac))]
|
||||
|
|
@ -644,12 +655,12 @@
|
|||
[else (die who "invalid" instr)])]
|
||||
[(xorl src dst)
|
||||
(cond
|
||||
[(and (imm8? src) (reg? dst)) (CR* #x83 '/6 dst (IMM8 src ac))]
|
||||
[(and (imm8? src) (reg? dst)) (CR* #x83 '/6 dst (IMM8 src ac))]
|
||||
[(and (imm8? src) (mem? dst)) (CR* #x83 '/6 dst (IMM8 src ac))]
|
||||
[(and (imm32? src) (eq? dst '%eax)) (CODE #x35 (IMM32 src ac))]
|
||||
[(and (reg? src) (reg? dst)) (CR* #x31 src dst ac)]
|
||||
[(and (mem? src) (reg? dst)) (CR* #x33 dst src ac)]
|
||||
[(and (reg? src) (mem? dst)) (CR* #x31 src dst ac)]
|
||||
[(and (imm32? src) (eq? dst '%eax)) (CODE #x35 (IMM32 src ac))]
|
||||
[(and (reg? src) (reg? dst)) (CR* #x31 src dst ac)]
|
||||
[(and (mem? src) (reg? dst)) (CR* #x33 dst src ac)]
|
||||
[(and (reg? src) (mem? dst)) (CR* #x31 src dst ac)]
|
||||
[else (die who "invalid" instr)])]
|
||||
[(leal src dst)
|
||||
(cond
|
||||
|
|
@ -657,13 +668,13 @@
|
|||
[else (die who "invalid" instr)])]
|
||||
[(cmpl src dst)
|
||||
(cond
|
||||
[(and (imm8? src) (reg? dst)) (CR* #x83 '/7 dst (IMM8 src ac))]
|
||||
[(and (imm32? src) (eq? dst '%eax)) (CODE #x3D (IMM32 src ac))]
|
||||
[(and (imm8? src) (reg? dst)) (CR* #x83 '/7 dst (IMM8 src ac))]
|
||||
[(and (imm32? src) (eq? dst '%eax)) (CODE #x3D (IMM32 src ac))]
|
||||
[(and (imm32? src) (reg? dst)) (CR* #x81 '/7 dst (IMM32 src ac))]
|
||||
[(and (reg? src) (reg? dst)) (CR* #x39 src dst ac)]
|
||||
[(and (mem? src) (reg? dst)) (CR* #x3B dst src ac)]
|
||||
[(and (reg? src) (reg? dst)) (CR* #x39 src dst ac)]
|
||||
[(and (mem? src) (reg? dst)) (CR* #x3B dst src ac)]
|
||||
[(and (imm8? src) (mem? dst)) (CR* #x83 '/7 dst (IMM8 src ac))]
|
||||
[(and (imm32? src) (mem? dst)) (CR* #x81 '/7 dst (IMM32 src ac))]
|
||||
[(and (imm32? src) (mem? dst)) (CR* #x81 '/7 dst (IMM32 src ac))]
|
||||
[else (die who "invalid" instr)])]
|
||||
[(imull src dst)
|
||||
(cond
|
||||
|
|
@ -721,7 +732,7 @@
|
|||
[(cvtsi2sd src dst)
|
||||
(cond
|
||||
[(and (xmmreg? dst) (reg? src)) (CCCR* #xF2 #x0F #x2A src dst ac)]
|
||||
[(and (xmmreg? dst) (mem? src)) (CCCR* #xF2 #x0F #x2A dst src ac)]
|
||||
[(and (xmmreg? dst) (mem? src)) (CCCR* #xF2 #x0F #x2A dst src ac)]
|
||||
[else (die who "invalid" instr)])]
|
||||
[(cvtsd2ss src dst)
|
||||
(cond
|
||||
|
|
@ -834,10 +845,21 @@
|
|||
(lambda (code idx x)
|
||||
(cond
|
||||
[(fixnum? x)
|
||||
(code-set! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2))
|
||||
(code-set! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
|
||||
(code-set! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
|
||||
(code-set! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
|
||||
(case wordsize
|
||||
[(4)
|
||||
(code-set! code (fx+ idx 0) (fxsll (fxlogand x #x3F) 2))
|
||||
(code-set! code (fx+ idx 1) (fxlogand (fxsra x 6) #xFF))
|
||||
(code-set! code (fx+ idx 2) (fxlogand (fxsra x 14) #xFF))
|
||||
(code-set! code (fx+ idx 3) (fxlogand (fxsra x 22) #xFF))]
|
||||
[else
|
||||
(code-set! code (fx+ idx 0) (fxsll (fxlogand x #x1F) 3))
|
||||
(code-set! code (fx+ idx 1) (fxlogand (fxsra x 5) #xFF))
|
||||
(code-set! code (fx+ idx 2) (fxlogand (fxsra x 13) #xFF))
|
||||
(code-set! code (fx+ idx 3) (fxlogand (fxsra x 21) #xFF))
|
||||
(code-set! code (fx+ idx 4) (fxlogand (fxsra x 29) #xFF))
|
||||
(code-set! code (fx+ idx 5) (fxlogand (fxsra x 37) #xFF))
|
||||
(code-set! code (fx+ idx 6) (fxlogand (fxsra x 45) #xFF))
|
||||
(code-set! code (fx+ idx 7) (fxlogand (fxsra x 53) #xFF))])]
|
||||
[else (die 'set-code-word! "unhandled" x)])))
|
||||
|
||||
(define (optimize-local-jumps ls)
|
||||
|
|
|
|||
|
|
@ -2442,7 +2442,10 @@
|
|||
(lambda (x)
|
||||
(cond
|
||||
[(flonum? x) (foreign-call "ikrt_fl_sin" x)]
|
||||
[(fixnum? x) (foreign-call "ikrt_fx_sin" x)]
|
||||
[(fixnum? x)
|
||||
(if (fx=? x 0)
|
||||
0
|
||||
(foreign-call "ikrt_fx_sin" x))]
|
||||
[(number? x) (sin (inexact x))]
|
||||
[else (die 'sin "not a number" x)])))
|
||||
|
||||
|
|
@ -2450,7 +2453,10 @@
|
|||
(lambda (x)
|
||||
(cond
|
||||
[(flonum? x) (foreign-call "ikrt_fl_cos" x)]
|
||||
[(fixnum? x) (foreign-call "ikrt_fx_cos" x)]
|
||||
[(fixnum? x)
|
||||
(if (fx=? x 0)
|
||||
1
|
||||
(foreign-call "ikrt_fx_cos" x))]
|
||||
[(number? x) (cos (inexact x))]
|
||||
[else (die 'cos "not a number" x)])))
|
||||
|
||||
|
|
@ -2458,7 +2464,10 @@
|
|||
(lambda (x)
|
||||
(cond
|
||||
[(flonum? x) (foreign-call "ikrt_fl_tan" x)]
|
||||
[(fixnum? x) (foreign-call "ikrt_fx_tan" x)]
|
||||
[(fixnum? x)
|
||||
(if (fx=? x 0)
|
||||
0
|
||||
(foreign-call "ikrt_fx_tan" x))]
|
||||
[(number? x) (tan (inexact x))]
|
||||
[else (die 'tan "not a number" x)])))
|
||||
|
||||
|
|
|
|||
|
|
@ -433,10 +433,11 @@
|
|||
(cond
|
||||
[(fxzero? x) (write-char #\0 p)]
|
||||
[(fx< x 0)
|
||||
(write-char #\- p)
|
||||
(if (fx= x -536870912)
|
||||
(write-char* "536870912" p)
|
||||
(loop (fx- 0 x) p))]
|
||||
(write-char* (fixnum->string x) p)]
|
||||
;(write-char #\- p)
|
||||
;(if (fx= x -536870912)
|
||||
; (write-char* "536870912" p)
|
||||
; (loop (fx- 0 x) p))]
|
||||
[else (loop x p)])))
|
||||
|
||||
(define write-char*
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1540
|
||||
1541
|
||||
|
|
|
|||
|
|
@ -1433,7 +1433,6 @@
|
|||
[register-callback i]
|
||||
[input-socket-buffer-size i]
|
||||
[output-socket-buffer-size i]
|
||||
|
||||
[ellipsis-map ]
|
||||
[optimize-cp i]
|
||||
[optimize-level i]
|
||||
|
|
|
|||
|
|
@ -51,7 +51,7 @@
|
|||
(define (smart-dirty-vector-set addr what)
|
||||
(struct-case what
|
||||
[(constant t)
|
||||
(if (or (fixnum? t) (immediate? t))
|
||||
(if (or (fx? t) (immediate? t))
|
||||
(prm 'nop)
|
||||
(dirty-vector-set addr))]
|
||||
[(known x t)
|
||||
|
|
@ -71,7 +71,7 @@
|
|||
(define (mem-assign v x i)
|
||||
(struct-case v
|
||||
[(constant t)
|
||||
(if (or (fixnum? t) (immediate? t))
|
||||
(if (or (fx? t) (immediate? t))
|
||||
(prm 'mset x (K i) (T v))
|
||||
(slow-mem-assign v x i))]
|
||||
[(known expr t)
|
||||
|
|
@ -239,7 +239,7 @@
|
|||
[else (interrupt)])])
|
||||
|
||||
(define (equable? x)
|
||||
(or (fixnum? x) (not (number? x))))
|
||||
(or (fx? x) (not (number? x))))
|
||||
|
||||
(define-primop memv safe
|
||||
[(V x ls)
|
||||
|
|
@ -453,7 +453,7 @@
|
|||
(interrupt-unless-fixnum t)))))
|
||||
(struct-case idx
|
||||
[(constant i)
|
||||
(if (and (fixnum? i) (fx>= i 0))
|
||||
(if (and (fx? i) (>= i 0))
|
||||
(check-fx idx)
|
||||
(check-? idx))]
|
||||
[(known idx idx-t)
|
||||
|
|
@ -475,7 +475,7 @@
|
|||
(interrupt-unless (prm 'u< (T idx) len)))))
|
||||
(struct-case idx
|
||||
[(constant i)
|
||||
(if (and (fixnum? i) (fx>= i 0))
|
||||
(if (and (fx? i) (>= i 0))
|
||||
(check-fx idx)
|
||||
(check-? idx))]
|
||||
[(known idx idx-t)
|
||||
|
|
@ -501,7 +501,7 @@
|
|||
[(V len)
|
||||
(struct-case len
|
||||
[(constant i)
|
||||
(if (fixnum? i)
|
||||
(if (and (fx? i) #f)
|
||||
(interrupt)
|
||||
(with-tmp ([v (prm 'alloc
|
||||
(K (align (+ (* i wordsize) disp-vector-data)))
|
||||
|
|
@ -531,7 +531,7 @@
|
|||
(or
|
||||
(struct-case i
|
||||
[(constant i)
|
||||
(and (fixnum? i)
|
||||
(and (fx? i)
|
||||
(fx>= i 0)
|
||||
(prm 'mref (T x)
|
||||
(K (+ (* i wordsize) (- disp-vector-data vector-tag)))))]
|
||||
|
|
@ -589,7 +589,7 @@
|
|||
[(E x i v)
|
||||
(struct-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(unless (fx? i) (interrupt))
|
||||
(mem-assign v (T x)
|
||||
(+ (* i wordsize)
|
||||
(- disp-vector-data vector-tag)))]
|
||||
|
|
@ -637,7 +637,7 @@
|
|||
[(V x i)
|
||||
(struct-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(unless (fx? i) (interrupt))
|
||||
(prm 'mref (T x)
|
||||
(K (+ (- disp-closure-data closure-tag)
|
||||
(* i wordsize))))]
|
||||
|
|
@ -863,7 +863,7 @@
|
|||
[(V x i)
|
||||
(struct-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(unless (fx? i) (interrupt))
|
||||
(prm 'sll (T x) (K i))]
|
||||
[(known i t) (cogen-value-$fxsll x i)]
|
||||
[else
|
||||
|
|
@ -875,17 +875,20 @@
|
|||
[(V x i)
|
||||
(struct-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(unless (fx? i) (interrupt))
|
||||
(prm 'logand
|
||||
(prm 'sra (T x) (K (if (> i 31) 31 i)))
|
||||
(prm 'sra (T x)
|
||||
(K (if (< i (* wordsize 8))
|
||||
i
|
||||
(- (* wordsize 8) 1))))
|
||||
(K (* -1 fx-scale)))]
|
||||
[(known i t) (cogen-value-$fxsra x i)]
|
||||
[else
|
||||
(with-tmp ([i (prm 'sra (T i) (K fx-shift))])
|
||||
(with-tmp ([i (make-conditional
|
||||
(prm '< i (K 32))
|
||||
(prm '< i (K (* 8 wordsize)))
|
||||
i
|
||||
(K 31))])
|
||||
(K (- (* 8 wordsize) 1)))])
|
||||
(prm 'logand
|
||||
(prm 'sra (T x) i)
|
||||
(K (* -1 fx-scale)))))])]
|
||||
|
|
@ -1296,7 +1299,7 @@
|
|||
[else (or* (prm 'logor a (T (car a*))) (cdr a*))]))
|
||||
(define (known-fixnum? x)
|
||||
(struct-case x
|
||||
[(constant i) (fixnum? i)]
|
||||
[(constant i) (fx? i)]
|
||||
[(known x t)
|
||||
(case (T:fixnum? t)
|
||||
[(yes) (record-optimization 'assert-fixnum x) #t]
|
||||
|
|
@ -1304,7 +1307,7 @@
|
|||
[else #f]))
|
||||
(define (known-non-fixnum? x)
|
||||
(struct-case x
|
||||
[(constant i) (not (fixnum? i))]
|
||||
[(constant i) (not (fx? i))]
|
||||
[(known x t) (eq? (T:fixnum? t) 'no)]
|
||||
[else #f]))
|
||||
(let-values ([(fx* others) (partition known-fixnum? (cons a a*))])
|
||||
|
|
@ -1872,7 +1875,7 @@
|
|||
[(V s i)
|
||||
(struct-case i
|
||||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(unless (fx? i) (interrupt))
|
||||
(prm 'sra
|
||||
(prm 'sll
|
||||
(prm 'logand
|
||||
|
|
|
|||
|
|
@ -0,0 +1,85 @@
|
|||
#!../src/ikarus -b ikarus.boot --r6rs-script
|
||||
|
||||
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
||||
;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum
|
||||
;;;
|
||||
;;; This program is free software: you can redistribute it and/or modify
|
||||
;;; it under the terms of the GNU General Public License version 3 as
|
||||
;;; published by the Free Software Foundation.
|
||||
;;;
|
||||
;;; This program is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;; General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
|
||||
(import (ikarus)
|
||||
(tests bitwise-op)
|
||||
(tests reader)
|
||||
(tests lists)
|
||||
(tests bytevectors)
|
||||
(tests strings)
|
||||
(tests hashtables)
|
||||
(tests numerics)
|
||||
;(tests numbers)
|
||||
(tests bignums)
|
||||
(tests fixnums)
|
||||
(tests div-and-mod)
|
||||
(tests fxcarry)
|
||||
(tests bignum-to-flonum)
|
||||
(tests string-to-number)
|
||||
(tests input-ports)
|
||||
(tests fldiv-and-mod)
|
||||
(tests parse-flonums)
|
||||
(tests io)
|
||||
(tests case-folding)
|
||||
(tests sorting)
|
||||
(tests fasl)
|
||||
)
|
||||
|
||||
(define (test-exact-integer-sqrt)
|
||||
(define (f i j inc)
|
||||
(when (< i j)
|
||||
(let-values ([(s r) (exact-integer-sqrt i)])
|
||||
(unless (and (= (+ (* s s) r) i)
|
||||
(< i (* (+ s 1) (+ s 1))))
|
||||
(error 'exact-integer-sqrt "wrong result" i))
|
||||
(f (+ i inc) j inc))))
|
||||
(f 0 10000 1)
|
||||
(f 0 536870911 10000)
|
||||
(f 0 536870911000 536870911)
|
||||
(printf "[exact-integer-sqrt] Happy Happy Joy Joy\n"))
|
||||
|
||||
;(test-bitwise-op)
|
||||
;(test-parse-flonums)
|
||||
;(test-case-folding)
|
||||
;(test-reader)
|
||||
;(test-char-syntax)
|
||||
;(test-bytevectors)
|
||||
;(test-strings)
|
||||
;(test-exact-integer-sqrt)
|
||||
;(test-bignum-to-flonum)
|
||||
;(test-bignum->flonum)
|
||||
;(test-string-to-number)
|
||||
;(test-div-and-mod)
|
||||
;(test-bignums)
|
||||
;(test-bignum-length)
|
||||
;(test-fxcarry)
|
||||
;(test-lists)
|
||||
;(test-hashtables)
|
||||
;(test-input-ports)
|
||||
;(test-bignum-conversion)
|
||||
;(test-fldiv-and-mod)
|
||||
;(test-fldiv0-and-mod0)
|
||||
;(test-fxdiv-and-mod)
|
||||
;(test-fxdiv0-and-mod0)
|
||||
;(test-fxlength)
|
||||
(test-bitwise-bit-count)
|
||||
;(test-io)
|
||||
;(test-sorting)
|
||||
;(test-fasl)
|
||||
;(test-numerics)
|
||||
(printf "Happy Happy Joy Joy\n")
|
||||
|
|
@ -18,11 +18,16 @@
|
|||
(import
|
||||
(ikarus.compiler)
|
||||
(match)
|
||||
(except (ikarus) scc-letrec optimize-cp optimize-level assembler-output))
|
||||
(except (ikarus) perform-tag-analysis tag-analysis-output
|
||||
cp0-effort-limit cp0-size-limit expand/optimize
|
||||
optimizer-output
|
||||
optimize-cp optimize-level assembler-output))
|
||||
|
||||
|
||||
(define (compile1 x)
|
||||
(let ([p (open-file-output-port "test64.fasl" (file-options no-fail))])
|
||||
(parameterize ([assembler-output #t])
|
||||
(parameterize ([optimize-level 0]
|
||||
[assembler-output #t])
|
||||
(compile-core-expr-to-port x p))
|
||||
(close-output-port p)))
|
||||
|
||||
|
|
|
|||
|
|
@ -114,8 +114,8 @@ next_gen_tag[generation_count] = {
|
|||
};
|
||||
|
||||
static ikptr
|
||||
meta_alloc_extending(int size, gc_t* gc, int meta_id){
|
||||
int mapsize = align_to_next_page(size);
|
||||
meta_alloc_extending(long int size, gc_t* gc, int meta_id){
|
||||
long int mapsize = align_to_next_page(size);
|
||||
if(mapsize < extension_amount[meta_id]){
|
||||
mapsize = extension_amount[meta_id];
|
||||
}
|
||||
|
|
@ -151,7 +151,7 @@ meta_alloc_extending(int size, gc_t* gc, int meta_id){
|
|||
|
||||
|
||||
static inline ikptr
|
||||
meta_alloc(int size, gc_t* gc, int meta_id){
|
||||
meta_alloc(long int size, gc_t* gc, int meta_id){
|
||||
assert(size == align(size));
|
||||
meta_t* meta = &gc->meta[meta_id];
|
||||
ikptr ap = meta->ap;
|
||||
|
|
@ -252,12 +252,12 @@ gc_alloc_new_data(int size, gc_t* gc){
|
|||
}
|
||||
|
||||
static inline ikptr
|
||||
gc_alloc_new_code(int size, gc_t* gc){
|
||||
gc_alloc_new_code(long int size, gc_t* gc){
|
||||
assert(size == align(size));
|
||||
if(size < pagesize){
|
||||
return meta_alloc(size, gc, meta_code);
|
||||
} else {
|
||||
int memreq = align_to_next_page(size);
|
||||
long int memreq = align_to_next_page(size);
|
||||
ikptr mem = ik_mmap_code(memreq, gc->collect_gen, gc->pcb);
|
||||
gc->segment_vector = gc->pcb->segment_vector;
|
||||
qupages_t* p = ik_malloc(sizeof(qupages_t));
|
||||
|
|
@ -374,7 +374,6 @@ extern void verify_integrity(ikpcb* pcb, char*);
|
|||
|
||||
ikpcb*
|
||||
ik_collect(unsigned long int mem_req, ikpcb* pcb){
|
||||
// fprintf(stderr, "ik_collect\n");
|
||||
#ifndef NDEBUG
|
||||
verify_integrity(pcb, "entry");
|
||||
#endif
|
||||
|
|
@ -483,8 +482,6 @@ ik_collect(unsigned long int mem_req, ikpcb* pcb){
|
|||
#endif
|
||||
|
||||
|
||||
|
||||
|
||||
/* delete all old heap pages */
|
||||
if(old_heap_pages){
|
||||
ikpages* p = old_heap_pages;
|
||||
|
|
@ -755,22 +752,22 @@ add_code_entry(gc_t* gc, ikptr entry){
|
|||
if(ref(x,0) == forward_ptr){
|
||||
return ref(x,wordsize) + off_code_data;
|
||||
}
|
||||
int idx = page_index(x);
|
||||
long int idx = page_index(x);
|
||||
unsigned int t = gc->segment_vector[idx];
|
||||
int gen = t & gen_mask;
|
||||
if(gen > gc->collect_gen){
|
||||
return entry;
|
||||
}
|
||||
int code_size = unfix(ref(x, disp_code_code_size));
|
||||
long int code_size = unfix(ref(x, disp_code_code_size));
|
||||
ikptr reloc_vec = ref(x, disp_code_reloc_vector);
|
||||
ikptr freevars = ref(x, disp_code_freevars);
|
||||
ikptr annotation = ref(x, disp_code_annotation);
|
||||
int required_mem = align(disp_code_data + code_size);
|
||||
long int required_mem = align(disp_code_data + code_size);
|
||||
if(required_mem >= pagesize){
|
||||
int new_tag = gc->collect_gen_tag;
|
||||
int idx = page_index(x);
|
||||
long int idx = page_index(x);
|
||||
gc->segment_vector[idx] = new_tag | code_mt;
|
||||
int i;
|
||||
long int i;
|
||||
for(i=pagesize, idx++; i<required_mem; i+=pagesize, idx++){
|
||||
gc->segment_vector[idx] = new_tag | data_mt;
|
||||
}
|
||||
|
|
@ -811,10 +808,10 @@ static void collect_stack(gc_t* gc, ikptr top, ikptr end){
|
|||
ikptr rp = ref(top, 0);
|
||||
long int rp_offset = unfix(ref(rp, disp_frame_offset));
|
||||
if(DEBUG_STACK){
|
||||
fprintf(stderr, "rp_offset=%ld\n", (long)rp_offset);
|
||||
fprintf(stderr, "rp_offset=%ld\n", rp_offset);
|
||||
}
|
||||
if(rp_offset <= 0){
|
||||
fprintf(stderr, "invalid rp_offset %ld\n", (long)rp_offset);
|
||||
fprintf(stderr, "invalid rp_offset %ld\n", rp_offset);
|
||||
exit(-1);
|
||||
}
|
||||
/* since the return point is alive, we need to find the code
|
||||
|
|
@ -891,7 +888,7 @@ static void collect_stack(gc_t* gc, ikptr top, ikptr end){
|
|||
for(i=0; i<bytes_in_mask; i++, fp-=8){
|
||||
unsigned char m = mask[i];
|
||||
#if DEBUG_STACK
|
||||
fprintf(stderr, "m[%d]=0x%x\n", i, m);
|
||||
fprintf(stderr, "m[%ld]=0x%x\n", i, m);
|
||||
#endif
|
||||
if(m & 0x01) { fp[-0] = add_object(gc, fp[-0], "frame0"); }
|
||||
if(m & 0x02) { fp[-1] = add_object(gc, fp[-1], "frame1"); }
|
||||
|
|
@ -1334,9 +1331,9 @@ relocate_new_code(ikptr x, gc_t* gc){
|
|||
#endif
|
||||
obj = add_object(gc, obj, "reloc3");
|
||||
ikptr displaced_object = obj + obj_off;
|
||||
ikptr next_word = code + code_off + wordsize;
|
||||
long int next_word = code + code_off + 4;
|
||||
ikptr relative_distance = displaced_object - (long int)next_word;
|
||||
ref(next_word, -wordsize) = relative_distance;
|
||||
*((int*)(code+code_off)) = relative_distance;
|
||||
p += (3*wordsize);
|
||||
}
|
||||
else if(tag == 1){
|
||||
|
|
|
|||
|
|
@ -206,7 +206,7 @@ ikptr ik_unsafe_alloc(ikpcb* pcb, int size);
|
|||
ikptr ik_safe_alloc(ikpcb* pcb, int size);
|
||||
|
||||
#define IK_HEAP_EXT_SIZE (32 * 4096)
|
||||
#define IK_HEAPSIZE (1024 * ((wordsize==4)?1:2) * 4096) /* 4/8 MB */
|
||||
#define IK_HEAPSIZE (1024 * ((wordsize==4)?1:16) * 4096) /* 4/8 MB */
|
||||
|
||||
#define wordsize ((int)(sizeof(ikptr)))
|
||||
#define wordshift ((wordsize == 4)?2:3)
|
||||
|
|
|
|||
|
|
@ -67,10 +67,8 @@ _ik_asm_enter:
|
|||
.byte 0
|
||||
.byte 0
|
||||
L_multivalue_label: # FIXME
|
||||
.long 0 # 2 longs
|
||||
.long 0 # for return address
|
||||
.byte 0
|
||||
.byte 0
|
||||
.quad L_multivalue_underflow
|
||||
.quad 0
|
||||
L_call:
|
||||
call *%rax # goooooooo
|
||||
# now we're back
|
||||
|
|
@ -91,6 +89,7 @@ L_do_underflow:
|
|||
mov -40(%rsp), %r14 # restore
|
||||
mov -48(%rsp), %r15 # restore
|
||||
ret # back to C, which handled the underflow
|
||||
multivalue_underflow:
|
||||
L_multivalue_underflow:
|
||||
add $8, %rsp
|
||||
jmp L_do_underflow
|
||||
|
|
@ -109,10 +108,21 @@ _ik_asm_reenter:
|
|||
# scheme stack is second arg 8(%esp) %rsi
|
||||
# pcb is the first arg 4(%esp) %rdi
|
||||
# return point is at 0(%esp)
|
||||
|
||||
mov %rbp, -8(%rsp) # preserve
|
||||
mov %rbx, -16(%rsp) # preserve
|
||||
mov %r12, -24(%rsp) # preserve
|
||||
mov %r13, -32(%rsp) # preserve
|
||||
mov %r14, -40(%rsp) # preserve
|
||||
mov %r15, -48(%rsp) # preserve
|
||||
|
||||
movq %rdx, %rax # third arg -> argc
|
||||
movq %rsi, %rbx # second arg -> rbx (scheme stack)
|
||||
movq %rdi, %rsi # first arg -> pcb
|
||||
movq 0(%rsi), %rbp # allocation pointer is at 0(pcb)
|
||||
|
||||
|
||||
subq $64, %rsp # for alignment
|
||||
movq %rsp, 48(%rsi) # save esp in pcb->system_stack
|
||||
movq %rbx, %rsp # load scheme stack from rbx
|
||||
cmpq $-8, %rax
|
||||
|
|
@ -120,10 +130,8 @@ _ik_asm_reenter:
|
|||
movq -8(%rsp), %rax
|
||||
ret
|
||||
L_multi_reentry:
|
||||
movq $0, %rax
|
||||
movq %rax, 0(%rax)
|
||||
movq 0(%rsp), %rbx
|
||||
jmp *-9(%rbx)
|
||||
jmp *-18(%rbx)
|
||||
|
||||
|
||||
.align 8
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@
|
|||
typedef struct {
|
||||
ikptr tag;
|
||||
ikptr top;
|
||||
int size;
|
||||
long int size;
|
||||
ikptr next;
|
||||
} cont;
|
||||
|
||||
|
|
|
|||
|
|
@ -29,8 +29,11 @@
|
|||
(((unsigned long int)(x)) & bignum_sign_mask)
|
||||
|
||||
|
||||
#define most_positive_fixnum 0x1FFFFFFF
|
||||
#define most_negative_fixnum 0x20000000
|
||||
#define most_positive_fixnum \
|
||||
(((unsigned long int)-1) >> (fx_shift+1))
|
||||
#define most_negative_fixnum (most_positive_fixnum+1)
|
||||
// #define most_positive_fixnum 0x1FFFFFFF
|
||||
// #define most_negative_fixnum 0x20000000
|
||||
|
||||
#define max_digits_per_limb 10
|
||||
|
||||
|
|
@ -1062,9 +1065,9 @@ copy_limbs(mp_limb_t* src, mp_limb_t* dst, int n1, int n2){
|
|||
}
|
||||
|
||||
static void
|
||||
bits_compliment(mp_limb_t* src, mp_limb_t* dst, int n){
|
||||
bits_compliment(mp_limb_t* src, mp_limb_t* dst, long int n){
|
||||
mp_limb_t carry = 1;
|
||||
int i;
|
||||
long int i;
|
||||
for(i=0; i<n; i++){
|
||||
mp_limb_t d = src[i];
|
||||
mp_limb_t c = carry + ~ d;
|
||||
|
|
@ -1107,8 +1110,8 @@ bits_compliment_carry(mp_limb_t* src, mp_limb_t* dst, int n1, int n2, mp_limb_t
|
|||
|
||||
|
||||
static void
|
||||
bits_compliment_with_carry(mp_limb_t* src, mp_limb_t* dst, int n, int carry){
|
||||
int i;
|
||||
bits_compliment_with_carry(mp_limb_t* src, mp_limb_t* dst, long int n, long int carry){
|
||||
long int i;
|
||||
for(i=0; i<n; i++){
|
||||
mp_limb_t d = src[i];
|
||||
mp_limb_t c = carry + ~ d;
|
||||
|
|
@ -1145,8 +1148,8 @@ bits_compliment_logor(mp_limb_t* s1, mp_limb_t* s2, mp_limb_t* dst, int n){
|
|||
}
|
||||
|
||||
|
||||
static int
|
||||
bits_carry(mp_limb_t* s, int n){
|
||||
static long int
|
||||
bits_carry(mp_limb_t* s, int n){
|
||||
/*
|
||||
int carry = 1;
|
||||
int i;
|
||||
|
|
@ -1482,20 +1485,20 @@ copy_bits_shifting_right(mp_limb_t* src, mp_limb_t* dst, int n, int m){
|
|||
int i;
|
||||
for(i=1; i<n; i++){
|
||||
mp_limb_t b = src[i];
|
||||
dst[i-1] = (b << (32-m)) | carry;
|
||||
dst[i-1] = (b << (mp_bits_per_limb-m)) | carry;
|
||||
carry = b >> m;
|
||||
}
|
||||
dst[n-1] = carry;
|
||||
}
|
||||
|
||||
static void
|
||||
copy_bits_shifting_left(unsigned int* src, unsigned int* dst, int n, int m){
|
||||
unsigned int carry = 0;
|
||||
int i;
|
||||
copy_bits_shifting_left(unsigned long int* src, unsigned long int* dst, int n, int m){
|
||||
unsigned long int carry = 0;
|
||||
long int i;
|
||||
for(i=0; i<n; i++){
|
||||
unsigned int b = src[i];
|
||||
unsigned long int b = src[i];
|
||||
dst[i] = (b << m) | carry;
|
||||
carry = b >> (32-m);
|
||||
carry = b >> (mp_bits_per_limb-m);
|
||||
}
|
||||
dst[n] = carry;
|
||||
}
|
||||
|
|
@ -1506,11 +1509,12 @@ copy_bits_shifting_left(unsigned int* src, unsigned int* dst, int n, int m){
|
|||
|
||||
ikptr
|
||||
ikrt_bignum_shift_right(ikptr x, ikptr y, ikpcb* pcb){
|
||||
int limb_shift = (wordsize == 4 ? 5 : 6);
|
||||
long int m = unfix(y);
|
||||
ikptr fst = ref(x, -vector_tag);
|
||||
long int n = bnfst_limb_count(fst);
|
||||
long int whole_limb_shift = m >> 5; /* FIXME: 5 are the bits in 32-bit num */
|
||||
int bit_shift = m & 31;
|
||||
long int whole_limb_shift = m >> limb_shift;
|
||||
long int bit_shift = m & (mp_bits_per_limb-1);
|
||||
long int new_limb_count = n - whole_limb_shift;
|
||||
if(bnfst_negative(fst)){
|
||||
if(new_limb_count <= 0){
|
||||
|
|
@ -1545,7 +1549,7 @@ ikrt_bignum_shift_right(ikptr x, ikptr y, ikpcb* pcb){
|
|||
new_limb_count,
|
||||
bit_shift);
|
||||
*((mp_limb_t*)(r+disp_bignum_data+(new_limb_count-1)*wordsize))
|
||||
|= (-1 << (32 - bit_shift));
|
||||
|= (-1L << (mp_bits_per_limb - bit_shift));
|
||||
bits_compliment(
|
||||
(mp_limb_t*)(long)(r+disp_bignum_data),
|
||||
(mp_limb_t*)(long)(r+disp_bignum_data),
|
||||
|
|
@ -1580,21 +1584,22 @@ ikrt_bignum_shift_right(ikptr x, ikptr y, ikpcb* pcb){
|
|||
|
||||
ikptr
|
||||
ikrt_fixnum_shift_left(ikptr x, ikptr y, ikpcb* pcb){
|
||||
int m = unfix(y);
|
||||
int n = unfix(x);
|
||||
int limb_count = (m >> 5) + 2; /* FIXME: 5 are the bits in 32-bit num */
|
||||
int bit_shift = m & 31;
|
||||
int limb_shift = (wordsize == 4 ? 5 : 6);
|
||||
long int m = unfix(y);
|
||||
long int n = unfix(x);
|
||||
long int limb_count = (m >> limb_shift) + 2;
|
||||
long int bit_shift = m & (mp_bits_per_limb-1);
|
||||
ikptr r = ik_safe_alloc(pcb, align(disp_bignum_data + limb_count * wordsize));
|
||||
unsigned int* s = (unsigned int*)(long)(r+disp_bignum_data);
|
||||
unsigned long int* s = (unsigned long int*)(long)(r+disp_bignum_data);
|
||||
bzero(s, limb_count * wordsize);
|
||||
if(n >= 0){
|
||||
if(bit_shift){
|
||||
s[limb_count-1] = n >> (32 - bit_shift);
|
||||
s[limb_count-1] = n >> (mp_bits_per_limb - bit_shift);
|
||||
}
|
||||
s[limb_count-2] = n << bit_shift;
|
||||
} else {
|
||||
if(bit_shift){
|
||||
s[limb_count-1] = (-n) >> (32 - bit_shift);
|
||||
s[limb_count-1] = (-n) >> (mp_bits_per_limb - bit_shift);
|
||||
}
|
||||
s[limb_count-2] = (-n) << bit_shift;
|
||||
}
|
||||
|
|
@ -1604,11 +1609,12 @@ ikrt_fixnum_shift_left(ikptr x, ikptr y, ikpcb* pcb){
|
|||
|
||||
ikptr
|
||||
ikrt_bignum_shift_left(ikptr x, ikptr y, ikpcb* pcb){
|
||||
int limb_shift = (wordsize == 4 ? 5 : 6);
|
||||
long int m = unfix(y);
|
||||
ikptr fst = ref(x, -vector_tag);
|
||||
long int n = bnfst_limb_count(fst);
|
||||
long int whole_limb_shift = m >> 5; /* FIXME: 5 are the bits in 32-bit num */
|
||||
long int bit_shift = m & 31;
|
||||
long int whole_limb_shift = m >> limb_shift;
|
||||
long int bit_shift = m & (mp_bits_per_limb-1);
|
||||
if(bit_shift == 0){
|
||||
long int limb_count = n + whole_limb_shift;
|
||||
pcb->root0 = &x;
|
||||
|
|
@ -1627,8 +1633,8 @@ ikrt_bignum_shift_left(ikptr x, ikptr y, ikpcb* pcb){
|
|||
unsigned int* s = (unsigned int*)(long)(r+disp_bignum_data);
|
||||
bzero(s, whole_limb_shift*wordsize);
|
||||
copy_bits_shifting_left(
|
||||
(unsigned int*)(long)(x+off_bignum_data),
|
||||
s+whole_limb_shift,
|
||||
(unsigned long int*)(long)(x+off_bignum_data),
|
||||
(unsigned long int*)(long)(s+whole_limb_shift),
|
||||
n,
|
||||
bit_shift);
|
||||
return normalize_bignum(limb_count, bnfst_negative(fst), r);
|
||||
|
|
@ -1743,7 +1749,7 @@ usages, qxn will be zero.
|
|||
|
||||
ikptr
|
||||
ikrt_bnfxdivrem(ikptr x, ikptr y, ikpcb* pcb){
|
||||
int yint = unfix(y);
|
||||
long int yint = unfix(y);
|
||||
ikptr fst = ref(x, -vector_tag);
|
||||
mp_size_t s2n = bnfst_limb_count(fst);
|
||||
pcb->root0 = &x;
|
||||
|
|
@ -1755,7 +1761,7 @@ ikrt_bnfxdivrem(ikptr x, ikptr y, ikpcb* pcb){
|
|||
0,
|
||||
s2p,
|
||||
s2n,
|
||||
abs(yint));
|
||||
labs(yint));
|
||||
|
||||
ikptr rem;
|
||||
|
||||
|
|
@ -1951,11 +1957,73 @@ all_zeros(mp_limb_t* start, mp_limb_t* end){
|
|||
}
|
||||
|
||||
#define PRECISION 53
|
||||
|
||||
static ikptr
|
||||
ikrt_bignum_to_flonum64(ikptr bn, ikptr more_bits, ikptr fl){
|
||||
ikptr fst = ref(bn, -vector_tag);
|
||||
long int limb_count = bnfst_limb_count(fst);
|
||||
mp_limb_t* sp = (mp_limb_t*)(long)(bn+off_bignum_data);
|
||||
double pos_result;
|
||||
if(limb_count == 1){
|
||||
pos_result = sp[0];
|
||||
} else if (limb_count == 2){
|
||||
mp_limb_t lo = sp[0];
|
||||
mp_limb_t hi = sp[1];
|
||||
pos_result = hi;
|
||||
pos_result = pos_result * 4294967296.0;
|
||||
pos_result = pos_result + lo;
|
||||
} else {
|
||||
mp_limb_t hi = sp[limb_count-1];
|
||||
mp_limb_t mi = sp[limb_count-2];
|
||||
int bc = limb_size(hi);
|
||||
if(bc < 32){
|
||||
mp_limb_t lo = sp[limb_count-3];
|
||||
hi = (hi << (32-bc)) | (mi >> bc);
|
||||
mi = (mi << (32-bc)) | (lo >> bc);
|
||||
}
|
||||
/* now hi has 32 full bits, and mi has 32 full bits */
|
||||
mp_limb_t mask = ((1<<(64-PRECISION)) - 1);
|
||||
if((mi & mask) == ((mask+1)>>1)){
|
||||
/* exactly at break point */
|
||||
if(((sp[limb_count-3] << (32-bc)) == 0) &&
|
||||
all_zeros(sp, sp+limb_count-4) &&
|
||||
(more_bits == 0)){
|
||||
if(mi & (1<<(64-PRECISION))){
|
||||
/* odd number, round to even */
|
||||
mi = mi | mask;
|
||||
}
|
||||
} else {
|
||||
/* round up */
|
||||
mi = mi | mask;
|
||||
}
|
||||
} else if ((mi & mask) > ((mask+1)>>1)){
|
||||
/* also round up */
|
||||
mi = mi | mask;
|
||||
} else {
|
||||
/* keep it to round down */
|
||||
}
|
||||
pos_result = hi;
|
||||
pos_result = pos_result * 4294967296.0;
|
||||
pos_result = pos_result + mi;
|
||||
int bignum_bits = bc + (mp_bits_per_limb * (limb_count-1));
|
||||
int exponent = bignum_bits - (2 * mp_bits_per_limb);
|
||||
while(exponent){
|
||||
pos_result *= 2.0;
|
||||
exponent -= 1;
|
||||
}
|
||||
}
|
||||
if(bnfst_negative(fst)){
|
||||
flonum_data(fl) = - pos_result;
|
||||
} else {
|
||||
flonum_data(fl) = pos_result;
|
||||
}
|
||||
return fl;
|
||||
}
|
||||
|
||||
ikptr
|
||||
ikrt_bignum_to_flonum(ikptr bn, ikptr more_bits, ikptr fl){
|
||||
if(mp_bits_per_limb != 32){
|
||||
fprintf(stderr, "ikarus BUG: bignum_to_flonum only works in 32bit now\n");
|
||||
exit(-1);
|
||||
if(mp_bits_per_limb == 64){
|
||||
return ikrt_bignum_to_flonum64(bn, more_bits, fl);
|
||||
}
|
||||
ikptr fst = ref(bn, -vector_tag);
|
||||
long int limb_count = bnfst_limb_count(fst);
|
||||
|
|
|
|||
|
|
@ -239,8 +239,8 @@ ik_mmap(int size){
|
|||
#endif
|
||||
memset(mem, -1, mapsize);
|
||||
#ifndef NDEBUG
|
||||
fprintf(stderr, "MMAP 0x%08x .. 0x%08x\n", (int)mem,
|
||||
((int)(mem))+mapsize-1);
|
||||
fprintf(stderr, "MMAP 0x%016lx .. 0x%016lx\n", (long int)mem,
|
||||
((long int)(mem))+mapsize-1);
|
||||
#endif
|
||||
return (ikptr)(long)mem;
|
||||
}
|
||||
|
|
@ -492,7 +492,7 @@ void ik_error(ikptr args){
|
|||
|
||||
void ik_stack_overflow(ikpcb* pcb){
|
||||
#ifndef NDEBUG
|
||||
fprintf(stderr, "entered ik_stack_overflow pcb=0x%08x\n", (int)pcb);
|
||||
fprintf(stderr, "entered ik_stack_overflow pcb=0x%016lx\n", (long int)pcb);
|
||||
#endif
|
||||
set_segment_type(pcb->stack_base, pcb->stack_size, data_mt, pcb);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue