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

code cleanup

This commit is contained in:
Abdulaziz Ghuloum 2006-12-04 13:10:28 -05:00
parent d6a0ffa3ea
commit 3b39b890b9
2 changed files with 252 additions and 272 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.

90
lib/libcompile.ss
View File

@ -1188,6 +1188,9 @@
free (unparse prog))) free (unparse prog)))
prog)) prog))
(define (optimize-closures x)
(define who 'optimize-closures)
x)
(define (lift-codes x) (define (lift-codes x)
(define who 'lift-codes) (define who 'lift-codes)
@ -1226,9 +1229,6 @@
(let ([x (E x)]) (let ([x (E x)])
(make-codes all-codes x))) (make-codes all-codes x)))
(define (syntactically-valid? op rand*) (define (syntactically-valid? op rand*)
(define (valid-arg-count? op rand*) (define (valid-arg-count? op rand*)
(let ([n (open-coded-primitive-args op)] [m (length rand*)]) (let ([n (open-coded-primitive-args op)] [m (length rand*)])
@ -1331,21 +1331,18 @@
(or (null? rand*) (or (null? rand*)
(valid-arg-types? op rand*)))) (valid-arg-types? op rand*))))
(begin ;;; UNINLINED ANALYSIS
;;; the output of simplify-operands differs from the input in that the ;;; the output of simplify-operands differs from the input in that the
;;; operands to primcalls are all simple (variables, primrefs, or constants). ;;; operands to primcalls are all simple (variables, primrefs, or constants).
;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to ;;; funcalls to open-codable primrefs whos arguments are "ok" are converted to
;;; primcalls. ;;; primcalls.
(define uninlined '())
(define (mark-uninlined x)
(define uninlined '())
(define (mark-uninlined x)
(cond (cond
[(assq x uninlined) => [(assq x uninlined) =>
(lambda (p) (set-cdr! p (fxadd1 (cdr p))))] (lambda (p) (set-cdr! p (fxadd1 (cdr p))))]
[else (set! uninlined (cons (cons x 1) uninlined))])) [else (set! uninlined (cons (cons x 1) uninlined))]))
(module ()
(module ()
(primitive-set! 'uninlined-stats (primitive-set! 'uninlined-stats
(lambda () (lambda ()
(let f ([ls uninlined] [ac '()]) (let f ([ls uninlined] [ac '()])
@ -1353,7 +1350,7 @@
[(null? ls) ac] [(null? ls) ac]
[(fx> (cdar ls) 15) [(fx> (cdar ls) 15)
(f (cdr ls) (cons (car ls) ac))] (f (cdr ls) (cons (car ls) ac))]
[else (f (cdr ls) ac)]))))) [else (f (cdr ls) ac)]))))))
(define (introduce-primcalls x) (define (introduce-primcalls x)
(define who 'introduce-primcalls) (define who 'introduce-primcalls)
@ -1445,7 +1442,6 @@
(make-codes (map CodeExpr list) (Tail body))])) (make-codes (map CodeExpr list) (Tail body))]))
(CodesExpr x)) (CodesExpr x))
(define (simplify-operands x) (define (simplify-operands x)
(define who 'simplify-operands) (define who 'simplify-operands)
(define (simple? x) (define (simple? x)
@ -1522,7 +1518,6 @@
(make-codes (map CodeExpr list) (Tail body))])) (make-codes (map CodeExpr list) (Tail body))]))
(CodesExpr x)) (CodesExpr x))
(define (insert-stack-overflow-checks x) (define (insert-stack-overflow-checks x)
(define who 'insert-stack-overflow-checks) (define who 'insert-stack-overflow-checks)
(define (insert-check body) (define (insert-check body)
@ -1580,7 +1575,6 @@
body))])) body))]))
(CodesExpr x)) (CodesExpr x))
(define (insert-allocation-checks x) (define (insert-allocation-checks x)
(define who 'insert-allocation-checks) (define who 'insert-allocation-checks)
(define (check-bytes n var body) (define (check-bytes n var body)
@ -1724,8 +1718,6 @@
(make-codes (map CodeExpr list) (Tail body))])) (make-codes (map CodeExpr list) (Tail body))]))
(CodesExpr x)) (CodesExpr x))
(define (remove-local-variables x) (define (remove-local-variables x)
(define who 'remove-local-variables) (define who 'remove-local-variables)
(define (simple* x* r) (define (simple* x* r)
@ -1967,9 +1959,6 @@
(Tail body 1 '() '()))])) (Tail body 1 '() '()))]))
(CodesExpr x)) (CodesExpr x))
(define checks-elim-count 0)
(define (optimize-ap-check x) (define (optimize-ap-check x)
(define who 'optimize-ap-check) (define who 'optimize-ap-check)
(define (min x y) (define (min x y)
@ -1998,8 +1987,6 @@
(let ([n (constant-value (car arg*))]) (let ([n (constant-value (car arg*))])
(cond (cond
[(fx< n f) [(fx< n f)
;(set! checks-elim-count (fxadd1 checks-elim-count))
;(printf "~s checks eliminated\n" checks-elim-count)
(values (make-constant #f) (fx- f n))] (values (make-constant #f) (fx- f n))]
[(fx<= n 4096) [(fx<= n 4096)
(values (make-primcall '$ap-check-const (values (make-primcall '$ap-check-const
@ -2073,7 +2060,7 @@
(Tail body 0))])) (Tail body 0))]))
(CodesExpr x)) (CodesExpr x))
(begin (begin ;;; DEFINITIONS
(define fx-shift 2) (define fx-shift 2)
(define fx-mask #x03) (define fx-mask #x03)
(define fx-tag 0) (define fx-tag 0)
@ -2162,10 +2149,9 @@
(define align-shift 3) (define align-shift 3)
(define dirty-word -1)) (define dirty-word -1))
(define (align n) (begin ;;; COGEN HELERS
(define (align n)
(fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift)) (fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift))
(begin
(define (mem off val) (define (mem off val)
(cond (cond
[(fixnum? off) (list 'disp (int off) val)] [(fixnum? off) (list 'disp (int off) val)]
@ -2234,7 +2220,6 @@
(define (argc-convention n) (define (argc-convention n)
(fx- 0 (fxsll n fx-shift)))) (fx- 0 (fxsll n fx-shift))))
(define pcb-ref (define pcb-ref
(lambda (x) (lambda (x)
(case x (case x
@ -2254,7 +2239,6 @@
(mem (fx- disp-symbol-system-value symbol-tag) (mem (fx- disp-symbol-system-value symbol-tag)
(obj op))) (obj op)))
(define (generate-code x) (define (generate-code x)
(define who 'generate-code) (define who 'generate-code)
(define (rp-label x) (define (rp-label x)
@ -3681,27 +3665,24 @@
(Tail body '())) (Tail body '()))
(map CodeExpr list))])) (map CodeExpr list))]))
(begin ;;; ASSEMBLY HELPERS
(define SL_nonprocedure (gensym "SL_nonprocedure")) (define SL_nonprocedure (gensym "SL_nonprocedure"))
(define SL_top_level_value_error (gensym "SL_top_level_value_error"))
(define SL_top_level_value_error (gensym "SL_top_level_value_error")) (define SL_car_error (gensym "SL_car_error"))
(define SL_car_error (gensym "SL_car_error")) (define SL_cdr_error (gensym "SL_cdr_error"))
(define SL_cdr_error (gensym "SL_cdr_error")) (define SL_invalid_args (gensym "SL_invalid_args"))
(define SL_foreign_call (gensym "SL_foreign_call"))
(define SL_invalid_args (gensym "SL_invalid_args")) (define SL_continuation_code (gensym "SL_continuation_code"))
(define SL_foreign_call (gensym "SL_foreign_call")) (define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp"))
(define SL_continuation_code (gensym "SL_continuation_code")) (define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp"))
(define SL_multiple_values_error_rp (gensym "SL_multiple_values_error_rp")) (define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values"))
(define SL_multiple_values_ignore_rp (gensym "SL_multiple_ignore_error_rp")) (define SL_underflow_handler (gensym "SL_underflow_handler"))
(define SL_underflow_multiple_values (gensym "SL_underflow_multiple_values")) (define SL_scheme_exit (gensym "SL_scheme_exit"))
(define SL_underflow_handler (gensym "SL_underflow_handler")) (define SL_apply (gensym "SL_apply"))
(define SL_scheme_exit (gensym "SL_scheme_exit")) (define SL_values (gensym "SL_values"))
(define SL_apply (gensym "SL_apply")) (define SL_call_with_values (gensym "SL_call_with_values"))
(define SL_values (gensym "SL_values")) (module ()
(define SL_call_with_values (gensym "SL_call_with_values")) (list*->code* (lambda (x) #f)
(module ()
(list*->code* (lambda (x) #f)
(list (list
(list 0 (list 0
(label SL_car_error) (label SL_car_error)
@ -3907,9 +3888,7 @@
(movl (mem 0 ebx) ebx) (movl (mem 0 ebx) ebx)
(jmp (mem disp-multivalue-rp ebx)) (jmp (mem disp-multivalue-rp ebx))
)) ))
))) ))))
(define (compile-expr expr) (define (compile-expr expr)
(let* ([p (recordize expr)] (let* ([p (recordize expr)]
@ -3921,6 +3900,7 @@
[p (copy-propagate p)] [p (copy-propagate p)]
[p (rewrite-assignments p)] [p (rewrite-assignments p)]
[p (convert-closures p)] [p (convert-closures p)]
[p (optimize-closures p)]
[p (lift-codes p)] [p (lift-codes p)]
[p (introduce-primcalls p)] [p (introduce-primcalls p)]
[p (simplify-operands p)] [p (simplify-operands p)]