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

more stupid optimizations

This commit is contained in:
Abdulaziz Ghuloum 2006-12-06 01:26:44 -05:00
parent 06c64dab3a
commit 6b0ec86de6
2 changed files with 33 additions and 9 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.

42
lib/libcompile.ss
View File

@ -876,7 +876,7 @@
(for-each (for-each
(lambda (x) (lambda (x)
(let ([n (getprop x '*compiler-giveup-tally*)]) (let ([n (getprop x '*compiler-giveup-tally*)])
(when (> n 100) (when (>= n 40)
(printf "~s ~s\n" n x)))) (printf "~s ~s\n" n x))))
giveup-list)) giveup-list))
(primitive-set! 'compiler-giveup-tally print-tally)) (primitive-set! 'compiler-giveup-tally print-tally))
@ -911,9 +911,17 @@
645 list 645 list
|# |#
(define (optimize-primcall ctxt op rand*) (module (optimize-primcall)
(define (giveup) (define (optimize-primcall ctxt op rand*)
(make-funcall (make-primref op) rand*)) (cond
[(getprop op *cookie*) =>
(lambda (proc)
(proc ctxt op rand*
(lambda ()
(make-funcall (make-primref op) rand*))))]
[else
(tally-giveup op)
(make-funcall (make-primref op) rand*)]))
(define (constant-value x k) (define (constant-value x k)
(record-case x (record-case x
[(constant t) (k t)] ; known [(constant t) (k t)] ; known
@ -930,7 +938,16 @@
(make-seq e0 e1)])) (make-seq e0 e1)]))
(define (equable? x) (define (equable? x)
(if (number? x) (fixnum? x) #t)) (if (number? x) (fixnum? x) #t))
(case op (define *cookie* (gensym "optimizer-cookie"))
(define-syntax set-cases
(syntax-rules ()
[(_ ctxt op rand* giveup
[(op** ...) b* b** ...] ...)
(begin
(let ([p (lambda (ctxt op rand* giveup) b* b** ...)])
(putprop 'op** *cookie* p) ...
(void)) ...)]))
(set-cases ctxt op rand* giveup
[(eq?) [(eq?)
(or (and (fx= (length rand*) 2) (or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)]) (let ([a0 (car rand*)] [a1 (cadr rand*)])
@ -1086,7 +1103,8 @@
[(car) (car v)] [(car) (car v)]
[else (cdr v)])))))))) [else (cdr v)]))))))))
(giveup))] (giveup))]
[(not null? pair? fixnum? vector?) [(not null? pair? fixnum? vector? string? char? symbol?
eof-object?)
(or (and (fx= (length rand*) 1) (or (and (fx= (length rand*) 1)
(let ([a (car rand*)]) (let ([a (car rand*)])
(case ctxt (case ctxt
@ -1102,6 +1120,10 @@
[(pair?) (pair? v)] [(pair?) (pair? v)]
[(fixnum?) (fixnum? v)] [(fixnum?) (fixnum? v)]
[(vector?) (vector? v)] [(vector?) (vector? v)]
[(string?) (string? v)]
[(char?) (char? v)]
[(symbol?) (symbol? v)]
[(eof-object?) (eof-object? v)]
[else [else
(error 'optimize (error 'optimize
"huh ~s" op)])))))]))) "huh ~s" op)])))))])))
@ -1123,9 +1145,11 @@
(giveup)))) (giveup))))
(error 'optimize "incorrect args ~s to ~s" (error 'optimize "incorrect args ~s to ~s"
(map unparse rand*) op))] (map unparse rand*) op))]
[else ;;; unoptimizables
(tally-giveup op) [(error syntax-error $syntax-dispatch $sc-put-cte
(giveup)])) primitive-set! apply)
(giveup)]
))
(define (copy-propagate x) (define (copy-propagate x)