[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-265-g5db3e6b
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-265-g5db3e6b |
|
Date: |
Mon, 21 Oct 2013 20:32:33 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=5db3e6bce42d902cb8e6ea53e9e950e47496ae59
The branch, master has been updated
via 5db3e6bce42d902cb8e6ea53e9e950e47496ae59 (commit)
via 1e6aee3bf9be79134fad7368e284dc91b1078675 (commit)
via 0620d6b4d2cabceb9b16e3aada7b6a251bf8be4a (commit)
via e92e0bbe9c696d9b06687e6d4f6827a90565ba69 (commit)
via c8ad7426e28d753816239c4fd17e11e5619db3ed (commit)
via bc01d8f7e04277a9ba1e2d780768712ceb17eda1 (commit)
from e636f424b97e8574e0db304f64a1541dd626b3a5 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 5db3e6bce42d902cb8e6ea53e9e950e47496ae59
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 22:25:27 2013 +0200
CPS->RTL compiler: add push-fluid and pop-fluid
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add cases for
push-fluid and pop-fluid.
commit 1e6aee3bf9be79134fad7368e284dc91b1078675
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 22:24:54 2013 +0200
DFG: Remove lift-definition!
* module/language/cps/dfg.scm: Remove lift-definition!.
commit 0620d6b4d2cabceb9b16e3aada7b6a251bf8be4a
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 22:24:18 2013 +0200
Fix contification bugs
* module/language/cps/contification.scm (compute-contification): Rewrite
to avoid mutating the DFG and the function while we are rewriting.
Instead we compute a contification, and if it is not empty, we apply
it and loop.
commit e92e0bbe9c696d9b06687e6d4f6827a90565ba69
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 16:59:42 2013 +0200
More robust contification
* module/language/cps/contification.scm (contify): It could be that
visiting pending contifications could enqueue more contifications, so
iterate to a fixed point. Signal an error if there are any pending
contifications at the end of an iteration.
commit c8ad7426e28d753816239c4fd17e11e5619db3ed
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 16:32:36 2013 +0200
add lookup-block-scope
* module/language/cps/dfg.scm (lookup-block-scope): New interface.
(visit-fun): Give a bit more info if link-blocks! fails.
commit bc01d8f7e04277a9ba1e2d780768712ceb17eda1
Author: Andy Wingo <address@hidden>
Date: Mon Oct 21 16:31:49 2013 +0200
DFG fixup.
* module/language/cps/dfg.scm: Remove dead-after-def? and
dead-after-use? export.
-----------------------------------------------------------------------
Summary of changes:
module/language/cps/compile-rtl.scm | 4 +
module/language/cps/contification.scm | 312 ++++++++++++++++++++-------------
module/language/cps/dfg.scm | 32 +---
3 files changed, 195 insertions(+), 153 deletions(-)
diff --git a/module/language/cps/compile-rtl.scm
b/module/language/cps/compile-rtl.scm
index 0303d61..163458e 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -222,6 +222,10 @@
(emit-set-cdr! asm (slot pair) (slot value)))
(($ $primcall 'define! (sym value))
(emit-define asm (slot sym) (slot value)))
+ (($ $primcall 'push-fluid (fluid val))
+ (emit-push-fluid asm (slot fluid) (slot val)))
+ (($ $primcall 'pop-fluid ())
+ (emit-pop-fluid asm))
(($ $primcall 'unwind ())
(emit-unwind asm))
(($ $primcall name args)
diff --git a/module/language/cps/contification.scm
b/module/language/cps/contification.scm
index 61f17eb..d0aa510 100644
--- a/module/language/cps/contification.scm
+++ b/module/language/cps/contification.scm
@@ -38,52 +38,22 @@
#:use-module (language rtl)
#:export (contify))
-(define (contify fun)
+(define (compute-contification fun)
(let* ((dfg (compute-dfg fun))
(cont-table (dfg-cont-table dfg))
(call-substs '())
(cont-substs '())
- (pending-contifications (make-hash-table)))
+ (fun-elisions '())
+ (cont-splices (make-hash-table)))
(define (subst-call! sym arities body-ks)
(set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(define (subst-return! old-tail new-tail)
(set! cont-substs (acons old-tail new-tail cont-substs)))
- (define (lookup-return-cont k)
- (match (assq-ref cont-substs k)
- (#f k)
- (k (lookup-return-cont k))))
-
- (define (add-pending-contifications! scope conts)
- (for-each (match-lambda
- (($ $cont k)
- (lift-definition! k scope dfg)))
- conts)
- (hashq-set! pending-contifications scope
- (append conts
- (hashq-ref pending-contifications scope '()))))
- (define (finish-pending-contifications call term-k)
- (match (hashq-ref pending-contifications term-k)
- (#f call)
- ((cont ...)
- ;; Catch any possible double-contification bug.
- (hashq-set! pending-contifications term-k 'poison)
- (build-cps-term
- ($letk ,(map visit-cont cont)
- ,call)))))
-
- (define (contify-call proc args)
- (and=> (assq-ref call-substs proc)
- (lambda (clauses)
- (let lp ((clauses clauses))
- (match clauses
- (() (error "invalid contification"))
- (((($ $arity req () #f () #f) . k) . clauses)
- (if (= (length req) (length args))
- (build-cps-term
- ($continue (lookup-return-cont k)
- ($values args)))
- (lp clauses)))
- ((_ . clauses) (lp clauses)))))))
+ (define (elide-function! k)
+ (set! fun-elisions (cons k fun-elisions)))
+ (define (splice-conts! scope conts)
+ (hashq-set! cont-splices scope
+ (append conts (hashq-ref cont-splices scope '()))))
;; If K is a continuation that binds one variable, and it has only
;; one predecessor, return that variable.
@@ -124,7 +94,7 @@
(match (find-call (lookup-cont use cont-table))
(($ $continue k ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
- (lookup-return-cont k)))
+ k))
(_ #f)))
(and
@@ -148,60 +118,61 @@
;; We have a common continuation. High fives!
;;
;; (1) Find the scope at which to contify.
- (let ((scope (if (continuation-bound-in? k term-k dfg)
- term-k
- (lookup-def k dfg))))
- ;; (2) Mark all SYMs for replacement in calls, and
- ;; mark the tail continuations for replacement by K.
- (for-each (lambda (sym tail arities bodies)
- (match bodies
- ((($ $cont body-k) ...)
- (subst-call! sym arities body-k)))
- (subst-return! tail k))
- syms tails arities bodies)
- ;; (3) Mutate the DFG to reflect the new scope of the
- ;; continuations, and arrange for the continuations to
- ;; be spliced into their new scope.
- (add-pending-contifications! scope (concatenate bodies))
- k)))))
+ (and=>
+ (if (continuation-bound-in? k term-k dfg)
+ ;; The common continuation is in scope at the
+ ;; function definition; yay.
+ term-k
+ ;; The common continuation is not in scope at the
+ ;; function definition. Boo.
+ (let ((scope (lookup-block-scope k dfg)))
+ (match (lookup-cont scope cont-table)
+ ;; The common continuation was the tail of some
+ ;; function inside the letrec body.
+ (($ $kentry self tail clauses)
+ (match clauses
+ ;; If that function has just one clause,
+ ;; contify into that clause. Otherwise
+ ;; bail.
+ ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
+ kargs)
+ (_ #f)))
+ ;; Otherwise the common continuation is in some
+ ;; scope we can add to via $letk.
+ (cont scope))))
+ (lambda (scope)
+ ;; (2) Mark all SYMs for replacement in calls, and
+ ;; mark the tail continuations for replacement by K.
+ (for-each (lambda (sym tail arities bodies)
+ (match bodies
+ ((($ $cont body-k) ...)
+ (subst-call! sym arities body-k)))
+ (subst-return! tail k))
+ syms tails arities bodies)
+ ;; (3) Arrange for the continuations to be spliced
+ ;; into their new scope.
+ (splice-conts! scope (concatenate bodies))
+ k))))))
(define (visit-fun term)
- (rewrite-cps-exp term
+ (match term
(($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (visit-cont body))))
(define (visit-cont cont)
- (rewrite-cps-cont cont
- (($ $cont sym src
- ($ $kargs (name) (and sym (? (cut assq <> call-substs)))
- body))
- (sym src ($kargs () () ,(visit-term body sym))))
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body sym))))
+ (match cont
+ (($ $cont sym src ($ $kargs _ _ body))
+ (visit-term body sym))
(($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
+ (for-each visit-cont clauses))
(($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (visit-cont body))
(($ $cont)
- ,cont)))
+ #t)))
(define (visit-term term term-k)
(match term
(($ $letk conts body)
- ;; Visit the body first, so we visit depth-first.
- (let lp ((body (visit-term body term-k)))
- ;; Because we attach contified functions on a particular
- ;; term-k, and one term-k can correspond to an arbitrarily
- ;; nested sequence of $letrec and $letk instances, normalize
- ;; so that all continuations are bound by one $letk --
- ;; guaranteeing that they are in the same scope.
- (rewrite-cps-term body
- (($ $letrec names syms funs body)
- ($letrec names syms funs ,(lp body)))
- (($ $letk conts* body)
- ($letk ,(append conts* (map visit-cont conts))
- ,body))
- (body
- ($letk ,(map visit-cont conts)
- ,body)))))
+ (for-each visit-cont conts)
+ (visit-term body term-k))
(($ $letrec names syms funs body)
(define (split-components nsf)
;; FIXME: Compute strongly-connected components. Currently
@@ -221,10 +192,9 @@
(if (recursive? kentry)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
- (define (visit-components components)
- (match components
- (() (visit-term body term-k))
- ((((name sym fun) ...) . components)
+ (define (visit-component component)
+ (match component
+ (((name sym fun) ...)
(match fun
((($ $fun meta free
($ $cont fun-k _
@@ -233,47 +203,137 @@
(($ $cont _ _ ($ $kclause arity body))
...))))
...)
- (if (contify-funs term-k sym self tail-k arity body)
- (visit-components components)
- (build-cps-term
- ($letrec name sym (map visit-fun fun)
- ,(visit-components components)))))))))
- (visit-components (split-components (map list names syms funs))))
+ (unless (contify-funs term-k sym self tail-k arity body)
+ (for-each visit-fun fun)))))))
+ (visit-term body term-k)
+ (for-each visit-component
+ (split-components (map list names syms funs))))
(($ $continue k exp)
- (let ((k* (lookup-return-cont k)))
- (define (default)
- (rewrite-cps-term exp
- (($ $fun) ($continue k* ,(visit-fun exp)))
- (($ $primcall 'return (val))
- ,(if (eq? k k*)
- (build-cps-term ($continue k* ,exp))
- (build-cps-term ($continue k* ($values (val))))))
- (($ $primcall 'return-values vals)
- ,(if (eq? k k*)
- (build-cps-term ($continue k* ,exp))
- (build-cps-term ($continue k* ($values vals)))))
- (_ ($continue k* ,exp))))
- (finish-pending-contifications
- (match exp
- (($ $fun meta free
- ($ $cont fun-k _
- ($ $kentry self
- ($ $cont tail-k _ ($ $ktail))
- (($ $cont _ _ ($ $kclause arity body)) ...))))
- (if (and=> (bound-symbol k*)
- (lambda (sym)
- (contify-fun term-k sym self tail-k arity body)))
- (build-cps-term
- ($continue k* ($values ())))
- (default)))
- (($ $call proc args)
- (or (contify-call proc args)
- (default)))
- (_ (default)))
- term-k)))))
+ (match exp
+ (($ $fun meta free
+ ($ $cont fun-k _
+ ($ $kentry self
+ ($ $cont tail-k _ ($ $ktail))
+ (($ $cont _ _ ($ $kclause arity body)) ...))))
+ (if (and=> (bound-symbol k)
+ (lambda (sym)
+ (contify-fun term-k sym self tail-k arity body)))
+ (elide-function! k)
+ (visit-fun exp)))
+ (_ #t)))))
- (let ((fun (visit-fun fun)))
+ (visit-fun fun)
+ (values call-substs cont-substs fun-elisions cont-splices)))
+
+(define (apply-contification fun call-substs cont-substs fun-elisions
cont-splices)
+ (define (contify-call proc args)
+ (and=> (assq-ref call-substs proc)
+ (lambda (clauses)
+ (let lp ((clauses clauses))
+ (match clauses
+ (() (error "invalid contification"))
+ (((($ $arity req () #f () #f) . k) . clauses)
+ (if (= (length req) (length args))
+ (build-cps-term
+ ($continue (lookup-return-cont k)
+ ($values args)))
+ (lp clauses)))
+ ((_ . clauses) (lp clauses)))))))
+ (define (lookup-return-cont k)
+ (match (assq-ref cont-substs k)
+ (#f k)
+ (k (lookup-return-cont k))))
+ (define (splice-continuations term-k term)
+ (match (hashq-ref cont-splices term-k)
+ (#f term)
+ ((cont ...)
+ (let lp ((term term))
+ (rewrite-cps-term term
+ (($ $letrec names syms funs body)
+ ($letrec names syms funs ,(lp body)))
+ (($ $letk conts* body)
+ ($letk ,(append conts* (map visit-cont cont))
+ ,body))
+ (body
+ ($letk ,(map visit-cont cont)
+ ,body)))))))
+ (define (visit-fun term)
+ (rewrite-cps-exp term
+ (($ $fun meta free body)
+ ($fun meta free ,(visit-cont body)))))
+ (define (visit-cont cont)
+ (rewrite-cps-cont cont
+ (($ $cont sym src
+ ($ $kargs (name) (and sym (? (cut assq <> call-substs)))
+ body))
+ (sym src ($kargs () () ,(visit-term body sym))))
+ (($ $cont sym src ($ $kargs names syms body))
+ (sym src ($kargs names syms ,(visit-term body sym))))
+ (($ $cont sym src ($ $kentry self tail clauses))
+ (sym src ($kentry self ,tail ,(map visit-cont clauses))))
+ (($ $cont sym src ($ $kclause arity body))
+ (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont)
+ ,cont)))
+ (define (visit-term term term-k)
+ (match term
+ (($ $letk conts body)
+ ;; Visit the body first, so we rewrite depth-first.
+ (let lp ((body (visit-term body term-k)))
+ ;; Because we attach contified functions on a particular
+ ;; term-k, and one term-k can correspond to an arbitrarily
+ ;; nested sequence of $letrec and $letk instances, normalize
+ ;; so that all continuations are bound by one $letk --
+ ;; guaranteeing that they are in the same scope.
+ (rewrite-cps-term body
+ (($ $letrec names syms funs body)
+ ($letrec names syms funs ,(lp body)))
+ (($ $letk conts* body)
+ ($letk ,(append conts* (map visit-cont conts))
+ ,body))
+ (body
+ ($letk ,(map visit-cont conts)
+ ,body)))))
+ (($ $letrec names syms funs body)
+ (rewrite-cps-term (filter (match-lambda
+ ((n s f) (not (assq s call-substs))))
+ (map list names syms funs))
+ (((names syms funs) ...)
+ ($letrec names syms (map visit-fun funs)
+ ,(visit-term body term-k)))))
+ (($ $continue k exp)
+ (splice-continuations
+ term-k
+ (let ((k* (lookup-return-cont k)))
+ (define (default)
+ (rewrite-cps-term exp
+ (($ $fun) ($continue k* ,(visit-fun exp)))
+ (($ $primcall 'return (val))
+ ,(if (eq? k k*)
+ (build-cps-term ($continue k* ,exp))
+ (build-cps-term ($continue k* ($values (val))))))
+ (($ $primcall 'return-values vals)
+ ,(if (eq? k k*)
+ (build-cps-term ($continue k* ,exp))
+ (build-cps-term ($continue k* ($values vals)))))
+ (_ ($continue k* ,exp))))
+ (match exp
+ (($ $fun)
+ (if (memq k fun-elisions)
+ (build-cps-term
+ ($continue k* ($values ())))
+ (default)))
+ (($ $call proc args)
+ (or (contify-call proc args)
+ (default)))
+ (_ (default))))))))
+ (visit-fun fun))
+
+(define (contify fun)
+ (call-with-values (lambda () (compute-contification fun))
+ (lambda (call-substs cont-substs fun-elisions cont-splices)
(if (null? call-substs)
fun
;; Iterate to fixed point.
- (contify fun)))))
+ (contify
+ (apply-contification fun call-substs cont-substs fun-elisions
cont-splices))))))
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 0e37835..e56c986 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -50,17 +50,15 @@
lookup-uses
lookup-predecessors
lookup-successors
+ lookup-block-scope
find-call
call-expression
find-expression
find-defining-expression
find-constant-value
- lift-definition!
continuation-bound-in?
variable-free-in?
constant-needs-allocation?
- dead-after-def?
- dead-after-use?
control-point?
lookup-bound-syms
@@ -601,7 +599,7 @@
(let ((pred-block (hashq-ref blocks pred))
(succ-block (hashq-ref blocks succ)))
(unless (and pred-block succ-block)
- (error "internal error"))
+ (error "internal error" pred-block succ-block))
(set-block-succs! pred-block (cons succ (block-succs pred-block)))
(set-block-preds! succ-block (cons pred (block-preds succ-block)))))
@@ -729,6 +727,9 @@
(($ $use-map name sym def uses)
uses)))))
+(define (lookup-block-scope k dfg)
+ (block-scope (lookup-block k (dfg-blocks dfg))))
+
(define (lookup-predecessors k dfg)
(match (lookup-block k (dfg-blocks dfg))
(($ $block _ _ preds succs) preds)))
@@ -812,29 +813,6 @@
(and (< scope-level level)
(lp scope))))))))
-;; FIXME: Splice preds, succs, dom tree.
-(define (lift-definition! k scope-k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (let ((scope-level (1+ (lookup-scope-level scope-k blocks))))
- ;; Fix parent scope link of K.
- (match (lookup-block k blocks)
- ((and block ($ $block))
- (set-block-scope! block scope-k)))
- ;; Fix up scope levels of K and all contained scopes.
- (let update-levels! ((k k) (level scope-level))
- (match (lookup-block k blocks)
- ((and block ($ $block))
- (set-block-scope-level! block scope-level)))
- (let lp ((cont (lookup-cont k conts)))
- (match cont
- (($ $letk (($ $cont kid) ...) body)
- (for-each (cut update-levels! <> (1+ scope-level)) kid)
- (lp body))
- (($ $letrec names syms funs body)
- (lp body))
- (_ #t))))))))
-
(define (continuation-bound-in? k use-k dfg)
(match dfg
(($ $dfg conts blocks use-maps)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-265-g5db3e6b,
Andy Wingo <=