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

- removed bset/h instruction from the compiler (it was rarely used 

and not implemented 100% correctly)
- fixed parameterize to allow (parameterize () def ... exp exp ...)
This commit is contained in:
Abdulaziz Ghuloum 2008-09-06 04:17:20 -07:00
parent 9b9464229a
commit 814c797633
6 changed files with 32 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
scheme/ikarus.compiler.altcogen.ss
View File

@ -276,7 +276,7 @@
[(funcall rator arg*) #t] [(funcall rator arg*) #t]
[(jmpcall label rator arg*) #t] [(jmpcall label rator arg*) #t]
[(mvcall rator k) #t] [(mvcall rator k) #t]
[(primcall op arg*) #t] ;;; (ormap A arg*)] PUNT!!! FIXME! [(primcall op arg*) (ormap A arg*)] ;PUNT!!! FIXME!
[(bind lhs* rhs* body) (or (ormap NonTail rhs*) (NonTail body))] [(bind lhs* rhs* body) (or (ormap NonTail rhs*) (NonTail body))]
[(fix lhs* rhs* body) (NonTail body)] [(fix lhs* rhs* body) (NonTail body)]
[(conditional e0 e1 e2) (or (NonTail e0) (NonTail e1) (NonTail e2))] [(conditional e0 e1 e2) (or (NonTail e0) (NonTail e1) (NonTail e2))]
@ -529,7 +529,7 @@
[(bref) [(bref)
(S* rands (S* rands
(lambda (rands) (lambda (rands)
(make-asm-instr 'move-byte d (make-asm-instr 'load8 d
(make-disp (car rands) (cadr rands)))))] (make-disp (car rands) (cadr rands)))))]
[(logand logxor logor int+ int- int* [(logand logxor logor int+ int- int*
int-/overflow int+/overflow int*/overflow) int-/overflow int+/overflow int*/overflow)
@ -612,7 +612,7 @@
(do-bind lhs* rhs* (E e))] (do-bind lhs* rhs* (E e))]
[(primcall op rands) [(primcall op rands)
(case op (case op
[(mset bset bset/c mset32) [(mset bset mset32)
(S* rands (S* rands
(lambda (s*) (lambda (s*)
(make-asm-instr op (make-asm-instr op
@ -835,7 +835,7 @@
(module ListySet (module ListySet
(make-empty-set set-member? set-add set-rem set-difference set-union (make-empty-set set-member? set-add set-rem set-difference set-union
empty-set? empty-set? singleton
set->list list->set) set->list list->set)
(define-struct set (v)) (define-struct set (v))
(define (make-empty-set) (make-set '())) (define (make-empty-set) (make-set '()))
@ -849,6 +849,8 @@
(define (set->list s) (define (set->list s)
(unless (set? s) (error 'set->list "not a set" s)) (unless (set? s) (error 'set->list "not a set" s))
(set-v s)) (set-v s))
(define (singleton x)
(make-set (list x)))
(define (set-add x s) (define (set-add x s)
;(unless (fixnum? x) (error 'set-add "not a fixnum" x)) ;(unless (fixnum? x) (error 'set-add "not a fixnum" x))
(unless (set? s) (error 'set-add "not a set" s)) (unless (set? s) (error 'set-add "not a set" s))
@ -886,7 +888,7 @@
[else (cons (car s1) (union (cdr s1) s2))]))) [else (cons (car s1) (union (cdr s1) s2))])))
(module IntegerSet (module IntegerSet
(make-empty-set set-member? set-add set-rem set-difference (make-empty-set set-member? set-add singleton set-rem set-difference
set-union empty-set? set->list list->set) set-union empty-set? set->list list->set)
;;; ;;;
(begin (begin
@ -921,6 +923,9 @@
[(eq? i 0) (eq? j (fxlogand s j))] [(eq? i 0) (eq? j (fxlogand s j))]
[else #f]))) [else #f])))
;;; ;;;
(define (singleton n)
(set-add n (make-empty-set)))
;;;
(define (set-add n s) (define (set-add n s)
(unless (fixnum? n) (error 'set-add "not a fixnum" n)) (unless (fixnum? n) (error 'set-add "not a fixnum" n))
(let f ([s s] [i (index-of n)] [j (mask-of n)]) (let f ([s s] [i (index-of n)] [j (mask-of n)])
@ -1332,7 +1337,7 @@
(union-nfvs ns1 ns2)))] (union-nfvs ns1 ns2)))]
[(asm-instr op d s) [(asm-instr op d s)
(case op (case op
[(move move-byte load32) [(move load8 load32)
(cond (cond
[(reg? d) [(reg? d)
(cond (cond
@ -1512,7 +1517,7 @@
[(cltd) [(cltd)
(mark-reg/vars-conf! edx vs) (mark-reg/vars-conf! edx vs)
(R s vs (rem-reg edx rs) fs ns)] (R s vs (rem-reg edx rs) fs ns)]
[(mset mset32 bset bset/c [(mset mset32 bset
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! fl:from-int fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! fl:from-int
fl:shuffle fl:load-single fl:store-single) fl:shuffle fl:load-single fl:store-single)
(R* (list s d) vs rs fs ns)] (R* (list s d) vs rs fs ns)]
@ -1708,14 +1713,14 @@
(make-conditional (P e0) (E e1) (E e2))] (make-conditional (P e0) (E e1) (E e2))]
[(asm-instr op d s) [(asm-instr op d s)
(case op (case op
[(move move-byte load32) [(move load8 load32)
(let ([d (R d)] [s (R s)]) (let ([d (R d)] [s (R s)])
(cond (cond
[(eq? d s) [(eq? d s)
(make-primcall 'nop '())] (make-primcall 'nop '())]
[else [else
(make-asm-instr op d s)]))] (make-asm-instr op d s)]))]
[(logand logor logxor int+ int- int* mset bset mset32 bset/c [(logand logor logxor int+ int- int* mset bset mset32
sll sra srl bswap! sll sra srl bswap!
cltd idiv int-/overflow int+/overflow int*/overflow cltd idiv int-/overflow int+/overflow int*/overflow
fl:load fl:store fl:add! fl:sub! fl:mul! fl:div! fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
@ -1909,7 +1914,7 @@
(define (R x) (define (R x)
(struct-case x (struct-case x
[(constant) (make-empty-set)] [(constant) (make-empty-set)]
[(var) (list->set (list x))] [(var) (singleton x)]
[(disp s0 s1) (set-union (R s0) (R s1))] [(disp s0 s1) (set-union (R s0) (R s1))]
[(fvar) (make-empty-set)] [(fvar) (make-empty-set)]
[(code-loc) (make-empty-set)] [(code-loc) (make-empty-set)]
@ -1929,7 +1934,7 @@
(let ([s (set-rem d s)]) (let ([s (set-rem d s)])
(set-for-each (lambda (y) (add-edge! g d y)) s) (set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (R v) s))] (set-union (R v) s))]
[(move-byte) [(load8)
(let ([s (set-rem d s)]) (let ([s (set-rem d s)])
(set-for-each (lambda (y) (add-edge! g d y)) s) (set-for-each (lambda (y) (add-edge! g d y)) s)
(when (var? d) (when (var? d)
@ -1948,8 +1953,6 @@
(let ([s (set-rem d s)]) (let ([s (set-rem d s)])
(set-for-each (lambda (y) (add-edge! g d y)) s) (set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (set-union (R v) (R d)) s))] (set-union (set-union (R v) (R d)) s))]
[(bset/c)
(set-union (set-union (R v) (R d)) s)]
[(bset) [(bset)
(when (var? v) (when (var? v)
(for-each (lambda (r) (add-edge! g v r)) (for-each (lambda (r) (add-edge! g v r))
@ -2230,7 +2233,7 @@
[(asm-instr op a b) [(asm-instr op a b)
(case op (case op
[(logor logxor logand int+ int- int* move [(logor logxor logand int+ int- int* move
move-byte load32 load8 load32
int-/overflow int+/overflow int*/overflow) int-/overflow int+/overflow int*/overflow)
(cond (cond
[(and (eq? op 'move) (eq? a b)) [(and (eq? op 'move) (eq? a b))
@ -2323,7 +2326,7 @@
(eq? b ecx)) (eq? b ecx))
(error who "invalid shift" b)) (error who "invalid shift" b))
x] x]
[(mset mset32 bset bset/c ) [(mset mset32 bset)
(cond (cond
[(not (small-operand? b)) [(not (small-operand? b))
(let ([u (mku)]) (let ([u (mku)])
@ -2609,33 +2612,27 @@
(label-address (sl-mv-ignore-rp-label)))) (label-address (sl-mv-ignore-rp-label))))
(cond (cond
[(string? target) ;; foreign call [(string? target) ;; foreign call
(cons* ;`(subl ,(* (fxsub1 size) wordsize) ,fpr) (cons* `(movl (foreign-label "ik_foreign_call") %ebx)
`(movl (foreign-label "ik_foreign_call") %ebx)
(compile-call-frame (compile-call-frame
size size
mask mask
(rp-label value) (rp-label value)
`(call %ebx)) `(call %ebx))
;`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)] ac)]
[target ;;; known call [target ;;; known call
(cons* ;`(subl ,(* (fxsub1 size) wordsize) ,fpr) (cons* (compile-call-frame
(compile-call-frame
size size
mask mask
(rp-label value) (rp-label value)
`(call (label ,target))) `(call (label ,target)))
;`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)] ac)]
[else [else
(cons* ;`(subl ,(* (fxsub1 size) wordsize) ,fpr) (cons* (compile-call-frame
(compile-call-frame
size size
mask mask
(rp-label value) (rp-label value)
`(call (disp ,(fx- disp-closure-code closure-tag) `(call (disp ,(fx- disp-closure-code closure-tag)
,cp-register))) ,cp-register)))
;`(addl ,(* (fxsub1 size) wordsize) ,fpr)
ac)]))] ac)]))]
[(asm-instr op d s) [(asm-instr op d s)
(case op (case op
@ -2650,12 +2647,11 @@
(if (eq? d s) (if (eq? d s)
ac ac
(cons `(movl ,(R s) ,(R d)) ac))] (cons `(movl ,(R s) ,(R d)) ac))]
[(move-byte) [(load8)
(if (eq? d s) (if (eq? d s)
ac ac
(cons `(movb ,(R/l s) ,(R/l d)) ac))] (cons `(movb ,(R/l s) ,(R/l d)) ac))]
[(bset/c) (cons `(movb ,(BYTE s) ,(R d)) ac)] [(bset) (cons `(movb ,(R/l s) ,(R d)) ac)]
[(bset) (cons `(movb ,(reg/l s) ,(R d)) ac)]
[(sll) (cons `(sall ,(R/cl s) ,(R d)) ac)] [(sll) (cons `(sall ,(R/cl s) ,(R d)) ac)]
[(sra) (cons `(sarl ,(R/cl s) ,(R d)) ac)] [(sra) (cons `(sarl ,(R/cl s) ,(R d)) ac)]
[(srl) (cons `(shrl ,(R/cl s) ,(R d)) ac)] [(srl) (cons `(shrl ,(R/cl s) ,(R d)) ac)]

2
scheme/ikarus.compiler.ss
View File

@ -2286,14 +2286,12 @@
(cmpl (int closure-tag) ebx) (cmpl (int closure-tag) ebx)
(jne (label (sl-nonprocedure-error-label))) (jne (label (sl-nonprocedure-error-label)))
(movl (int (argc-convention 0)) eax) (movl (int (argc-convention 0)) eax)
;(subl (int (fx* wordsize 2)) fpr)
(compile-call-frame (compile-call-frame
3 3
'#(#b110) '#(#b110)
(label-address L_cwv_multi_rp) (label-address L_cwv_multi_rp)
(indirect-cpr-call)) (indirect-cpr-call))
;;; one value returned ;;; one value returned
;(addl (int (fx* wordsize 2)) fpr)
(movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer
(movl ebx cpr) (movl ebx cpr)
(movl eax (mem (fx- 0 wordsize) fpr)) (movl eax (mem (fx- 0 wordsize) fpr))

6
scheme/ikarus.numerics.ss
View File

@ -2704,11 +2704,11 @@
[(= x 0) (make-rectangular 0 (asinh y))] [(= x 0) (make-rectangular 0 (asinh y))]
[else [else
(let* ([z^2 (+ (* x x) (* y y))] (let* ([z^2 (+ (* x x) (* y y))]
[z^2-1 (- z^2 1)] [z^2-1 (- z^2 1.0)]
[z^2-1^2 (* z^2-1 z^2-1)] [z^2-1^2 (* z^2-1 z^2-1)]
[y^2 (* y y)] [y^2 (* y y)]
[q (sqrt (+ z^2-1^2 (* 4 y^2)))]) [q (sqrt (+ z^2-1^2 (* 4.0 y^2)))])
(define (sgn x) (if (< x 0) -1 1)) (define (sgn x) (if (< x 0) -1.0 1.0))
(make-rectangular (make-rectangular
(* 0.5 (sgn x) (acos (- q z^2))) (* 0.5 (sgn x) (acos (- q z^2)))
(* 0.5 (sgn y) (acosh (+ q z^2)))))]))] (* 0.5 (sgn y) (acosh (+ q z^2)))))]))]

2
scheme/last-revision
View File

@ -1 +1 @@
1586 1588

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

@ -1832,7 +1832,7 @@
(prm 'mset s (prm 'mset s
(K (- disp-bytevector-length bytevector-tag)) (K (- disp-bytevector-length bytevector-tag))
(K (* n fx-scale))) (K (* n fx-scale)))
(prm 'bset/c s (prm 'bset s
(K (+ n (- disp-bytevector-data bytevector-tag))) (K (+ n (- disp-bytevector-data bytevector-tag)))
(K 0)) (K 0))
s)] s)]
@ -1847,7 +1847,7 @@
(prm 'mset s (prm 'mset s
(K (- disp-bytevector-length bytevector-tag)) (K (- disp-bytevector-length bytevector-tag))
(T n)) (T n))
(prm 'bset/c s (prm 'bset s
(prm 'int+ (prm 'int+
(prm 'sra (T n) (K fx-shift)) (prm 'sra (T n) (K fx-shift))
(K (- disp-bytevector-data bytevector-tag))) (K (- disp-bytevector-data bytevector-tag)))
@ -1918,7 +1918,7 @@
(struct-case c (struct-case c
[(constant c) [(constant c)
(unless (fx? c) (interrupt)) (unless (fx? c) (interrupt))
(prm 'bset/c (T x) (prm 'bset (T x)
(K (+ i (- disp-bytevector-data bytevector-tag))) (K (+ i (- disp-bytevector-data bytevector-tag)))
(K (cond (K (cond
[(<= -128 c 127) c] [(<= -128 c 127) c]
@ -1932,7 +1932,7 @@
(struct-case c (struct-case c
[(constant c) [(constant c)
(unless (fx? c) (interrupt)) (unless (fx? c) (interrupt))
(prm 'bset/c (T x) (prm 'bset (T x)
(prm 'int+ (prm 'int+
(prm 'sra (T i) (K fx-shift)) (prm 'sra (T i) (K fx-shift))
(K (- disp-bytevector-data bytevector-tag))) (K (- disp-bytevector-data bytevector-tag)))

2
scheme/psyntax.expander.ss
View File

@ -2043,7 +2043,7 @@
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
((_ () b b* ...) ((_ () b b* ...)
(bless `(begin ,b . ,b*))) (bless `(let () ,b . ,b*)))
((_ ((olhs* orhs*) ...) b b* ...) ((_ ((olhs* orhs*) ...) b b* ...)
(let ((lhs* (generate-temporaries olhs*)) (let ((lhs* (generate-temporaries olhs*))
(rhs* (generate-temporaries orhs*))) (rhs* (generate-temporaries orhs*)))