1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013 Free Software Foundation, Inc.
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.
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.
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
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.
26 ;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet
27 ;;; and Weeks's "Contification using Dominators".
31 (define-module (language cps contification)
32 #:use-module (ice-9 match)
33 #:use-module ((srfi srfi-1) #:select (concatenate filter-map))
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)
41 (define (compute-contification fun)
42 (let* ((dfg (compute-dfg fun))
43 (cont-table (dfg-cont-table dfg))
47 (cont-splices (make-hash-table)))
48 (define (subst-call! sym arities body-ks)
49 (set! call-substs (acons sym (map cons arities body-ks) call-substs)))
50 (define (subst-return! old-tail new-tail)
51 (set! cont-substs (acons old-tail new-tail cont-substs)))
52 (define (elide-function! k cont)
53 (set! fun-elisions (acons k cont fun-elisions)))
54 (define (splice-conts! scope conts)
55 (hashq-set! cont-splices scope
56 (append conts (hashq-ref cont-splices scope '()))))
58 ;; If K is a continuation that binds one variable, and it has only
59 ;; one predecessor, return that variable.
60 (define (bound-symbol k)
61 (match (lookup-cont k cont-table)
63 (match (lookup-predecessors k dfg)
65 ;; K has one predecessor, the one that defined SYM.
70 (define (contify-fun term-k sym self tail arities bodies)
72 (list sym) (list self) (list tail)
73 (list arities) (list bodies)))
75 ;; Given a set of mutually recursive functions bound to local
76 ;; variables SYMS, with self symbols SELFS, tail continuations
77 ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K,
78 ;; contify them if we can prove that they all return to the same
79 ;; continuation. Returns a true value on success, and false
81 (define (contify-funs term-k syms selfs tails arities bodies)
83 (null? (lookup-uses sym dfg)))
85 ;; Are the given args compatible with any of the arities?
86 (define (applicable? proc args)
88 (($ $arity req () #f () #f)
89 (= (length args) (length req)))
91 (assq-ref (map cons syms arities) proc)))
93 ;; If the use of PROC in continuation USE is a call to PROC that
94 ;; is compatible with one of the procedure's arities, return the
95 ;; target continuation. Otherwise return #f.
96 (define (call-target use proc)
97 (match (find-call (lookup-cont use cont-table))
98 (($ $continue k ($ $call proc* args))
99 (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args)
103 ;; If this set of functions is always called with one
104 ;; continuation, not counting tail calls between the functions,
105 ;; return that continuation.
106 (define (find-common-continuation)
107 (let visit-syms ((syms syms) (k #f))
111 (let visit-uses ((uses (lookup-uses sym dfg)) (k k))
113 (() (visit-syms syms k))
115 (and=> (call-target use sym)
118 ((memq k* tails) (visit-uses uses k))
119 ((not k) (visit-uses uses k*))
120 ((eq? k k*) (visit-uses uses k))
123 ;; Given that the functions are called with the common
124 ;; continuation K, determine the scope at which to contify the
125 ;; functions. If K is in scope in the term, we go ahead and
126 ;; contify them there. Otherwise the scope is inside the letrec
127 ;; body, and so choose the scope in which the continuation is
128 ;; defined, whose free variables are a superset of the free
129 ;; variables of the functions.
131 ;; FIXME: Does this choose the right scope for contified let-bound
133 (define (find-contification-scope k)
134 (if (continuation-bound-in? k term-k dfg)
136 (let ((scope (lookup-block-scope k dfg)))
137 (match (lookup-cont scope cont-table)
138 ;; The common continuation was the tail of some function
139 ;; inside the letrec body. If that function has just
140 ;; one clause, contify into that clause. Otherwise
142 (($ $kentry self tail clauses)
144 ((($ $cont _ _ ($ $kclause arity ($ $cont kargs))))
149 ;; We are going to contify. Mark all SYMs for replacement in
150 ;; calls, and mark the tail continuations for replacement by K.
151 ;; Arrange for the continuations to be spliced into SCOPE.
152 (define (enqueue-contification! k scope)
153 (for-each (lambda (sym tail arities bodies)
155 ((($ $cont body-k) ...)
156 (subst-call! sym arities body-k)))
157 (subst-return! tail k))
158 syms tails arities bodies)
159 (splice-conts! scope (concatenate bodies))
163 (and (and-map unused? selfs)
164 (and=> (find-common-continuation)
166 (and=> (find-contification-scope k)
167 (cut enqueue-contification! k <>))))))
169 (define (visit-fun term)
171 (($ $fun meta free body)
173 (define (visit-cont cont)
175 (($ $cont sym src ($ $kargs _ _ body))
176 (visit-term body sym))
177 (($ $cont sym src ($ $kentry self tail clauses))
178 (for-each visit-cont clauses))
179 (($ $cont sym src ($ $kclause arity body))
183 (define (visit-term term term-k)
185 (($ $letk conts body)
186 (for-each visit-cont conts)
187 (visit-term body term-k))
188 (($ $letrec names syms funs body)
189 (define (split-components nsf)
190 ;; FIXME: Compute strongly-connected components. Currently
191 ;; we just put non-recursive functions in their own
192 ;; components, and lump everything else in the remaining
194 (define (recursive? k)
195 (or-map (cut variable-free-in? <> k dfg) syms))
196 (let lp ((nsf nsf) (rec '()))
202 (((and elt (n s ($ $fun meta free ($ $cont kentry))))
204 (if (recursive? kentry)
205 (lp nsf (cons elt rec))
206 (cons (list elt) (lp nsf rec)))))))
207 (define (visit-component component)
209 (((name sym fun) ...)
214 ($ $cont tail-k _ ($ $ktail))
215 (($ $cont _ _ ($ $kclause arity body))
218 (unless (contify-funs term-k sym self tail-k arity body)
219 (for-each visit-fun fun)))))))
220 (visit-term body term-k)
221 (for-each visit-component
222 (split-components (map list names syms funs))))
228 ($ $cont tail-k _ ($ $ktail))
229 (($ $cont _ _ ($ $kclause arity body)) ...))))
230 (if (and=> (bound-symbol k)
232 (contify-fun term-k sym self tail-k arity body)))
233 (elide-function! k (lookup-cont k cont-table))
238 (values call-substs cont-substs fun-elisions cont-splices)))
240 (define (apply-contification fun call-substs cont-substs fun-elisions cont-splices)
241 (define (contify-call proc args)
242 (and=> (assq-ref call-substs proc)
244 (let lp ((clauses clauses))
246 (() (error "invalid contification"))
247 (((($ $arity req () #f () #f) . k) . clauses)
248 (if (= (length req) (length args))
253 ((_ . clauses) (lp clauses)))))))
254 (define (continue k exp)
255 (define (lookup-return-cont k)
256 (match (assq-ref cont-substs k)
258 (k (lookup-return-cont k))))
259 (let ((k* (lookup-return-cont k)))
260 ;; We are contifying this return. It must be a call or a
261 ;; primcall to values, return, or return-values.
263 (build-cps-term ($continue k ,exp))
264 (rewrite-cps-term exp
265 (($ $primcall 'return (val))
266 ($continue k* ($primcall 'values (val))))
268 ($continue k* ($primcall 'values vals)))
269 (_ ($continue k* ,exp))))))
270 (define (splice-continuations term-k term)
271 (match (hashq-ref cont-splices term-k)
274 (let lp ((term term))
275 (rewrite-cps-term term
276 (($ $letrec names syms funs body)
277 ($letrec names syms funs ,(lp body)))
278 (($ $letk conts* body)
279 ($letk ,(append conts* (filter-map visit-cont cont))
282 ($letk ,(filter-map visit-cont cont)
284 (define (visit-fun term)
285 (rewrite-cps-exp term
286 (($ $fun meta free body)
287 ($fun meta free ,(visit-cont body)))))
288 (define (visit-cont cont)
289 (rewrite-cps-cont cont
290 (($ $cont (? (cut assq <> fun-elisions)))
291 ;; This cont gets inlined in place of the $fun.
293 (($ $cont sym src ($ $kargs names syms body))
294 (sym src ($kargs names syms ,(visit-term body sym))))
295 (($ $cont sym src ($ $kentry self tail clauses))
296 (sym src ($kentry self ,tail ,(map visit-cont clauses))))
297 (($ $cont sym src ($ $kclause arity body))
298 (sym src ($kclause ,arity ,(visit-cont body))))
301 (define (visit-term term term-k)
303 (($ $letk conts body)
304 ;; Visit the body first, so we rewrite depth-first.
305 (let lp ((body (visit-term body term-k)))
306 ;; Because we attach contified functions on a particular
307 ;; term-k, and one term-k can correspond to an arbitrarily
308 ;; nested sequence of $letrec and $letk instances, normalize
309 ;; so that all continuations are bound by one $letk --
310 ;; guaranteeing that they are in the same scope.
311 (rewrite-cps-term body
312 (($ $letrec names syms funs body)
313 ($letrec names syms funs ,(lp body)))
314 (($ $letk conts* body)
315 ($letk ,(append conts* (filter-map visit-cont conts))
318 ($letk ,(filter-map visit-cont conts)
320 (($ $letrec names syms funs body)
321 (rewrite-cps-term (filter (match-lambda
322 ((n s f) (not (assq s call-substs))))
323 (map list names syms funs))
324 (((names syms funs) ...)
325 ($letrec names syms (map visit-fun funs)
326 ,(visit-term body term-k)))))
328 (splice-continuations
333 ((assq-ref fun-elisions k)
335 (($ $kargs (_) (_) body)
336 (visit-term body k))))
338 (continue k (visit-fun exp)))))
340 (or (contify-call proc args)
342 (_ (continue k exp)))))))
345 (define (contify fun)
346 (call-with-values (lambda () (compute-contification fun))
347 (lambda (call-substs cont-substs fun-elisions cont-splices)
348 (if (null? call-substs)
350 ;; Iterate to fixed point.
352 (pk 'CONTIFIED (length call-substs))
354 (apply-contification fun call-substs cont-substs fun-elisions cont-splices)))))))