;;; 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-module (language cps contification)
#:use-module (ice-9 match)
- #:use-module ((srfi srfi-1) #:select (concatenate))
+ #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
#:use-module (srfi srfi-26)
#: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 '())
(set! call-substs (acons sym (map cons arities body-ks) call-substs)))
(define (subst-return! old-tail new-tail)
(set! cont-substs (acons old-tail new-tail cont-substs)))
- (define (elide-function! k)
- (set! fun-elisions (cons k 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)
;; Are the given args compatible with any of the arities?
(define (applicable? proc args)
- (or-map (match-lambda
- (($ $arity req () #f () #f)
- (= (length args) (length req)))
- (_ #f))
- (assq-ref (map cons syms arities) proc)))
+ (let lp ((arities (assq-ref (map cons syms arities) proc)))
+ (match arities
+ ((($ $arity req () #f () #f) . arities)
+ (or (= (length args) (length req))
+ (lp arities)))
+ ;; If we reached the end of the arities, fail. Also fail if
+ ;; the next arity in the list has optional, keyword, or rest
+ ;; arguments.
+ (_ #f))))
;; If the use of PROC in continuation USE is a call to PROC that
;; 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))
- (($ $continue k ($ $call proc* args))
+ (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 meta free body)
+ (($ $fun free body)
(visit-cont body))))
(define (visit-cont cont)
(match cont
- (($ $cont sym src ($ $kargs _ _ body))
+ (($ $cont sym ($ $kargs _ _ body))
(visit-term body sym))
- (($ $cont sym src ($ $kentry self tail clauses))
- (for-each visit-cont clauses))
- (($ $cont sym src ($ $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 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 meta free
- ($ $cont fun-k _
- ($ $kentry self
- ($ $cont tail-k _ ($ $ktail))
- (($ $cont _ _ ($ $kclause arity body))
- ...))))
+ ((($ $fun free
+ ($ $cont fun-k
+ ($ $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 exp)
+ (($ $continue k src exp)
(match exp
- (($ $fun meta free
- ($ $cont fun-k _
- ($ $kentry self
- ($ $cont tail-k _ ($ $ktail))
- (($ $cont _ _ ($ $kclause arity body)) ...))))
+ (($ $fun free
+ ($ $cont fun-k
+ ($ $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)
+ (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)
- (define (contify-call proc args)
+ (define (contify-call src proc args)
(and=> (assq-ref call-substs proc)
(lambda (clauses)
(let lp ((clauses clauses))
(((($ $arity req () #f () #f) . k) . clauses)
(if (= (length req) (length args))
(build-cps-term
- ($continue k
+ ($continue k src
($values args)))
(lp clauses)))
((_ . clauses) (lp clauses)))))))
- (define (continue k exp)
+ (define (continue k src exp)
(define (lookup-return-cont k)
(match (assq-ref cont-substs k)
(#f 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))
+ (build-cps-term ($continue k src ,exp))
(rewrite-cps-term exp
(($ $primcall 'return (val))
- ($continue k* ($primcall 'values (val))))
+ ($continue k* src ($primcall 'values (val))))
(($ $values vals)
- ($continue k* ($primcall 'values vals)))
- (_ ($continue k* ,exp))))))
+ ($continue k* src ($primcall 'values vals)))
+ (_ ($continue k* src ,exp))))))
(define (splice-continuations term-k term)
(match (hashq-ref cont-splices term-k)
(#f term)
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
- ($letk ,(append conts* (map visit-cont cont))
+ ($letk ,(append conts* (filter-map visit-cont cont))
,body))
(body
- ($letk ,(map visit-cont cont)
+ ($letk ,(filter-map visit-cont cont)
,body)))))))
(define (visit-fun term)
(rewrite-cps-exp term
- (($ $fun meta free body)
- ($fun meta free ,(visit-cont body)))))
+ (($ $fun free body)
+ ($fun free ,(visit-cont body)))))
(define (visit-cont cont)
(rewrite-cps-cont cont
- (($ $cont (and k (? (cut memq <> fun-elisions))) src
- ($ $kargs (_) (_) body))
- (k src ($kargs () () ,(visit-term body k))))
- (($ $cont sym src ($ $kargs names syms body))
- (sym src ($kargs names syms ,(visit-term body sym))))
- (($ $cont sym src ($ $kentry self tail clauses))
- (sym src ($kentry self ,tail ,(map visit-cont clauses))))
- (($ $cont sym src ($ $kclause arity body))
- (sym src ($kclause ,arity ,(visit-cont body))))
+ (($ $cont (? (cut assq <> fun-elisions)))
+ ;; This cont gets inlined in place of the $fun.
+ ,#f)
+ (($ $cont sym ($ $kargs names syms body))
+ (sym ($kargs names syms ,(visit-term body sym))))
+ (($ $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)
(($ $letrec names syms funs body)
($letrec names syms funs ,(lp body)))
(($ $letk conts* body)
- ($letk ,(append conts* (map visit-cont conts))
+ ($letk ,(append conts* (filter-map visit-cont conts))
,body))
(body
- ($letk ,(map visit-cont conts)
+ ($letk ,(filter-map visit-cont conts)
,body)))))
(($ $letrec names syms funs body)
(rewrite-cps-term (filter (match-lambda
(((names syms funs) ...)
($letrec names syms (map visit-fun funs)
,(visit-term body term-k)))))
- (($ $continue k exp)
+ (($ $continue k src exp)
(splice-continuations
term-k
(match exp
(($ $fun)
- (if (memq k fun-elisions)
- (build-cps-term
- ($continue k ($values ())))
- (continue k (visit-fun exp))))
+ (cond
+ ((assq-ref fun-elisions k)
+ => (match-lambda
+ (($ $kargs (_) (_) body)
+ (visit-term body k))))
+ (else
+ (continue k src (visit-fun exp)))))
(($ $call proc args)
- (or (contify-call proc args)
- (continue k exp)))
- (_ (continue k exp)))))))
- (visit-fun fun))
+ (or (contify-call src proc args)
+ (continue k src exp)))
+ (_ (continue k src exp)))))))
+ (visit-cont fun))
(define (contify fun)
(call-with-values (lambda () (compute-contification fun))
(if (null? call-substs)
fun
;; Iterate to fixed point.
- (begin
- (pk 'CONTIFIED (length call-substs))
- (contify
- (apply-contification fun call-substs cont-substs fun-elisions cont-splices)))))))
+ (contify
+ (apply-contification fun call-substs cont-substs fun-elisions cont-splices))))))
HCoop / bpt / guile.git / blobdiff