X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/b681671ede9cefcbfa9d59169030b013f5ddfc6a..fd61004764931116bcf2d9875b2aa7dc05992d7c:/module/language/cps/contification.scm diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index aa162e021..dc832c338 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -1,6 +1,6 @@ ;;; 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 @@ -35,12 +35,12 @@ #: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 '()) @@ -52,13 +52,21 @@ (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) ((_) @@ -67,6 +75,17 @@ (_ #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) @@ -84,20 +103,26 @@ ;; 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 @@ -128,23 +153,49 @@ ;; 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. @@ -168,16 +219,17 @@ (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) @@ -199,46 +251,52 @@ (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 (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) - (define (contify-call proc args) + (define (contify-call src proc args) (and=> (assq-ref call-substs proc) (lambda (clauses) (let lp ((clauses clauses)) @@ -247,11 +305,11 @@ (((($ $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) @@ -260,13 +318,13 @@ ;; 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) @@ -283,19 +341,20 @@ ,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 (? (cut assq <> fun-elisions))) ;; This cont gets inlined in place of the $fun. ,#f) - (($ $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 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) @@ -324,7 +383,7 @@ (((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 @@ -335,12 +394,12 @@ (($ $kargs (_) (_) body) (visit-term body k)))) (else - (continue k (visit-fun exp))))) + (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)) @@ -348,7 +407,5 @@ (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))))))