revived waddell's letrec/letrec* optimization

This commit is contained in:
Abdulaziz Ghuloum 2009-07-04 21:05:03 +03:00
parent 7a6ae6322c
commit 832fe616d2
2 changed files with 160 additions and 23 deletions

View File

@ -2,14 +2,19 @@
(module (debug-scc optimize-letrec) (module (debug-scc optimize-letrec)
(define (unique-prelex x)
(let ([x (make-prelex (prelex-name x) (prelex-operand x))])
(set-prelex-source-referenced?! x #t)
x))
(define (build-assign* lhs* rhs* body)
(define (mark-assigned! lhs) (define (mark-assigned! lhs)
;;; FIXME: this is very fragile ;;; FIXME: this is very fragile
(unless (prelex-source-assigned? lhs) (unless (prelex-source-assigned? lhs)
(set-prelex-source-assigned?! lhs (set-prelex-source-assigned?! lhs
(or (prelex-global-location lhs) #t)))) (or (prelex-global-location lhs) #t))))
(define (optimize-letrec/basic x) (for-each mark-assigned! lhs*)
(define who 'optimize-letrec/basic)
(define (assign* lhs* rhs* body)
(let f ([lhs* lhs*] [rhs* rhs*]) (let f ([lhs* lhs*] [rhs* rhs*])
(cond (cond
[(null? lhs*) body] [(null? lhs*) body]
@ -17,20 +22,17 @@
(make-seq (make-seq
(make-assign (car lhs*) (car rhs*)) (make-assign (car lhs*) (car rhs*))
(f (cdr lhs*) (cdr rhs*)))]))) (f (cdr lhs*) (cdr rhs*)))])))
(define (optimize-letrec/basic x)
(define who 'optimize-letrec/basic)
(define (do-rec*bind lhs* rhs* body) (define (do-rec*bind lhs* rhs* body)
(for-each mark-assigned! lhs*)
(make-bind lhs* (map (lambda (x) (make-constant #f)) lhs*) (make-bind lhs* (map (lambda (x) (make-constant #f)) lhs*)
(assign* lhs* rhs* body))) (build-assign* lhs* rhs* body)))
(define (do-recbind lhs* rhs* body) (define (do-recbind lhs* rhs* body)
(for-each mark-assigned! lhs*) (let ([t* (map unique-prelex 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 lhs* (map (lambda (x) (make-constant #f)) lhs*)
(make-bind t* rhs* (make-bind t* rhs*
(assign* lhs* t* body))))) (build-assign* lhs* t* body)))))
(define (L x) (define (L x)
(struct-case x (struct-case x
[(clambda g cls* cp free name) [(clambda g cls* cp free name)
@ -78,6 +80,137 @@
(E x)) (E x))
(define (optimize-letrec/waddell x)
(define simple-primitives '())
(define who 'optimize-letrec/waddell)
(define (extend-hash lhs* h ref)
(for-each (lambda (lhs) (hashtable-set! h lhs #t)) lhs*)
(lambda (x)
(unless (hashtable-ref h x #f)
(hashtable-set! h x #t)
(ref x))))
(define (E* x* ref comp)
(cond
[(null? x*) '()]
[else
(cons (E (car x*) ref comp)
(E* (cdr x*) ref comp))]))
(define (do-rhs* i lhs* rhs* ref comp vref vcomp)
(cond
[(null? rhs*) '()]
[else
(let ([h (make-eq-hashtable)]
[rest (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp)])
(let ([ref
(lambda (x)
(unless (hashtable-ref h x #f)
(hashtable-set! h x #t)
(ref x)
(when (memq x lhs*)
(vector-set! vref i #t))))]
[comp
(lambda ()
(vector-set! vcomp i #t)
(comp))])
(cons (E (car rhs*) ref comp) rest)))]))
(define (partition-rhs* i lhs* rhs* vref vcomp)
(cond
[(null? lhs*) (values '() '() '() '() '() '())]
[else
(let-values
([(slhs* srhs* llhs* lrhs* clhs* crhs*)
(partition-rhs* (fxadd1 i) (cdr lhs*) (cdr rhs*) vref vcomp)]
[(lhs rhs) (values (car lhs*) (car rhs*))])
(cond
[(prelex-source-assigned? lhs)
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
[(clambda? rhs)
(values slhs* srhs* (cons lhs llhs*) (cons rhs lrhs*) clhs* crhs*)]
[(or (vector-ref vref i) (vector-ref vcomp i))
(values slhs* srhs* llhs* lrhs* (cons lhs clhs*) (cons rhs crhs*))]
[else
(values (cons lhs slhs*) (cons rhs srhs*) llhs* lrhs* clhs* crhs*)]
))]))
(define (do-recbind lhs* rhs* body ref comp letrec?)
(let ([h (make-eq-hashtable)]
[vref (make-vector (length lhs*) #f)]
[vcomp (make-vector (length lhs*) #f)])
(let* ([ref (extend-hash lhs* h ref)]
[body (E body ref comp)])
(let ([rhs* (do-rhs* 0 lhs* rhs* ref comp vref vcomp)])
(let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*)
(partition-rhs* 0 lhs* rhs* vref vcomp)])
;;; (let ([made-complex
;;; (filter (lambda (x) (not (var-assigned x)))
;;; clhs*)])
;;; (unless (null? made-complex)
;;; (set! complex-count
;;; (+ complex-count (length made-complex)))
;;; (printf "COMPLEX (~s) = ~s\n"
;;; complex-count
;;; (map unparse made-complex))))
(let ([void* (map (lambda (x) (make-constant (void))) clhs*)])
(make-bind slhs* srhs*
(make-bind clhs* void*
(make-fix llhs* lrhs*
(if letrec?
(let ([t* (map unique-prelex clhs*)])
(make-bind t* crhs*
(build-assign* clhs* t* body)))
(build-assign* clhs* crhs* body)))))))))))
(define (E x ref comp)
(struct-case x
[(constant) x]
[(prelex) (ref x) x]
[(assign lhs rhs)
(ref lhs)
(comp)
(make-assign lhs (E rhs ref comp))]
[(primref) x]
[(bind lhs* rhs* body)
(let ([rhs* (E* rhs* ref comp)])
(let ([h (make-eq-hashtable)])
(let ([body (E body (extend-hash lhs* h ref) comp)])
(make-bind lhs* rhs* body))))]
[(recbind lhs* rhs* body)
(if (null? lhs*)
(E body ref comp)
(do-recbind lhs* rhs* body ref comp #t))]
[(rec*bind lhs* rhs* body)
(if (null? lhs*)
(E body ref comp)
(do-recbind lhs* rhs* body ref comp #f))]
[(conditional e0 e1 e2)
(make-conditional (E e0 ref comp) (E e1 ref comp) (E e2 ref comp))]
[(seq e0 e1) (make-seq (E e0 ref comp) (E e1 ref comp))]
[(clambda g cls* cp free name)
(make-clambda g
(map (lambda (x)
(struct-case x
[(clambda-case info body)
(let ([h (make-eq-hashtable)])
(let ([body (E body (extend-hash (case-info-args info) h ref) void)])
(make-clambda-case info body)))]))
cls*)
cp free name)]
[(funcall rator rand*)
(let ([rator (E rator ref comp)] [rand* (E* rand* ref comp)])
(struct-case rator
[(primref op)
(unless (memq op simple-primitives)
(comp))]
[else
(comp)])
(make-funcall rator rand*))]
[(mvcall p c)
(let ([p (E p ref comp)] [c (E c ref comp)])
(comp)
(make-mvcall p c))]
[(forcall rator rand*)
(make-forcall rator (E* rand* ref comp))]
[else (error who "invalid expression" (unparse x))]))
(E x (lambda (x) (error who "free var found" x))
void))
(define (optimize-letrec/scc x) (define (optimize-letrec/scc x)
(define who 'optimize-letrec/scc) (define who 'optimize-letrec/scc)
@ -339,3 +472,7 @@
(define (optimize-letrec x) (define (optimize-letrec x)
((current-letrec-pass) x))) ((current-letrec-pass) x)))

View File

@ -1 +1 @@
1822 1823