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.

53
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)
(cond (or (and (fx= (length rand*) 2)
[(fx= (length rand*) 2) (let ([a0 (car rand*)] [a1 (cadr rand*)])
(let ([x (car rand*)] [ls (cadr rand*)]) (constant-value a1
(cond (lambda (ls)
[(known-value ls) => (cond
(lambda (kls) [(not (list? ls)) #f]
(record-case kls [(eq? ctxt 'e) (mk-seq a0 a1)]
[(constant t) [(constant-value a0
(cond (lambda (x)
[(not (list? t)) (giveup)] (mk-seq (mk-seq a0 a1)
[(eq? ctxt 'e) (mk-seq x ls)] (case ctxt
[(andmap (lambda (x) [(v) (make-constant (memv x ls))]
(if (number? x) [else (make-constant
(fixnum? x) (if (memv x ls) #t #f))]))))]
#t)) [(andmap
t) (lambda (x)
(optimize-primcall ctxt 'memq rand*)] (if (number? x) (fixnum? x) #t))
[else (giveup)])] ls)
[else (giveup)]))] (optimize-primcall ctxt 'memq rand*)]
[else (giveup)]))] [else #f])))))
[else (giveup)])] (giveup))]
[else (giveup)])) [else (giveup)]))