[bpt/guile.git] / module / language / cps / contification.scm

;;; Continuation-passing style (CPS) intermediate language (IL)

;; Copyright (C) 2013 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
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;; Commentary:
;;;
;;; Contification is a pass that turns $fun instances into $cont
;;; instances if all calls to the $fun return to the same continuation.
;;; This is a more rigorous variant of our old "fixpoint labels
;;; allocation" optimization.
;;;
;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
;;; and Weeks's "Contification using Dominators".
;;;
;;; Code:

(define-module (language cps contification)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (concatenate))
  #:use-module (srfi srfi-26)
  #:use-module (language cps)
  #:use-module (language cps dfg)
  #:use-module (language cps primitives)
  #:use-module (language rtl)
  #:export (contify))

(define (contify fun)
  (let* ((dfg (compute-dfg fun))
         (cont-table (dfg-cont-table dfg))
         (call-substs '())
         (cont-substs '()))
    (define (subst-call! sym arities body-ks)
      (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 (lookup-return-cont k)
      (or (assq-ref cont-substs k) k))

    (define (contify-call proc args)
      (and=> (assq-ref call-substs proc)
             (lambda (clauses)
               (let lp ((clauses clauses))
                 (match clauses
                   (() (error "invalid contification"))
                   (((($ $arity req () #f () #f) . k) . clauses)
                    (if (= (length req) (length args))
                        (build-cps-term
                          ($continue k ($values args)))
                        (lp clauses)))
                   ((_ . clauses) (lp clauses)))))))

    ;; 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)
        (($ $kargs (_) (sym))
         (match (lookup-uses k dfg)
           ((_)
            ;; K has one predecessor, the one that defined SYM.
            sym)
           (_ #f)))
        (_ #f)))

    (define (contify-fun term-k sym self tail arities bodies)
      (contify-funs term-k
                    (list sym) (list self) (list tail)
                    (list arities) (list bodies)))

    ;; Given a set of mutually recursive functions bound to local
    ;; variables SYMS, with self symbols SELFS, tail continuations
    ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
    ;; contify them if we can prove that they all return to the same
    ;; continuation.  If successful, return that common continuation.
    ;; Otherwise return #f.
    (define (contify-funs term-k syms selfs tails arities bodies)
      ;; 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)))

      ;; 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))
           (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
                k))
          (_ #f)))

      (and
       (and-map null? (map (cut lookup-uses <> dfg) selfs))
       (and=> (let visit-syms ((syms syms) (k #f))
                (match syms
                  (() k)
                  ((sym . syms)
                   (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
                     (match uses
                       (() (visit-syms syms k))
                       ((use . uses)
                        (and=> (call-target use sym)
                               (lambda (k*)
                                 (cond
                                  ((memq k* tails) (visit-uses uses k))
                                  ((not k) (visit-uses uses k*))
                                  ((eq? k k*) (visit-uses uses k))
                                  (else #f))))))))))
              (lambda (k)
                ;; We have a common continuation, so we contify: mark
                ;; all SYMs for replacement in calls, and mark the tail
                ;; continuations for replacement by K.
                (for-each (lambda (sym tail arities bodies)
                            (for-each (cut lift-definition! <> term-k dfg)
                                      bodies)
                            (subst-call! sym arities bodies)
                            (subst-return! tail k))
                          syms tails arities bodies)
                k))))

    ;; This is a first cut at a contification algorithm.  It contifies
    ;; non-recursive functions that only have positional arguments.
    (define (visit-fun term)
      (rewrite-cps-exp term
        (($ $fun meta free body)
         ($fun meta free ,(visit-cont body)))))
    (define (visit-cont cont)
      (rewrite-cps-cont cont
        (($ $cont sym src
            ($ $kargs (name) (and sym (? (cut assq <> call-substs)))
               body))
         (sym src ($kargs () () ,(visit-term body sym))))
        (($ $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)
         ,cont)))
    (define (visit-term term term-k)
      (match term
        (($ $letk conts body)
         ;; Visit the body first, so we visit depth-first.
         (let ((body (visit-term body term-k)))
           (build-cps-term
             ($letk ,(map visit-cont conts) ,body))))
        (($ $letrec names syms funs body)
         (define (split-components nsf)
           ;; FIXME: Compute strongly-connected components.  Currently
           ;; we just put non-recursive functions in their own
           ;; components, and lump everything else in the remaining
           ;; component.
           (define (recursive? k)
             (or-map (cut variable-free-in? <> k dfg) syms))
           (let lp ((nsf nsf) (rec '()))
             (match nsf
               (()
                (if (null? rec)
                    '()
                    (list rec)))
               (((and elt (n s ($ $fun meta free ($ $cont kentry))))
                 . nsf)
                (if (recursive? kentry)
                    (lp nsf (cons elt rec))
                    (cons (list elt) (lp nsf rec)))))))
         (define (visit-components components)
           (match components
             (() (visit-term body term-k))
             ((((name sym fun) ...) . components)
              (match fun
                ((($ $fun meta free
                     ($ $cont fun-k _
                        ($ $kentry self
                           ($ $cont tail-k _ ($ $ktail))
                           (($ $cont _ _ ($ $kclause arity
                                            (and body ($ $cont body-k))))
                            ...))))
                  ...)
                 (if (contify-funs term-k sym self tail-k arity body-k)
                     (let ((body* (visit-components components)))
                       (build-cps-term
                         ($letk ,(map visit-cont (concatenate body))
                           ,body*)))
                     (let-gensyms (k)
                       (build-cps-term
                         ($letrec name sym (map visit-fun fun)
                                  ,(visit-components components))))))))))
         (visit-components (split-components (map list names syms funs))))
        (($ $continue k exp)
         (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
             (($ $fun meta free
                 ($ $cont fun-k _
                    ($ $kentry self
                       ($ $cont tail-k _ ($ $ktail))
                       (($ $cont _ _ ($ $kclause arity
                                        (and body ($ $cont body-k))))
                        ...))))
              (if (and=> (bound-symbol k*)
                         (lambda (sym)
                           (contify-fun term-k sym self tail-k arity body-k)))
                  (build-cps-term
                    ($letk ,(map visit-cont body)
                      ($continue k* ($values ()))))
                  (default)))
             (($ $call proc args)
              (or (contify-call proc args)
                  (default)))
             (_ (default)))))))

    (let ((fun (visit-fun fun)))
      (if (null? call-substs)
          fun
          ;; Iterate to fixed point.
          (contify fun)))))
Commit	Line	Data
8ac8e2df AW	1	;;; Continuation-passing style (CPS) intermediate language (IL)
	2
	3	;; Copyright (C) 2013 Free Software Foundation, Inc.
	4
	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	18
	19	;;; Commentary:
	20	;;;
	21	;;; Contification is a pass that turns $fun instances into $cont
	22	;;; instances if all calls to the $fun return to the same continuation.
	23	;;; This is a more rigorous variant of our old "fixpoint labels
	24	;;; allocation" optimization.
	25	;;;
	26	;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
	27	;;; and Weeks's "Contification using Dominators".
	28	;;;
	29	;;; Code:
	30
	31	(define-module (language cps contification)
	32	#:use-module (ice-9 match)
	33	#:use-module ((srfi srfi-1) #:select (concatenate))
	34	#:use-module (srfi srfi-26)
	35	#:use-module (language cps)
	36	#:use-module (language cps dfg)
	37	#:use-module (language cps primitives)
	38	#:use-module (language rtl)
	39	#:export (contify))
	40
	41	(define (contify fun)
	42	(let* ((dfg (compute-dfg fun))
	43	(cont-table (dfg-cont-table dfg))
	44	(call-substs '())
	45	(cont-substs '()))
	46	(define (subst-call! sym arities body-ks)
	47	(set! call-substs (acons sym (map cons arities body-ks) call-substs)))
	48	(define (subst-return! old-tail new-tail)
	49	(set! cont-substs (acons old-tail new-tail cont-substs)))
	50	(define (lookup-return-cont k)
	51	(or (assq-ref cont-substs k) k))
	52
	53	(define (contify-call proc args)
	54	(and=> (assq-ref call-substs proc)
	55	(lambda (clauses)
	56	(let lp ((clauses clauses))
	57	(match clauses
	58	(() (error "invalid contification"))
	59	(((($ $arity req () #f () #f) . k) . clauses)
	60	(if (= (length req) (length args))
	61	(build-cps-term
	62	($continue k ($values args)))
	63	(lp clauses)))
	64	((_ . clauses) (lp clauses)))))))
65
66	;; If K is a continuation that binds one variable, and it has only
67	;; one predecessor, return that variable.
68	(define (bound-symbol k)
69	(match (lookup-cont k cont-table)
70	(($ $kargs (_) (sym))
71	(match (lookup-uses k dfg)
72	((_)
73	;; K has one predecessor, the one that defined SYM.
74	sym)
75	(_ #f)))
76	(_ #f)))
77
78	(define (contify-fun term-k sym self tail arities bodies)
79	(contify-funs term-k
80	(list sym) (list self) (list tail)
81	(list arities) (list bodies)))
82
d51fb1e6 AW	83	;; Given a set of mutually recursive functions bound to local
	84	;; variables SYMS, with self symbols SELFS, tail continuations
	85	;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
	86	;; contify them if we can prove that they all return to the same
	87	;; continuation. If successful, return that common continuation.
	88	;; Otherwise return #f.
8ac8e2df AW	89	(define (contify-funs term-k syms selfs tails arities bodies)
	90	;; Are the given args compatible with any of the arities?
	91	(define (applicable? proc args)
	92	(or-map (match-lambda
	93	(($ $arity req () #f () #f)
	94	(= (length args) (length req)))
	95	(_ #f))
	96	(assq-ref (map cons syms arities) proc)))
	97
	98	;; If the use of PROC in continuation USE is a call to PROC that
	99	;; is compatible with one of the procedure's arities, return the
	100	;; target continuation. Otherwise return #f.
	101	(define (call-target use proc)
	102	(match (find-call (lookup-cont use cont-table))
	103	(($ $continue k ($ $call proc* args))
	104	(and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
	105	k))
	106	(_ #f)))
	107
	108	(and
	109	(and-map null? (map (cut lookup-uses <> dfg) selfs))
	110	(and=> (let visit-syms ((syms syms) (k #f))
	111	(match syms
	112	(() k)
	113	((sym . syms)
	114	(let visit-uses ((uses (lookup-uses sym dfg)) (k k))
	115	(match uses
	116	(() (visit-syms syms k))
	117	((use . uses)
	118	(and=> (call-target use sym)
	119	(lambda (k*)
	120	(cond
	121	((memq k* tails) (visit-uses uses k))
	122	((not k) (visit-uses uses k*))
	123	((eq? k k*) (visit-uses uses k))
	124	(else #f))))))))))
	125	(lambda (k)
	126	;; We have a common continuation, so we contify: mark
	127	;; all SYMs for replacement in calls, and mark the tail
	128	;; continuations for replacement by K.
	129	(for-each (lambda (sym tail arities bodies)
	130	(for-each (cut lift-definition! <> term-k dfg)
	131	bodies)
	132	(subst-call! sym arities bodies)
	133	(subst-return! tail k))
	134	syms tails arities bodies)
	135	k))))
	136
	137	;; This is a first cut at a contification algorithm. It contifies
	138	;; non-recursive functions that only have positional arguments.
	139	(define (visit-fun term)
	140	(rewrite-cps-exp term
	141	(($ $fun meta free body)
	142	($fun meta free ,(visit-cont body)))))
	143	(define (visit-cont cont)
	144	(rewrite-cps-cont cont
	145	(($ $cont sym src
	146	($ $kargs (name) (and sym (? (cut assq <> call-substs)))
	147	body))
	148	(sym src ($kargs () () ,(visit-term body sym))))
	149	(($ $cont sym src ($ $kargs names syms body))
	150	(sym src ($kargs names syms ,(visit-term body sym))))
	151	(($ $cont sym src ($ $kentry self tail clauses))
	152	(sym src ($kentry self ,tail ,(map visit-cont clauses))))
153	(($ $cont sym src ($ $kclause arity body))
154	(sym src ($kclause ,arity ,(visit-cont body))))
155	(($ $cont)
156	,cont)))
157	(define (visit-term term term-k)
158	(match term
159	(($ $letk conts body)
160	;; Visit the body first, so we visit depth-first.
161	(let ((body (visit-term body term-k)))
162	(build-cps-term
163	($letk ,(map visit-cont conts) ,body))))
164	(($ $letrec names syms funs body)
165	(define (split-components nsf)
166	;; FIXME: Compute strongly-connected components. Currently
167	;; we just put non-recursive functions in their own
168	;; components, and lump everything else in the remaining
169	;; component.
170	(define (recursive? k)
d51fb1e6	171	(or-map (cut variable-free-in? <> k dfg) syms))
8ac8e2df AW	172	(let lp ((nsf nsf) (rec '()))
	173	(match nsf
	174	(()
	175	(if (null? rec)
	176	'()
	177	(list rec)))
	178	(((and elt (n s ($ $fun meta free ($ $cont kentry))))
	179	. nsf)
	180	(if (recursive? kentry)
	181	(lp nsf (cons elt rec))
	182	(cons (list elt) (lp nsf rec)))))))
	183	(define (visit-components components)
	184	(match components
	185	(() (visit-term body term-k))
	186	((((name sym fun) ...) . components)
	187	(match fun
	188	((($ $fun meta free
	189	($ $cont fun-k _
	190	($ $kentry self
	191	($ $cont tail-k _ ($ $ktail))
	192	(($ $cont _ _ ($ $kclause arity
	193	(and body ($ $cont body-k))))
	194	...))))
	195	...)
	196	(if (contify-funs term-k sym self tail-k arity body-k)
	197	(let ((body* (visit-components components)))
	198	(build-cps-term
	199	($letk ,(map visit-cont (concatenate body))
	200	,body*)))
	201	(let-gensyms (k)
	202	(build-cps-term
	203	($letrec name sym (map visit-fun fun)
	204	,(visit-components components))))))))))
	205	(visit-components (split-components (map list names syms funs))))
	206	(($ $continue k exp)
	207	(let ((k* (lookup-return-cont k)))
	208	(define (default)
	209	(rewrite-cps-term exp
	210	(($ $fun) ($continue k* ,(visit-fun exp)))
	211	(($ $primcall 'return (val))
	212	,(if (eq? k k*)
	213	(build-cps-term ($continue k* ,exp))
	214	(build-cps-term ($continue k* ($values (val))))))
	215	(($ $primcall 'return-values vals)
	216	,(if (eq? k k*)
	217	(build-cps-term ($continue k* ,exp))
	218	(build-cps-term ($continue k* ($values vals)))))
	219	(_ ($continue k* ,exp))))
	220	(match exp
	221	(($ $fun meta free
	222	($ $cont fun-k _
	223	($ $kentry self
	224	($ $cont tail-k _ ($ $ktail))
	225	(($ $cont _ _ ($ $kclause arity
	226	(and body ($ $cont body-k))))
	227	...))))
	228	(if (and=> (bound-symbol k*)
	229	(lambda (sym)
	230	(contify-fun term-k sym self tail-k arity body-k)))
	231	(build-cps-term
	232	($letk ,(map visit-cont body)
	233	($continue k* ($values ()))))
	234	(default)))
	235	(($ $call proc args)
236	(or (contify-call proc args)
237	(default)))
238	(_ (default)))))))
239
240	(let ((fun (visit-fun fun)))
241	(if (null? call-substs)
242	fun
243	;; Iterate to fixed point.
244	(contify fun)))))