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

predicates now evaluate their args in the acum.

This commit is contained in:
Abdulaziz Ghuloum 2006-12-07 03:36:31 -05:00
parent bd71be0d64
commit 8aab527c56
2 changed files with 63 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

48
lib/libcompile.ss
View File

@ -1074,7 +1074,7 @@
(case ctxt (case ctxt
[(e) a] [(e) a]
[else [else
(constant-value a (or (constant-value a
(lambda (v) (lambda (v)
(mk-seq a (mk-seq a
(make-constant (make-constant
@ -1090,7 +1090,8 @@
[(eof-object?) (eof-object? v)] [(eof-object?) (eof-object? v)]
[else [else
(error 'optimize (error 'optimize
"huh ~s" op)])))))]))) "huh ~s" op)])))))
(make-primcall op rand*))])))
(giveup))] (giveup))]
[($car $cdr) [($car $cdr)
(or (and (fx= (length rand*) 1) (or (and (fx= (length rand*) 1)
@ -2053,7 +2054,10 @@
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))] [(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(primcall op arg*) [(primcall op arg*)
(cond (cond
[(memq op '(not car cdr cadr fxadd1 fxsub1)) ;;; SIMPLIFY [(memq op '(not car cdr cadr fxadd1 fxsub1
null? pair? fixnum? vector? string?
char? symbol? eof-object?
)) ;;; SIMPLIFY
(make-primcall op (map Expr arg*))] (make-primcall op (map Expr arg*))]
[else [else
(simplify* arg* '() '() (simplify* arg* '() '()
@ -2882,10 +2886,10 @@
[(not Lt) (cons (list (opposite op) Lf) ac)] [(not Lt) (cons (list (opposite op) Lf) ac)]
[else (list* (list op Lt) (jmp Lf) ac)])) [else (list* (list op Lt) (jmp Lf) ac)]))
(define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac) (define (indirect-type-pred pri-mask pri-tag sec-mask sec-tag rand* Lt Lf ac)
(NonTail (car rand*)
(cond (cond
[(and Lt Lf) [(and Lt Lf)
(list* (movl (Simple (car rand*)) eax) (list* (movl eax ebx)
(movl eax ebx)
(andl (int pri-mask) ebx) (andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx) (cmpl (int pri-tag) ebx)
(jne Lf) (jne Lf)
@ -2898,8 +2902,7 @@
(jmp Lt) (jmp Lt)
ac)] ac)]
[Lf [Lf
(list* (movl (Simple (car rand*)) eax) (list* (movl eax ebx)
(movl eax ebx)
(andl (int pri-mask) ebx) (andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx) (cmpl (int pri-tag) ebx)
(jne Lf) (jne Lf)
@ -2912,8 +2915,7 @@
ac)] ac)]
[Lt [Lt
(let ([L_END (unique-label)]) (let ([L_END (unique-label)])
(list* (movl (Simple (car rand*)) eax) (list* (movl eax ebx)
(movl eax ebx)
(andl (int pri-mask) ebx) (andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx) (cmpl (int pri-tag) ebx)
(jne L_END) (jne L_END)
@ -2925,27 +2927,14 @@
(je Lt) (je Lt)
L_END L_END
ac))] ac))]
[else ac])) [else ac])))
(define (type-pred mask tag rand* Lt Lf ac) (define (type-pred mask tag rand* Lt Lf ac)
(cond (let* ([ac (cond-branch 'je Lt Lf ac)]
[mask [ac (cons (cmpl (int tag) eax) ac)]
(list* [ac (if mask
(movl (Simple (car rand*)) eax) (cons (andl (int mask) eax) ac)
(andl (int mask) eax) ac)])
(cmpl (int tag) eax) (NonTail (car rand*) ac)))
(cond-branch 'je Lt Lf ac))]
[else
(let ([v (Simple (car rand*))])
(cond
[(memq (car v) '(mem register))
(list*
(cmpl (int tag) (Simple (car rand*)))
(cond-branch 'je Lt Lf ac))]
[else
(list*
(movl (Simple (car rand*)) eax)
(cmpl (int tag) eax)
(cond-branch 'je Lt Lf ac))]))]))
(define (compare-and-branch op rand* Lt Lf ac) (define (compare-and-branch op rand* Lt Lf ac)
(define (opposite x) (define (opposite x)
(cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle])))) (cadr (assq x '([je je] [jl jg] [jle jge] [jg jl] [jge jle]))))
@ -2981,7 +2970,6 @@
[($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)] [($unbound-object?) (type-pred #f unbound rand* Lt Lf ac)]
[($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)] [($forward-ptr?) (type-pred #f -1 rand* Lt Lf ac)]
[(not) (Pred (car rand*) Lf Lt ac)] [(not) (Pred (car rand*) Lf Lt ac)]
;[(not) (type-pred #f bool-f rand* Lt Lf ac)]
[(eof-object?) (type-pred #f eof rand* Lt Lf ac)] [(eof-object?) (type-pred #f eof rand* Lt Lf ac)]
[(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)] [(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)]
[($code?) [($code?)