Commit | Line | Data |
---|---|---|
8ac8e2df AW |
1 | ;;; Continuation-passing style (CPS) intermediate language (IL) |
2 | ||
fbdb69b2 | 3 | ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. |
8ac8e2df AW |
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) | |
b681671e | 33 | #:use-module ((srfi srfi-1) #:select (concatenate filter-map)) |
8ac8e2df AW |
34 | #:use-module (srfi srfi-26) |
35 | #:use-module (language cps) | |
36 | #:use-module (language cps dfg) | |
37 | #:use-module (language cps primitives) | |
691697de | 38 | #:use-module (language bytecode) |
8ac8e2df AW |
39 | #:export (contify)) |
40 | ||
0620d6b4 | 41 | (define (compute-contification fun) |
8ac8e2df | 42 | (let* ((dfg (compute-dfg fun)) |
310da5e1 | 43 | (scope-table (make-hash-table)) |
8ac8e2df | 44 | (call-substs '()) |
7ea00e23 | 45 | (cont-substs '()) |
0620d6b4 AW |
46 | (fun-elisions '()) |
47 | (cont-splices (make-hash-table))) | |
8ac8e2df AW |
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))) | |
b681671e AW |
52 | (define (elide-function! k cont) |
53 | (set! fun-elisions (acons k cont fun-elisions))) | |
0620d6b4 | 54 | (define (splice-conts! scope conts) |
310da5e1 AW |
55 | (for-each (match-lambda |
56 | (($ $cont k) (hashq-set! scope-table k scope))) | |
57 | conts) | |
0620d6b4 AW |
58 | (hashq-set! cont-splices scope |
59 | (append conts (hashq-ref cont-splices scope '())))) | |
8ac8e2df | 60 | |
310da5e1 AW |
61 | (define (lookup-return-cont k) |
62 | (match (assq-ref cont-substs k) | |
63 | (#f k) | |
64 | (k (lookup-return-cont k)))) | |
65 | ||
8ac8e2df AW |
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) | |
fbdb69b2 | 69 | (match (lookup-cont k dfg) |
8ac8e2df | 70 | (($ $kargs (_) (sym)) |
f22979db | 71 | (match (lookup-predecessors k dfg) |
8ac8e2df AW |
72 | ((_) |
73 | ;; K has one predecessor, the one that defined SYM. | |
74 | sym) | |
75 | (_ #f))) | |
76 | (_ #f))) | |
77 | ||
90dce16d AW |
78 | (define (extract-arities clause) |
79 | (match clause | |
80 | (($ $cont _ ($ $kclause arity body alternate)) | |
81 | (cons arity (extract-arities alternate))) | |
82 | (#f '()))) | |
83 | (define (extract-bodies clause) | |
84 | (match clause | |
85 | (($ $cont _ ($ $kclause arity body alternate)) | |
86 | (cons body (extract-bodies alternate))) | |
87 | (#f '()))) | |
88 | ||
8ac8e2df AW |
89 | (define (contify-fun term-k sym self tail arities bodies) |
90 | (contify-funs term-k | |
91 | (list sym) (list self) (list tail) | |
92 | (list arities) (list bodies))) | |
93 | ||
d51fb1e6 AW |
94 | ;; Given a set of mutually recursive functions bound to local |
95 | ;; variables SYMS, with self symbols SELFS, tail continuations | |
96 | ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K, | |
97 | ;; contify them if we can prove that they all return to the same | |
7ea00e23 AW |
98 | ;; continuation. Returns a true value on success, and false |
99 | ;; otherwise. | |
8ac8e2df | 100 | (define (contify-funs term-k syms selfs tails arities bodies) |
8b2a96d0 AW |
101 | (define (unused? sym) |
102 | (null? (lookup-uses sym dfg))) | |
103 | ||
8ac8e2df AW |
104 | ;; Are the given args compatible with any of the arities? |
105 | (define (applicable? proc args) | |
be564260 AW |
106 | (let lp ((arities (assq-ref (map cons syms arities) proc))) |
107 | (match arities | |
108 | ((($ $arity req () #f () #f) . arities) | |
109 | (or (= (length args) (length req)) | |
110 | (lp arities))) | |
111 | ;; If we reached the end of the arities, fail. Also fail if | |
112 | ;; the next arity in the list has optional, keyword, or rest | |
113 | ;; arguments. | |
114 | (_ #f)))) | |
8ac8e2df AW |
115 | |
116 | ;; If the use of PROC in continuation USE is a call to PROC that | |
117 | ;; is compatible with one of the procedure's arities, return the | |
118 | ;; target continuation. Otherwise return #f. | |
119 | (define (call-target use proc) | |
fbdb69b2 | 120 | (match (find-call (lookup-cont use dfg)) |
6e422a35 | 121 | (($ $continue k src ($ $call proc* args)) |
8ac8e2df | 122 | (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args) |
310da5e1 AW |
123 | ;; Converge more quickly by resolving already-contified |
124 | ;; call targets. | |
125 | (lookup-return-cont k))) | |
8ac8e2df AW |
126 | (_ #f))) |
127 | ||
8b2a96d0 AW |
128 | ;; If this set of functions is always called with one |
129 | ;; continuation, not counting tail calls between the functions, | |
130 | ;; return that continuation. | |
131 | (define (find-common-continuation) | |
132 | (let visit-syms ((syms syms) (k #f)) | |
133 | (match syms | |
134 | (() k) | |
135 | ((sym . syms) | |
136 | (let visit-uses ((uses (lookup-uses sym dfg)) (k k)) | |
137 | (match uses | |
138 | (() (visit-syms syms k)) | |
139 | ((use . uses) | |
140 | (and=> (call-target use sym) | |
141 | (lambda (k*) | |
142 | (cond | |
143 | ((memq k* tails) (visit-uses uses k)) | |
144 | ((not k) (visit-uses uses k*)) | |
145 | ((eq? k k*) (visit-uses uses k)) | |
146 | (else #f))))))))))) | |
147 | ||
148 | ;; Given that the functions are called with the common | |
149 | ;; continuation K, determine the scope at which to contify the | |
150 | ;; functions. If K is in scope in the term, we go ahead and | |
151 | ;; contify them there. Otherwise the scope is inside the letrec | |
152 | ;; body, and so choose the scope in which the continuation is | |
153 | ;; defined, whose free variables are a superset of the free | |
154 | ;; variables of the functions. | |
155 | ;; | |
310da5e1 AW |
156 | ;; There is some slight trickiness here. Call-target already uses |
157 | ;; the information we compute within this pass. Previous | |
158 | ;; contifications may cause functions to be contified not at their | |
159 | ;; point of definition but at their point of non-recursive use. | |
160 | ;; That will cause the scope nesting to change. (It may | |
161 | ;; effectively push a function deeper down the tree -- the second | |
162 | ;; case above, a call within the letrec body.) What if we contify | |
163 | ;; to the tail of a previously contified function? We have to | |
164 | ;; track what the new scope tree will be when asking whether K | |
165 | ;; will be bound in TERM-K's scope, not the scope tree that | |
166 | ;; existed when we started the pass. | |
167 | ;; | |
8b2a96d0 AW |
168 | ;; FIXME: Does this choose the right scope for contified let-bound |
169 | ;; functions? | |
170 | (define (find-contification-scope k) | |
310da5e1 AW |
171 | (define (scope-contains? scope k) |
172 | (let ((k-scope (or (hashq-ref scope-table k) | |
173 | (let ((k-scope (lookup-block-scope k dfg))) | |
174 | (hashq-set! scope-table k k-scope) | |
175 | k-scope)))) | |
176 | (or (eq? scope k-scope) | |
177 | (and k-scope (scope-contains? scope k-scope))))) | |
178 | ||
179 | ;; Find the scope of K. | |
180 | (define (continuation-scope k) | |
181 | (or (hashq-ref scope-table k) | |
182 | (let ((scope (lookup-block-scope k dfg))) | |
183 | (hashq-set! scope-table k scope) | |
184 | scope))) | |
185 | ||
186 | (let ((k-scope (continuation-scope k))) | |
187 | (if (scope-contains? k-scope term-k) | |
188 | term-k | |
fbdb69b2 | 189 | (match (lookup-cont k-scope dfg) |
8320f504 | 190 | (($ $kfun src meta self tail clause) |
310da5e1 AW |
191 | ;; K is the tail of some function. If that function |
192 | ;; has just one clause, return that clause. Otherwise | |
193 | ;; bail. | |
90dce16d AW |
194 | (match clause |
195 | (($ $cont _ ($ $kclause arity ($ $cont kargs) #f)) | |
8b2a96d0 AW |
196 | kargs) |
197 | (_ #f))) | |
310da5e1 | 198 | (_ k-scope))))) |
8b2a96d0 AW |
199 | |
200 | ;; We are going to contify. Mark all SYMs for replacement in | |
201 | ;; calls, and mark the tail continuations for replacement by K. | |
202 | ;; Arrange for the continuations to be spliced into SCOPE. | |
203 | (define (enqueue-contification! k scope) | |
204 | (for-each (lambda (sym tail arities bodies) | |
205 | (match bodies | |
206 | ((($ $cont body-k) ...) | |
207 | (subst-call! sym arities body-k))) | |
208 | (subst-return! tail k)) | |
209 | syms tails arities bodies) | |
210 | (splice-conts! scope (concatenate bodies)) | |
211 | #t) | |
212 | ||
213 | ;; "Call me maybe" | |
214 | (and (and-map unused? selfs) | |
215 | (and=> (find-common-continuation) | |
216 | (lambda (k) | |
217 | (and=> (find-contification-scope k) | |
218 | (cut enqueue-contification! k <>)))))) | |
8ac8e2df | 219 | |
8ac8e2df | 220 | (define (visit-fun term) |
0620d6b4 | 221 | (match term |
24b611e8 | 222 | (($ $fun free body) |
0620d6b4 | 223 | (visit-cont body)))) |
8ac8e2df | 224 | (define (visit-cont cont) |
0620d6b4 | 225 | (match cont |
6e422a35 | 226 | (($ $cont sym ($ $kargs _ _ body)) |
0620d6b4 | 227 | (visit-term body sym)) |
8320f504 | 228 | (($ $cont sym ($ $kfun src meta self tail clause)) |
90dce16d AW |
229 | (when clause (visit-cont clause))) |
230 | (($ $cont sym ($ $kclause arity body alternate)) | |
231 | (visit-cont body) | |
232 | (when alternate (visit-cont alternate))) | |
8ac8e2df | 233 | (($ $cont) |
0620d6b4 | 234 | #t))) |
8ac8e2df | 235 | (define (visit-term term term-k) |
0620d6b4 AW |
236 | (match term |
237 | (($ $letk conts body) | |
238 | (for-each visit-cont conts) | |
239 | (visit-term body term-k)) | |
240 | (($ $letrec names syms funs body) | |
241 | (define (split-components nsf) | |
242 | ;; FIXME: Compute strongly-connected components. Currently | |
243 | ;; we just put non-recursive functions in their own | |
244 | ;; components, and lump everything else in the remaining | |
245 | ;; component. | |
246 | (define (recursive? k) | |
247 | (or-map (cut variable-free-in? <> k dfg) syms)) | |
248 | (let lp ((nsf nsf) (rec '())) | |
249 | (match nsf | |
250 | (() | |
251 | (if (null? rec) | |
252 | '() | |
253 | (list rec))) | |
8320f504 | 254 | (((and elt (n s ($ $fun free ($ $cont kfun)))) |
0620d6b4 | 255 | . nsf) |
8320f504 | 256 | (if (recursive? kfun) |
0620d6b4 AW |
257 | (lp nsf (cons elt rec)) |
258 | (cons (list elt) (lp nsf rec))))))) | |
90dce16d AW |
259 | (define (extract-arities+bodies clauses) |
260 | (values (map extract-arities clauses) | |
261 | (map extract-bodies clauses))) | |
0620d6b4 AW |
262 | (define (visit-component component) |
263 | (match component | |
264 | (((name sym fun) ...) | |
265 | (match fun | |
24b611e8 | 266 | ((($ $fun free |
6e422a35 | 267 | ($ $cont fun-k |
8320f504 | 268 | ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) |
24b611e8 | 269 | clause))) |
0620d6b4 | 270 | ...) |
90dce16d AW |
271 | (call-with-values (lambda () (extract-arities+bodies clause)) |
272 | (lambda (arities bodies) | |
273 | (if (contify-funs term-k sym self tail-k arities bodies) | |
274 | (for-each (cut for-each visit-cont <>) bodies) | |
275 | (for-each visit-fun fun))))))))) | |
0620d6b4 AW |
276 | (visit-term body term-k) |
277 | (for-each visit-component | |
278 | (split-components (map list names syms funs)))) | |
6e422a35 | 279 | (($ $continue k src exp) |
0620d6b4 | 280 | (match exp |
24b611e8 | 281 | (($ $fun free |
6e422a35 | 282 | ($ $cont fun-k |
8320f504 | 283 | ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause))) |
0620d6b4 AW |
284 | (if (and=> (bound-symbol k) |
285 | (lambda (sym) | |
90dce16d AW |
286 | (contify-fun term-k sym self tail-k |
287 | (extract-arities clause) | |
288 | (extract-bodies clause)))) | |
7338a49f | 289 | (begin |
fbdb69b2 | 290 | (elide-function! k (lookup-cont k dfg)) |
90dce16d | 291 | (for-each visit-cont (extract-bodies clause))) |
0620d6b4 AW |
292 | (visit-fun exp))) |
293 | (_ #t))))) | |
294 | ||
295 | (visit-fun fun) | |
296 | (values call-substs cont-substs fun-elisions cont-splices))) | |
297 | ||
298 | (define (apply-contification fun call-substs cont-substs fun-elisions cont-splices) | |
6e422a35 | 299 | (define (contify-call src proc args) |
0620d6b4 AW |
300 | (and=> (assq-ref call-substs proc) |
301 | (lambda (clauses) | |
302 | (let lp ((clauses clauses)) | |
303 | (match clauses | |
304 | (() (error "invalid contification")) | |
305 | (((($ $arity req () #f () #f) . k) . clauses) | |
306 | (if (= (length req) (length args)) | |
e92e0bbe | 307 | (build-cps-term |
6e422a35 | 308 | ($continue k src |
0620d6b4 AW |
309 | ($values args))) |
310 | (lp clauses))) | |
311 | ((_ . clauses) (lp clauses))))))) | |
6e422a35 | 312 | (define (continue k src exp) |
8b2a96d0 AW |
313 | (define (lookup-return-cont k) |
314 | (match (assq-ref cont-substs k) | |
315 | (#f k) | |
316 | (k (lookup-return-cont k)))) | |
317 | (let ((k* (lookup-return-cont k))) | |
318 | ;; We are contifying this return. It must be a call or a | |
319 | ;; primcall to values, return, or return-values. | |
320 | (if (eq? k k*) | |
6e422a35 | 321 | (build-cps-term ($continue k src ,exp)) |
8b2a96d0 AW |
322 | (rewrite-cps-term exp |
323 | (($ $primcall 'return (val)) | |
6e422a35 | 324 | ($continue k* src ($primcall 'values (val)))) |
8b2a96d0 | 325 | (($ $values vals) |
6e422a35 AW |
326 | ($continue k* src ($primcall 'values vals))) |
327 | (_ ($continue k* src ,exp)))))) | |
0620d6b4 AW |
328 | (define (splice-continuations term-k term) |
329 | (match (hashq-ref cont-splices term-k) | |
330 | (#f term) | |
331 | ((cont ...) | |
332 | (let lp ((term term)) | |
333 | (rewrite-cps-term term | |
334 | (($ $letrec names syms funs body) | |
335 | ($letrec names syms funs ,(lp body))) | |
336 | (($ $letk conts* body) | |
b681671e | 337 | ($letk ,(append conts* (filter-map visit-cont cont)) |
0620d6b4 AW |
338 | ,body)) |
339 | (body | |
b681671e | 340 | ($letk ,(filter-map visit-cont cont) |
0620d6b4 AW |
341 | ,body))))))) |
342 | (define (visit-fun term) | |
343 | (rewrite-cps-exp term | |
24b611e8 AW |
344 | (($ $fun free body) |
345 | ($fun free ,(visit-cont body))))) | |
0620d6b4 AW |
346 | (define (visit-cont cont) |
347 | (rewrite-cps-cont cont | |
b681671e AW |
348 | (($ $cont (? (cut assq <> fun-elisions))) |
349 | ;; This cont gets inlined in place of the $fun. | |
350 | ,#f) | |
6e422a35 AW |
351 | (($ $cont sym ($ $kargs names syms body)) |
352 | (sym ($kargs names syms ,(visit-term body sym)))) | |
8320f504 AW |
353 | (($ $cont sym ($ $kfun src meta self tail clause)) |
354 | (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))) | |
90dce16d AW |
355 | (($ $cont sym ($ $kclause arity body alternate)) |
356 | (sym ($kclause ,arity ,(visit-cont body) | |
357 | ,(and alternate (visit-cont alternate))))) | |
0620d6b4 AW |
358 | (($ $cont) |
359 | ,cont))) | |
360 | (define (visit-term term term-k) | |
361 | (match term | |
362 | (($ $letk conts body) | |
363 | ;; Visit the body first, so we rewrite depth-first. | |
364 | (let lp ((body (visit-term body term-k))) | |
365 | ;; Because we attach contified functions on a particular | |
366 | ;; term-k, and one term-k can correspond to an arbitrarily | |
367 | ;; nested sequence of $letrec and $letk instances, normalize | |
368 | ;; so that all continuations are bound by one $letk -- | |
369 | ;; guaranteeing that they are in the same scope. | |
370 | (rewrite-cps-term body | |
371 | (($ $letrec names syms funs body) | |
372 | ($letrec names syms funs ,(lp body))) | |
373 | (($ $letk conts* body) | |
b681671e | 374 | ($letk ,(append conts* (filter-map visit-cont conts)) |
0620d6b4 AW |
375 | ,body)) |
376 | (body | |
b681671e | 377 | ($letk ,(filter-map visit-cont conts) |
0620d6b4 AW |
378 | ,body))))) |
379 | (($ $letrec names syms funs body) | |
380 | (rewrite-cps-term (filter (match-lambda | |
381 | ((n s f) (not (assq s call-substs)))) | |
382 | (map list names syms funs)) | |
383 | (((names syms funs) ...) | |
384 | ($letrec names syms (map visit-fun funs) | |
385 | ,(visit-term body term-k))))) | |
6e422a35 | 386 | (($ $continue k src exp) |
0620d6b4 AW |
387 | (splice-continuations |
388 | term-k | |
8b2a96d0 AW |
389 | (match exp |
390 | (($ $fun) | |
b681671e AW |
391 | (cond |
392 | ((assq-ref fun-elisions k) | |
393 | => (match-lambda | |
394 | (($ $kargs (_) (_) body) | |
395 | (visit-term body k)))) | |
396 | (else | |
6e422a35 | 397 | (continue k src (visit-fun exp))))) |
8b2a96d0 | 398 | (($ $call proc args) |
6e422a35 AW |
399 | (or (contify-call src proc args) |
400 | (continue k src exp))) | |
401 | (_ (continue k src exp))))))) | |
0620d6b4 | 402 | (visit-fun fun)) |
8ac8e2df | 403 | |
0620d6b4 AW |
404 | (define (contify fun) |
405 | (call-with-values (lambda () (compute-contification fun)) | |
406 | (lambda (call-substs cont-substs fun-elisions cont-splices) | |
8ac8e2df AW |
407 | (if (null? call-substs) |
408 | fun | |
409 | ;; Iterate to fixed point. | |
1d15832f AW |
410 | (contify |
411 | (apply-contification fun call-substs cont-substs fun-elisions cont-splices)))))) |