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

* removed one instance of build-graph which reduces compile time 

from 225 secs down to 17!  Sweet!
This commit is contained in:
Abdulaziz Ghuloum 2007-06-06 02:32:45 +03:00
parent feb9764645
commit 7301be0ab0
2 changed files with 26 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

55
src/libaltcogen.ss
View File

@ -1998,15 +1998,16 @@
(record-case x (record-case x
[(locals vars body) [(locals vars body)
(init-vars! vars) (init-vars! vars)
(let ([v (list->vector vars)]) (let ([varvec (list->vector vars)])
(let ([call-live* (uncover-frame-conflicts body v)]) (let ([call-live* (uncover-frame-conflicts body varvec)])
(let ([body (rewrite body v)]) (let ([body (rewrite body varvec)])
(make-locals (make-locals
(let f ([vars vars]) (cons varvec
(cond (let f ([vars vars])
[(null? vars) '()] (cond
[(var-loc (car vars)) (f (cdr vars))] [(null? vars) '()]
[else (cons (car vars) (f (cdr vars)))])) [(var-loc (car vars)) (f (cdr vars))]
[else (cons (car vars) (f (cdr vars)))])))
body))))] body))))]
[else (error 'assign-frame-sizes "invalid main ~s" x)])) [else (error 'assign-frame-sizes "invalid main ~s" x)]))
;;; ;;;
@ -2212,7 +2213,7 @@
(values (cons sp spills) sp* env))))))] (values (cons sp spills) sp* env))))))]
[else (error 'color-graph "whoaaa")])) [else (error 'color-graph "whoaaa")]))
;;; ;;;
(define (substitute env x frm-graph) (define (substitute env x)
(define who 'substitute) (define who 'substitute)
(define (Var x) (define (Var x)
(cond (cond
@ -2288,24 +2289,20 @@
;(print-code x) ;(print-code x)
(T x)) (T x))
;;; ;;;
(define (do-spill sp* g) (define (do-spill sp* varvec)
(import conflict-helpers)
(define (find/set-loc x) (define (find/set-loc x)
(let ([ls (set->list (node-neighbors x g))]) (let f ([i 1] [conf (var-frm-conf x)])
(define (conflicts? i ls) (let ([fv (mkfvar i)])
(and (pair? ls)
(or (record-case (car ls)
[(fvar j)
(and (fixnum? j) (fx= i j))]
[else #f])
(conflicts? i (cdr ls)))))
(let f ([i 1])
(cond (cond
[(conflicts? i ls) (f (fxadd1 i))] [(mem-frm? fv conf) (f (fxadd1 i) conf)]
[else [else
(let ([fv (mkfvar i)]) (for-each-var (var-var-conf x) varvec
(for-each (lambda (y) (add-edge! g y fv)) ls) (lambda (y)
(delete-node! x g) (set-var-frm-conf! y
(cons x fv))])))) (add-frm fv (var-frm-conf y)))))
(set-var-loc! x fv)
(cons x fv)]))))
(map find/set-loc sp*)) (map find/set-loc sp*))
;;; ;;;
(define (add-unspillables un* x) (define (add-unspillables un* x)
@ -2477,8 +2474,8 @@
(define (color-program x) (define (color-program x)
(define who 'color-program) (define who 'color-program)
(record-case x (record-case x
[(locals sp* body) [(locals vars body)
(let ([frame-g (build-graph body fvar?)]) (let ([varvec (car vars)] [sp* (cdr vars)])
(let loop ([sp* (list->set sp*)] [un* (make-empty-set)] [body body]) (let loop ([sp* (list->set sp*)] [un* (make-empty-set)] [body body])
(let-values ([(un* body) (add-unspillables un* body)]) (let-values ([(un* body) (add-unspillables un* body)])
(let ([g (build-graph body (let ([g (build-graph body
@ -2487,10 +2484,10 @@
(memq x all-registers))))]) (memq x all-registers))))])
(let-values ([(spills sp* env) (color-graph sp* un* g)]) (let-values ([(spills sp* env) (color-graph sp* un* g)])
(cond (cond
[(null? spills) (substitute env body frame-g)] [(null? spills) (substitute env body)]
[else [else
(let* ([env (do-spill spills frame-g)] (let* ([env (do-spill spills varvec)]
[body (substitute env body frame-g)]) [body (substitute env body)])
(loop sp* un* body))]))))))])) (loop sp* un* body))]))))))]))
;;; ;;;
(define (color-by-chaitin x) (define (color-by-chaitin x)