;;; 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
(define (compute-contification fun)
(let* ((dfg (compute-dfg fun))
- (cont-table (dfg-cont-table dfg))
(scope-table (make-hash-table))
(call-substs '())
(cont-substs '())
;; 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)
;; Converge more quickly by resolving already-contified
(let ((k-scope (continuation-scope k)))
(if (scope-contains? k-scope term-k)
term-k
- (match (lookup-cont k-scope cont-table)
- (($ $kentry self tail clauses)
+ (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 clauses
- ((($ $cont _ ($ $kclause arity ($ $cont kargs))))
+ (match clause
+ (($ $cont _ ($ $kclause arity ($ $cont kargs) #f))
kargs)
(_ #f)))
(_ k-scope)))))
(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)))
...)
- (if (contify-funs term-k sym self tail-k arity body)
- (for-each (cut for-each visit-cont <>) 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)))
+ (contify-fun term-k sym self tail-k
+ (extract-arities clause)
+ (extract-bodies clause))))
(begin
- (elide-function! k (lookup-cont k cont-table))
- (for-each visit-cont body))
+ (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))
HCoop / bpt / guile.git / blobdiff