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

106
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,9 +100,11 @@
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.
(define (find-common-continuation)
(let visit-syms ((syms syms) (k #f))
(match syms (match syms
(() k) (() k)
((sym . syms) ((sym . syms)
@ -113,46 +118,53 @@
((memq k* tails) (visit-uses uses k)) ((memq k* tails) (visit-uses uses k))
((not k) (visit-uses uses k*)) ((not k) (visit-uses uses k*))
((eq? k k*) (visit-uses uses k)) ((eq? k k*) (visit-uses uses k))
(else #f)))))))))) (else #f)))))))))))
(lambda (k)
;; We have a common continuation. High fives! ;; Given that the functions are called with the common
;; continuation K, determine the scope at which to contify the
;; functions. If K is in scope in the term, we go ahead and
;; contify them there. Otherwise the scope is inside the letrec
;; body, and so choose the scope in which the continuation is
;; defined, whose free variables are a superset of the free
;; variables of the functions.
;; ;;
;; (1) Find the scope at which to contify. ;; FIXME: Does this choose the right scope for contified let-bound
(and=> ;; functions?
(define (find-contification-scope k)
(if (continuation-bound-in? k term-k dfg) (if (continuation-bound-in? k term-k dfg)
;; The common continuation is in scope at the
;; function definition; yay.
term-k term-k
;; The common continuation is not in scope at the
;; function definition. Boo.
(let ((scope (lookup-block-scope k dfg))) (let ((scope (lookup-block-scope k dfg)))
(match (lookup-cont scope cont-table) (match (lookup-cont scope cont-table)
;; The common continuation was the tail of some ;; The common continuation was the tail of some function
;; function inside the letrec body. ;; inside the letrec body. If that function has just
;; one clause, contify into that clause. Otherwise
;; bail.
(($ $kentry self tail clauses) (($ $kentry self tail clauses)
(match clauses (match clauses
;; If that function has just one clause,
;; contify into that clause. Otherwise
;; bail.
((($ $cont _ _ ($ $kclause arity ($ $cont kargs)))) ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
kargs) kargs)
(_ #f))) (_ #f)))
;; Otherwise the common continuation is in some (_ scope)))))
;; scope we can add to via $letk.
(cont scope)))) ;; We are going to contify. Mark all SYMs for replacement in
(lambda (scope) ;; calls, and mark the tail continuations for replacement by K.
;; (2) Mark all SYMs for replacement in calls, and ;; Arrange for the continuations to be spliced into SCOPE.
;; mark the tail continuations for replacement by K. (define (enqueue-contification! k scope)
(for-each (lambda (sym tail arities bodies) (for-each (lambda (sym tail arities bodies)
(match bodies (match bodies
((($ $cont body-k) ...) ((($ $cont body-k) ...)
(subst-call! sym arities body-k))) (subst-call! sym arities body-k)))
(subst-return! tail k)) (subst-return! tail k))
syms tails arities bodies) syms tails arities bodies)
;; (3) Arrange for the continuations to be spliced
;; into their new scope.
(splice-conts! scope (concatenate bodies)) (splice-conts! scope (concatenate bodies))
k)))))) #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 (continue k exp)
(define (lookup-return-cont k) (define (lookup-return-cont k)
(match (assq-ref cont-substs k) (match (assq-ref cont-substs k)
(#f k) (#f k)
(k (lookup-return-cont 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)))
(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 (match exp
(($ $fun) (($ $fun)
(if (memq k fun-elisions) (if (memq k fun-elisions)
(build-cps-term (build-cps-term
($continue k* ($values ()))) ($continue k ($values ())))
(default))) (continue k (visit-fun exp))))
(($ $call proc args) (($ $call proc args)
(or (contify-call proc args) (or (contify-call proc args)
(default))) (continue k exp)))
(_ (default)))))))) (_ (continue k exp)))))))
(visit-fun fun)) (visit-fun fun))
(define (contify fun) (define (contify fun)