diff --git a/c64 b/c64
index f0b3826..6680cfb 100755
--- a/c64
+++ b/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
diff --git a/scheme/Makefile.am b/scheme/Makefile.am
index 2f13c65..69abf61 100644
--- a/scheme/Makefile.am
+++ b/scheme/Makefile.am
@@ -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
diff --git a/scheme/Makefile.in b/scheme/Makefile.in
index 32bdea9..cf26200 100644
--- a/scheme/Makefile.in
+++ b/scheme/Makefile.in
@@ -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:
diff --git a/scheme/ikarus.compiler.altcogen.ss b/scheme/ikarus.compiler.altcogen.ss
index d531a83..4a7afd5 100644
--- a/scheme/ikarus.compiler.altcogen.ss
+++ b/scheme/ikarus.compiler.altcogen.ss
@@ -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
diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss
index 635f5b5..87894f7 100644
--- a/scheme/ikarus.intel-assembler.ss
+++ b/scheme/ikarus.intel-assembler.ss
@@ -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)
diff --git a/scheme/ikarus.numerics.ss b/scheme/ikarus.numerics.ss
index be39369..4f19481 100644
--- a/scheme/ikarus.numerics.ss
+++ b/scheme/ikarus.numerics.ss
@@ -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)])))
diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss
index b27b53f..4db49ae 100644
--- a/scheme/ikarus.writer.ss
+++ b/scheme/ikarus.writer.ss
@@ -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*
diff --git a/scheme/last-revision b/scheme/last-revision
index bf9b507..2760076 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1540
+1541
diff --git a/scheme/makefile.ss b/scheme/makefile.ss
index 22791fb..aaab383 100755
--- a/scheme/makefile.ss
+++ b/scheme/makefile.ss
@@ -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]
diff --git a/scheme/pass-specify-rep-primops.ss b/scheme/pass-specify-rep-primops.ss
index 0957b48..504f191 100644
--- a/scheme/pass-specify-rep-primops.ss
+++ b/scheme/pass-specify-rep-primops.ss
@@ -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
diff --git a/scheme/run-tests.64.ss b/scheme/run-tests.64.ss
new file mode 100755
index 0000000..3742fe0
--- /dev/null
+++ b/scheme/run-tests.64.ss
@@ -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 .
+
+
+(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")
diff --git a/scheme/test64.ss b/scheme/test64.ss
index 9fff590..449393e 100755
--- a/scheme/test64.ss
+++ b/scheme/test64.ss
@@ -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)))
diff --git a/src/ikarus-collect.c b/src/ikarus-collect.c
index 6151bf4..6d345de 100644
--- a/src/ikarus-collect.c
+++ b/src/ikarus-collect.c
@@ -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++; isegment_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 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
diff --git a/src/ikarus-exec.c b/src/ikarus-exec.c
index df26b2d..24b5a42 100644
--- a/src/ikarus-exec.c
+++ b/src/ikarus-exec.c
@@ -25,7 +25,7 @@
typedef struct {
ikptr tag;
ikptr top;
- int size;
+ long int size;
ikptr next;
} cont;
diff --git a/src/ikarus-numerics.c b/src/ikarus-numerics.c
index cc92a84..ebc831e 100644
--- a/src/ikarus-numerics.c
+++ b/src/ikarus-numerics.c
@@ -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> 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> (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);
diff --git a/src/ikarus-runtime.c b/src/ikarus-runtime.c
index 1926d82..121115f 100644
--- a/src/ikarus-runtime.c
+++ b/src/ikarus-runtime.c
@@ -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);