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

fasl-write now writes different fasl objects depending on the 

architecture bitness.
This commit is contained in:
Abdulaziz Ghuloum 2008-01-02 23:22:55 -05:00
parent 7fb7add0ce
commit 3c99e7d393
9 changed files with 136 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
configure vendored
View File

@ -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

6
configure.ac
View File

@ -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])])

4
scheme/Makefile.am
View File

@ -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

3
scheme/Makefile.in
View File

@ -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

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

73
scheme/ikarus.compiler.ss
View File

@ -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)

62
scheme/ikarus.fasl.write.ss
View File

@ -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

16
scheme/ikarus.intel-assembler.ss
View File

@ -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)])))

2
scheme/last-revision
View File

@ -1 +1 @@
1314
1315