* Copy propagation for constants and primrefs works.

This commit is contained in:
Abdulaziz Ghuloum 2006-12-03 13:45:51 -05:00
parent 787264e8cf
commit 6c30b75e57
2 changed files with 172 additions and 4 deletions

Binary file not shown.

View File

@ -831,18 +831,20 @@
(define who 'uncover-assigned/referenced)
(define (Expr* x*)
(for-each Expr x*))
(define (init-var x)
(set-var-assigned! x #f)
(set-var-referenced! x #f))
(define (Expr x)
(record-case x
[(constant) (void)]
[(var) (set-var-referenced! x #t)]
[(primref) (void)]
[(bind lhs* rhs* body)
(begin (Expr body) (Expr* rhs*))]
[(recbind lhs* rhs* body)
(error who "BUG:recbind cannot be here")
(for-each init-var lhs*)
(begin (Expr body) (Expr* rhs*))]
[(fix lhs* rhs* body)
(Expr* rhs*)
(for-each init-var lhs*)
(Expr* rhs*)
(Expr body)
(when (ormap var-assigned lhs*)
(error who "a fix lhs is assigned"))]
@ -852,6 +854,7 @@
[(clambda cls*)
(for-each
(lambda (cls)
(for-each init-var (clambda-case-arg* cls))
(Expr (clambda-case-body cls)))
cls*)]
[(primcall rator rand*) (Expr* rand*)]
@ -867,6 +870,168 @@
(Expr x)
x)
(define (copy-propagate x)
(define who 'copy-propagate)
(define the-void (make-primcall 'void '()))
(define (known-value x)
(record-case x
[(constant) x] ; known
[(primref) x] ; known
[(bind lhs* rhs* body) (known-value body)]
[(fix lhs* rhs* body) (known-value body)]
[(seq e0 e1) (known-value e1)]
[else #f]))
(define (partition-referenced lhs* rhs*)
(cond
[(null? lhs*) (values '() '() the-void)]
[else
(let ([lhs (car lhs*)] [rhs (car rhs*)])
(let-values ([(lhs* rhs* eff*)
(partition-referenced
(cdr lhs*) (cdr rhs*))])
(cond
[(var-referenced lhs)
(values (cons lhs lhs*) (cons rhs rhs*) eff*)]
[else
(values lhs* rhs* (mk-seq eff* (Effect rhs)))])))]))
(define (partition/assign-known lhs* rhs*)
(cond
[(null? lhs*) (values '() '() the-void)]
[else
(let ([lhs (car lhs*)] [rhs (car rhs*)])
(let-values ([(lhs* rhs* eff*)
(partition/assign-known
(cdr lhs*) (cdr rhs*))])
(cond
[(and (not (var-assigned lhs)) (known-value rhs)) =>
(lambda (v)
(set-var-referenced! lhs v)
(values lhs* rhs* (mk-seq eff* rhs)))]
[else
(values (cons lhs lhs*) (cons rhs rhs*) eff*)])))]))
(define (do-bind lhs* rhs* body k)
(let-values ([(lhs* rhs* eff0)
(partition-referenced lhs* rhs*)])
(let ([rhs* (map Value rhs*)])
(let-values ([(lhs* rhs* eff1)
(partition/assign-known lhs* rhs*)])
(let ([body
(cond
[(null? lhs*) (k body)]
[else
(make-bind lhs* rhs* (k body))])])
(mk-seq (mk-seq eff0 eff1) body))))))
(define (do-fix lhs* rhs* body k)
(let-values ([(lhs* rhs* eff*)
(partition-referenced lhs* rhs*)])
(cond
[(null? lhs*) (k body)]
[else
(make-fix lhs* (map Value rhs*) (k body))])))
(define (mk-seq e0 e1) ;;; keep e1 seq-free.
(cond
[(and (primcall? e0) (eq? (primcall-arg* e0) 'void)) e1]
[(seq? e1)
(make-seq (make-seq e0 (seq-e0 e1)) (seq-e1 e1))]
[else
(make-seq e0 e1)]))
(define (do-clambda x)
(make-clambda
(map (lambda (cls)
(record-case cls
[(clambda-case arg* proper body)
(make-clambda-case arg* proper
(Value body))]))
(clambda-cases x))))
(define (Effect x)
(record-case x
[(constant) the-void]
[(var) the-void]
[(primref) the-void]
[(bind lhs* rhs* body)
(do-bind lhs* rhs* body Effect)]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* body Effect)]
[(conditional test conseq altern)
(make-conditional (Pred test) (Effect conseq) (Effect altern))]
[(seq e0 e1) (mk-seq (Effect e0) (Effect e1))]
[(clambda cls*) the-void]
[(primcall rator rand*) ; remove effect-free primcalls
(make-primcall rator (map Value rand*))]
[(funcall rator rand*)
(make-funcall (Value rator) (map Value rand*))]
[(appcall rator rand*)
(make-appcall (Value rator) (map Value rand*))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(assign lhs rhs)
(unless (var-assigned lhs)
(error who "var ~s is not assigned" lhs))
(if (var-referenced lhs)
(make-assign lhs (Value rhs))
(Effect rhs))]
[else (error who "invalid effect expression ~s" (unparse x))]))
(define (Pred x)
(record-case x
[(constant) x]
[(var)
(let ([r (var-referenced x)])
(if (constant? r) r x))]
[(primref) (make-constant #t)]
[(bind lhs* rhs* body)
(do-bind lhs* rhs* body Pred)]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* body Pred)]
[(conditional test conseq altern)
(make-conditional (Pred test) (Pred conseq) (Pred altern))]
[(seq e0 e1) (mk-seq (Effect e0) (Pred e1))]
[(clambda cls*) (make-constant #t)]
[(primcall rator rand*) ;;; check for some effect-free/known prims
(make-primcall rator (map Value rand*))]
[(funcall rator rand*)
(make-funcall (Value rator) (map Value rand*))]
[(appcall rator rand*)
(make-appcall (Value rator) (map Value rand*))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(assign lhs rhs)
(mk-seq (Effect x) (make-constant #t))]
[else (error who "invalid pred expression ~s" (unparse x))]))
(define (Value x)
(record-case x
[(constant) x]
[(var)
(let ([r (var-referenced x)])
(case r
[(#t) x]
[(#f) (error who "Reference to a var ~s that should not be" x)]
[else r]))]
[(primref) x]
[(bind lhs* rhs* body)
(do-bind lhs* rhs* body Value)]
[(fix lhs* rhs* body)
(do-fix lhs* rhs* body Value)]
[(conditional test conseq altern)
(make-conditional (Pred test) (Value conseq) (Value altern))]
[(seq e0 e1) (mk-seq (Effect e0) (Value e1))]
[(clambda) (do-clambda x)]
[(primcall rator rand*)
(make-primcall rator (map Value rand*))]
[(funcall rator rand*)
(make-funcall (Value rator) (map Value rand*))]
[(appcall rator rand*)
(make-appcall (Value rator) (map Value rand*))]
[(forcall rator rand*)
(make-forcall rator (map Value rand*))]
[(assign lhs rhs)
(mk-seq (Effect x) (make-primcall 'void '()))]
[else (error who "invalid value expression ~s" (unparse x))]))
(let ([x (Value x)])
;;; since we messed up the references and assignments here, we
;;; redo them
(uncover-assigned/referenced x)))
(define (rewrite-assignments x)
@ -3045,6 +3210,8 @@
[(null? arg*) ac]
[else
(Effect (car arg*) (f (cdr arg*)))]))]
[(car) ;;; may signal an error
(do-value-prim op arg* ac)]
[else
(error 'do-effect-prim "unhandled op ~s" op)]))
(define (do-simple-test x Lt Lf ac)
@ -3696,6 +3863,7 @@
[p (optimize-letrec p)]
;[p (remove-letrec p)]
[p (uncover-assigned/referenced p)]
[p (copy-propagate p)]
[p (rewrite-assignments p)]
[p (convert-closures p)]
[p (lift-codes p)]