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.

524
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,29 +1331,26 @@
(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 '()) (cond
(define (mark-uninlined x) [(assq x uninlined) =>
(cond (lambda (p) (set-cdr! p (fxadd1 (cdr p))))]
[(assq x uninlined) => [else (set! uninlined (cons (cons x 1) uninlined))]))
(lambda (p) (set-cdr! p (fxadd1 (cdr p))))] (module ()
[else (set! uninlined (cons (cons x 1) uninlined))])) (primitive-set! 'uninlined-stats
(lambda ()
(module () (let f ([ls uninlined] [ac '()])
(primitive-set! 'uninlined-stats (cond
(lambda () [(null? ls) ac]
(let f ([ls uninlined] [ac '()]) [(fx> (cdar ls) 15)
(cond (f (cdr ls) (cons (car ls) ac))]
[(null? ls) ac] [else (f (cdr ls) ac)]))))))
[(fx> (cdar ls) 15)
(f (cdr ls) (cons (car 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
(fxsll (fxsra (fx+ n (fxsub1 object-alignment)) align-shift) align-shift)) (define (align n)
(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,235 +3665,230 @@
(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)
(list
(module () (list 0
(list*->code* (lambda (x) #f) (label SL_car_error)
(list (movl ebx (mem (fx- 0 wordsize) fpr))
(list 0 (movl (primref-loc 'car-error) cpr)
(label SL_car_error) (movl (int (argc-convention 1)) eax)
(movl ebx (mem (fx- 0 wordsize) fpr)) (tail-indirect-cpr-call))
(movl (primref-loc 'car-error) cpr)
(movl (int (argc-convention 1)) eax) (list 0
(tail-indirect-cpr-call)) (label SL_cdr_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(list 0 (movl (primref-loc 'cdr-error) cpr)
(label SL_cdr_error) (movl (int (argc-convention 1)) eax)
(movl ebx (mem (fx- 0 wordsize) fpr)) (tail-indirect-cpr-call))
(movl (primref-loc 'cdr-error) cpr)
(movl (int (argc-convention 1)) eax) (list 0
(tail-indirect-cpr-call)) (label SL_top_level_value_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(list 0 (movl (primref-loc 'top-level-value-error) cpr)
(label SL_top_level_value_error) (movl (int (argc-convention 1)) eax)
(movl ebx (mem (fx- 0 wordsize) fpr)) (tail-indirect-cpr-call))
(movl (primref-loc 'top-level-value-error) cpr)
(movl (int (argc-convention 1)) eax) (let ([L_cwv_done (gensym)]
(tail-indirect-cpr-call)) [L_cwv_loop (gensym)]
[L_cwv_multi_rp (gensym)]
(let ([L_cwv_done (gensym)] [L_cwv_call (gensym)])
[L_cwv_loop (gensym)] (list
[L_cwv_multi_rp (gensym)] 0 ; no free vars
[L_cwv_call (gensym)]) (label SL_call_with_values)
(list (cmpl (int (argc-convention 2)) eax)
0 ; no free vars (jne (label SL_invalid_args))
(label SL_call_with_values) (movl (mem (fx- 0 wordsize) fpr) ebx) ; producer
(cmpl (int (argc-convention 2)) eax) (movl ebx cpr)
(jne (label SL_invalid_args)) (andl (int closure-mask) ebx)
(movl (mem (fx- 0 wordsize) fpr) ebx) ; producer (cmpl (int closure-tag) ebx)
(movl ebx cpr) (jne (label SL_nonprocedure))
(andl (int closure-mask) ebx) (movl (int (argc-convention 0)) eax)
(cmpl (int closure-tag) ebx) (subl (int (fx* wordsize 2)) fpr)
(jne (label SL_nonprocedure)) (jmp (label L_cwv_call))
(movl (int (argc-convention 0)) eax) ; MV NEW FRAME
(subl (int (fx* wordsize 2)) fpr) (byte-vector '#(#b110))
(jmp (label L_cwv_call)) (int (fx* wordsize 3))
; MV NEW FRAME '(current-frame-offset)
(byte-vector '#(#b110)) (label-address L_cwv_multi_rp)
(int (fx* wordsize 3)) (byte 0)
'(current-frame-offset) (byte 0)
(label-address L_cwv_multi_rp) (label L_cwv_call)
(byte 0) (indirect-cpr-call)
(byte 0) ;;; one value returned
(label L_cwv_call) (addl (int (fx* wordsize 2)) fpr)
(indirect-cpr-call) (movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer
;;; one value returned (movl ebx cpr)
(addl (int (fx* wordsize 2)) fpr) (movl eax (mem (fx- 0 wordsize) fpr))
(movl (mem (fx* -2 wordsize) fpr) ebx) ; consumer (movl (int (argc-convention 1)) eax)
(movl ebx cpr) (andl (int closure-mask) ebx)
(movl eax (mem (fx- 0 wordsize) fpr)) (cmpl (int closure-tag) ebx)
(movl (int (argc-convention 1)) eax) (jne (label SL_nonprocedure))
(andl (int closure-mask) ebx) (tail-indirect-cpr-call)
(cmpl (int closure-tag) ebx) ;;; multiple values returned
(jne (label SL_nonprocedure)) (label L_cwv_multi_rp)
(tail-indirect-cpr-call) ; because values does not pop the return point
;;; multiple values returned ; we have to adjust fp one more word here
(label L_cwv_multi_rp) (addl (int (fx* wordsize 3)) fpr)
; because values does not pop the return point (movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer
; we have to adjust fp one more word here (cmpl (int (argc-convention 0)) eax)
(addl (int (fx* wordsize 3)) fpr) (je (label L_cwv_done))
(movl (mem (fx* -2 wordsize) fpr) cpr) ; consumer (movl (int (fx* -4 wordsize)) ebx)
(cmpl (int (argc-convention 0)) eax) (addl fpr ebx) ; ebx points to first value
(je (label L_cwv_done)) (movl ebx ecx)
(movl (int (fx* -4 wordsize)) ebx) (addl eax ecx) ; ecx points to the last value
(addl fpr ebx) ; ebx points to first value (label L_cwv_loop)
(movl ebx ecx) (movl (mem 0 ebx) edx)
(addl eax ecx) ; ecx points to the last value (movl edx (mem (fx* 3 wordsize) ebx))
(label L_cwv_loop) (subl (int wordsize) ebx)
(movl (mem 0 ebx) edx) (cmpl ecx ebx)
(movl edx (mem (fx* 3 wordsize) ebx)) (jge (label L_cwv_loop))
(subl (int wordsize) ebx) (label L_cwv_done)
(cmpl ecx ebx) (movl cpr ebx)
(jge (label L_cwv_loop)) (andl (int closure-mask) ebx)
(label L_cwv_done) (cmpl (int closure-tag) ebx)
(movl cpr ebx) (jne (label SL_nonprocedure))
(andl (int closure-mask) ebx) (tail-indirect-cpr-call)))
(cmpl (int closure-tag) ebx)
(jne (label SL_nonprocedure)) (let ([L_values_one_value (gensym)]
(tail-indirect-cpr-call))) [L_values_many_values (gensym)])
(list 0 ; no freevars
(let ([L_values_one_value (gensym)] (label SL_values)
[L_values_many_values (gensym)]) (cmpl (int (argc-convention 1)) eax)
(list 0 ; no freevars (je (label L_values_one_value))
(label SL_values) (label L_values_many_values)
(cmpl (int (argc-convention 1)) eax) (movl (mem 0 fpr) ebx) ; return point
(je (label L_values_one_value)) (jmp (mem disp-multivalue-rp ebx)) ; go
(label L_values_many_values) (label L_values_one_value)
(movl (mem 0 fpr) ebx) ; return point (movl (mem (fx- 0 wordsize) fpr) eax)
(jmp (mem disp-multivalue-rp ebx)) ; go (ret)))
(label L_values_one_value)
(movl (mem (fx- 0 wordsize) fpr) eax) (let ([L_apply_done (gensym)]
(ret))) [L_apply_loop (gensym)])
(list 0
(let ([L_apply_done (gensym)] (label SL_apply)
[L_apply_loop (gensym)]) (movl (mem fpr eax) ebx)
(list 0 (cmpl (int nil) ebx)
(label SL_apply) (je (label L_apply_done))
(movl (mem fpr eax) ebx) (label L_apply_loop)
(cmpl (int nil) ebx) (movl (mem (fx- disp-car pair-tag) ebx) ecx)
(je (label L_apply_done)) (movl (mem (fx- disp-cdr pair-tag) ebx) ebx)
(label L_apply_loop) (movl ecx (mem fpr eax))
(movl (mem (fx- disp-car pair-tag) ebx) ecx) (subl (int wordsize) eax)
(movl (mem (fx- disp-cdr pair-tag) ebx) ebx) (cmpl (int nil) ebx)
(movl ecx (mem fpr eax)) (jne (label L_apply_loop))
(subl (int wordsize) eax) (label L_apply_done)
(cmpl (int nil) ebx) (addl (int wordsize) eax)
(jne (label L_apply_loop)) (tail-indirect-cpr-call)))
(label L_apply_done)
(addl (int wordsize) eax) (list 0
(tail-indirect-cpr-call))) (label SL_nonprocedure)
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(list 0 (movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
(label SL_nonprocedure) (movl (int (argc-convention 1)) eax)
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg (tail-indirect-cpr-call))
(movl (primref-loc '$apply-nonprocedure-error-handler) cpr)
(movl (int (argc-convention 1)) eax) (list 0
(tail-indirect-cpr-call)) (label SL_multiple_values_error_rp)
(movl (primref-loc '$multiple-values-error) cpr)
(list 0 (tail-indirect-cpr-call))
(label SL_multiple_values_error_rp)
(movl (primref-loc '$multiple-values-error) cpr) (list 0
(tail-indirect-cpr-call)) (label SL_multiple_values_ignore_rp)
(ret))
(list 0
(label SL_multiple_values_ignore_rp) (list 0
(ret)) (label SL_invalid_args)
;;;
(list 0 (movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg
(label SL_invalid_args) (negl eax)
;;; (movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr))
(movl cpr (mem (fx- 0 wordsize) fpr)) ; first arg (movl (primref-loc '$incorrect-args-error-handler) cpr)
(negl eax) (movl (int (argc-convention 2)) eax)
(movl eax (mem (fx- 0 (fx* 2 wordsize)) fpr)) (tail-indirect-cpr-call))
(movl (primref-loc '$incorrect-args-error-handler) cpr)
(movl (int (argc-convention 2)) eax) (let ([Lset (gensym)] [Lloop (gensym)])
(tail-indirect-cpr-call)) (list 0
(label SL_foreign_call)
(let ([Lset (gensym)] [Lloop (gensym)]) (movl fpr (pcb-ref 'frame-pointer))
(list 0 (movl apr (pcb-ref 'allocation-pointer))
(label SL_foreign_call) (movl fpr ebx)
(movl fpr (pcb-ref 'frame-pointer)) (movl (pcb-ref 'system-stack) esp)
(movl apr (pcb-ref 'allocation-pointer)) (pushl pcr)
(movl fpr ebx) (cmpl (int 0) eax)
(movl (pcb-ref 'system-stack) esp) (je (label Lset))
(pushl pcr) (label Lloop)
(cmpl (int 0) eax) (movl (mem ebx eax) ecx)
(je (label Lset)) (pushl ecx)
(label Lloop) (addl (int 4) eax)
(movl (mem ebx eax) ecx) (cmpl (int 0) eax)
(pushl ecx) (jne (label Lloop))
(addl (int 4) eax) (label Lset)
(cmpl (int 0) eax) ; FOREIGN NEW FRAME
(jne (label Lloop)) (call cpr)
(label Lset) (movl (pcb-ref 'frame-pointer) fpr)
; FOREIGN NEW FRAME (movl (pcb-ref 'allocation-pointer) apr)
(call cpr) (ret)))
(movl (pcb-ref 'frame-pointer) fpr)
(movl (pcb-ref 'allocation-pointer) apr) (let ([L_cont_zero_args (gensym)]
(ret))) [L_cont_mult_args (gensym)]
[L_cont_one_arg (gensym)]
(let ([L_cont_zero_args (gensym)] [L_cont_mult_move_args (gensym)]
[L_cont_mult_args (gensym)] [L_cont_mult_copy_loop (gensym)])
[L_cont_one_arg (gensym)] (list 1 ; freevars
[L_cont_mult_move_args (gensym)] (label SL_continuation_code)
[L_cont_mult_copy_loop (gensym)]) (movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k
(list 1 ; freevars (movl ebx (pcb-ref 'next-continuation)) ; set
(label SL_continuation_code) (movl (pcb-ref 'frame-base) ebx)
(movl (mem (fx- disp-closure-data closure-tag) cpr) ebx) ; captured-k (cmpl (int (argc-convention 1)) eax)
(movl ebx (pcb-ref 'next-continuation)) ; set (jg (label L_cont_zero_args))
(movl (pcb-ref 'frame-base) ebx) (jl (label L_cont_mult_args))
(cmpl (int (argc-convention 1)) eax) (label L_cont_one_arg)
(jg (label L_cont_zero_args)) (movl (mem (fx- 0 wordsize) fpr) eax)
(jl (label L_cont_mult_args)) (movl ebx fpr)
(label L_cont_one_arg) (subl (int wordsize) fpr)
(movl (mem (fx- 0 wordsize) fpr) eax) (ret)
(movl ebx fpr) (label L_cont_zero_args)
(subl (int wordsize) fpr) (subl (int wordsize) ebx)
(ret) (movl ebx fpr)
(label L_cont_zero_args) (movl (mem 0 ebx) ebx) ; return point
(subl (int wordsize) ebx) (jmp (mem disp-multivalue-rp ebx)) ; go
(movl ebx fpr) (label L_cont_mult_args)
(movl (mem 0 ebx) ebx) ; return point (subl (int wordsize) ebx)
(jmp (mem disp-multivalue-rp ebx)) ; go (cmpl ebx fpr)
(label L_cont_mult_args) (jne (label L_cont_mult_move_args))
(subl (int wordsize) ebx) (movl (mem 0 ebx) ebx)
(cmpl ebx fpr) (jmp (mem disp-multivalue-rp ebx))
(jne (label L_cont_mult_move_args)) (label L_cont_mult_move_args)
(movl (mem 0 ebx) ebx) ; move args from fpr to ebx
(jmp (mem disp-multivalue-rp ebx)) (movl (int 0) ecx)
(label L_cont_mult_move_args) (label L_cont_mult_copy_loop)
; move args from fpr to ebx (subl (int wordsize) ecx)
(movl (int 0) ecx) (movl (mem fpr ecx) edx)
(label L_cont_mult_copy_loop) (movl edx (mem ebx ecx))
(subl (int wordsize) ecx) (cmpl ecx eax)
(movl (mem fpr ecx) edx) (jne (label L_cont_mult_copy_loop))
(movl edx (mem ebx ecx)) (movl ebx fpr)
(cmpl ecx eax) (movl (mem 0 ebx) ebx)
(jne (label L_cont_mult_copy_loop)) (jmp (mem disp-multivalue-rp ebx))
(movl ebx fpr) ))
(movl (mem 0 ebx) 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)]