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
parent
341e53a36d
commit
3b8eb4bbd4
|
|
@ -1909,7 +1909,8 @@
|
|||
[(4) 2]
|
||||
[(8) 3]
|
||||
[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 align-shift (+ wordshift 1))
|
||||
(define fx-shift wordshift)
|
||||
|
|
@ -2085,6 +2086,13 @@
|
|||
(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 ()
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1316
|
||||
1317
|
||||
|
|
|
|||
|
|
@ -131,7 +131,7 @@
|
|||
(define-primop immediate? safe
|
||||
[(P x)
|
||||
(make-conditional
|
||||
(tag-test (T x) fixnum-mask fixnum-tag)
|
||||
(tag-test (T x) fx-mask fx-tag)
|
||||
(make-constant #t)
|
||||
(tag-test (T x) 7 7))]
|
||||
[(E x) (nop)])
|
||||
|
|
@ -151,7 +151,7 @@
|
|||
(define-primop pointer-value unsafe
|
||||
[(V x) (prm 'logand
|
||||
(prm 'srl (T x) (K 1))
|
||||
(K (* -1 fixnum-scale)))]
|
||||
(K (* -1 fx-scale)))]
|
||||
[(P x) (K #t)]
|
||||
[(E x) (nop)])
|
||||
|
||||
|
|
@ -336,7 +336,7 @@
|
|||
/section)
|
||||
|
||||
(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)])
|
||||
|
||||
(define-primop $make-vector unsafe
|
||||
|
|
@ -349,7 +349,7 @@
|
|||
(K vector-tag))])
|
||||
(prm 'mset v
|
||||
(K (- disp-vector-length vector-tag))
|
||||
(K (make-constant (* i fixnum-scale))))
|
||||
(K (make-constant (* i fx-scale))))
|
||||
v)]
|
||||
[else
|
||||
(with-tmp ([alen (align-code (T len) disp-vector-data)])
|
||||
|
|
@ -566,7 +566,7 @@
|
|||
(section ;;; fixnums
|
||||
|
||||
(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)])
|
||||
|
||||
|
||||
|
|
@ -641,7 +641,7 @@
|
|||
(unless (fixnum? b) (interrupt))
|
||||
(prm 'int* (T a) (K b))]
|
||||
[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)]
|
||||
[(E x y) (nop)])
|
||||
|
||||
|
|
@ -677,7 +677,7 @@
|
|||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'sll (T x) (K i))]
|
||||
[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)]
|
||||
[(E x i) (nop)])
|
||||
|
||||
|
|
@ -688,23 +688,23 @@
|
|||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'logand
|
||||
(prm 'sra (T x) (K (if (> i 31) 31 i)))
|
||||
(K (* -1 fixnum-scale)))]
|
||||
(K (* -1 fx-scale)))]
|
||||
[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
|
||||
(prm '< i (K 32))
|
||||
i
|
||||
(K 31))])
|
||||
(prm 'logand
|
||||
(prm 'sra (T x) i)
|
||||
(K (* -1 fixnum-scale)))))])]
|
||||
(K (* -1 fx-scale)))))])]
|
||||
[(P x i) (K #t)]
|
||||
[(E x i) (nop)])
|
||||
|
||||
(define-primop $fxquotient unsafe
|
||||
[(V a b)
|
||||
(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)]
|
||||
[(E a b) (nop)])
|
||||
|
||||
|
|
@ -783,7 +783,7 @@
|
|||
(prm 'srl ;;; FIXME: bref
|
||||
(prm 'mref (T s)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(prm 'sra (T i) (K fx-shift))
|
||||
;;; ENDIANNESS DEPENDENCY
|
||||
(K (- disp-bignum-data
|
||||
(- wordsize 1)
|
||||
|
|
@ -1004,7 +1004,7 @@
|
|||
(prm 'mref (T x)
|
||||
(K (- (+ disp-flonum-data 4) vector-tag)))
|
||||
(K 20))
|
||||
(K fixnum-shift))])
|
||||
(K fx-shift))])
|
||||
|
||||
/section)
|
||||
|
||||
|
|
@ -1054,7 +1054,7 @@
|
|||
(assert-fixnums (car a*) (cdr a*)))]
|
||||
[else
|
||||
(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*)
|
||||
(cond
|
||||
|
|
@ -1309,13 +1309,13 @@
|
|||
(define-primop $fixnum->char unsafe
|
||||
[(V x)
|
||||
(prm 'logor
|
||||
(prm 'sll (T x) (K (- char-shift fixnum-shift)))
|
||||
(prm 'sll (T x) (K (- char-shift fx-shift)))
|
||||
(K char-tag))]
|
||||
[(P x) (K #t)]
|
||||
[(E x) (nop)])
|
||||
|
||||
(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)]
|
||||
[(E x) (nop)])
|
||||
|
||||
|
|
@ -1403,7 +1403,7 @@
|
|||
(K bytevector-tag))])
|
||||
(prm 'mset s
|
||||
(K (- disp-bytevector-length bytevector-tag))
|
||||
(K (* n fixnum-scale)))
|
||||
(K (* n fx-scale)))
|
||||
(prm 'bset/c s
|
||||
(K (+ n (- disp-bytevector-data bytevector-tag)))
|
||||
(K 0))
|
||||
|
|
@ -1411,7 +1411,7 @@
|
|||
[else
|
||||
(with-tmp ([s (prm 'alloc
|
||||
(align-code
|
||||
(prm 'sra (T n) (K fixnum-shift))
|
||||
(prm 'sra (T n) (K fx-shift))
|
||||
(+ disp-bytevector-data 1))
|
||||
(K bytevector-tag))])
|
||||
(prm 'mset s
|
||||
|
|
@ -1419,7 +1419,7 @@
|
|||
(T n))
|
||||
(prm 'bset/c s
|
||||
(prm 'int+
|
||||
(prm 'sra (T n) (K fixnum-shift))
|
||||
(prm 'sra (T n) (K fx-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag)))
|
||||
(K 0))
|
||||
s)])]
|
||||
|
|
@ -1447,7 +1447,7 @@
|
|||
(prm 'logand
|
||||
(prm 'bref (T s)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(prm 'sra (T i) (K fx-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag))))
|
||||
(K 255))
|
||||
(K fx-shift))])]
|
||||
|
|
@ -1472,7 +1472,7 @@
|
|||
(prm 'sll
|
||||
(prm 'bref (T s)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(prm 'sra (T i) (K fx-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag))))
|
||||
(K (- (* wordsize 8) 8)))
|
||||
(K (- (* wordsize 8) (+ 8 fx-shift))))])]
|
||||
|
|
@ -1504,7 +1504,7 @@
|
|||
(unless (fixnum? c) (interrupt))
|
||||
(prm 'bset/c (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(prm 'sra (T i) (K fx-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag)))
|
||||
(K (cond
|
||||
[(<= -128 c 127) c]
|
||||
|
|
@ -1513,7 +1513,7 @@
|
|||
[else
|
||||
(prm 'bset/h (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(prm 'sra (T i) (K fx-shift))
|
||||
(K (- disp-bytevector-data bytevector-tag)))
|
||||
(prm 'sll (T c) (K (- 8 fx-shift))))])])])
|
||||
|
||||
|
|
@ -1522,7 +1522,7 @@
|
|||
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
||||
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
||||
(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)))
|
||||
(prm 'fl:store x (K (- disp-flonum-data vector-tag)))
|
||||
x)])
|
||||
|
|
@ -1534,7 +1534,7 @@
|
|||
; (with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
||||
; (prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
||||
; (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)))
|
||||
; (prm 'fl:shuffle
|
||||
; (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))])
|
||||
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
||||
(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))])
|
||||
(prm 'bswap! x0 x0)
|
||||
(prm 'mset x (K (+ floff wordsize)) x0))
|
||||
|
|
@ -1564,7 +1564,7 @@
|
|||
(seq*
|
||||
(prm 'fl:load (T x) (K (- disp-flonum-data vector-tag)))
|
||||
(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))))])
|
||||
|
||||
|
||||
|
|
@ -1573,7 +1573,7 @@
|
|||
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-tag))])
|
||||
(prm 'mset x (K (- vector-tag)) (K flonum-tag))
|
||||
(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)))
|
||||
(prm 'fl:single->double)
|
||||
(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:double->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))))])
|
||||
|
||||
(define-primop $bytevector-ieee-single-nonnative-ref unsafe
|
||||
|
|
@ -1594,7 +1594,7 @@
|
|||
[floff (- disp-flonum-data vector-tag)])
|
||||
(with-tmp ([x (prm 'alloc (K (align flonum-size)) (K vector-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))])
|
||||
(prm 'bswap! x0 x0)
|
||||
(prm 'mset x (K floff) x0)))
|
||||
|
|
@ -1613,7 +1613,7 @@
|
|||
; (K (make-object '#vu8(7 6 2 3 4 5 1 0)))
|
||||
; (K (- disp-bytevector-data bytevector-tag)))
|
||||
; (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))))])
|
||||
|
||||
(define-primop $bytevector-ieee-double-nonnative-set! unsafe
|
||||
|
|
@ -1621,7 +1621,7 @@
|
|||
(let ([bvoff (- disp-bytevector-data bytevector-tag)]
|
||||
[floff (- disp-flonum-data vector-tag)])
|
||||
(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))])
|
||||
(prm 'bswap! x0 x0)
|
||||
(prm 'mset t (K (+ bvoff wordsize)) x0))
|
||||
|
|
@ -1637,7 +1637,7 @@
|
|||
(prm 'fl:load (T x) (K floff))
|
||||
(prm 'fl:double->single)
|
||||
(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))
|
||||
(with-tmp ([x0 (prm 'mref t (K bvoff))])
|
||||
(prm 'bswap! x0 x0)
|
||||
|
|
@ -1660,7 +1660,7 @@
|
|||
(K string-tag))])
|
||||
(prm 'mset s
|
||||
(K (- disp-string-length string-tag))
|
||||
(K (* n fixnum-scale)))
|
||||
(K (* n fx-scale)))
|
||||
s)]
|
||||
[else
|
||||
(with-tmp ([s (prm 'alloc
|
||||
|
|
@ -1685,7 +1685,7 @@
|
|||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'mref (T s)
|
||||
(K (+ (* i fixnum-scale)
|
||||
(K (+ (* i fx-scale)
|
||||
(- disp-string-data string-tag))))]
|
||||
[else
|
||||
(prm 'mref (T s)
|
||||
|
|
@ -1731,7 +1731,7 @@
|
|||
[(constant i)
|
||||
(unless (fixnum? i) (interrupt))
|
||||
(prm 'mset (T x)
|
||||
(K (+ (* i fixnum-scale) (- disp-string-data string-tag)))
|
||||
(K (+ (* i fx-scale) (- disp-string-data string-tag)))
|
||||
(T c))]
|
||||
[else
|
||||
(prm 'mset (T x)
|
||||
|
|
@ -1985,18 +1985,18 @@
|
|||
(prm 'logand
|
||||
(prm 'mref (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(prm 'sra (T i) (K fx-shift))
|
||||
(K (- disp-code-data vector-tag))))
|
||||
(K 255))
|
||||
(K fixnum-shift))])
|
||||
(K fx-shift))])
|
||||
|
||||
(define-primop $code-set! unsafe
|
||||
[(E x i v)
|
||||
(prm 'bset/h (T x)
|
||||
(prm 'int+
|
||||
(prm 'sra (T i) (K fixnum-shift))
|
||||
(prm 'sra (T i) (K fx-shift))
|
||||
(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
|
||||
[(E x v) (mem-assign v (T x) (- disp-code-annotation vector-tag))])
|
||||
|
|
@ -2010,9 +2010,10 @@
|
|||
|
||||
(define-primop $data->transcoder unsafe
|
||||
[(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))])
|
||||
(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)
|
||||
|
||||
|
|
|
|||
|
|
@ -20,17 +20,17 @@
|
|||
;
|
||||
;#!eof
|
||||
|
||||
(define-syntax export-all-module
|
||||
(syntax-rules (define)
|
||||
[(_ M (define name* v*) ...)
|
||||
(module M (name* ...)
|
||||
(define name* v*) ...)]))
|
||||
|
||||
(export-all-module object-representation
|
||||
(define fixnum-scale 4)
|
||||
(define fixnum-shift 2)
|
||||
(define fixnum-tag 0)
|
||||
(define fixnum-mask 3))
|
||||
;(define-syntax export-all-module
|
||||
; (syntax-rules (define)
|
||||
; [(_ M (define name* v*) ...)
|
||||
; (module M (name* ...)
|
||||
; (define name* v*) ...)]))
|
||||
;
|
||||
;(export-all-module object-representation
|
||||
; (define fixnum-scale 4)
|
||||
; (define fixnum-shift 2)
|
||||
; (define fixnum-tag 0)
|
||||
; (define fixnum-mask 3))
|
||||
|
||||
(module primops (primop? get-primop set-primop!)
|
||||
(define cookie (gensym))
|
||||
|
|
@ -44,7 +44,7 @@
|
|||
)
|
||||
|
||||
(module (specify-representation)
|
||||
(import object-representation)
|
||||
;(import object-representation)
|
||||
(import primops)
|
||||
(define-struct PH
|
||||
(interruptable? p-handler p-handled? v-handler v-handled? e-handler e-handled?))
|
||||
|
|
@ -325,10 +325,11 @@
|
|||
(build-closures clhs* crhs*
|
||||
(build-setters clhs* crhs* body)))])))
|
||||
|
||||
|
||||
(define (constant-rep x)
|
||||
(let ([c (constant-value x)])
|
||||
(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))]
|
||||
[(eq? c (void)) (make-constant void-object)]
|
||||
[(bwp-object? c) (make-constant bwp-object)]
|
||||
|
|
@ -461,7 +462,7 @@
|
|||
(define (interrupt-when x)
|
||||
(make-conditional x (interrupt) (prm 'nop)))
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
@ -32,18 +32,31 @@
|
|||
.align 8
|
||||
ik_asm_enter:
|
||||
_ik_asm_enter:
|
||||
# ignored value is the third arg 12(%esp)
|
||||
# code is the second arg 8(%esp)
|
||||
# pcb is the first arg 4(%esp)
|
||||
# return point is at 0(%esp)
|
||||
movl %esi, -4(%esp) # preserve
|
||||
movl %ebp, -8(%esp) # preserve
|
||||
movl 4(%esp), %esi
|
||||
movl 0(%esi), %ebp # allocation pointer is at 0(pcb)
|
||||
movl %esp, %eax
|
||||
subl $16, %esp # 24 for alignment
|
||||
movl %esp, 24(%esi) # save esp in pcb->system_stack
|
||||
movl 8(%esi), %esp # load scheme stack from pcb->frame_pinter
|
||||
# c parameters come in registers:
|
||||
# %rdi, %rsi, %rdx, %rcx, %r8 and %r9
|
||||
# return value registers are %rax and %rdi
|
||||
# callee-save registers:
|
||||
# %rbp, %rbx, %r12, r13, r14, %r15 are callee-save
|
||||
|
||||
|
||||
# First, save all callee-save registers
|
||||
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
|
||||
|
||||
# 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
|
||||
.byte 0
|
||||
.byte 0
|
||||
|
|
@ -59,21 +72,27 @@ L_multivalue_label: # FIXME
|
|||
.byte 0
|
||||
.byte 0
|
||||
L_call:
|
||||
call *8(%eax) # goooooooo
|
||||
call *%rax # goooooooo
|
||||
# now we're back
|
||||
ik_underflow_handler:
|
||||
movl %eax, -8(%esp) # store the return value
|
||||
movl $-4, %eax # set rvcount = 1
|
||||
mov %rax, -16(%rsp) # store the return value
|
||||
mov $-8, %rax # set rvcount = 1
|
||||
L_do_underflow:
|
||||
movl %esp, 8(%esi) # store scheme stack in pcb->frame_pointer
|
||||
movl %ebp, 0(%esi) # store allocation pointer
|
||||
movl 24(%esi), %esp # restore system stack
|
||||
addl $16, %esp # 24 for alignment (>= 16)
|
||||
movl -4(%esp), %esi # restore callee-save registers
|
||||
movl -8(%esp), %ebp #
|
||||
ret # back to C, which handled the underflow
|
||||
mov %rsp, 16(%rsi) # store scheme stack in pcb->frame_pointer
|
||||
mov %rbp, 0(%rsi) # store allocation pointer
|
||||
mov 48(%rsi), %rsp # restore system stack
|
||||
add $64, %rsp # 64 for alignment
|
||||
|
||||
# restore callee-save registers
|
||||
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:
|
||||
addl $4, %esp
|
||||
add $8, %rsp
|
||||
jmp L_do_underflow
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -64,8 +64,8 @@ ikptr ik_exec_code(ikpcb* pcb, ikptr code_ptr){
|
|||
argc = ik_asm_reenter(pcb, new_fbase, argc);
|
||||
next_k = pcb->next_k;
|
||||
}
|
||||
return ref(pcb->frame_base, -2*wordsize);
|
||||
return argc;
|
||||
ikptr rv = ref(pcb->frame_base, -2*wordsize);
|
||||
return rv;
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -110,16 +110,12 @@ void ik_fasl_load(ikpcb* pcb, char* fasl_file){
|
|||
}
|
||||
close(fd);
|
||||
}
|
||||
ikptr val = void_object;
|
||||
if(wordsize == 4){
|
||||
ik_exec_code(pcb, v);
|
||||
} else {
|
||||
fprintf(stderr, "NOT EXECING YET\n");
|
||||
}
|
||||
if(val != void_object){
|
||||
/* this is from revision 1
|
||||
and is no longer needed
|
||||
and should be removed */
|
||||
fprintf(stderr, ";;; EXECING ...\n");
|
||||
ikptr val = ik_exec_code(pcb, v);
|
||||
fprintf(stderr, ";;; RETURNED ...\n");
|
||||
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");
|
||||
exit(-10);
|
||||
}
|
||||
if(wordsize == 8){
|
||||
fprintf(stderr, "DONE READING FASL, EXITING ...\n");
|
||||
exit(-1);
|
||||
}
|
||||
}
|
||||
|
||||
static ikptr
|
||||
|
|
|
|||
Loading…
Reference in New Issue