;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (language cps)
#:use-module (language cps dfg)
#:use-module (language cps primitives)
- #:use-module (language rtl)
+ #:use-module (language bytecode)
#:export (contify))
(define (compute-contification fun)
(let* ((dfg (compute-dfg fun))
- (cont-table (dfg-cont-table dfg))
+ (scope-table (make-hash-table))
(call-substs '())
(cont-substs '())
(fun-elisions '())
(define (elide-function! k cont)
(set! fun-elisions (acons k cont fun-elisions)))
(define (splice-conts! scope conts)
+ (for-each (match-lambda
+ (($ $cont k) (hashq-set! scope-table k scope)))
+ conts)
(hashq-set! cont-splices scope
(append conts (hashq-ref cont-splices scope '()))))
+ (define (lookup-return-cont k)
+ (match (assq-ref cont-substs k)
+ (#f k)
+ (k (lookup-return-cont k))))
+
;; If K is a continuation that binds one variable, and it has only
;; one predecessor, return that variable.
(define (bound-symbol k)
- (match (lookup-cont k cont-table)
+ (match (lookup-cont k dfg)
(($ $kargs (_) (sym))
(match (lookup-predecessors k dfg)
((_)
(_ #f)))
(_ #f)))
+ (define (extract-arities clause)
+ (match clause
+ (($ $cont _ ($ $kclause arity body alternate))
+ (cons arity (extract-arities alternate)))
+ (#f '())))
+ (define (extract-bodies clause)
+ (match clause
+ (($ $cont _ ($ $kclause arity body alternate))
+ (cons body (extract-bodies alternate)))
+ (#f '())))
+
(define (contify-fun term-k sym self tail arities bodies)
(contify-funs term-k
(list sym) (list self) (list tail)
;; is compatible with one of the procedure's arities, return the
;; target continuation. Otherwise return #f.
(define (call-target use proc)
- (match (find-call (lookup-cont use cont-table))
+ (match (find-call (lookup-cont use dfg))
(($ $continue k src ($ $call proc* args))
(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
- k))
+ ;; Converge more quickly by resolving already-contified
+ ;; call targets.
+ (lookup-return-cont k)))
(_ #f)))
;; If this set of functions is always called with one
;; defined, whose free variables are a superset of the free
;; variables of the functions.
;;
+ ;; There is some slight trickiness here. Call-target already uses
+ ;; the information we compute within this pass. Previous
+ ;; contifications may cause functions to be contified not at their
+ ;; point of definition but at their point of non-recursive use.
+ ;; That will cause the scope nesting to change. (It may
+ ;; effectively push a function deeper down the tree -- the second
+ ;; case above, a call within the letrec body.) What if we contify
+ ;; to the tail of a previously contified function? We have to
+ ;; track what the new scope tree will be when asking whether K
+ ;; will be bound in TERM-K's scope, not the scope tree that
+ ;; existed when we started the pass.
+ ;;
;; FIXME: Does this choose the right scope for contified let-bound
;; functions?
(define (find-contification-scope k)
- (if (continuation-bound-in? k term-k dfg)
- term-k
- (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. If that function has just
- ;; one clause, contify into that clause. Otherwise
- ;; bail.
- (($ $kentry self tail clauses)
- (match clauses
- ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
+ (define (scope-contains? scope k)
+ (let ((k-scope (or (hashq-ref scope-table k)
+ (let ((k-scope (lookup-block-scope k dfg)))
+ (hashq-set! scope-table k k-scope)
+ k-scope))))
+ (or (eq? scope k-scope)
+ (and k-scope (scope-contains? scope k-scope)))))
+
+ ;; Find the scope of K.
+ (define (continuation-scope k)
+ (or (hashq-ref scope-table k)
+ (let ((scope (lookup-block-scope k dfg)))
+ (hashq-set! scope-table k scope)
+ scope)))
+
+ (let ((k-scope (continuation-scope k)))
+ (if (scope-contains? k-scope term-k)
+ term-k
+ (match (lookup-cont k-scope dfg)
+ (($ $kfun src meta self tail clause)
+ ;; K is the tail of some function. If that function
+ ;; has just one clause, return that clause. Otherwise
+ ;; bail.
+ (match clause
+ (($ $cont _ ($ $kclause arity ($ $cont kargs) #f))
kargs)
(_ #f)))
- (_ scope)))))
+ (_ k-scope)))))
;; We are going to contify. Mark all SYMs for replacement in
;; calls, and mark the tail continuations for replacement by K.
(define (visit-fun term)
(match term
- (($ $fun src meta free body)
+ (($ $fun free body)
(visit-cont body))))
(define (visit-cont cont)
(match cont
(($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
- (($ $cont sym ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont sym ($ $kclause arity body))
- (visit-cont body))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (when clause (visit-cont clause)))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (visit-cont body)
+ (when alternate (visit-cont alternate)))
(($ $cont)
#t)))
(define (visit-term term term-k)
(if (null? rec)
'()
(list rec)))
- (((and elt (n s ($ $fun src meta free ($ $cont kentry))))
+ (((and elt (n s ($ $fun free ($ $cont kfun))))
. nsf)
- (if (recursive? kentry)
+ (if (recursive? kfun)
(lp nsf (cons elt rec))
(cons (list elt) (lp nsf rec)))))))
+ (define (extract-arities+bodies clauses)
+ (values (map extract-arities clauses)
+ (map extract-bodies clauses)))
(define (visit-component component)
(match component
(((name sym fun) ...)
(match fun
- ((($ $fun src meta free
+ ((($ $fun free
($ $cont fun-k
- ($ $kentry self
- ($ $cont tail-k ($ $ktail))
- (($ $cont _ ($ $kclause arity body))
- ...))))
+ ($ $kfun src meta self ($ $cont tail-k ($ $ktail))
+ clause)))
...)
- (unless (contify-funs term-k sym self tail-k arity body)
- (for-each visit-fun fun)))))))
+ (call-with-values (lambda () (extract-arities+bodies clause))
+ (lambda (arities bodies)
+ (if (contify-funs term-k sym self tail-k arities bodies)
+ (for-each (cut for-each visit-cont <>) bodies)
+ (for-each visit-fun fun)))))))))
(visit-term body term-k)
(for-each visit-component
(split-components (map list names syms funs))))
(($ $continue k src exp)
(match exp
- (($ $fun src meta free
+ (($ $fun free
($ $cont fun-k
- ($ $kentry self
- ($ $cont tail-k ($ $ktail))
- (($ $cont _ ($ $kclause arity body)) ...))))
+ ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause)))
(if (and=> (bound-symbol k)
(lambda (sym)
- (contify-fun term-k sym self tail-k arity body)))
- (elide-function! k (lookup-cont k cont-table))
+ (contify-fun term-k sym self tail-k
+ (extract-arities clause)
+ (extract-bodies clause))))
+ (begin
+ (elide-function! k (lookup-cont k dfg))
+ (for-each visit-cont (extract-bodies clause)))
(visit-fun exp)))
(_ #t)))))
- (visit-fun fun)
+ (visit-cont fun)
(values call-substs cont-substs fun-elisions cont-splices)))
(define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
,body)))))))
(define (visit-fun term)
(rewrite-cps-exp term
- (($ $fun src meta free body)
- ($fun src meta free ,(visit-cont body)))))
+ (($ $fun free body)
+ ($fun free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
(($ $cont (? (cut assq <> fun-elisions)))
,#f)
(($ $cont sym ($ $kargs names syms body))
(sym ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym ($ $kentry self tail clauses))
- (sym ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym ($ $kclause arity body))
- (sym ($kclause ,arity ,(visit-cont body))))
+ (($ $cont sym ($ $kfun src meta self tail clause))
+ (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause)))))
+ (($ $cont sym ($ $kclause arity body alternate))
+ (sym ($kclause ,arity ,(visit-cont body)
+ ,(and alternate (visit-cont alternate)))))
(($ $cont)
,cont)))
(define (visit-term term term-k)
(or (contify-call src proc args)
(continue k src exp)))
(_ (continue k src exp)))))))
- (visit-fun fun))
+ (visit-cont fun))
(define (contify fun)
(call-with-values (lambda () (compute-contification fun))