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

* Cleanup of some junk code in color-by-chaitin

This commit is contained in:
Abdulaziz Ghuloum 2007-06-06 01:16:34 +03:00
parent 1dc9e83448
commit feb9764645
2 changed files with 427 additions and 487 deletions

BIN
src/ikarus.boot
View File

Binary file not shown.

914
src/libaltcogen.ss
View File

@ -1319,49 +1319,17 @@
;;; ;;;
#|IntegerGraphs|#) #|IntegerGraphs|#)
(module (assign-frame-sizes) (module conflict-helpers
;;; assign-frame-sizes module (empty-var-set rem-var add-var union-vars mem-var? for-each-var init-vars!
(define indent (make-parameter 0)) empty-nfv-set rem-nfv add-nfv union-nfvs mem-nfv? for-each-nfv init-nfv!
empty-frm-set rem-frm add-frm union-frms mem-frm?
empty-reg-set rem-reg add-reg union-regs mem-reg?
reg?)
(import IntegerSet) (import IntegerSet)
(define (has-nontail-call? x)
(define who 'has-nontail-call?)
(define (E x)
(record-case x
[(seq e0 e1) (or (E e0) (E e1))]
[(conditional e0 e1 e2)
(or (P e0) (E e1) (E e2))]
[(nframe) #t]
[(asm-instr) #f]
[(primcall op args)
(case op
[(interrupt nop) #f]
[else (error who "invalid effect ~s" (unparse x))])]
[(shortcut body handler)
(or (E body) (E handler))]
[else (error who "invalid effect ~s" x)]))
(define (P x)
(record-case x
[(seq e0 e1) (or (E e0) (P e1))]
[(conditional e0 e1 e2)
(or (P e0) (P e1) (P e2))]
[(asm-instr) #f]
[(constant) #f]
[(shortcut body handler)
(or (P body) (P handler))]
[else (error who "invalid pred ~s" x)]))
(define (T x)
(record-case x
[(seq e0 e1)
(or (E e0) (T e1))]
[(conditional e0 e1 e2)
(or (P e0) (T e1) (T e2))]
[(primcall) #f]
[(shortcut body handler)
(or (T body) (T handler))]
[else (error who "invalid tail ~s" x)]))
(T x))
;;;
(begin (begin
(define (add-frm x s) (set-add (fvar-idx x) s))
(define (rem-nfv x s)
(remq x s))
(define (init-var! x i) (define (init-var! x i)
(set-var-index! x i) (set-var-index! x i)
(set-var-var-move! x (empty-var-set)) (set-var-var-move! x (empty-var-set))
@ -1394,7 +1362,6 @@
(define (mem-reg? x s) (set-member? (register-index x) s)) (define (mem-reg? x s) (set-member? (register-index x) s))
(define (union-regs s1 s2) (set-union s1 s2)) (define (union-regs s1 s2) (set-union s1 s2))
(define (empty-frm-set) (make-empty-set)) (define (empty-frm-set) (make-empty-set))
(define (add-frm x s) (set-add (fvar-idx x) s))
(define (mem-frm? x s) (set-member? (fvar-idx x) s)) (define (mem-frm? x s) (set-member? (fvar-idx x) s))
(define (rem-frm x s) (set-rem (fvar-idx x) s)) (define (rem-frm x s) (set-rem (fvar-idx x) s))
(define (union-frms s1 s2) (set-union s1 s2)) (define (union-frms s1 s2) (set-union s1 s2))
@ -1403,8 +1370,6 @@
(cond (cond
[(memq x s) s] [(memq x s) s]
[else (cons x s)])) [else (cons x s)]))
(define (rem-nfv x s)
(remq x s))
(define (mem-nfv? x s) (define (mem-nfv? x s)
(memq x s)) (memq x s))
(define (union-nfvs s1 s2) (define (union-nfvs s1 s2)
@ -1414,399 +1379,401 @@
[(memq (car s1) s2) (f (cdr s1) s2)] [(memq (car s1) s2) (f (cdr s1) s2)]
[else (cons (car s1) (f (cdr s1) s2))]))) [else (cons (car s1) (f (cdr s1) s2))])))
(define (for-each-nfv s f) (define (for-each-nfv s f)
(for-each f s))) (for-each f s))))
;;;
(define (uncover-frame-conflicts x varvec) (define (uncover-frame-conflicts x varvec)
(define who 'uncover-frame-conflicts) (import IntegerSet)
(define spill-set (make-empty-set)) (import conflict-helpers)
(define (mark-reg/vars-conf! r vs) (define who 'uncover-frame-conflicts)
(for-each-var vs varvec (define spill-set (make-empty-set))
(lambda (v) (define (mark-reg/vars-conf! r vs)
(set-var-reg-conf! v (for-each-var vs varvec
(add-reg r (var-reg-conf v)))))) (lambda (v)
(define (mark-frm/vars-conf! f vs) (set-var-reg-conf! v
(for-each-var vs varvec (add-reg r (var-reg-conf v))))))
(lambda (v) (define (mark-frm/vars-conf! f vs)
(set-var-frm-conf! v (for-each-var vs varvec
(add-frm f (var-frm-conf v)))))) (lambda (v)
(define (mark-frm/nfvs-conf! f ns) (set-var-frm-conf! v
(for-each-nfv ns (add-frm f (var-frm-conf v))))))
(lambda (n) (define (mark-frm/nfvs-conf! f ns)
(set-nfv-frm-conf! n (for-each-nfv ns
(add-frm f (nfv-frm-conf n)))))) (lambda (n)
(define (mark-var/vars-conf! v vs) (set-nfv-frm-conf! n
(for-each-var vs varvec (add-frm f (nfv-frm-conf n))))))
(lambda (w) (define (mark-var/vars-conf! v vs)
(set-var-var-conf! w (for-each-var vs varvec
(add-var v (var-var-conf w))))) (lambda (w)
(set-var-var-conf! v (set-var-var-conf! w
(union-vars vs (var-var-conf v)))) (add-var v (var-var-conf w)))))
(define (mark-var/frms-conf! v fs) (set-var-var-conf! v
(set-var-frm-conf! v (union-vars vs (var-var-conf v))))
(union-frms fs (var-frm-conf v)))) (define (mark-var/frms-conf! v fs)
(define (mark-var/regs-conf! v rs) (set-var-frm-conf! v
(set-var-reg-conf! v (union-frms fs (var-frm-conf v))))
(union-regs rs (var-reg-conf v)))) (define (mark-var/regs-conf! v rs)
(define (mark-var/nfvs-conf! v ns) (set-var-reg-conf! v
(for-each-nfv ns (union-regs rs (var-reg-conf v))))
(lambda (n) (define (mark-var/nfvs-conf! v ns)
(set-nfv-var-conf! n (for-each-nfv ns
(add-var v (nfv-var-conf n)))))) (lambda (n)
(define (mark-nfv/vars-conf! n vs) (set-nfv-var-conf! n
(set-nfv-var-conf! n (add-var v (nfv-var-conf n))))))
(union-vars vs (nfv-var-conf n)))) (define (mark-nfv/vars-conf! n vs)
(define (mark-nfv/frms-conf! n fs) (set-nfv-var-conf! n
(set-nfv-frm-conf! n (union-vars vs (nfv-var-conf n))))
(union-frms fs (nfv-frm-conf n)))) (define (mark-nfv/frms-conf! n fs)
(define (mark-nfv/nfvs-conf! n ns) (set-nfv-frm-conf! n
(set-nfv-nfv-conf! n (union-frms fs (nfv-frm-conf n))))
(union-nfvs ns (nfv-nfv-conf n))) (define (mark-nfv/nfvs-conf! n ns)
(for-each-nfv ns (set-nfv-nfv-conf! n
(lambda (m) (union-nfvs ns (nfv-nfv-conf n)))
(set-nfv-nfv-conf! m (for-each-nfv ns
(add-nfv n (nfv-nfv-conf m)))))) (lambda (m)
(define (mark-var/var-move! x y) (set-nfv-nfv-conf! m
(set-var-var-move! x (add-nfv n (nfv-nfv-conf m))))))
(add-var y (var-var-move x))) (define (mark-var/var-move! x y)
(set-var-var-move! y (set-var-var-move! x
(add-var x (var-var-move y)))) (add-var y (var-var-move x)))
(define (mark-var/frm-move! x y) (set-var-var-move! y
(set-var-frm-move! x (add-var x (var-var-move y))))
(add-frm y (var-frm-move x)))) (define (mark-var/frm-move! x y)
(define (mark-var/reg-move! x y) (set-var-frm-move! x
(set-var-reg-move! x (add-frm y (var-frm-move x))))
(add-reg y (var-reg-move x)))) (define (mark-var/reg-move! x y)
(define (const? x) (set-var-reg-move! x
(or (constant? x) (add-reg y (var-reg-move x))))
(code-loc? x))) (define (const? x)
(define (R x vs rs fs ns) (or (constant? x)
(cond (code-loc? x)))
[(const? x) (values vs rs fs ns)] (define (R x vs rs fs ns)
[(reg? x) (cond
(values vs (add-reg x rs) fs ns)] [(const? x) (values vs rs fs ns)]
[(fvar? x) [(reg? x)
(values vs rs (add-frm x fs) ns)] (values vs (add-reg x rs) fs ns)]
[(var? x) [(fvar? x)
(values (add-var x vs) rs fs ns)] (values vs rs (add-frm x fs) ns)]
[(nfv? x) [(var? x)
(values vs rs fs (add-nfv x ns))] (values (add-var x vs) rs fs ns)]
[(disp? x) [(nfv? x)
(let-values ([(vs rs fs ns) (R (disp-s0 x) vs rs fs ns)]) (values vs rs fs (add-nfv x ns))]
(R (disp-s1 x) vs rs fs ns))] [(disp? x)
[else (error who "invalid R ~s" x)])) (let-values ([(vs rs fs ns) (R (disp-s0 x) vs rs fs ns)])
(define (R* ls vs rs fs ns) (R (disp-s1 x) vs rs fs ns))]
(cond [else (error who "invalid R ~s" x)]))
[(null? ls) (values vs rs fs ns)] (define (R* ls vs rs fs ns)
[else (cond
(let-values ([(vs rs fs ns) (R (car ls) vs rs fs ns)]) [(null? ls) (values vs rs fs ns)]
(R* (cdr ls) vs rs fs ns))])) [else
(define (E x vs rs fs ns) (let-values ([(vs rs fs ns) (R (car ls) vs rs fs ns)])
(record-case x (R* (cdr ls) vs rs fs ns))]))
[(seq e0 e1) (define (E x vs rs fs ns)
(let-values ([(vs rs fs ns) (E e1 vs rs fs ns)]) (record-case x
(E e0 vs rs fs ns))] [(seq e0 e1)
[(conditional e0 e1 e2) (let-values ([(vs rs fs ns) (E e1 vs rs fs ns)])
(let-values ([(vs1 rs1 fs1 ns1) (E e1 vs rs fs ns)] (E e0 vs rs fs ns))]
[(vs2 rs2 fs2 ns2) (E e2 vs rs fs ns)]) [(conditional e0 e1 e2)
(P e0 (let-values ([(vs1 rs1 fs1 ns1) (E e1 vs rs fs ns)]
vs1 rs1 fs1 ns1 [(vs2 rs2 fs2 ns2) (E e2 vs rs fs ns)])
vs2 rs2 fs2 ns2 (P e0
(union-vars vs1 vs2) vs1 rs1 fs1 ns1
(union-regs rs1 rs2) vs2 rs2 fs2 ns2
(union-frms fs1 fs2) (union-vars vs1 vs2)
(union-nfvs ns1 ns2)))] (union-regs rs1 rs2)
[(asm-instr op d s) (union-frms fs1 fs2)
(case op (union-nfvs ns1 ns2)))]
[(move) [(asm-instr op d s)
(cond (case op
[(reg? d) [(move)
(cond (cond
[(not (mem-reg? d rs)) [(reg? d)
(set-asm-instr-op! x 'nop) (cond
(values vs rs fs ns)] [(not (mem-reg? d rs))
[(or (const? s) (disp? s) (reg? s)) (set-asm-instr-op! x 'nop)
(let ([rs (rem-reg d rs)]) (values vs rs fs ns)]
(mark-reg/vars-conf! d vs) [(or (const? s) (disp? s) (reg? s))
(R s vs rs fs ns))] (let ([rs (rem-reg d rs)])
[(var? s) (mark-reg/vars-conf! d vs)
(let ([rs (rem-reg d rs)] (R s vs rs fs ns))]
[vs (rem-var s vs)]) [(var? s)
(mark-var/reg-move! s d) (let ([rs (rem-reg d rs)]
(mark-reg/vars-conf! d vs) [vs (rem-var s vs)])
(values (add-var s vs) rs fs ns))] (mark-var/reg-move! s d)
[(fvar? s) (mark-reg/vars-conf! d vs)
(let ([rs (rem-reg d rs)]) (values (add-var s vs) rs fs ns))]
(mark-reg/vars-conf! d vs) [(fvar? s)
(values vs rs (add-frm s fs) ns))] (let ([rs (rem-reg d rs)])
[else (error who "invalid rs ~s" (unparse x))])] (mark-reg/vars-conf! d vs)
[(fvar? d) (values vs rs (add-frm s fs) ns))]
(cond [else (error who "invalid rs ~s" (unparse x))])]
[(not (mem-frm? d fs)) [(fvar? d)
(set-asm-instr-op! x 'nop) (cond
(values vs rs fs ns)] [(not (mem-frm? d fs))
[(or (const? s) (disp? s) (reg? s)) (set-asm-instr-op! x 'nop)
(let ([fs (rem-frm d fs)]) (values vs rs fs ns)]
(mark-frm/vars-conf! d vs) [(or (const? s) (disp? s) (reg? s))
(mark-frm/nfvs-conf! d ns) (let ([fs (rem-frm d fs)])
(R s vs rs fs ns))] (mark-frm/vars-conf! d vs)
[(var? s) (mark-frm/nfvs-conf! d ns)
(let ([fs (rem-frm d fs)] (R s vs rs fs ns))]
[vs (rem-var s vs)]) [(var? s)
(mark-var/frm-move! s d) (let ([fs (rem-frm d fs)]
(mark-frm/vars-conf! d vs) [vs (rem-var s vs)])
(mark-frm/nfvs-conf! d ns) (mark-var/frm-move! s d)
(values (add-var s vs) rs fs ns))] (mark-frm/vars-conf! d vs)
[else (error who "invalid fs ~s" s)])] (mark-frm/nfvs-conf! d ns)
[(var? d) (values (add-var s vs) rs fs ns))]
(cond [else (error who "invalid fs ~s" s)])]
[(not (mem-var? d vs)) [(var? d)
(set-asm-instr-op! x 'nop) (cond
(values vs rs fs ns)] [(not (mem-var? d vs))
[(or (disp? s) (constant? s)) (set-asm-instr-op! x 'nop)
(let ([vs (rem-var d vs)]) (values vs rs fs ns)]
(mark-var/vars-conf! d vs) [(or (disp? s) (constant? s))
(mark-var/frms-conf! d fs) (let ([vs (rem-var d vs)])
(mark-var/regs-conf! d rs) (mark-var/vars-conf! d vs)
(mark-var/nfvs-conf! d ns) (mark-var/frms-conf! d fs)
(R s vs rs fs ns))] (mark-var/regs-conf! d rs)
[(reg? s) (mark-var/nfvs-conf! d ns)
(let ([vs (rem-var d vs)] (R s vs rs fs ns))]
[rs (rem-reg s rs)]) [(reg? s)
(mark-var/reg-move! d s) (let ([vs (rem-var d vs)]
(mark-var/vars-conf! d vs) [rs (rem-reg s rs)])
(mark-var/frms-conf! d fs) (mark-var/reg-move! d s)
(mark-var/regs-conf! d rs) (mark-var/vars-conf! d vs)
(mark-var/nfvs-conf! d ns) (mark-var/frms-conf! d fs)
(values vs (add-reg s rs) fs ns))] (mark-var/regs-conf! d rs)
[(var? s) (mark-var/nfvs-conf! d ns)
(let ([vs (rem-var d (rem-var s vs))]) (values vs (add-reg s rs) fs ns))]
(mark-var/var-move! d s) [(var? s)
(mark-var/vars-conf! d vs) (let ([vs (rem-var d (rem-var s vs))])
(mark-var/frms-conf! d fs) (mark-var/var-move! d s)
(mark-var/regs-conf! d rs) (mark-var/vars-conf! d vs)
(mark-var/nfvs-conf! d ns) (mark-var/frms-conf! d fs)
(values (add-var s vs) rs fs ns))] (mark-var/regs-conf! d rs)
[(fvar? s) (mark-var/nfvs-conf! d ns)
(let ([vs (rem-var d vs)] (values (add-var s vs) rs fs ns))]
[fs (rem-frm s fs)]) [(fvar? s)
(mark-var/frm-move! d s) (let ([vs (rem-var d vs)]
(mark-var/vars-conf! d vs) [fs (rem-frm s fs)])
(mark-var/frms-conf! d fs) (mark-var/frm-move! d s)
(mark-var/regs-conf! d rs) (mark-var/vars-conf! d vs)
(mark-var/nfvs-conf! d ns) (mark-var/frms-conf! d fs)
(values vs rs (add-frm s fs) ns))] (mark-var/regs-conf! d rs)
[else (error who "invalid vs ~s" s)])] (mark-var/nfvs-conf! d ns)
[(nfv? d) (values vs rs (add-frm s fs) ns))]
(cond [else (error who "invalid vs ~s" s)])]
[(not (mem-nfv? d ns)) (error who "dead nfv")] [(nfv? d)
[(or (disp? s) (constant? s) (reg? s)) (cond
(let ([ns (rem-nfv d ns)]) [(not (mem-nfv? d ns)) (error who "dead nfv")]
(mark-nfv/vars-conf! d vs) [(or (disp? s) (constant? s) (reg? s))
(mark-nfv/frms-conf! d fs) (let ([ns (rem-nfv d ns)])
(R s vs rs fs ns))] (mark-nfv/vars-conf! d vs)
[(var? s) (mark-nfv/frms-conf! d fs)
(let ([ns (rem-nfv d ns)] (R s vs rs fs ns))]
[vs (rem-var s vs)]) [(var? s)
(mark-nfv/vars-conf! d vs) (let ([ns (rem-nfv d ns)]
(mark-nfv/frms-conf! d fs) [vs (rem-var s vs)])
(values (add-var s vs) rs fs ns))] (mark-nfv/vars-conf! d vs)
[(fvar? s) (mark-nfv/frms-conf! d fs)
(let ([ns (rem-nfv d ns)] (values (add-var s vs) rs fs ns))]
[fs (rem-frm s fs)]) [(fvar? s)
(mark-nfv/vars-conf! d vs) (let ([ns (rem-nfv d ns)]
(mark-nfv/frms-conf! d fs) [fs (rem-frm s fs)])
(values vs rs (add-frm s fs) ns))] (mark-nfv/vars-conf! d vs)
[else (error who "invalid ns ~s" s)])] (mark-nfv/frms-conf! d fs)
[else (error who "invalid d ~s" d)])] (values vs rs (add-frm s fs) ns))]
[(int-/overflow int+/overflow int*/overflow) [else (error who "invalid ns ~s" s)])]
(let ([v (exception-live-set)]) [else (error who "invalid d ~s" d)])]
(unless (vector? v) [(int-/overflow int+/overflow int*/overflow)
(error who "unbound exception")) (let ([v (exception-live-set)])
(let ([vs (union-vars vs (vector-ref v 0))] (unless (vector? v)
[rs (union-regs rs (vector-ref v 1))] (error who "unbound exception"))
[fs (union-frms fs (vector-ref v 2))] (let ([vs (union-vars vs (vector-ref v 0))]
[ns (union-nfvs ns (vector-ref v 3))]) [rs (union-regs rs (vector-ref v 1))]
(cond [fs (union-frms fs (vector-ref v 2))]
[(var? d) [ns (union-nfvs ns (vector-ref v 3))])
(cond (cond
[(not (mem-var? d vs)) [(var? d)
(set-asm-instr-op! x 'nop) (cond
(values vs rs fs ns)] [(not (mem-var? d vs))
[else (set-asm-instr-op! x 'nop)
(let ([vs (rem-var d vs)]) (values vs rs fs ns)]
(mark-var/vars-conf! d vs) [else
(mark-var/frms-conf! d fs) (let ([vs (rem-var d vs)])
(mark-var/nfvs-conf! d ns) (mark-var/vars-conf! d vs)
(mark-var/regs-conf! d rs) (mark-var/frms-conf! d fs)
(R s (add-var d vs) rs fs ns))])] (mark-var/nfvs-conf! d ns)
[(reg? d) (mark-var/regs-conf! d rs)
(cond (R s (add-var d vs) rs fs ns))])]
[(not (mem-reg? d rs)) [(reg? d)
(values vs rs fs ns)] (cond
[else [(not (mem-reg? d rs))
(let ([rs (rem-reg d rs)]) (values vs rs fs ns)]
(mark-reg/vars-conf! d vs) [else
(R s vs (add-reg d rs) fs ns))])] (let ([rs (rem-reg d rs)])
[(nfv? d) (mark-reg/vars-conf! d vs)
(cond (R s vs (add-reg d rs) fs ns))])]
[(not (mem-nfv? d ns)) (error who "dead nfv")] [(nfv? d)
[else (cond
(let ([ns (rem-nfv d ns)]) [(not (mem-nfv? d ns)) (error who "dead nfv")]
(mark-nfv/vars-conf! d vs) [else
(mark-nfv/frms-conf! d fs) (let ([ns (rem-nfv d ns)])
(R s vs rs fs (add-nfv d ns)))])] (mark-nfv/vars-conf! d vs)
[else (error who "invalid op d ~s" (unparse x))])))] (mark-nfv/frms-conf! d fs)
[(logand logor logxor sll sra srl int+ int- int*) (R s vs rs fs (add-nfv d ns)))])]
(cond [else (error who "invalid op d ~s" (unparse x))])))]
[(var? d) [(logand logor logxor sll sra srl int+ int- int*)
(cond (cond
[(not (mem-var? d vs)) [(var? d)
(set-asm-instr-op! x 'nop) (cond
(values vs rs fs ns)] [(not (mem-var? d vs))
[else (set-asm-instr-op! x 'nop)
(let ([vs (rem-var d vs)]) (values vs rs fs ns)]
(mark-var/vars-conf! d vs) [else
(mark-var/frms-conf! d fs) (let ([vs (rem-var d vs)])
(mark-var/nfvs-conf! d ns) (mark-var/vars-conf! d vs)
(mark-var/regs-conf! d rs) (mark-var/frms-conf! d fs)
(R s (add-var d vs) rs fs ns))])] (mark-var/nfvs-conf! d ns)
[(reg? d) (mark-var/regs-conf! d rs)
(cond (R s (add-var d vs) rs fs ns))])]
[(not (mem-reg? d rs)) [(reg? d)
(values vs rs fs ns)] (cond
[else [(not (mem-reg? d rs))
(let ([rs (rem-reg d rs)]) (values vs rs fs ns)]
(mark-reg/vars-conf! d vs) [else
(R s vs (add-reg d rs) fs ns))])] (let ([rs (rem-reg d rs)])
[(nfv? d) (mark-reg/vars-conf! d vs)
(cond (R s vs (add-reg d rs) fs ns))])]
[(not (mem-nfv? d ns)) (error who "dead nfv")] [(nfv? d)
[else (cond
(let ([ns (rem-nfv d ns)]) [(not (mem-nfv? d ns)) (error who "dead nfv")]
(mark-nfv/vars-conf! d vs) [else
(mark-nfv/frms-conf! d fs) (let ([ns (rem-nfv d ns)])
(R s vs rs fs (add-nfv d ns)))])] (mark-nfv/vars-conf! d vs)
[else (error who "invalid op d ~s" (unparse x))])] (mark-nfv/frms-conf! d fs)
[(idiv) (R s vs rs fs (add-nfv d ns)))])]
(mark-reg/vars-conf! eax vs) [else (error who "invalid op d ~s" (unparse x))])]
(mark-reg/vars-conf! edx vs) [(idiv)
(R s vs (add-reg eax (add-reg edx rs)) fs ns)] (mark-reg/vars-conf! eax vs)
[(cltd) (mark-reg/vars-conf! edx vs)
(mark-reg/vars-conf! edx vs) (R s vs (add-reg eax (add-reg edx rs)) fs ns)]
(R s vs (rem-reg edx rs) fs ns)] [(cltd)
[(mset bset/c bset/h) (mark-reg/vars-conf! edx vs)
(R* (list s d) vs rs fs ns)] (R s vs (rem-reg edx rs) fs ns)]
[else (error who "invalid effect op ~s" (unparse x))])] [(mset bset/c bset/h)
[(ntcall target value args mask size) (R* (list s d) vs rs fs ns)]
(set! spill-set (union-vars vs spill-set)) [else (error who "invalid effect op ~s" (unparse x))])]
(for-each-var vs varvec (lambda (x) (set-var-loc! x #t))) [(ntcall target value args mask size)
(R* args vs (empty-reg-set) fs ns)] (set! spill-set (union-vars vs spill-set))
[(nframe nfvs live body) (for-each-var vs varvec (lambda (x) (set-var-loc! x #t)))
(for-each init-nfv! nfvs) (R* args vs (empty-reg-set) fs ns)]
(set-nframe-live! x (vector vs fs ns)) [(nframe nfvs live body)
(E body vs rs fs ns)] (for-each init-nfv! nfvs)
[(primcall op args) (set-nframe-live! x (vector vs fs ns))
(case op (E body vs rs fs ns)]
[(nop) (values vs rs fs ns)] [(primcall op args)
[(interrupt) (case op
(let ([v (exception-live-set)]) [(nop) (values vs rs fs ns)]
(unless (vector? v) [(interrupt)
(error who "unbound exception")) (let ([v (exception-live-set)])
(values (vector-ref v 0) (unless (vector? v)
(vector-ref v 1) (error who "unbound exception"))
(vector-ref v 2) (values (vector-ref v 0)
(vector-ref v 3)))] (vector-ref v 1)
[else (error who "invalid effect op ~s" op)])] (vector-ref v 2)
[(shortcut body handler) (vector-ref v 3)))]
(let-values ([(vsh rsh fsh nsh) (E handler vs rs fs ns)]) [else (error who "invalid effect op ~s" op)])]
(parameterize ([exception-live-set [(shortcut body handler)
(vector vsh rsh fsh nsh)]) (let-values ([(vsh rsh fsh nsh) (E handler vs rs fs ns)])
(E body vs rs fs ns)))] (parameterize ([exception-live-set
[else (error who "invalid effect ~s" (unparse x))])) (vector vsh rsh fsh nsh)])
(define (P x vst rst fst nst (E body vs rs fs ns)))]
vsf rsf fsf nsf [else (error who "invalid effect ~s" (unparse x))]))
vsu rsu fsu nsu) (define (P x vst rst fst nst
(record-case x vsf rsf fsf nsf
[(seq e0 e1) vsu rsu fsu nsu)
(let-values ([(vs rs fs ns) (record-case x
(P e1 vst rst fst nst [(seq e0 e1)
vsf rsf fsf nsf (let-values ([(vs rs fs ns)
vsu rsu fsu nsu)]) (P e1 vst rst fst nst
(E e0 vs rs fs ns))] vsf rsf fsf nsf
[(conditional e0 e1 e2) vsu rsu fsu nsu)])
(let-values ([(vs1 rs1 fs1 ns1) (E e0 vs rs fs ns))]
(P e1 vst rst fst nst [(conditional e0 e1 e2)
vsf rsf fsf nsf (let-values ([(vs1 rs1 fs1 ns1)
vsu rsu fsu nsu)] (P e1 vst rst fst nst
[(vs2 rs2 fs2 ns2) vsf rsf fsf nsf
(P e2 vst rst fst nst vsu rsu fsu nsu)]
vsf rsf fsf nsf [(vs2 rs2 fs2 ns2)
vsu rsu fsu nsu)]) (P e2 vst rst fst nst
(P e0 vsf rsf fsf nsf
vs1 rs1 fs1 ns1 vsu rsu fsu nsu)])
vs2 rs2 fs2 ns2 (P e0
(union-vars vs1 vs2) vs1 rs1 fs1 ns1
(union-regs rs1 rs2) vs2 rs2 fs2 ns2
(union-frms fs1 fs2) (union-vars vs1 vs2)
(union-nfvs ns1 ns2)))] (union-regs rs1 rs2)
[(constant t) (union-frms fs1 fs2)
(if t (union-nfvs ns1 ns2)))]
(values vst rst fst nst) [(constant t)
(values vsf rsf fsf nsf))] (if t
[(asm-instr op d s) (values vst rst fst nst)
(R* (list d s) vsu rsu fsu nsu)] (values vsf rsf fsf nsf))]
[(shortcut body handler) [(asm-instr op d s)
(let-values ([(vsh rsh fsh nsh) (R* (list d s) vsu rsu fsu nsu)]
(P handler vst rst fst nst [(shortcut body handler)
vsf rsf fsf nsf (let-values ([(vsh rsh fsh nsh)
vsu rsu fsu nsu)]) (P handler vst rst fst nst
(parameterize ([exception-live-set vsf rsf fsf nsf
(vector vsh rsh fsh nsh)]) vsu rsu fsu nsu)])
(P body vst rst fst nst (parameterize ([exception-live-set
vsf rsf fsf nsf (vector vsh rsh fsh nsh)])
vsu rsu fsu nsu)))] (P body vst rst fst nst
[else (error who "invalid pred ~s" (unparse x))])) vsf rsf fsf nsf
(define (T x) vsu rsu fsu nsu)))]
(record-case x [else (error who "invalid pred ~s" (unparse x))]))
[(seq e0 e1) (define (T x)
(let-values ([(vs rs fs ns) (T e1)]) (record-case x
(E e0 vs rs fs ns))] [(seq e0 e1)
[(conditional e0 e1 e2) (let-values ([(vs rs fs ns) (T e1)])
(let-values ([(vs1 rs1 fs1 ns1) (T e1)] (E e0 vs rs fs ns))]
[(vs2 rs2 fs2 ns2) (T e2)]) [(conditional e0 e1 e2)
(P e0 (let-values ([(vs1 rs1 fs1 ns1) (T e1)]
vs1 rs1 fs1 ns1 [(vs2 rs2 fs2 ns2) (T e2)])
vs2 rs2 fs2 ns2 (P e0
(union-vars vs1 vs2) vs1 rs1 fs1 ns1
(union-regs rs1 rs2) vs2 rs2 fs2 ns2
(union-frms fs1 fs2) (union-vars vs1 vs2)
(union-nfvs ns1 ns2)))] (union-regs rs1 rs2)
[(primcall op arg*) (union-frms fs1 fs2)
(case op (union-nfvs ns1 ns2)))]
[(return indirect-jump direct-jump) [(primcall op arg*)
(R* arg* (empty-var-set) (case op
(empty-reg-set) [(return indirect-jump direct-jump)
(empty-frm-set) (R* arg* (empty-var-set)
(empty-nfv-set))] (empty-reg-set)
[else (error who "invalid tail op ~s" x)])] (empty-frm-set)
[(shortcut body handler) (empty-nfv-set))]
(let-values ([(vsh rsh fsh nsh) (T handler)]) [else (error who "invalid tail op ~s" x)])]
(parameterize ([exception-live-set [(shortcut body handler)
(vector vsh rsh fsh nsh)]) (let-values ([(vsh rsh fsh nsh) (T handler)])
(T body)))] (parameterize ([exception-live-set
[else (error who "invalid tail ~s" x)])) (vector vsh rsh fsh nsh)])
(define exception-live-set (T body)))]
(make-parameter #f)) [else (error who "invalid tail ~s" x)]))
(T x) (define exception-live-set
spill-set) (make-parameter #f))
(define-syntax frm-loc (T x)
(syntax-rules () spill-set)
[(_ x)
(let ([t x])
(if (fvar? t)
(fvar-idx t) (module (assign-frame-sizes)
(error 'frm-loc "in ~s ~s" (unparse t) '(frm-loc x))))])) ;;; assign-frame-sizes module
;;; (define indent (make-parameter 0))
(import IntegerSet)
(import conflict-helpers)
(define (rewrite x varvec) (define (rewrite x varvec)
(define who 'rewrite) (define who 'rewrite)
(define (assign x) (define (assign x)
@ -1924,13 +1891,13 @@
[else [else
(let ([loc (nfv-loc (car ls))]) (let ([loc (nfv-loc (car ls))])
(unless (fvar? loc) (error 'max-nfv "not assigned")) (unless (fvar? loc) (error 'max-nfv "not assigned"))
(max-nfv (cdr ls) (max i (frm-loc loc))))])) (max-nfv (cdr ls) (max i (fvar-idx loc))))]))
(define (actual-frame-size vars i) (define (actual-frame-size vars i)
(define (var-conflict? i vs) (define (var-conflict? i vs)
(ormap (lambda (xi) (ormap (lambda (xi)
(let ([loc (var-loc (vector-ref varvec xi))]) (let ([loc (var-loc (vector-ref varvec xi))])
(and (fvar? loc) (and (fvar? loc)
(fx= i (frm-loc loc))))) (fx= i (fvar-idx loc)))))
(set->list vs))) (set->list vs)))
(define (frame-size-ok? i vars) (define (frame-size-ok? i vars)
(or (null? vars) (or (null? vars)
@ -1955,7 +1922,7 @@
(let ([loc (nfv-loc x)]) (let ([loc (nfv-loc x)])
(cond (cond
[loc [loc
(when (fx= (frm-loc loc) i) (when (fx= (fvar-idx loc) i)
(error who "invalid assignment"))] (error who "invalid assignment"))]
[else [else
(set-nfv-nfv-conf! x (set-nfv-nfv-conf! x
@ -1968,7 +1935,7 @@
(let ([loc (var-loc x)]) (let ([loc (var-loc x)])
(cond (cond
[(fvar? loc) [(fvar? loc)
(when (fx= (frm-loc loc) i) (when (fx= (fvar-idx loc) i)
(error who "invalid assignment"))] (error who "invalid assignment"))]
[else [else
(set-var-frm-conf! x (set-var-frm-conf! x
@ -2030,21 +1997,17 @@
(define (Main x) (define (Main x)
(record-case x (record-case x
[(locals vars body) [(locals vars body)
(cond (init-vars! vars)
[(has-nontail-call? body) (let ([v (list->vector vars)])
(init-vars! vars) (let ([call-live* (uncover-frame-conflicts body v)])
(let ([v (list->vector vars)]) (let ([body (rewrite body v)])
(let ([call-live* (uncover-frame-conflicts body v)]) (make-locals
(let ([body (rewrite body v)]) (let f ([vars vars])
(make-locals (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))] body))))]
[else (cons (car vars) (f (cdr vars)))]))
body))))]
[else
(make-locals vars body)])]
[else (error 'assign-frame-sizes "invalid main ~s" x)])) [else (error 'assign-frame-sizes "invalid main ~s" x)]))
;;; ;;;
(define (ClambdaCase x) (define (ClambdaCase x)
@ -2090,7 +2053,6 @@
[(constant) (make-empty-set)] [(constant) (make-empty-set)]
[(var) (list->set (list x))] [(var) (list->set (list x))]
[(disp s0 s1) (set-union (R s0) (R s1))] [(disp s0 s1) (set-union (R s0) (R s1))]
[(nfv) (list->set (list x))]
[(fvar) (list->set (if (reg? x) (list x) '()))] [(fvar) (list->set (if (reg? x) (list x) '()))]
[(code-loc) (make-empty-set)] [(code-loc) (make-empty-set)]
[else [else
@ -2104,40 +2066,18 @@
(case op (case op
[(move) [(move)
(let ([s (set-rem d s)]) (let ([s (set-rem d s)])
(record-case d (set-for-each (lambda (y) (add-edge! g d y)) s)
[(nfv c i) (set-union (R v) s))]
(if (list? c)
(set-nfv-conf! d
(set-union c s))
(set-nfv-conf! d s))
(set-union (R v) s)]
[else
(set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (R v) s)]))]
[(int-/overflow int+/overflow int*/overflow) [(int-/overflow int+/overflow int*/overflow)
(unless (exception-live-set) (unless (exception-live-set)
(error who "uninitialized live set")) (error who "uninitialized live set"))
(let ([s (set-rem d (set-union s (exception-live-set)))]) (let ([s (set-rem d (set-union s (exception-live-set)))])
(record-case d (set-for-each (lambda (y) (add-edge! g d y)) s)
[(nfv c i) (set-union (set-union (R v) (R d)) s))]
(if (list? c)
(set-nfv-conf! d (set-union c s))
(set-nfv-conf! d s))
(set-union (set-union (R v) (R d)) s)]
[else
(set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (set-union (R v) (R d)) s)]))]
[(logand logxor int+ int- int* logor sll sra srl) [(logand logxor int+ int- int* logor sll sra srl)
(let ([s (set-rem d s)]) (let ([s (set-rem d s)])
(record-case d (set-for-each (lambda (y) (add-edge! g d y)) s)
[(nfv c i) (set-union (set-union (R v) (R d)) s))]
(if (list? c)
(set-nfv-conf! d (set-union c s))
(set-nfv-conf! d s))
(set-union (set-union (R v) (R d)) s)]
[else
(set-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (set-union (R v) (R d)) s)]))]
[(bset/c) [(bset/c)
(set-union (set-union (R v) (R d)) s)] (set-union (set-union (R v) (R d)) s)]
[(bset/h) [(bset/h)
@ -3003,9 +2943,9 @@
;[foo (printf "4")] ;[foo (printf "4")]
[x (impose-calling-convention/evaluation-order x)] [x (impose-calling-convention/evaluation-order x)]
;[foo (printf "5")] ;[foo (printf "5")]
[x (assign-frame-sizes x)] [x (time-it "frame" (lambda () (assign-frame-sizes x)))]
;[foo (printf "6")] ;[foo (printf "6")]
[x (color-by-chaitin x)] [x (time-it "register" (lambda () (color-by-chaitin x)))]
;[foo (printf "7")] ;[foo (printf "7")]
[ls (flatten-codes x)] [ls (flatten-codes x)]
;[foo (printf "8")] ;[foo (printf "8")]