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.

138
lib/libcompile.ss
View File

@ -1074,23 +1074,24 @@
(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
(case op (case op
[(not) (not v)] [(not) (not v)]
[(null?) (null? v)] [(null?) (null? v)]
[(pair?) (pair? v)] [(pair?) (pair? v)]
[(fixnum?) (fixnum? v)] [(fixnum?) (fixnum? v)]
[(vector?) (vector? v)] [(vector?) (vector? v)]
[(string?) (string? v)] [(string?) (string? v)]
[(char?) (char? v)] [(char?) (char? v)]
[(symbol?) (symbol? v)] [(symbol?) (symbol? v)]
[(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,70 +2886,55 @@
[(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)
(cond (NonTail (car rand*)
[(and Lt Lf) (cond
(list* (movl (Simple (car rand*)) eax) [(and Lt Lf)
(movl eax ebx) (list* (movl eax ebx)
(andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx)
(jne Lf)
(movl (mem (fx- 0 pri-tag) eax) ebx)
(if sec-mask
(andl (int sec-mask) ebx)
'(nop))
(cmpl (int sec-tag) ebx)
(jne Lf)
(jmp Lt)
ac)]
[Lf
(list* (movl (Simple (car rand*)) eax)
(movl eax ebx)
(andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx)
(jne Lf)
(movl (mem (fx- 0 pri-tag) eax) ebx)
(if sec-mask
(andl (int sec-mask) ebx)
'(nop))
(cmpl (int sec-tag) ebx)
(jne Lf)
ac)]
[Lt
(let ([L_END (unique-label)])
(list* (movl (Simple (car rand*)) eax)
(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 Lf)
(movl (mem (fx- 0 pri-tag) eax) ebx) (movl (mem (fx- 0 pri-tag) eax) ebx)
(if sec-mask (if sec-mask
(andl (int sec-mask) ebx) (andl (int sec-mask) ebx)
'(nop)) '(nop))
(cmpl (int sec-tag) ebx) (cmpl (int sec-tag) ebx)
(je Lt) (jne Lf)
L_END (jmp Lt)
ac))] ac)]
[else ac])) [Lf
(list* (movl eax ebx)
(andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx)
(jne Lf)
(movl (mem (fx- 0 pri-tag) eax) ebx)
(if sec-mask
(andl (int sec-mask) ebx)
'(nop))
(cmpl (int sec-tag) ebx)
(jne Lf)
ac)]
[Lt
(let ([L_END (unique-label)])
(list* (movl eax ebx)
(andl (int pri-mask) ebx)
(cmpl (int pri-tag) ebx)
(jne L_END)
(movl (mem (fx- 0 pri-tag) eax) ebx)
(if sec-mask
(andl (int sec-mask) ebx)
'(nop))
(cmpl (int sec-tag) ebx)
(je Lt)
L_END
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?)