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

* altcogen passes 1.8

This commit is contained in:
Abdulaziz Ghuloum 2007-02-11 18:06:04 -05:00
parent c44caba238
commit 6fd790b046
2 changed files with 31 additions and 14 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.

45
src/libaltcogen.ss
View File

@ -807,11 +807,17 @@
(cond (cond
[(or (var? rhs) (reg? rhs)) [(or (var? rhs) (reg? rhs))
(let ([s (set-rem rhs (set-rem lhs s))]) (let ([s (set-rem rhs (set-rem lhs s))])
(for-each (lambda (x) (add-edge! g lhs x)) s) (for-each (lambda (x)
(when (or (var? x) (reg? x))
(add-edge! g lhs x)))
s)
(cons rhs s))] (cons rhs s))]
[else [else
(let ([s (set-rem lhs s)]) (let ([s (set-rem lhs s)])
(for-each (lambda (x) (add-edge! g lhs x)) s) (for-each (lambda (x)
(when (or (var? x) (reg? x))
(add-edge! g lhs x)))
s)
(Rhs rhs s))])] (Rhs rhs s))])]
[(nfvar? lhs) [(nfvar? lhs)
(let ([s (set-rem lhs s)]) (let ([s (set-rem lhs s)])
@ -910,9 +916,9 @@
(values spills (cons sp sp*) (values spills (cons sp sp*)
(cons (cons sp r) env)) (cons (cons sp r) env))
(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) (define (substitute env x frm-graph)
(define who 'substitute) (define who 'substitute)
(define (max-live vars i) (define (max-live vars i)
(cond (cond
@ -943,7 +949,14 @@
[else (actual-frame-size vars (fxadd1 i))])) [else (actual-frame-size vars (fxadd1 i))]))
(define (assign-frame-vars! vars i) (define (assign-frame-vars! vars i)
(unless (null? vars) (unless (null? vars)
(set-nfvar-loc! (car vars) (mkfvar i)) (let ([v (car vars)]
[fv (mkfvar i)])
(set-nfvar-loc! v fv)
(for-each
(lambda (x)
(when (var? x)
(add-edge! frm-graph x fv)))
(nfvar-conf v)))
(assign-frame-vars! (cdr vars) (fxadd1 i)))) (assign-frame-vars! (cdr vars) (fxadd1 i))))
(define (Var x) (define (Var x)
(cond (cond
@ -1120,12 +1133,13 @@
(let ([g (build-graph body symbol?)]) (let ([g (build-graph body symbol?)])
; (printf "loop:\n") ; (printf "loop:\n")
; (print-code body) ; (print-code body)
;(print-graph g)
(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)] [(null? spills) (substitute env body frame-g)]
[else [else
(let* ([env (do-spill spills frame-g)] (let* ([env (do-spill spills frame-g)]
[body (substitute env body)]) [body (substitute env body frame-g)])
(let-values ([(un* body) (let-values ([(un* body)
(add-unspillables un* body)]) (add-unspillables un* body)])
(loop sp* un* body)))])))))])) (loop sp* un* body)))])))))]))
@ -1186,6 +1200,8 @@
(record-case x (record-case x
[(constant c) [(constant c)
(cons `(movl ,(Rand x) ,d) ac)] (cons `(movl ,(Rand x) ,d) ac)]
[(fvar i)
(cons `(movl ,(FVar i) ,d) ac)]
[(primcall op rands) [(primcall op rands)
(case op (case op
[(mref) [(mref)
@ -1360,13 +1376,14 @@
[x (color-by-chaitin x)] [x (color-by-chaitin x)]
;[foo (print-code x)] ;[foo (print-code x)]
[ls (flatten-codes x)]) [ls (flatten-codes x)])
(parameterize ([gensym-prefix "L"] (when #f
[print-gensym #f]) (parameterize ([gensym-prefix "L"]
(for-each [print-gensym #f])
(lambda (ls) (for-each
(newline) (lambda (ls)
(for-each (lambda (x) (printf " ~s\n" x)) ls)) (newline)
ls)) (for-each (lambda (x) (printf " ~s\n" x)) ls))
ls)))
ls)) ls))
#|module alt-cogen|#) #|module alt-cogen|#)