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

Ikarus can compile immediates in 64-bit mode. 

It feels like I'm going through my compilers tutorial all over again!
This commit is contained in:
Abdulaziz Ghuloum 2008-01-03 04:42:10 -05:00
parent 341e53a36d
commit 3b8eb4bbd4
8 changed files with 167 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
scheme/ikarus.compiler.ss
View File

@ -1909,7 +1909,8 @@
[(4) 2] [(4) 2]
[(8) 3] [(8) 3]
[else [else
(error 'ikarus "wordsize is neither 4 nor 8" wordsize)])) (error 'ikarus "wordsize is neither 4 nor 8" wordsize)]))
(define fx-scale wordsize)
(define object-alignment (* 2 wordsize)) (define object-alignment (* 2 wordsize))
(define align-shift (+ wordshift 1)) (define align-shift (+ wordshift 1))
(define fx-shift wordshift) (define fx-shift wordshift)
@ -2085,6 +2086,13 @@
(define pcb-collect-key (* 12 wordsize)) (define pcb-collect-key (* 12 wordsize))
(define (fx? x)
(let* ([intbits (* wordsize 8)]
[fxbits (- intbits fx-shift)])
(and (or (fixnum? x) (bignum? x))
(<= (- (expt 2 (- fxbits 1)))
x
(- (expt 2 (- fxbits 1)) 1)))))
(module () (module ()

2
scheme/last-revision
View File

@ -1 +1 @@
1316 1317

85
scheme/pass-specify-rep-primops.ss
View File

@ -131,7 +131,7 @@
(define-primop immediate? safe (define-primop immediate? safe
[(P x) [(P x)
(make-conditional (make-conditional
(tag-test (T x) fixnum-mask fixnum-tag) (tag-test (T x) fx-mask fx-tag)
(make-constant #t) (make-constant #t)
(tag-test (T x) 7 7))] (tag-test (T x) 7 7))]
[(E x) (nop)]) [(E x) (nop)])
@ -151,7 +151,7 @@
(define-primop pointer-value unsafe (define-primop pointer-value unsafe
[(V x) (prm 'logand [(V x) (prm 'logand
(prm 'srl (T x) (K 1)) (prm 'srl (T x) (K 1))
(K (* -1 fixnum-scale)))] (K (* -1 fx-scale)))]
[(P x) (K #t)] [(P x) (K #t)]
[(E x) (nop)]) [(E x) (nop)])
@ -336,7 +336,7 @@
/section) /section)
(define-primop vector? unsafe (define-primop vector? unsafe
[(P x) (sec-tag-test (T x) vector-mask vector-tag fixnum-mask fixnum-tag)] [(P x) (sec-tag-test (T x) vector-mask vector-tag fx-mask fx-tag)]
[(E x) (nop)]) [(E x) (nop)])
(define-primop $make-vector unsafe (define-primop $make-vector unsafe
@ -349,7 +349,7 @@
(K vector-tag))]) (K vector-tag))])
(prm 'mset v (prm 'mset v
(K (- disp-vector-length vector-tag)) (K (- disp-vector-length vector-tag))
(K (make-constant (* i fixnum-scale)))) (K (make-constant (* i fx-scale))))
v)] v)]
[else [else
(with-tmp ([alen (align-code (T len) disp-vector-data)]) (with-tmp ([alen (align-code (T len) disp-vector-data)])
@ -566,7 +566,7 @@
(section ;;; fixnums (section ;;; fixnums
(define-primop fixnum? safe (define-primop fixnum? safe
[(P x) (tag-test (T x) fixnum-mask fixnum-tag)] [(P x) (tag-test (T x) fx-mask fx-tag)]
[(E x) (nop)]) [(E x) (nop)])
@ -641,7 +641,7 @@
(unless (fixnum? b) (interrupt)) (unless (fixnum? b) (interrupt))
(prm 'int* (T a) (K b))] (prm 'int* (T a) (K b))]
[else [else
(prm 'int* (T a) (prm 'sra (T b) (K fixnum-shift)))])])] (prm 'int* (T a) (prm 'sra (T b) (K fx-shift)))])])]
[(P x y) (K #t)] [(P x y) (K #t)]
[(E x y) (nop)]) [(E x y) (nop)])
@ -677,7 +677,7 @@
(unless (fixnum? i) (interrupt)) (unless (fixnum? i) (interrupt))
(prm 'sll (T x) (K i))] (prm 'sll (T x) (K i))]
[else [else
(prm 'sll (T x) (prm 'sra (T i) (K fixnum-shift)))])] (prm 'sll (T x) (prm 'sra (T i) (K fx-shift)))])]
[(P x i) (K #t)] [(P x i) (K #t)]
[(E x i) (nop)]) [(E x i) (nop)])
@ -688,23 +688,23 @@
(unless (fixnum? i) (interrupt)) (unless (fixnum? i) (interrupt))
(prm 'logand (prm 'logand
(prm 'sra (T x) (K (if (> i 31) 31 i))) (prm 'sra (T x) (K (if (> i 31) 31 i)))
(K (* -1 fixnum-scale)))] (K (* -1 fx-scale)))]
[else [else
(with-tmp ([i (prm 'sra (T i) (K fixnum-shift))]) (with-tmp ([i (prm 'sra (T i) (K fx-shift))])
(with-tmp ([i (make-conditional (with-tmp ([i (make-conditional
(prm '< i (K 32)) (prm '< i (K 32))
i i
(K 31))]) (K 31))])
(prm 'logand (prm 'logand
(prm 'sra (T x) i) (prm 'sra (T x) i)
(K (* -1 fixnum-scale)))))])] (K (* -1 fx-scale)))))])]
[(P x i) (K #t)] [(P x i) (K #t)]
[(E x i) (nop)]) [(E x i) (nop)])
(define-primop $fxquotient unsafe (define-primop $fxquotient unsafe
[(V a b) [(V a b)
(with-tmp ([b (T b)]) ;;; FIXME: why is quotient called remainder? (with-tmp ([b (T b)]) ;;; FIXME: why is quotient called remainder?
(prm 'sll (prm 'remainder (T a) b) (K fixnum-shift)))] (prm 'sll (prm 'remainder (T a) b) (K fx-shift)))]
[(P a b) (K #t)] [(P a b) (K #t)]
[(E a b) (nop)]) [(E a b) (nop)])
@ -783,7 +783,7 @@
(prm 'srl ;;; FIXME: bref (prm 'srl ;;; FIXME: bref
(prm 'mref (T s) (prm 'mref (T s)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fixnum-shift)) (prm 'sra (T i) (K fx-shift))
;;; ENDIANNESS DEPENDENCY ;;; ENDIANNESS DEPENDENCY
(K (- disp-bignum-data (K (- disp-bignum-data
(- wordsize 1) (- wordsize 1)
@ -1004,7 +1004,7 @@
(prm 'mref (T x) (prm 'mref (T x)
(K (- (+ disp-flonum-data 4) vector-tag))) (K (- (+ disp-flonum-data 4) vector-tag)))
(K 20)) (K 20))
(K fixnum-shift))]) (K fx-shift))])
/section) /section)
@ -1054,7 +1054,7 @@
(assert-fixnums (car a*) (cdr a*)))] (assert-fixnums (car a*) (cdr a*)))]
[else [else
(interrupt-unless (interrupt-unless
(tag-test (or* (T a) a*) fixnum-mask fixnum-tag))])) (tag-test (or* (T a) a*) fx-mask fx-tag))]))
(define (fixnum-fold-p op a a*) (define (fixnum-fold-p op a a*)
(cond (cond
@ -1309,13 +1309,13 @@
(define-primop $fixnum->char unsafe (define-primop $fixnum->char unsafe
[(V x) [(V x)
(prm 'logor (prm 'logor
(prm 'sll (T x) (K (- char-shift fixnum-shift))) (prm 'sll (T x) (K (- char-shift fx-shift)))
(K char-tag))] (K char-tag))]
[(P x) (K #t)] [(P x) (K #t)]
[(E x) (nop)]) [(E x) (nop)])
(define-primop $char->fixnum unsafe (define-primop $char->fixnum unsafe
[(V x) (prm 'sra (T x) (K (- char-shift fixnum-shift)))] [(V x) (prm 'sra (T x) (K (- char-shift fx-shift)))]
[(P x) (K #t)] [(P x) (K #t)]
[(E x) (nop)]) [(E x) (nop)])
@ -1403,7 +1403,7 @@
(K bytevector-tag))]) (K bytevector-tag))])
(prm 'mset s (prm 'mset s
(K (- disp-bytevector-length bytevector-tag)) (K (- disp-bytevector-length bytevector-tag))
(K (* n fixnum-scale))) (K (* n fx-scale)))
(prm 'bset/c s (prm 'bset/c s
(K (+ n (- disp-bytevector-data bytevector-tag))) (K (+ n (- disp-bytevector-data bytevector-tag)))
(K 0)) (K 0))
@ -1411,7 +1411,7 @@
[else [else
(with-tmp ([s (prm 'alloc (with-tmp ([s (prm 'alloc
(align-code (align-code
(prm 'sra (T n) (K fixnum-shift)) (prm 'sra (T n) (K fx-shift))
(+ disp-bytevector-data 1)) (+ disp-bytevector-data 1))
(K bytevector-tag))]) (K bytevector-tag))])
(prm 'mset s (prm 'mset s
@ -1419,7 +1419,7 @@
(T n)) (T n))
(prm 'bset/c s (prm 'bset/c s
(prm 'int+ (prm 'int+
(prm 'sra (T n) (K fixnum-shift)) (prm 'sra (T n) (K fx-shift))
(K (- disp-bytevector-data bytevector-tag))) (K (- disp-bytevector-data bytevector-tag)))
(K 0)) (K 0))
s)])] s)])]
@ -1447,7 +1447,7 @@
(prm 'logand (prm 'logand
(prm 'bref (T s) (prm 'bref (T s)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fixnum-shift)) (prm 'sra (T i) (K fx-shift))
(K (- disp-bytevector-data bytevector-tag)))) (K (- disp-bytevector-data bytevector-tag))))
(K 255)) (K 255))
(K fx-shift))])] (K fx-shift))])]
@ -1472,7 +1472,7 @@
(prm 'sll (prm 'sll
(prm 'bref (T s) (prm 'bref (T s)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fixnum-shift)) (prm 'sra (T i) (K fx-shift))
(K (- disp-bytevector-data bytevector-tag)))) (K (- disp-bytevector-data bytevector-tag))))
(K (- (* wordsize 8) 8))) (K (- (* wordsize 8) 8)))
(K (- (* wordsize 8) (+ 8 fx-shift))))])] (K (- (* wordsize 8) (+ 8 fx-shift))))])]
@ -1504,7 +1504,7 @@
(unless (fixnum? c) (interrupt)) (unless (fixnum? c) (interrupt))
(prm 'bset/c (T x) (prm 'bset/c (T x)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fixnum-shift)) (prm 'sra (T i) (K fx-shift))
(K (- disp-bytevector-data bytevector-tag))) (K (- disp-bytevector-data bytevector-tag)))
(K (cond (K (cond
[(<= -128 c 127) c] [(<= -128 c 127) c]
@ -1513,7 +1513,7 @@
[else [else
(prm 'bset/h (T x) (prm 'bset/h (T x)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fixnum-shift)) (prm 'sra (T i) (K fx-shift))
(K (- disp-bytevector-data bytevector-tag))) (K (- disp-bytevector-data bytevector-tag)))
(prm 'sll (T c) (K (- 8 fx-shift))))])])]) (prm 'sll (T c) (K (- 8 fx-shift))))])])])
@ -1522,7 +1522,7 @@
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))]) (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag)) (prm 'mset x (K (- vector-tag)) (K flonum-tag))
(prm 'fl:load (prm 'fl:load
(prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift))) (prm 'int+ (T bv) (prm 'sra (T i) (K fx-shift)))
(K (- disp-bytevector-data bytevector-tag))) (K (- disp-bytevector-data bytevector-tag)))
(prm 'fl:store x (K (- disp-flonum-data vector-tag))) (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
x)]) x)])
@ -1534,7 +1534,7 @@
; (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))]) ; (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
; (prm 'mset x (K (- vector-tag)) (K flonum-tag)) ; (prm 'mset x (K (- vector-tag)) (K flonum-tag))
; (prm 'fl:load ; (prm 'fl:load
; (prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift))) ; (prm 'int+ (T bv) (prm 'sra (T i) (K fx-shift)))
; (K (- disp-bytevector-data bytevector-tag))) ; (K (- disp-bytevector-data bytevector-tag)))
; (prm 'fl:shuffle ; (prm 'fl:shuffle
; (K (make-object '#vu8(7 6 2 3 4 5 1 0))) ; (K (make-object '#vu8(7 6 2 3 4 5 1 0)))
@ -1549,7 +1549,7 @@
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))]) (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag)) (prm 'mset x (K (- vector-tag)) (K flonum-tag))
(with-tmp ([t (prm 'int+ (T bv) (with-tmp ([t (prm 'int+ (T bv)
(prm 'sra (T i) (K fixnum-shift)))]) (prm 'sra (T i) (K fx-shift)))])
(with-tmp ([x0 (prm 'mref t (K bvoff))]) (with-tmp ([x0 (prm 'mref t (K bvoff))])
(prm 'bswap! x0 x0) (prm 'bswap! x0 x0)
(prm 'mset x (K (+ floff wordsize)) x0)) (prm 'mset x (K (+ floff wordsize)) x0))
@ -1564,7 +1564,7 @@
(seq* (seq*
(prm 'fl:load (T x) (K (- disp-flonum-data vector-tag))) (prm 'fl:load (T x) (K (- disp-flonum-data vector-tag)))
(prm 'fl:store (prm 'fl:store
(prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift))) (prm 'int+ (T bv) (prm 'sra (T i) (K fx-shift)))
(K (- disp-bytevector-data bytevector-tag))))]) (K (- disp-bytevector-data bytevector-tag))))])
@ -1573,7 +1573,7 @@
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))]) (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag)) (prm 'mset x (K (- vector-tag)) (K flonum-tag))
(prm 'fl:load-single (prm 'fl:load-single
(prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift))) (prm 'int+ (T bv) (prm 'sra (T i) (K fx-shift)))
(K (- disp-bytevector-data bytevector-tag))) (K (- disp-bytevector-data bytevector-tag)))
(prm 'fl:single->double) (prm 'fl:single->double)
(prm 'fl:store x (K (- disp-flonum-data vector-tag))) (prm 'fl:store x (K (- disp-flonum-data vector-tag)))
@ -1585,7 +1585,7 @@
(prm 'fl:load (T x) (K (- disp-flonum-data vector-tag))) (prm 'fl:load (T x) (K (- disp-flonum-data vector-tag)))
(prm 'fl:double->single) (prm 'fl:double->single)
(prm 'fl:store-single (prm 'fl:store-single
(prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift))) (prm 'int+ (T bv) (prm 'sra (T i) (K fx-shift)))
(K (- disp-bytevector-data bytevector-tag))))]) (K (- disp-bytevector-data bytevector-tag))))])
(define-primop $bytevector-ieee-single-nonnative-ref unsafe (define-primop $bytevector-ieee-single-nonnative-ref unsafe
@ -1594,7 +1594,7 @@
[floff (- disp-flonum-data vector-tag)]) [floff (- disp-flonum-data vector-tag)])
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))]) (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
(prm 'mset x (K (- vector-tag)) (K flonum-tag)) (prm 'mset x (K (- vector-tag)) (K flonum-tag))
(with-tmp ([t (prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift)))]) (with-tmp ([t (prm 'int+ (T bv) (prm 'sra (T i) (K fx-shift)))])
(with-tmp ([x0 (prm 'mref t (K bvoff))]) (with-tmp ([x0 (prm 'mref t (K bvoff))])
(prm 'bswap! x0 x0) (prm 'bswap! x0 x0)
(prm 'mset x (K floff) x0))) (prm 'mset x (K floff) x0)))
@ -1613,7 +1613,7 @@
; (K (make-object '#vu8(7 6 2 3 4 5 1 0))) ; (K (make-object '#vu8(7 6 2 3 4 5 1 0)))
; (K (- disp-bytevector-data bytevector-tag))) ; (K (- disp-bytevector-data bytevector-tag)))
; (prm 'fl:store ; (prm 'fl:store
; (prm 'int+ (T bv) (prm 'sra (T i) (K fixnum-shift))) ; (prm 'int+ (T bv) (prm 'sra (T i) (K fx-shift)))
; (K (- disp-bytevector-data bytevector-tag))))]) ; (K (- disp-bytevector-data bytevector-tag))))])
(define-primop $bytevector-ieee-double-nonnative-set! unsafe (define-primop $bytevector-ieee-double-nonnative-set! unsafe
@ -1621,7 +1621,7 @@
(let ([bvoff (- disp-bytevector-data bytevector-tag)] (let ([bvoff (- disp-bytevector-data bytevector-tag)]
[floff (- disp-flonum-data vector-tag)]) [floff (- disp-flonum-data vector-tag)])
(with-tmp ([t (prm 'int+ (T bv) (with-tmp ([t (prm 'int+ (T bv)
(prm 'sra (T i) (K fixnum-shift)))]) (prm 'sra (T i) (K fx-shift)))])
(with-tmp ([x0 (prm 'mref (T x) (K floff))]) (with-tmp ([x0 (prm 'mref (T x) (K floff))])
(prm 'bswap! x0 x0) (prm 'bswap! x0 x0)
(prm 'mset t (K (+ bvoff wordsize)) x0)) (prm 'mset t (K (+ bvoff wordsize)) x0))
@ -1637,7 +1637,7 @@
(prm 'fl:load (T x) (K floff)) (prm 'fl:load (T x) (K floff))
(prm 'fl:double->single) (prm 'fl:double->single)
(with-tmp ([t (prm 'int+ (T bv) (with-tmp ([t (prm 'int+ (T bv)
(prm 'sra (T i) (K fixnum-shift)))]) (prm 'sra (T i) (K fx-shift)))])
(prm 'fl:store-single t (K bvoff)) (prm 'fl:store-single t (K bvoff))
(with-tmp ([x0 (prm 'mref t (K bvoff))]) (with-tmp ([x0 (prm 'mref t (K bvoff))])
(prm 'bswap! x0 x0) (prm 'bswap! x0 x0)
@ -1660,7 +1660,7 @@
(K string-tag))]) (K string-tag))])
(prm 'mset s (prm 'mset s
(K (- disp-string-length string-tag)) (K (- disp-string-length string-tag))
(K (* n fixnum-scale))) (K (* n fx-scale)))
s)] s)]
[else [else
(with-tmp ([s (prm 'alloc (with-tmp ([s (prm 'alloc
@ -1685,7 +1685,7 @@
[(constant i) [(constant i)
(unless (fixnum? i) (interrupt)) (unless (fixnum? i) (interrupt))
(prm 'mref (T s) (prm 'mref (T s)
(K (+ (* i fixnum-scale) (K (+ (* i fx-scale)
(- disp-string-data string-tag))))] (- disp-string-data string-tag))))]
[else [else
(prm 'mref (T s) (prm 'mref (T s)
@ -1731,7 +1731,7 @@
[(constant i) [(constant i)
(unless (fixnum? i) (interrupt)) (unless (fixnum? i) (interrupt))
(prm 'mset (T x) (prm 'mset (T x)
(K (+ (* i fixnum-scale) (- disp-string-data string-tag))) (K (+ (* i fx-scale) (- disp-string-data string-tag)))
(T c))] (T c))]
[else [else
(prm 'mset (T x) (prm 'mset (T x)
@ -1985,18 +1985,18 @@
(prm 'logand (prm 'logand
(prm 'mref (T x) (prm 'mref (T x)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fixnum-shift)) (prm 'sra (T i) (K fx-shift))
(K (- disp-code-data vector-tag)))) (K (- disp-code-data vector-tag))))
(K 255)) (K 255))
(K fixnum-shift))]) (K fx-shift))])
(define-primop $code-set! unsafe (define-primop $code-set! unsafe
[(E x i v) [(E x i v)
(prm 'bset/h (T x) (prm 'bset/h (T x)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fixnum-shift)) (prm 'sra (T i) (K fx-shift))
(K (- disp-code-data vector-tag))) (K (- disp-code-data vector-tag)))
(prm 'sll (T v) (K (- 8 fixnum-shift))))]) (prm 'sll (T v) (K (- 8 fx-shift))))])
(define-primop $set-code-annotation! unsafe (define-primop $set-code-annotation! unsafe
[(E x v) (mem-assign v (T x) (- disp-code-annotation vector-tag))]) [(E x v) (mem-assign v (T x) (- disp-code-annotation vector-tag))])
@ -2010,9 +2010,10 @@
(define-primop $data->transcoder unsafe (define-primop $data->transcoder unsafe
[(V x) (prm 'logor [(V x) (prm 'logor
(prm 'sll (T x) (K (- transcoder-payload-shift fixnum-shift))) (prm 'sll (T x) (K (- transcoder-payload-shift
fx-shift)))
(K transcoder-tag))]) (K transcoder-tag))])
(define-primop $transcoder->data unsafe (define-primop $transcoder->data unsafe
[(V x) (prm 'sra (T x) (K (- transcoder-payload-shift fixnum-shift)))]) [(V x) (prm 'sra (T x) (K (- transcoder-payload-shift fx-shift)))])
/section) /section)

