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

* newcogen passes 1.6

This commit is contained in:
Abdulaziz Ghuloum 2007-02-11 17:51:42 -05:00
parent 910b52f1f1
commit c44caba238
2 changed files with 33 additions and 20 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.

53
src/libaltcogen.ss
View File

@ -165,7 +165,7 @@
(make-seq (Expr e0) (Expr e1))] (make-seq (Expr e0) (Expr e1))]
[(closure) x] [(closure) x]
[(primcall op arg*) [(primcall op arg*)
(make-appcall (make-primref op) (map Expr arg*))] (make-funcall (make-primref op) (map Expr arg*))]
[(forcall op arg*) [(forcall op arg*)
(make-forcall op (map Expr arg*))] (make-forcall op (map Expr arg*))]
[(funcall rator arg*) [(funcall rator arg*)
@ -540,6 +540,27 @@
(values (cons (car regs) r*) (values (cons (car regs) r*)
(cons (car args) rl*) (cons (car args) rl*)
f*))]))) f*))])))
(define (handle-nontail-call rator rands dest)
(let-values ([(reg-locs reg-args frm-args)
(nontail-locations (cons rator rands))])
(let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)]
[frmt* (map (lambda (x) (make-nfvar #f #f)) frm-args)])
(let ([body
(make-nframe frmt* #f
(do-bind frmt* frm-args
(do-bind regt* reg-args
(assign* reg-locs regt*
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
(make-primcall
'indirect-call
(cons argc-register
(append reg-locs frmt*))))))))])
(if dest
(make-seq body (make-set dest return-value-register))
body)))))
(define (V d x) (define (V d x)
(record-case x (record-case x
[(constant) (make-set d x)] [(constant) (make-set d x)]
@ -555,23 +576,7 @@
(lambda (rands) (lambda (rands)
(make-set d (make-primcall op rands))))] (make-set d (make-primcall op rands))))]
[(funcall rator rands) [(funcall rator rands)
(let-values ([(reg-locs reg-args frm-args) (handle-nontail-call rator rands d)]
(nontail-locations (cons rator rands))])
(let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)]
[frmt* (map (lambda (x) (make-nfvar #f #f)) frm-args)])
(make-seq
(make-nframe frmt* #f
(do-bind frmt* frm-args
(do-bind regt* reg-args
(assign* reg-locs regt*
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
(make-primcall
'indirect-call
(cons argc-register (append reg-locs frmt*))))))))
(make-set d return-value-register))))]
[else (error who "invalid value ~s" x)])) [else (error who "invalid value ~s" x)]))
;;; ;;;
(define (assign* lhs* rhs* ac) (define (assign* lhs* rhs* ac)
@ -596,6 +601,8 @@
(S* rands (S* rands
(lambda (rands) (lambda (rands)
(make-primcall op rands)))] (make-primcall op rands)))]
[(funcall rator rands)
(handle-nontail-call rator rands #f)]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
;;; ;;;
(define (P x) (define (P x)
@ -920,7 +927,10 @@
(or (let f ([x (car ls)]) (or (let f ([x (car ls)])
(record-case x (record-case x
[(fvar j) (eq? i j)] [(fvar j) (eq? i j)]
[(var) (f (Var x))] [(var)
(cond
[(assq x env) => (lambda (x) (f (cdr x)))]
[else #f])]
[(nfvar conf loc) (f loc)] [(nfvar conf loc) (f loc)]
[else #f])) [else #f]))
(conflicts? i (cdr ls))))) (conflicts? i (cdr ls)))))
@ -1339,7 +1349,10 @@
(define (alt-cogen x) (define (alt-cogen x)
(verify-new-cogen-input x) (verify-new-cogen-input x)
(let* ([x (remove-primcalls x)] (let* (
;[foo (print-code x)]
[x (remove-primcalls x)]
;[foo (print-code x)]
[x (eliminate-fix x)] [x (eliminate-fix x)]
[x (specify-representation x)] [x (specify-representation x)]
[x (impose-calling-convention/evaluation-order x)] [x (impose-calling-convention/evaluation-order x)]