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

cleaup optimizr a bit

This commit is contained in:
Abdulaziz Ghuloum 2006-12-05 21:30:42 -05:00
parent 6e6291e158
commit 0d476b91e2
2 changed files with 26 additions and 27 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.

49
lib/libcompile.ss
View File

@ -866,13 +866,12 @@
(define (optimize-primcall ctxt op rand*) (define (optimize-primcall ctxt op rand*)
(define (giveup) (define (giveup)
(make-funcall (make-primref op) rand*)) (make-funcall (make-primref op) rand*))
(define (known-value x) (define (constant-value x k)
(record-case x (record-case x
[(constant) x] ; known [(constant t) (k t)] ; known
[(primref) x] ; known [(bind lhs* rhs* body) (constant-value body k)]
[(bind lhs* rhs* body) (known-value body)] [(fix lhs* rhs* body) (constant-value body k)]
[(fix lhs* rhs* body) (known-value body)] [(seq e0 e1) (constant-value e1 k)]
[(seq e0 e1) (known-value e1)]
[else #f])) [else #f]))
(define (mk-seq e0 e1) ;;; keep e1 seq-free. (define (mk-seq e0 e1) ;;; keep e1 seq-free.
(cond (cond
@ -883,27 +882,27 @@
(make-seq e0 e1)])) (make-seq e0 e1)]))
(case op (case op
[(memv) [(memv)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])
(constant-value a1
(lambda (ls)
(cond (cond
[(fx= (length rand*) 2) [(not (list? ls)) #f]
(let ([x (car rand*)] [ls (cadr rand*)]) [(eq? ctxt 'e) (mk-seq a0 a1)]
(cond [(constant-value a0
[(known-value ls) => (lambda (x)
(lambda (kls) (mk-seq (mk-seq a0 a1)
(record-case kls (case ctxt
[(constant t) [(v) (make-constant (memv x ls))]
(cond [else (make-constant
[(not (list? t)) (giveup)] (if (memv x ls) #t #f))]))))]
[(eq? ctxt 'e) (mk-seq x ls)] [(andmap
[(andmap (lambda (x) (lambda (x)
(if (number? x) (if (number? x) (fixnum? x) #t))
(fixnum? x) ls)
#t))
t)
(optimize-primcall ctxt 'memq rand*)] (optimize-primcall ctxt 'memq rand*)]
[else (giveup)])] [else #f])))))
[else (giveup)]))] (giveup))]
[else (giveup)]))]
[else (giveup)])]
[else (giveup)])) [else (giveup)]))