29
scheme/pass-specify-rep.ss
View File

@ -20,17 +20,17 @@
; ;
;#!eof ;#!eof
(define-syntax export-all-module ;(define-syntax export-all-module
(syntax-rules (define) ; (syntax-rules (define)
[(_ M (define name* v*) ...) ; [(_ M (define name* v*) ...)
(module M (name* ...) ; (module M (name* ...)
(define name* v*) ...)])) ; (define name* v*) ...)]))
;
(export-all-module object-representation ;(export-all-module object-representation
(define fixnum-scale 4) ; (define fixnum-scale 4)
(define fixnum-shift 2) ; (define fixnum-shift 2)
(define fixnum-tag 0) ; (define fixnum-tag 0)
(define fixnum-mask 3)) ; (define fixnum-mask 3))
(module primops (primop? get-primop set-primop!) (module primops (primop? get-primop set-primop!)
(define cookie (gensym)) (define cookie (gensym))
@ -44,7 +44,7 @@
) )
(module (specify-representation) (module (specify-representation)
(import object-representation) ;(import object-representation)
(import primops) (import primops)
(define-struct PH (define-struct PH
(interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?)) (interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?))
@ -325,10 +325,11 @@
(build-closures clhs* crhs* (build-closures clhs* crhs*
(build-setters clhs* crhs* body)))]))) (build-setters clhs* crhs* body)))])))
(define (constant-rep x) (define (constant-rep x)
(let ([c (constant-value x)]) (let ([c (constant-value x)])
(cond (cond
[(fixnum? c) (make-constant (* c fixnum-scale))] [(fx? c) (make-constant (* c fx-scale))]
[(boolean? c) (make-constant (if c bool-t bool-f))] [(boolean? c) (make-constant (if c bool-t bool-f))]
[(eq? c (void)) (make-constant void-object)] [(eq? c (void)) (make-constant void-object)]
[(bwp-object? c) (make-constant bwp-object)] [(bwp-object? c) (make-constant bwp-object)]
@ -461,7 +462,7 @@
(define (interrupt-when x) (define (interrupt-when x)
(make-conditional x (interrupt) (prm 'nop))) (make-conditional x (interrupt) (prm 'nop)))
(define (interrupt-unless-fixnum x) (define (interrupt-unless-fixnum x)
(interrupt-unless (tag-test x fixnum-mask fixnum-tag))) (interrupt-unless (tag-test x fx-mask fx-tag)))
(define (T x) (define (T x)

52
scheme/test64.ss Executable file
View File

@ -0,0 +1,52 @@
#!/usr/bin/env ikarus --r6rs-script
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
;;; Copyright (C) 2006,2007 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/>.
;;; vim:syntax=scheme
(import
(ikarus compiler)
(except (ikarus) assembler-output))
(define (compile1 x)
(printf "Compiling ~s\n" x)
(let ([p (open-file-output-port "test64.boot" (file-options no-fail))])
(parameterize ([assembler-output #t])
(compile-core-expr-to-port x p))
(close-output-port p)))
(define (compile-and-run x)
(compile1 x)
(let ([rs (system "../src/ikarus -b test64.boot > test64.out")])
(unless (= rs 0) (error 'run1 "died"))
(with-input-from-file "test64.out" read)))
(define (compile-test-and-run expr expected)
(let ([val (compile-and-run expr)])
(unless (equal? val expected)
(error 'compile-test-and-run "failed:got:expected" val expected))))
(define all-tests
'([(quote 42) 42]
[(quote #f) #f]
[(quote ()) ()]))
(for-each
(lambda (x)
(compile-test-and-run (car x) (cadr x)))
all-tests)
(printf "Happy Happy Joy Joy\n")

65
src/ikarus-enter.S
View File

@ -32,18 +32,31 @@
.align 8 .align 8
ik_asm_enter: ik_asm_enter:
_ik_asm_enter: _ik_asm_enter:
# ignored value is the third arg 12(%esp) # c parameters come in registers:
# code is the second arg 8(%esp) # %rdi, %rsi, %rdx, %rcx, %r8 and %r9
# pcb is the first arg 4(%esp) # return value registers are %rax and %rdi
# return point is at 0(%esp) # callee-save registers:
movl %esi, -4(%esp) # preserve # %rbp, %rbx, %r12, r13, r14, %r15 are callee-save
movl %ebp, -8(%esp) # preserve
movl 4(%esp), %esi
movl 0(%esi), %ebp # allocation pointer is at 0(pcb) # First, save all callee-save registers
movl %esp, %eax mov %rbp, -8(%rsp) # preserve
subl $16, %esp # 24 for alignment mov %rbx, -16(%rsp) # preserve
movl %esp, 24(%esi) # save esp in pcb->system_stack mov %r12, -24(%rsp) # preserve
movl 8(%esi), %esp # load scheme stack from pcb->frame_pinter mov %r13, -32(%rsp) # preserve
mov %r14, -40(%rsp) # preserve
mov %r15, -48(%rsp) # preserve
# code is the second arg, or %rsi
# pcb is the first arg, or %rdi
# return point is at 0(%rsp)
mov %rsi, %rax # move code pointer to %rax
mov %rdi, %rsi # move pcb into pcb-register (%rsi)
mov 0(%rsi), %rbp # allocation pointer is at 0(pcb)
sub $64, %rsp # 64 for alignment
mov %rsp, 48(%rsi) # save esp in pcb->system_stack
mov 16(%rsi), %rsp # load scheme stack from pcb->frame_pinter
jmp L_call jmp L_call
.byte 0 .byte 0
.byte 0 .byte 0
@ -59,21 +72,27 @@ L_multivalue_label: # FIXME
.byte 0 .byte 0
.byte 0 .byte 0
L_call: L_call:
call *8(%eax) # goooooooo call *%rax # goooooooo
# now we're back # now we're back
ik_underflow_handler: ik_underflow_handler:
movl %eax, -8(%esp) # store the return value mov %rax, -16(%rsp) # store the return value
movl $-4, %eax # set rvcount = 1 mov $-8, %rax # set rvcount = 1
L_do_underflow: L_do_underflow:
movl %esp, 8(%esi) # store scheme stack in pcb->frame_pointer mov %rsp, 16(%rsi) # store scheme stack in pcb->frame_pointer
movl %ebp, 0(%esi) # store allocation pointer mov %rbp, 0(%rsi) # store allocation pointer
movl 24(%esi), %esp # restore system stack mov 48(%rsi), %rsp # restore system stack
addl $16, %esp # 24 for alignment (>= 16) add $64, %rsp # 64 for alignment
movl -4(%esp), %esi # restore callee-save registers
movl -8(%esp), %ebp # # restore callee-save registers
ret # back to C, which handled the underflow mov -8(%rsp) , %rbp # restore
mov -16(%rsp), %rbx # restore
mov -24(%rsp), %r12 # restore
mov -32(%rsp), %r13 # restore
mov -40(%rsp), %r14 # restore
mov -48(%rsp), %r15 # restore
ret # back to C, which handled the underflow
L_multivalue_underflow: L_multivalue_underflow:
addl $4, %esp add $8, %rsp
jmp L_do_underflow jmp L_do_underflow

4
src/ikarus-exec.c
View File

@ -64,8 +64,8 @@ ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr){
argc = ik_asm_reenter(pcb, new_fbase, argc); argc = ik_asm_reenter(pcb, new_fbase, argc);
next_k = pcb->next_k; next_k = pcb->next_k;
} }
return ref(pcb->frame_base, -2*wordsize); ikptr rv = ref(pcb->frame_base, -2*wordsize);
return argc; return rv;
} }

14
src/ikarus-fasl.c
View File

@ -110,16 +110,12 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
} }
close(fd); close(fd);
} }
ikptr val = void_object;
if(wordsize == 4){ if(wordsize == 4){
ik_exec_code(pcb, v); ik_exec_code(pcb, v);
} else { } else {
fprintf(stderr, "NOT EXECING YET\n"); fprintf(stderr, ";;; EXECING ...\n");
} ikptr val = ik_exec_code(pcb, v);
if(val != void_object){ fprintf(stderr, ";;; RETURNED ...\n");
/* this is from revision 1
and is no longer needed
and should be removed */
ik_print(val); ik_print(val);
} }
} }
@ -127,10 +123,6 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
fprintf(stderr, "fasl-read did not reach eof!\n"); fprintf(stderr, "fasl-read did not reach eof!\n");
exit(-10); exit(-10);
} }
if(wordsize == 8){
fprintf(stderr, "DONE READING FASL, EXITING ...\n");
exit(-1);
}
} }
static ikptr static ikptr