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
[(e) a]
[else
(constant-value a
(or (constant-value a
(lambda (v)
(mk-seq a
(make-constant
@ -1090,7 +1090,8 @@
[(eof-object?) (eof-object? v)]
[else
(error 'optimize
"huh ~s" op)])))))])))
"huh ~s" op)])))))
(make-primcall op rand*))])))
(giveup))]
[($car $cdr)
(or (and (fx= (length rand*) 1)
@ -2053,7 +2054,10 @@
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(primcall op arg*)
(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*))]
[else
(simplify* arg* '() '()
@ -2882,10 +2886,10 @@
[(not Lt) (cons (list (opposite op) 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)
(NonTail (car rand*)
(cond
[(and Lt Lf)
(list* (movl (Simple (car rand*)) eax)
(movl eax ebx)
(list* (movl eax ebx)
(andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx)
(jne Lf)
@ -2898,8 +2902,7 @@
(jmp Lt)
ac)]
[Lf
(list* (movl (Simple (car rand*)) eax)
(movl eax ebx)
(list* (movl eax ebx)
(andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx)
(jne Lf)
@ -2912,8 +2915,7 @@
ac)]
[Lt
(let ([L_END (unique-label)])
(list* (movl (Simple (car rand*)) eax)
(movl eax ebx)
(list* (movl eax ebx)
(andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx)
(jne L_END)
@ -2925,27 +2927,14 @@
(je Lt)
L_END
ac))]
[else ac]))
[else ac])))
(define (type-pred mask tag rand* Lt Lf ac)
(cond
[mask
(list*
(movl (Simple (car rand*)) eax)
(andl (int mask) eax)
(cmpl (int tag) eax)
(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))]))]))
(let* ([ac (cond-branch 'je Lt Lf ac)]
[ac (cons (cmpl (int tag) eax) ac)]
[ac (if mask
(cons (andl (int mask) eax) ac)
ac)])
(NonTail (car rand*) ac)))
(define (compare-and-branch op rand* Lt Lf ac)
(define (opposite x)
(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)]
[($forward-ptr?) (type-pred #f -1 rand* Lt Lf 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)]
[(bwp-object?) (type-pred #f bwp-object rand* Lt Lf ac)]
[($code?)