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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

122
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,9 +1379,11 @@
[(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)
(import IntegerSet)
(import conflict-helpers)
(define who 'uncover-frame-conflicts) (define who 'uncover-frame-conflicts)
(define spill-set (make-empty-set)) (define spill-set (make-empty-set))
(define (mark-reg/vars-conf! r vs) (define (mark-reg/vars-conf! r vs)
@ -1799,14 +1766,14 @@
(make-parameter #f)) (make-parameter #f))
(T x) (T x)
spill-set) spill-set)
(define-syntax frm-loc
(syntax-rules ()
[(_ x)
(let ([t x]) (module (assign-frame-sizes)
(if (fvar? t) ;;; assign-frame-sizes module
(fvar-idx t) (define indent (make-parameter 0))
(error 'frm-loc "in ~s ~s" (unparse t) '(frm-loc x))))])) (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,8 +1997,6 @@
(define (Main x) (define (Main x)
(record-case x (record-case x
[(locals vars body) [(locals vars body)
(cond
[(has-nontail-call? body)
(init-vars! vars) (init-vars! vars)
(let ([v (list->vector vars)]) (let ([v (list->vector vars)])
(let ([call-live* (uncover-frame-conflicts body v)]) (let ([call-live* (uncover-frame-conflicts body v)])
@ -2043,8 +2008,6 @@
[(var-loc (car vars)) (f (cdr vars))] [(var-loc (car vars)) (f (cdr vars))]
[else (cons (car vars) (f (cdr vars)))])) [else (cons (car vars) (f (cdr vars)))]))
body))))] 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
[(nfv c i)
(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-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (R v) 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
[(nfv c i)
(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-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (set-union (R v) (R d)) 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
[(nfv c i)
(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-for-each (lambda (y) (add-edge! g d y)) s)
(set-union (set-union (R v) (R d)) 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")]