* Cleanup of some junk code in color-by-chaitin
This commit is contained in:
Abdulaziz Ghuloum
parent
1dc9e83448
commit
feb9764645
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -1319,49 +1319,17 @@
|
|||
;;;
|
||||
#|IntegerGraphs|#)
|
||||
|
||||
(module (assign-frame-sizes)
|
||||
;;; assign-frame-sizes module
|
||||
(define indent (make-parameter 0))
|
||||
(module conflict-helpers
|
||||
(empty-var-set rem-var add-var union-vars mem-var? for-each-var init-vars!
|
||||
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)
|
||||
(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
|
||||
(define (add-frm x s) (set-add (fvar-idx x) s))
|
||||
(define (rem-nfv x s)
|
||||
(remq x s))
|
||||
(define (init-var! x i)
|
||||
(set-var-index! x i)
|
||||
(set-var-var-move! x (empty-var-set))
|
||||
|
|
@ -1394,7 +1362,6 @@
|
|||
(define (mem-reg? x s) (set-member? (register-index x) s))
|
||||
(define (union-regs s1 s2) (set-union s1 s2))
|
||||
(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 (rem-frm x s) (set-rem (fvar-idx x) s))
|
||||
(define (union-frms s1 s2) (set-union s1 s2))
|
||||
|
|
@ -1403,8 +1370,6 @@
|
|||
(cond
|
||||
[(memq x s) s]
|
||||
[else (cons x s)]))
|
||||
(define (rem-nfv x s)
|
||||
(remq x s))
|
||||
(define (mem-nfv? x s)
|
||||
(memq x s))
|
||||
(define (union-nfvs s1 s2)
|
||||
|
|
@ -1414,9 +1379,11 @@
|
|||
[(memq (car s1) s2) (f (cdr s1) s2)]
|
||||
[else (cons (car s1) (f (cdr s1) s2))])))
|
||||
(define (for-each-nfv s f)
|
||||
(for-each f s)))
|
||||
;;;
|
||||
(define (uncover-frame-conflicts x varvec)
|
||||
(for-each f s))))
|
||||
|
||||
(define (uncover-frame-conflicts x varvec)
|
||||
(import IntegerSet)
|
||||
(import conflict-helpers)
|
||||
(define who 'uncover-frame-conflicts)
|
||||
(define spill-set (make-empty-set))
|
||||
(define (mark-reg/vars-conf! r vs)
|
||||
|
|
@ -1799,14 +1766,14 @@
|
|||
(make-parameter #f))
|
||||
(T x)
|
||||
spill-set)
|
||||
(define-syntax frm-loc
|
||||
(syntax-rules ()
|
||||
[(_ x)
|
||||
(let ([t x])
|
||||
(if (fvar? t)
|
||||
(fvar-idx t)
|
||||
(error 'frm-loc "in ~s ~s" (unparse t) '(frm-loc x))))]))
|
||||
;;;
|
||||
|
||||
|
||||
|
||||
(module (assign-frame-sizes)
|
||||
;;; assign-frame-sizes module
|
||||
(define indent (make-parameter 0))
|
||||
(import IntegerSet)
|
||||
(import conflict-helpers)
|
||||
(define (rewrite x varvec)
|
||||
(define who 'rewrite)
|
||||
(define (assign x)
|
||||
|
|
@ -1924,13 +1891,13 @@
|
|||
[else
|
||||
(let ([loc (nfv-loc (car ls))])
|
||||
(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 (var-conflict? i vs)
|
||||
(ormap (lambda (xi)
|
||||
(let ([loc (var-loc (vector-ref varvec xi))])
|
||||
(and (fvar? loc)
|
||||
(fx= i (frm-loc loc)))))
|
||||
(fx= i (fvar-idx loc)))))
|
||||
(set->list vs)))
|
||||
(define (frame-size-ok? i vars)
|
||||
(or (null? vars)
|
||||
|
|
@ -1955,7 +1922,7 @@
|
|||
(let ([loc (nfv-loc x)])
|
||||
(cond
|
||||
[loc
|
||||
(when (fx= (frm-loc loc) i)
|
||||
(when (fx= (fvar-idx loc) i)
|
||||
(error who "invalid assignment"))]
|
||||
[else
|
||||
(set-nfv-nfv-conf! x
|
||||
|
|
@ -1968,7 +1935,7 @@
|
|||
(let ([loc (var-loc x)])
|
||||
(cond
|
||||
[(fvar? loc)
|
||||
(when (fx= (frm-loc loc) i)
|
||||
(when (fx= (fvar-idx loc) i)
|
||||
(error who "invalid assignment"))]
|
||||
[else
|
||||
(set-var-frm-conf! x
|
||||
|
|
@ -2030,8 +1997,6 @@
|
|||
(define (Main x)
|
||||
(record-case x
|
||||
[(locals vars body)
|
||||
(cond
|
||||
[(has-nontail-call? body)
|
||||
(init-vars! vars)
|
||||
(let ([v (list->vector vars)])
|
||||
(let ([call-live* (uncover-frame-conflicts body v)])
|
||||
|
|
@ -2043,8 +2008,6 @@
|
|||
[(var-loc (car vars)) (f (cdr vars))]
|
||||
[else (cons (car vars) (f (cdr vars)))]))
|
||||
body))))]
|
||||
[else
|
||||
(make-locals vars body)])]
|
||||
[else (error 'assign-frame-sizes "invalid main ~s" x)]))
|
||||
;;;
|
||||
(define (ClambdaCase x)
|
||||
|
|
@ -2090,7 +2053,6 @@
|
|||
[(constant) (make-empty-set)]
|
||||
[(var) (list->set (list x))]
|
||||
[(disp s0 s1) (set-union (R s0) (R s1))]
|
||||
[(nfv) (list->set (list x))]
|
||||
[(fvar) (list->set (if (reg? x) (list x) '()))]
|
||||
[(code-loc) (make-empty-set)]
|
||||
[else
|
||||
|
|
@ -2104,40 +2066,18 @@
|
|||
(case op
|
||||
[(move)
|
||||
(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-union (R v) s)]))]
|
||||
(set-union (R v) s))]
|
||||
[(int-/overflow int+/overflow int*/overflow)
|
||||
(unless (exception-live-set)
|
||||
(error who "uninitialized 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-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)
|
||||
(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-union (set-union (R v) (R d)) s)]))]
|
||||
(set-union (set-union (R v) (R d)) s))]
|
||||
[(bset/c)
|
||||
(set-union (set-union (R v) (R d)) s)]
|
||||
[(bset/h)
|
||||
|
|
@ -3003,9 +2943,9 @@
|
|||
;[foo (printf "4")]
|
||||
[x (impose-calling-convention/evaluation-order x)]
|
||||
;[foo (printf "5")]
|
||||
[x (assign-frame-sizes x)]
|
||||
[x (time-it "frame" (lambda () (assign-frame-sizes x)))]
|
||||
;[foo (printf "6")]
|
||||
[x (color-by-chaitin x)]
|
||||
[x (time-it "register" (lambda () (color-by-chaitin x)))]
|
||||
;[foo (printf "7")]
|
||||
[ls (flatten-codes x)]
|
||||
;[foo (printf "8")]
|
||||
|
|
|
|||
Loading…
Reference in New Issue