added basic letrec/letrec* handling (as in the one defined in R5RS)

This commit is contained in:
Abdulaziz Ghuloum 2009-07-04 20:33:38 +03:00
parent cc569cce64
commit 7a6ae6322c
2 changed files with 328 additions and 248 deletions

View File

@ -2,7 +2,84 @@
(module (debug-scc optimize-letrec) (module (debug-scc optimize-letrec)
(define (optimize-letrec/scc x) (define (mark-assigned! lhs)
;;; FIXME: this is very fragile
(unless (prelex-source-assigned? lhs)
(set-prelex-source-assigned?! lhs
(or (prelex-global-location lhs) #t))))
(define (optimize-letrec/basic x)
(define who 'optimize-letrec/basic)
(define (assign* lhs* rhs* body)
(let f ([lhs* lhs*] [rhs* rhs*])
(cond
[(null? lhs*) body]
[else
(make-seq
(make-assign (car lhs*) (car rhs*))
(f (cdr lhs*) (cdr rhs*)))])))
(define (do-rec*bind lhs* rhs* body)
(for-each mark-assigned! lhs*)
(make-bind lhs* (map (lambda (x) (make-constant #f)) lhs*)
(assign* lhs* rhs* body)))
(define (do-recbind lhs* rhs* body)
(for-each mark-assigned! lhs*)
(let ([t* (map (lambda (x)
(let ([x (make-prelex (prelex-name x) (prelex-operand x))])
(set-prelex-source-referenced?! x #t)
x))
lhs*)])
(make-bind lhs* (map (lambda (x) (make-constant #f)) lhs*)
(make-bind t* rhs*
(assign* lhs* t* body)))))
(define (L x)
(struct-case x
[(clambda g cls* cp free name)
(make-clambda g
(map (lambda (x)
(struct-case x
[(clambda-case info body)
(make-clambda-case info (E body))]))
cls*)
cp free name)]))
(define (E x)
(struct-case x
[(constant) x]
[(prelex)
(assert (prelex-source-referenced? x))
x]
[(assign lhs rhs)
(assert (prelex-source-assigned? lhs))
(make-assign lhs (E rhs))]
[(primref) x]
[(bind lhs* rhs* body)
(if (null? lhs*)
(E body)
(make-bind lhs* (map E rhs*) (E body)))]
[(recbind lhs* rhs* body)
(if (null? lhs*)
(E body)
(do-recbind lhs* (map E rhs*) (E body)))]
[(rec*bind lhs* rhs* body)
(if (null? lhs*)
(E body)
(do-rec*bind lhs* (map E rhs*) (E body)))]
[(conditional e0 e1 e2)
(make-conditional (E e0) (E e1) (E e2))]
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(clambda g cls* cp free name)
(L x)]
[(funcall rator rand*)
(make-funcall (E rator) (map E rand*))]
[(mvcall p c)
(make-mvcall (E p) (E c))]
[(forcall rator rand*)
(make-forcall rator (map E rand*))]
[else (error who "invalid expression" (unparse x))]))
(E x))
(define (optimize-letrec/scc x)
(define who 'optimize-letrec/scc) (define who 'optimize-letrec/scc)
(module (get-sccs-in-order) (module (get-sccs-in-order)
(define-struct node (data link* lowlink root done collection)) (define-struct node (data link* lowlink root done collection))
@ -255,7 +332,10 @@
x)) x))
(define debug-scc (make-parameter #f)) (define debug-scc (make-parameter #f))
(define (optimize-letrec x) (define current-letrec-pass
(optimize-letrec/scc x))) (make-parameter optimize-letrec/scc))
(define (optimize-letrec x)
((current-letrec-pass) x)))

View File

@ -1 +1 @@
1821 1822