diff --git a/configure b/configure index a2fe251..6963382 100755 --- a/configure +++ b/configure @@ -5536,11 +5536,9 @@ cat >>confdefs.h <<_ACEOF _ACEOF -if (test $ac_cv_sizeof_void_p != 4); then - { { echo "$as_me:$LINENO: error: Ikarus can only run in 32-bit mode." >&5 -echo "$as_me: error: Ikarus can only run in 32-bit mode." >&2;} - { (exit 1); exit 1; }; } -fi +# if (test $ac_cv_sizeof_void_p != 4); then +# AC_MSG_ERROR([Ikarus can only run in 32-bit mode.]) +# fi # Checks for libraries. { echo "$as_me:$LINENO: checking for library containing dlsym" >&5 diff --git a/configure.ac b/configure.ac index a64849f..d1a1f80 100644 --- a/configure.ac +++ b/configure.ac @@ -29,9 +29,9 @@ case "$target_os" in AC_CHECK_SIZEOF(void *) -if (test $ac_cv_sizeof_void_p != 4); then - AC_MSG_ERROR([Ikarus can only run in 32-bit mode.]) -fi +# if (test $ac_cv_sizeof_void_p != 4); then +# AC_MSG_ERROR([Ikarus can only run in 32-bit mode.]) +# fi # Checks for libraries. AC_SEARCH_LIBS(dlsym, dl,, [AC_MSG_ERROR([Cannot find libdl])]) diff --git a/scheme/Makefile.am b/scheme/Makefile.am index d66c90a..3d95dd0 100644 --- a/scheme/Makefile.am +++ b/scheme/Makefile.am @@ -31,10 +31,12 @@ revno = "$(shell sed 's/ .*//' ../.bzr/branch/last-revision 2>/dev/null)" last-revision: $(shell ls ../.bzr/branch/last-revision 2>/dev/null) echo $(revno) >$@ -ikarus.config.ss: Makefile last-revision +ikarus.config.ss: Makefile last-revision ../config.h echo '(define ikarus-version "$(PACKAGE_VERSION)")' >$@ echo '(define ikarus-revision "$(shell cat last-revision)")' >>$@ echo '(define ikarus-lib-dir "$(pkglibdir)")' >>$@ + echo '(define wordsize $(shell grep SIZEOF_VOID_P ../config.h | sed "s/.*\(.\)/\1/g"))' >>$@ + CLEANFILES=$(nodist_pkglib_DATA) ikarus.config.ss MAINTAINERCLEANFILES=last-revision diff --git a/scheme/Makefile.in b/scheme/Makefile.in index 73286a3..a93ad88 100644 --- a/scheme/Makefile.in +++ b/scheme/Makefile.in @@ -370,10 +370,11 @@ all: $(nodist_pkglib_DATA) last-revision: $(shell ls ../.bzr/branch/last-revision 2>/dev/null) echo $(revno) >$@ -ikarus.config.ss: Makefile last-revision +ikarus.config.ss: Makefile last-revision ../config.h echo '(define ikarus-version "$(PACKAGE_VERSION)")' >$@ echo '(define ikarus-revision "$(shell cat last-revision)")' >>$@ echo '(define ikarus-lib-dir "$(pkglibdir)")' >>$@ + 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 --r6rs-script makefile.ss diff --git a/scheme/ikarus.boot.prebuilt b/scheme/ikarus.boot.prebuilt index 011a854..d5a60b8 100644 Binary files a/scheme/ikarus.boot.prebuilt and b/scheme/ikarus.boot.prebuilt differ diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 1521895..888a439 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -25,8 +25,10 @@ (only (ikarus system $codes) $code->closure) (only (ikarus system $structs) $struct-ref $struct/rtd?) (except (ikarus) + fasl-write compile-core-expr-to-port assembler-output current-primitive-locations eval-core) + (ikarus fasl write) (ikarus intel-assembler)) @@ -807,6 +809,7 @@ (define (mk-seq e0 e1) ;;; keep e1 seq-free. (cond [(and (primcall? e0) (eq? (primcall-op e0) 'void)) e1] + [(or (constant? e0) (primref? e0)) e1] [(seq? e1) (make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))] [else @@ -1084,6 +1087,65 @@ (list (make-constant v0) a1)))))) (make-funcall (make-primref op) rand*)))) (giveup))] + [(-) + (or (and (>= (length rand*) 1) + (andmap + (lambda (x) + (constant-value x number?)) + rand*) + (begin + (let ([r (apply - + (map (lambda (x) + (constant-value x + (lambda (v) v))) + rand*))]) + (let f ([rand* rand*]) + (cond + [(null? rand*) (make-constant r)] + [else + (mk-seq (car rand*) (f (cdr rand*)))]))))) + (giveup))] + [(+ *) + (or (and (>= (length rand*) 0) + (andmap + (lambda (x) + (constant-value x number?)) + rand*) + (begin + (let ([r (apply + (case op + [(+) +] + [(*) *] + [else (error 'ikarus "BUG: no prim" op)]) + (map (lambda (x) + (constant-value x + (lambda (v) v))) + rand*))]) + (let f ([rand* rand*]) + (cond + [(null? rand*) (make-constant r)] + [else + (mk-seq (car rand*) (f (cdr rand*)))]))))) + (giveup))] + [(expt) + (or (and (= (length rand*) 2) + (andmap + (lambda (x) + (constant-value x + (lambda (v) (or (fixnum? v) (bignum? v))))) + rand*) + (begin + (let ([r (apply expt + (map (lambda (x) + (constant-value x + (lambda (v) v))) + rand*))]) + (let f ([rand* rand*]) + (cond + [(null? rand*) (make-constant r)] + [else + (mk-seq (car rand*) (f (cdr rand*)))]))))) + (giveup))] ;X; [(fx- fx+ fx*) ;X; (or (and (fx= (length rand*) 2) ;X; (let ([a0 (car rand*)] [a1 (cadr rand*)]) @@ -1838,9 +1900,16 @@ (make-codes (map CodeExpr list) (Tail body))])) (CodesExpr x)) + (begin ;;; DEFINITIONS - (define wordsize 4) - (define wordshift 2) + (module (wordsize) + (include "ikarus.config.ss")) + (define wordshift + (case wordsize + [(4) 2] + [(8) 3] + [else + (error 'ikarus "wordsize is neither 4 nor 8" wordsize)])) (define object-alignment (* 2 wordsize)) (define align-shift (+ wordshift 1)) (define fx-shift wordshift) diff --git a/scheme/ikarus.fasl.write.ss b/scheme/ikarus.fasl.write.ss index c6e8933..38ceabb 100644 --- a/scheme/ikarus.fasl.write.ss +++ b/scheme/ikarus.fasl.write.ss @@ -29,7 +29,33 @@ (ikarus system $bignums) (except (ikarus code-objects) procedure-annotation) (except (ikarus) fasl-write write-byte)) - + + (module (wordsize) + (include "ikarus.config.ss")) + + (define-syntax fxshift + (identifier-syntax + (case wordsize + [(4) 2] + [(8) 3] + [else (error 'fxshift "invalid wordsize" wordsize)]))) + + (define-syntax intbits (identifier-syntax (* wordsize 8))) + + (define-syntax fxbits (identifier-syntax (- intbits fxshift))) + + (define (fx? x) + (and (or (fixnum? x) (bignum? x)) + (<= (- (expt 2 (- fxbits 1))) + x + (- (expt 2 (- fxbits 1)) 1)))) + + (define (int? x) + (and (or (fixnum? x) (bignum? x)) + (<= (- (expt 2 (- intbits 1))) + x + (- (expt 2 (- intbits 1)) 1)))) + (define-syntax write-byte (syntax-rules () [(_ byte port) @@ -38,27 +64,26 @@ (define (put-tag c p) (write-byte (char->integer c) p)) - (define write-fixnum - (lambda (x p) - (unless (fixnum? x) (die 'write-fixnum "not a fixnum" x)) - (write-byte (fxsll (fxlogand x #x3F) 2) p) - (write-byte (fxlogand (fxsra x 6) #xFF) p) - (write-byte (fxlogand (fxsra x 14) #xFF) p) - (write-byte (fxlogand (fxsra x 22) #xFF) p))) (define write-int (lambda (x p) - (unless (fixnum? x) (die 'write-int "not a fixnum" x)) - (write-byte (fxlogand x #xFF) p) - (write-byte (fxlogand (fxsra x 8) #xFF) p) - (write-byte (fxlogand (fxsra x 16) #xFF) p) - (write-byte (fxlogand (fxsra x 24) #xFF) p))) + (unless (int? x) (die 'write-int "not a int" x)) + (write-byte (bitwise-and x #xFF) p) + (write-byte (bitwise-and (sra x 8) #xFF) p) + (write-byte (bitwise-and (sra x 16) #xFF) p) + (write-byte (bitwise-and (sra x 24) #xFF) p) + (when (eqv? wordsize 8) + (write-byte (bitwise-and (sra x 32) #xFF) p) + (write-byte (bitwise-and (sra x 40) #xFF) p) + (write-byte (bitwise-and (sra x 48) #xFF) p) + (write-byte (bitwise-and (sra x 56) #xFF) p)))) + (define fasl-write-immediate (lambda (x p) (cond [(null? x) (put-tag #\N p)] - [(fixnum? x) + [(fx? x) (put-tag #\I p) - (write-fixnum x p)] + (write-int (bitwise-arithmetic-shift-left x fxshift) p)] [(char? x) (let ([n ($char->fixnum x)]) (if ($fx<= n 255) @@ -152,7 +177,10 @@ [(code? x) (put-tag #\x p) (write-int (code-size x) p) - (write-fixnum (code-freevars x) p) + (write-int (bitwise-arithmetic-shift-left + (code-freevars x) + fxshift) + p) (let ([m (fasl-write-object ($code-annotation x) p h m)]) (let f ([i 0] [n (code-size x)]) (unless (fx= i n) @@ -315,7 +343,7 @@ (put-tag #\I port) (put-tag #\K port) (put-tag #\0 port) - (put-tag #\1 port) + (put-tag (if (= wordsize 4) #\1 #\2) port) (fasl-write-object x port h 1) (void)))) (define fasl-write diff --git a/scheme/ikarus.intel-assembler.ss b/scheme/ikarus.intel-assembler.ss index ce70a03..ee14f97 100644 --- a/scheme/ikarus.intel-assembler.ss +++ b/scheme/ikarus.intel-assembler.ss @@ -136,7 +136,7 @@ (define-syntax byte (syntax-rules () - [(_ x) (fxlogand x 255)])) + [(_ x) (bitwise-and x 255)])) (define word @@ -194,17 +194,17 @@ (if (fixnum? n) (cons* (byte n) - (byte (fxsra n 8)) - (byte (fxsra n 16)) - (byte (fxsra n 24)) + (byte (sra n 8)) + (byte (sra n 16)) + (byte (sra n 24)) ac) (let* ([lo (remainder n 256)] [hi (quotient (if (< n 0) (- n 255) n) 256)]) (cons* (byte lo) (byte hi) - (byte (fxsra hi 8)) - (byte (fxsra hi 16)) + (byte (sra hi 8)) + (byte (sra hi 16)) ac)))] [(obj? n) (let ([v (cadr n)]) @@ -218,7 +218,7 @@ (cons (cons 'label-addr (label-name n)) ac)] [(foreign? n) (cons (cons 'foreign-label (label-name n)) ac)] - [(label? n) + [(label? n) (cons (cons 'relative (label-name n)) ac)] [else (die 'IMM32 "invalid" n)]))) @@ -291,7 +291,7 @@ [else (cons* (byte (fxlogor 4 (fxsll (register-index r1) 3))) - (byte (fxlogor (register-index r2) + (byte (fxlogor (register-index r2) (fxsll (register-index r3) 3))) ac)]))) diff --git a/scheme/last-revision b/scheme/last-revision index 25a5cea..5239676 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1314 +1315