mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-23 20:05:32 +02:00
Code Activity

Contify returns via calls to "values"

Browse source 
* module/language/cps/contification.scm: Returns from contified
  functions should primcall to 'values, as in general the return
  continuation is a multiple value context ($ktrunc or $ktail).  A later
  pass can elide the primcall if appropriate.
This commit is contained in:
Andy Wingo 2013-10-22 22:29:56 +02:00
parent 5db3e6bce4
commit 8b2a96d044
1 changed files with 98 additions and 88 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -79,6 +79,9 @@
;; continuation. Returns a true value on success, and false ;; continuation. Returns a true value on success, and false
;; otherwise. ;; otherwise.
(define (contify-funs term-k syms selfs tails arities bodies) (define (contify-funs term-k syms selfs tails arities bodies)
(define (unused? sym)
(null? (lookup-uses sym dfg)))
;; 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)
(or-map (match-lambda (or-map (match-lambda
@ -97,62 +100,71 @@
k)) k))
(_ #f))) (_ #f)))
(and ;; If this set of functions is always called with one
(and-map null? (map (cut lookup-uses <> dfg) selfs)) ;; continuation, not counting tail calls between the functions,
(and=> (let visit-syms ((syms syms) (k #f)) ;; return that continuation.
(match syms (define (find-common-continuation)
(() k) (let visit-syms ((syms syms) (k #f))
((sym . syms) (match syms
(let visit-uses ((uses (lookup-uses sym dfg)) (k k)) (() k)
(match uses ((sym . syms)
(() (visit-syms syms k)) (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
((use . uses) (match uses
(and=> (call-target use sym) (() (visit-syms syms k))
(lambda (k*) ((use . uses)
(cond (and=> (call-target use sym)
((memq k* tails) (visit-uses uses k)) (lambda (k*)
((not k) (visit-uses uses k*)) (cond
((eq? k k*) (visit-uses uses k)) ((memq k* tails) (visit-uses uses k))
(else #f)))))))))) ((not k) (visit-uses uses k*))
(lambda (k) ((eq? k k*) (visit-uses uses k))
;; We have a common continuation. High fives! (else #f)))))))))))
;;
;; (1) Find the scope at which to contify. ;; Given that the functions are called with the common
(and=> ;; continuation K, determine the scope at which to contify the
(if (continuation-bound-in? k term-k dfg) ;; functions. If K is in scope in the term, we go ahead and
;; The common continuation is in scope at the ;; contify them there. Otherwise the scope is inside the letrec
;; function definition; yay. ;; body, and so choose the scope in which the continuation is
term-k ;; defined, whose free variables are a superset of the free
;; The common continuation is not in scope at the ;; variables of the functions.
;; function definition. Boo. ;;
(let ((scope (lookup-block-scope k dfg))) ;; FIXME: Does this choose the right scope for contified let-bound
(match (lookup-cont scope cont-table) ;; functions?
;; The common continuation was the tail of some (define (find-contification-scope k)
;; function inside the letrec body. (if (continuation-bound-in? k term-k dfg)
(($ $kentry self tail clauses) term-k
(match clauses (let ((scope (lookup-block-scope k dfg)))
;; If that function has just one clause, (match (lookup-cont scope cont-table)
;; contify into that clause. Otherwise ;; The common continuation was the tail of some function
;; bail. ;; inside the letrec body. If that function has just
((($ $cont _ _ ($ $kclause arity ($ $cont kargs)))) ;; one clause, contify into that clause. Otherwise
kargs) ;; bail.
(_ #f))) (($ $kentry self tail clauses)
;; Otherwise the common continuation is in some (match clauses
;; scope we can add to via $letk. ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
(cont scope)))) kargs)
(lambda (scope) (_ #f)))
;; (2) Mark all SYMs for replacement in calls, and (_ scope)))))
;; mark the tail continuations for replacement by K.
(for-each (lambda (sym tail arities bodies) ;; We are going to contify. Mark all SYMs for replacement in
(match bodies ;; calls, and mark the tail continuations for replacement by K.
((($ $cont body-k) ...) ;; Arrange for the continuations to be spliced into SCOPE.
(subst-call! sym arities body-k))) (define (enqueue-contification! k scope)
(subst-return! tail k)) (for-each (lambda (sym tail arities bodies)
syms tails arities bodies) (match bodies
;; (3) Arrange for the continuations to be spliced ((($ $cont body-k) ...)
;; into their new scope. (subst-call! sym arities body-k)))
(splice-conts! scope (concatenate bodies)) (subst-return! tail k))
k)))))) syms tails arities bodies)
(splice-conts! scope (concatenate bodies))
#t)
;; "Call me maybe"
(and (and-map unused? selfs)
(and=> (find-common-continuation)
(lambda (k)
(and=> (find-contification-scope k)
(cut enqueue-contification! k <>))))))
(define (visit-fun term) (define (visit-fun term)
(match term (match term
@ -235,14 +247,26 @@
(((($ $arity req () #f () #f) . k) . clauses) (((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args)) (if (= (length req) (length args))
(build-cps-term (build-cps-term
($continue (lookup-return-cont k) ($continue k
($values args))) ($values args)))
(lp clauses))) (lp clauses)))
((_ . clauses) (lp clauses))))))) ((_ . clauses) (lp clauses)))))))
(define (lookup-return-cont k) (define (continue k exp)
(match (assq-ref cont-substs k) (define (lookup-return-cont k)
(#f k) (match (assq-ref cont-substs k)
(k (lookup-return-cont k)))) (#f k)
(k (lookup-return-cont k))))
(let ((k* (lookup-return-cont k)))
;; We are contifying this return. It must be a call or a
;; primcall to values, return, or return-values.
(if (eq? k k*)
(build-cps-term ($continue k ,exp))
(rewrite-cps-term exp
(($ $primcall 'return (val))
($continue k* ($primcall 'values (val))))
(($ $values vals)
($continue k* ($primcall 'values vals)))
(_ ($continue k* ,exp))))))
(define (splice-continuations term-k term) (define (splice-continuations term-k term)
(match (hashq-ref cont-splices term-k) (match (hashq-ref cont-splices term-k)
(#f term) (#f term)
@ -263,10 +287,9 @@
($fun meta free ,(visit-cont body))))) ($fun meta free ,(visit-cont body)))))
(define (visit-cont cont) (define (visit-cont cont)
(rewrite-cps-cont cont (rewrite-cps-cont cont
(($ $cont sym src (($ $cont (and k (? (cut memq <> fun-elisions))) src
($ $kargs (name) (and sym (? (cut assq <> call-substs))) ($ $kargs (_) (_) body))
body)) (k src ($kargs () () ,(visit-term body k))))
(sym src ($kargs () () ,(visit-term body sym))))
(($ $cont sym src ($ $kargs names syms body)) (($ $cont sym src ($ $kargs names syms body))
(sym src ($kargs names syms ,(visit-term body sym)))) (sym src ($kargs names syms ,(visit-term body sym))))
(($ $cont sym src ($ $kentry self tail clauses)) (($ $cont sym src ($ $kentry self tail clauses))
@ -304,29 +327,16 @@
(($ $continue k exp) (($ $continue k exp)
(splice-continuations (splice-continuations
term-k term-k
(let ((k* (lookup-return-cont k))) (match exp
(define (default) (($ $fun)
(rewrite-cps-term exp (if (memq k fun-elisions)
(($ $fun) ($continue k* ,(visit-fun exp))) (build-cps-term
(($ $primcall 'return (val)) ($continue k ($values ())))
,(if (eq? k k*) (continue k (visit-fun exp))))
(build-cps-term ($continue k* ,exp)) (($ $call proc args)
(build-cps-term ($continue k* ($values (val)))))) (or (contify-call proc args)
(($ $primcall 'return-values vals) (continue k exp)))
,(if (eq? k k*) (_ (continue k exp)))))))
(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)) (visit-fun fun))
(define (contify fun) (define (contify fun)