mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-14 15:40:19 +02:00
Code Activity

Contify functions in the scope of their continuation.

Browse source 
* module/language/cps/contification.scm (contify): Fix to contify
  functions in the scope of their continuation.
This commit is contained in:
Andy Wingo 2013-10-04 14:08:52 +02:00
parent d51fb1e67b
commit 7ea00e230a
1 changed files with 80 additions and 48 deletions
Download patch file Download diff file Expand all files Collapse all files

128
module/language/cps/contification.scm
View file

@ -42,7 +42,8 @@
(let* ((dfg (compute-dfg fun)) (let* ((dfg (compute-dfg fun))
(cont-table (dfg-cont-table dfg)) (cont-table (dfg-cont-table dfg))
(call-substs '()) (call-substs '())
(cont-substs '())) (cont-substs '())
(pending-contifications (make-hash-table)))
(define (subst-call! sym arities body-ks) (define (subst-call! sym arities body-ks)
(set! call-substs (acons sym (map cons arities body-ks) call-substs))) (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(define (subst-return! old-tail new-tail) (define (subst-return! old-tail new-tail)
@ -50,6 +51,24 @@
(define (lookup-return-cont k) (define (lookup-return-cont k)
(or (assq-ref cont-substs k) k)) (or (assq-ref cont-substs k) 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) (define (contify-call proc args)
(and=> (assq-ref call-substs proc) (and=> (assq-ref call-substs proc)
(lambda (clauses) (lambda (clauses)
@ -84,8 +103,8 @@
;; variables SYMS, with self symbols SELFS, tail continuations ;; variables SYMS, with self symbols SELFS, tail continuations
;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K, ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
;; contify them if we can prove that they all return to the same ;; contify them if we can prove that they all return to the same
;; continuation. If successful, return that common continuation. ;; continuation. Returns a true value on success, and false
;; Otherwise return #f. ;; otherwise.
(define (contify-funs term-k syms selfs tails arities bodies) (define (contify-funs term-k syms selfs tails arities bodies)
;; Are the given args compatible with any of the arities? ;; Are the given args compatible with any of the arities?
(define (applicable? proc args) (define (applicable? proc args)
@ -123,19 +142,26 @@
((eq? k k*) (visit-uses uses k)) ((eq? k k*) (visit-uses uses k))
(else #f)))))))))) (else #f))))))))))
(lambda (k) (lambda (k)
;; We have a common continuation, so we contify: mark ;; We have a common continuation. High fives!
;; all SYMs for replacement in calls, and mark the tail ;;
;; continuations for replacement by K. ;; (1) Find the scope at which to contify.
(for-each (lambda (sym tail arities bodies) (let ((scope (if (variable-bound-in? k term-k dfg)
(for-each (cut lift-definition! <> term-k dfg) term-k
bodies) (lookup-def k dfg))))
(subst-call! sym arities bodies) ;; (2) Mark all SYMs for replacement in calls, and
(subst-return! tail k)) ;; mark the tail continuations for replacement by K.
syms tails arities bodies) (for-each (lambda (sym tail arities bodies)
k)))) (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)))))
;; This is a first cut at a contification algorithm. It contifies
;; non-recursive functions that only have positional arguments.
(define (visit-fun term) (define (visit-fun term)
(rewrite-cps-exp term (rewrite-cps-exp term
(($ $fun meta free body) (($ $fun meta free body)
@ -158,9 +184,21 @@
(match term (match term
(($ $letk conts body) (($ $letk conts body)
;; Visit the body first, so we visit depth-first. ;; Visit the body first, so we visit depth-first.
(let ((body (visit-term body term-k))) (let lp ((body (visit-term body term-k)))
(build-cps-term ;; Because we attach contified functions on a particular
($letk ,(map visit-cont conts) ,body)))) ;; 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) (($ $letrec names syms funs body)
(define (split-components nsf) (define (split-components nsf)
;; FIXME: Compute strongly-connected components. Currently ;; FIXME: Compute strongly-connected components. Currently
@ -189,19 +227,14 @@
($ $cont fun-k _ ($ $cont fun-k _
($ $kentry self ($ $kentry self
($ $cont tail-k _ ($ $ktail)) ($ $cont tail-k _ ($ $ktail))
(($ $cont _ _ ($ $kclause arity (($ $cont _ _ ($ $kclause arity body))
(and body ($ $cont body-k))))
...)))) ...))))
...) ...)
(if (contify-funs term-k sym self tail-k arity body-k) (if (contify-funs term-k sym self tail-k arity body)
(let ((body* (visit-components components))) (visit-components components)
(build-cps-term (build-cps-term
($letk ,(map visit-cont (concatenate body)) ($letrec name sym (map visit-fun fun)
,body*))) ,(visit-components components)))))))))
(let-gensyms (k)
(build-cps-term
($letrec name sym (map visit-fun fun)
,(visit-components components))))))))))
(visit-components (split-components (map list names syms funs)))) (visit-components (split-components (map list names syms funs))))
(($ $continue k exp) (($ $continue k exp)
(let ((k* (lookup-return-cont k))) (let ((k* (lookup-return-cont k)))
@ -217,25 +250,24 @@
(build-cps-term ($continue k* ,exp)) (build-cps-term ($continue k* ,exp))
(build-cps-term ($continue k* ($values vals))))) (build-cps-term ($continue k* ($values vals)))))
(_ ($continue k* ,exp)))) (_ ($continue k* ,exp))))
(match exp (finish-pending-contifications
(($ $fun meta free (match exp
($ $cont fun-k _ (($ $fun meta free
($ $kentry self ($ $cont fun-k _
($ $cont tail-k _ ($ $ktail)) ($ $kentry self
(($ $cont _ _ ($ $kclause arity ($ $cont tail-k _ ($ $ktail))
(and body ($ $cont body-k)))) (($ $cont _ _ ($ $kclause arity body)) ...))))
...)))) (if (and=> (bound-symbol k*)
(if (and=> (bound-symbol k*) (lambda (sym)
(lambda (sym) (contify-fun term-k sym self tail-k arity body)))
(contify-fun term-k sym self tail-k arity body-k))) (build-cps-term
(build-cps-term ($continue k* ($values ())))
($letk ,(map visit-cont body) (default)))
($continue k* ($values ())))) (($ $call proc args)
(default))) (or (contify-call proc args)
(($ $call proc args) (default)))
(or (contify-call proc args) (_ (default)))
(default))) term-k)))))
(_ (default)))))))
(let ((fun (visit-fun fun))) (let ((fun (visit-fun fun)))
(if (null? call-substs) (if (null? call-substs)