Commit | Line | Data |
---|---|---|
4fefc3a8 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 | ;;; This pass converts Tree-IL to the continuation-passing style (CPS) | |
22 | ;;; language. | |
23 | ;;; | |
24 | ;;; CPS is a lower-level representation than Tree-IL. Converting to | |
25 | ;;; CPS, beyond adding names for all control points and all values, | |
26 | ;;; simplifies expressions in the following ways, among others: | |
27 | ;;; | |
28 | ;;; * Fixing the order of evaluation. | |
29 | ;;; | |
30 | ;;; * Converting assigned variables to boxed variables. | |
31 | ;;; | |
32 | ;;; * Requiring that Scheme's <letrec> has already been lowered to | |
33 | ;;; <fix>. | |
34 | ;;; | |
35 | ;;; * Inlining default-value initializers into lambda-case | |
36 | ;;; expressions. | |
37 | ;;; | |
38 | ;;; * Inlining prompt bodies. | |
39 | ;;; | |
40 | ;;; * Turning toplevel and module references into primcalls. This | |
41 | ;;; involves explicitly modelling the "scope" of toplevel lookups | |
42 | ;;; (indicating the module with respect to which toplevel bindings | |
43 | ;;; are resolved). | |
44 | ;;; | |
45 | ;;; The utility of CPS is that it gives a name to everything: every | |
46 | ;;; intermediate value, and every control point (continuation). As such | |
47 | ;;; it is more verbose than Tree-IL, but at the same time more simple as | |
48 | ;;; the number of concepts is reduced. | |
49 | ;;; | |
50 | ;;; Code: | |
51 | ||
52 | (define-module (language tree-il compile-cps) | |
53 | #:use-module (ice-9 match) | |
54 | #:use-module ((srfi srfi-1) #:select (fold fold-right filter-map)) | |
55 | #:use-module (srfi srfi-26) | |
56 | #:use-module ((system foreign) #:select (make-pointer pointer->scm)) | |
57 | #:use-module (language cps) | |
58 | #:use-module (language cps primitives) | |
59 | #:use-module (language tree-il analyze) | |
60 | #:use-module (language tree-il optimize) | |
61 | #:use-module ((language tree-il) | |
62 | #:select | |
63 | (<void> | |
64 | <const> <primitive-ref> <lexical-ref> <lexical-set> | |
65 | <module-ref> <module-set> | |
66 | <toplevel-ref> <toplevel-set> <toplevel-define> | |
67 | <conditional> | |
68 | <call> <primcall> | |
69 | <seq> | |
70 | <lambda> <lambda-case> | |
71 | <let> <letrec> <fix> <let-values> | |
72 | <prompt> <abort> | |
73 | make-conditional make-const make-primcall | |
74 | tree-il-src | |
75 | tree-il-fold)) | |
76 | #:export (compile-cps)) | |
77 | ||
78 | ;;; Guile's semantics are that a toplevel lambda captures a reference on | |
79 | ;;; the current module, and that all contained lambdas use that module | |
80 | ;;; to resolve toplevel variables. This parameter tracks whether or not | |
81 | ;;; we are in a toplevel lambda. If we are in a lambda, the parameter | |
82 | ;;; is bound to a fresh name identifying the module that was current | |
83 | ;;; when the toplevel lambda is defined. | |
84 | ;;; | |
85 | ;;; This is more complicated than it need be. Ideally we should resolve | |
86 | ;;; all toplevel bindings to bindings from specific modules, unless the | |
87 | ;;; binding is unbound. This is always valid if the compilation unit | |
88 | ;;; sets the module explicitly, as when compiling a module, but it | |
89 | ;;; doesn't work for files auto-compiled for use with `load'. | |
90 | ;;; | |
91 | (define current-topbox-scope (make-parameter #f)) | |
92 | ||
93 | (define (toplevel-box src name bound? val-proc) | |
94 | (let-gensyms (name-sym bound?-sym kbox box) | |
95 | (build-cps-term | |
96 | ($letconst (('name name-sym name) | |
97 | ('bound? bound?-sym bound?)) | |
98 | ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box)))) | |
99 | ,(match (current-topbox-scope) | |
100 | (#f | |
101 | (build-cps-term | |
102 | ($continue kbox | |
103 | ($primcall 'resolve | |
104 | (name-sym bound?-sym))))) | |
105 | (scope | |
106 | (let-gensyms (scope-sym) | |
107 | (build-cps-term | |
108 | ($letconst (('scope scope-sym scope)) | |
109 | ($continue kbox | |
110 | ($primcall 'cached-toplevel-box | |
111 | (scope-sym name-sym bound?-sym))))))))))))) | |
112 | ||
113 | (define (module-box src module name public? bound? val-proc) | |
114 | (let-gensyms (module-sym name-sym public?-sym bound?-sym kbox box) | |
115 | (build-cps-term | |
116 | ($letconst (('module module-sym module) | |
117 | ('name name-sym name) | |
118 | ('public? public?-sym public?) | |
119 | ('bound? bound?-sym bound?)) | |
120 | ($letk ((kbox src ($kargs ('box) (box) ,(val-proc box)))) | |
121 | ($continue kbox | |
122 | ($primcall 'cached-module-box | |
123 | (module-sym name-sym public?-sym bound?-sym)))))))) | |
124 | ||
125 | (define (capture-toplevel-scope src scope k) | |
126 | (let-gensyms (module scope-sym kmodule) | |
127 | (build-cps-term | |
128 | ($letconst (('scope scope-sym scope)) | |
129 | ($letk ((kmodule src ($kargs ('module) (module) | |
130 | ($continue k | |
131 | ($primcall 'cache-current-module! | |
132 | (module scope-sym)))))) | |
133 | ($continue kmodule | |
134 | ($primcall 'current-module ()))))))) | |
135 | ||
136 | (define (fold-formals proc seed arity gensyms inits) | |
137 | (match arity | |
138 | (($ $arity req opt rest kw allow-other-keys?) | |
139 | (let () | |
140 | (define (fold-req names gensyms seed) | |
141 | (match names | |
142 | (() (fold-opt opt gensyms inits seed)) | |
143 | ((name . names) | |
144 | (proc name (car gensyms) #f | |
145 | (fold-req names (cdr gensyms) seed))))) | |
146 | (define (fold-opt names gensyms inits seed) | |
147 | (match names | |
148 | (() (fold-rest rest gensyms inits seed)) | |
149 | ((name . names) | |
150 | (proc name (car gensyms) (car inits) | |
151 | (fold-opt names (cdr gensyms) (cdr inits) seed))))) | |
152 | (define (fold-rest rest gensyms inits seed) | |
153 | (match rest | |
154 | (#f (fold-kw kw gensyms inits seed)) | |
155 | (name (proc name (car gensyms) #f | |
156 | (fold-kw kw (cdr gensyms) inits seed))))) | |
157 | (define (fold-kw kw gensyms inits seed) | |
158 | (match kw | |
159 | (() | |
160 | (unless (null? gensyms) | |
161 | (error "too many gensyms")) | |
162 | (unless (null? inits) | |
163 | (error "too many inits")) | |
164 | seed) | |
165 | (((key name var) . kw) | |
166 | (unless (eq? var (car gensyms)) | |
167 | (error "unexpected keyword arg order")) | |
168 | (proc name var (car inits) | |
169 | (fold-kw kw (cdr gensyms) (cdr inits) seed))))) | |
170 | (fold-req req gensyms seed))))) | |
171 | ||
172 | (define (unbound? src sym kt kf) | |
173 | (define tc8-iflag 4) | |
174 | (define unbound-val 9) | |
175 | (define unbound-bits (logior (ash unbound-val 8) tc8-iflag)) | |
176 | (let-gensyms (unbound ktest) | |
177 | (build-cps-term | |
178 | ($letconst (('unbound unbound (pointer->scm (make-pointer unbound-bits)))) | |
179 | ($letk ((ktest src ($kif kt kf))) | |
180 | ($continue ktest | |
181 | ($primcall 'eq? (sym unbound)))))))) | |
182 | ||
183 | (define (init-default-value name sym subst init body) | |
184 | (match (assq-ref subst sym) | |
185 | ((subst-sym box?) | |
186 | (let ((src (tree-il-src init))) | |
187 | (define (maybe-box k make-body) | |
188 | (if box? | |
189 | (let-gensyms (kbox phi) | |
190 | (build-cps-term | |
191 | ($letk ((kbox src ($kargs (name) (phi) | |
192 | ($continue k ($primcall 'box (phi)))))) | |
193 | ,(make-body kbox)))) | |
194 | (make-body k))) | |
195 | (let-gensyms (knext kbound kunbound) | |
196 | (build-cps-term | |
197 | ($letk ((knext src ($kargs (name) (subst-sym) ,body))) | |
198 | ,(maybe-box | |
199 | knext | |
200 | (lambda (k) | |
201 | (build-cps-term | |
202 | ($letk ((kbound src ($kargs () () ($continue k ($var sym)))) | |
203 | (kunbound src ($kargs () () ,(convert init k subst)))) | |
204 | ,(unbound? src sym kunbound kbound)))))))))))) | |
205 | ||
206 | ;; exp k-name alist -> term | |
207 | (define (convert exp k subst) | |
208 | ;; exp (v-name -> term) -> term | |
209 | (define (convert-arg exp k) | |
210 | (match exp | |
211 | (($ <lexical-ref> src name sym) | |
212 | (match (assq-ref subst sym) | |
213 | ((box #t) | |
214 | (let-gensyms (kunboxed unboxed) | |
215 | (build-cps-term | |
216 | ($letk ((kunboxed src ($kargs ('unboxed) (unboxed) ,(k unboxed)))) | |
217 | ($continue kunboxed ($primcall 'box-ref (box))))))) | |
218 | ((subst #f) (k subst)) | |
219 | (#f (k sym)))) | |
220 | (else | |
221 | (let ((src (tree-il-src exp))) | |
222 | (let-gensyms (karg arg) | |
223 | (build-cps-term | |
224 | ($letk ((karg src ($kargs ('arg) (arg) ,(k arg)))) | |
225 | ,(convert exp karg subst)))))))) | |
226 | ;; (exp ...) ((v-name ...) -> term) -> term | |
227 | (define (convert-args exps k) | |
228 | (match exps | |
229 | (() (k '())) | |
230 | ((exp . exps) | |
231 | (convert-arg exp | |
232 | (lambda (name) | |
233 | (convert-args exps | |
234 | (lambda (names) | |
235 | (k (cons name names))))))))) | |
236 | (define (box-bound-var name sym body) | |
237 | (match (assq-ref subst sym) | |
238 | ((box #t) | |
239 | (let-gensyms (k) | |
240 | (build-cps-term | |
241 | ($letk ((k #f ($kargs (name) (box) ,body))) | |
242 | ($continue k ($primcall 'box (sym))))))) | |
243 | (else body))) | |
244 | ||
245 | (match exp | |
246 | (($ <lexical-ref> src name sym) | |
247 | (match (assq-ref subst sym) | |
248 | ((box #t) (build-cps-term ($continue k ($primcall 'box-ref (box))))) | |
249 | ((subst #f) (build-cps-term ($continue k ($var subst)))) | |
250 | (#f (build-cps-term ($continue k ($var sym)))))) | |
251 | ||
252 | (($ <void> src) | |
253 | (build-cps-term ($continue k ($void)))) | |
254 | ||
255 | (($ <const> src exp) | |
256 | (build-cps-term ($continue k ($const exp)))) | |
257 | ||
258 | (($ <primitive-ref> src name) | |
259 | (build-cps-term ($continue k ($prim name)))) | |
260 | ||
261 | (($ <lambda> fun-src meta body) | |
262 | (let () | |
263 | (define (convert-clauses body ktail) | |
264 | (match body | |
265 | (#f '()) | |
266 | (($ <lambda-case> src req opt rest kw inits gensyms body alternate) | |
267 | (let* ((arity (make-$arity req (or opt '()) rest | |
268 | (if kw (cdr kw) '()) (and kw (car kw)))) | |
269 | (names (fold-formals (lambda (name sym init names) | |
270 | (cons name names)) | |
271 | '() | |
272 | arity gensyms inits))) | |
273 | (cons | |
274 | (let-gensyms (kclause kargs) | |
275 | (build-cps-cont | |
276 | (kclause | |
277 | src | |
278 | ($kclause ,arity | |
279 | (kargs | |
280 | src | |
281 | ($kargs names gensyms | |
282 | ,(fold-formals | |
283 | (lambda (name sym init body) | |
284 | (if init | |
285 | (init-default-value name sym subst init body) | |
286 | (box-bound-var name sym body))) | |
287 | (convert body ktail subst) | |
288 | arity gensyms inits))))))) | |
289 | (convert-clauses alternate ktail)))))) | |
290 | (if (current-topbox-scope) | |
291 | (let-gensyms (kentry self ktail) | |
292 | (build-cps-term | |
293 | ($continue k | |
294 | ($fun meta '() | |
295 | (kentry fun-src | |
296 | ($kentry self (ktail #f ($ktail)) | |
297 | ,(convert-clauses body ktail))))))) | |
298 | (let-gensyms (scope kscope) | |
299 | (build-cps-term | |
300 | ($letk ((kscope fun-src | |
301 | ($kargs () () | |
302 | ,(parameterize ((current-topbox-scope scope)) | |
303 | (convert exp k subst))))) | |
304 | ,(capture-toplevel-scope fun-src scope kscope))))))) | |
305 | ||
306 | (($ <module-ref> src mod name public?) | |
307 | (module-box | |
308 | src mod name public? #t | |
309 | (lambda (box) | |
310 | (build-cps-term ($continue k ($primcall 'box-ref (box))))))) | |
311 | ||
312 | (($ <module-set> src mod name public? exp) | |
313 | (convert-arg exp | |
314 | (lambda (val) | |
315 | (module-box | |
316 | src mod name public? #f | |
317 | (lambda (box) | |
318 | (build-cps-term ($continue k ($primcall 'box-set! (box val))))))))) | |
319 | ||
320 | (($ <toplevel-ref> src name) | |
321 | (toplevel-box | |
322 | src name #t | |
323 | (lambda (box) | |
324 | (build-cps-term ($continue k ($primcall 'box-ref (box))))))) | |
325 | ||
326 | (($ <toplevel-set> src name exp) | |
327 | (convert-arg exp | |
328 | (lambda (val) | |
329 | (toplevel-box | |
330 | src name #f | |
331 | (lambda (box) | |
332 | (build-cps-term ($continue k ($primcall 'box-set! (box val))))))))) | |
333 | ||
334 | (($ <toplevel-define> src name exp) | |
335 | (convert-arg exp | |
336 | (lambda (val) | |
337 | (let-gensyms (kname name-sym) | |
338 | (build-cps-term | |
339 | ($letconst (('name name-sym name)) | |
340 | ($continue k ($primcall 'define! (name-sym val))))))))) | |
341 | ||
342 | (($ <call> src proc args) | |
343 | (convert-args (cons proc args) | |
344 | (match-lambda | |
345 | ((proc . args) | |
346 | (build-cps-term ($continue k ($call proc args))))))) | |
347 | ||
348 | (($ <primcall> src name args) | |
349 | (case name | |
350 | ((list) | |
351 | (convert (fold-right (lambda (elem tail) | |
352 | (make-primcall src 'cons | |
353 | (list elem tail))) | |
354 | (make-const src '()) | |
355 | args) | |
356 | k subst)) | |
357 | (else | |
358 | (if (branching-primitive? name) | |
359 | (convert (make-conditional src exp (make-const #f #t) | |
360 | (make-const #f #f)) | |
361 | k subst) | |
362 | (convert-args args | |
363 | (lambda (args) | |
364 | (if (eq? name 'values) | |
365 | (build-cps-term ($continue k ($values args))) | |
366 | (build-cps-term ($continue k ($primcall name args)))))))))) | |
367 | ||
368 | ;; Prompts with inline handlers. | |
369 | (($ <prompt> src escape-only? tag body | |
370 | ($ <lambda> hsrc hmeta | |
371 | ($ <lambda-case> _ hreq #f hrest #f () hsyms hbody #f))) | |
372 | ;; Handler: | |
373 | ;; khargs: check args returned to handler, -> khbody | |
374 | ;; khbody: the handler, -> k | |
375 | ;; | |
376 | ;; Post-body: | |
377 | ;; krest: collect return vals from body to list, -> kpop | |
378 | ;; kpop: pop the prompt, -> kprim | |
379 | ;; kprim: load the values primitive, -> kret | |
380 | ;; kret: (apply values rvals), -> k | |
381 | ;; | |
382 | ;; Escape prompts evaluate the body with the continuation of krest. | |
383 | ;; Otherwise we do a no-inline call to body, continuing to krest. | |
384 | (convert-arg tag | |
385 | (lambda (tag) | |
386 | (let ((hnames (append hreq (if hrest (list hrest) '())))) | |
387 | (let-gensyms (khargs khbody kret kprim prim kpop krest vals kbody) | |
388 | (build-cps-term | |
389 | ($letk* ((khbody hsrc ($kargs hnames hsyms | |
390 | ,(fold box-bound-var | |
391 | (convert hbody k subst) | |
392 | hnames hsyms))) | |
393 | (khargs hsrc ($ktrunc hreq hrest khbody)) | |
394 | (kpop src | |
395 | ($kargs ('rest) (vals) | |
396 | ($letk ((kret | |
397 | src | |
398 | ($kargs () () | |
399 | ($letk ((kprim | |
400 | src | |
401 | ($kargs ('prim) (prim) | |
402 | ($continue k | |
403 | ($primcall 'apply | |
404 | (prim vals)))))) | |
405 | ($continue kprim | |
406 | ($prim 'values)))))) | |
407 | ($continue kret | |
408 | ($primcall 'pop-prompt ()))))) | |
409 | (krest src ($ktrunc '() 'rest kpop))) | |
410 | ,(if escape-only? | |
411 | (build-cps-term | |
412 | ($letk ((kbody (tree-il-src body) | |
413 | ($kargs () () | |
414 | ,(convert body krest subst)))) | |
415 | ($continue kbody ($prompt #t tag khargs)))) | |
416 | (convert-arg body | |
417 | (lambda (thunk) | |
418 | (build-cps-term | |
419 | ($letk ((kbody (tree-il-src body) | |
420 | ($kargs () () | |
421 | ($continue krest | |
422 | ($primcall 'call-thunk/no-inline | |
423 | (thunk)))))) | |
424 | ($continue kbody | |
425 | ($prompt #f tag khargs)))))))))))))) | |
426 | ||
427 | ;; Eta-convert prompts without inline handlers. | |
428 | (($ <prompt> src escape-only? tag body handler) | |
429 | (convert-args (list tag body handler) | |
430 | (lambda (args) | |
431 | (build-cps-term | |
432 | ($continue k ($primcall 'call-with-prompt args)))))) | |
433 | ||
434 | (($ <abort> src tag args tail) | |
435 | (convert-args (append (list tag) args (list tail)) | |
436 | (lambda (args*) | |
437 | (build-cps-term ($continue k ($primcall 'abort args*)))))) | |
438 | ||
439 | (($ <conditional> src test consequent alternate) | |
440 | (let-gensyms (kif kt kf) | |
441 | (build-cps-term | |
442 | ($letk* ((kt (tree-il-src consequent) ($kargs () () | |
443 | ,(convert consequent k subst))) | |
444 | (kf (tree-il-src alternate) ($kargs () () | |
445 | ,(convert alternate k subst))) | |
446 | (kif src ($kif kt kf))) | |
447 | ,(match test | |
448 | (($ <primcall> src (? branching-primitive? name) args) | |
449 | (convert-args args | |
450 | (lambda (args) | |
451 | (build-cps-term ($continue kif ($primcall name args)))))) | |
452 | (_ (convert-arg test | |
453 | (lambda (test) | |
454 | (build-cps-term ($continue kif ($var test))))))))))) | |
455 | ||
456 | (($ <lexical-set> src name gensym exp) | |
457 | (convert-arg exp | |
458 | (lambda (exp) | |
459 | (match (assq-ref subst gensym) | |
460 | ((box #t) | |
461 | (build-cps-term | |
462 | ($continue k ($primcall 'box-set! (box exp))))))))) | |
463 | ||
464 | (($ <seq> src head tail) | |
465 | (let-gensyms (ktrunc kseq) | |
466 | (build-cps-term | |
467 | ($letk* ((kseq (tree-il-src tail) ($kargs () () | |
468 | ,(convert tail k subst))) | |
469 | (ktrunc src ($ktrunc '() #f kseq))) | |
470 | ,(convert head ktrunc subst))))) | |
471 | ||
472 | (($ <let> src names syms vals body) | |
473 | (let lp ((names names) (syms syms) (vals vals)) | |
474 | (match (list names syms vals) | |
475 | ((() () ()) (convert body k subst)) | |
476 | (((name . names) (sym . syms) (val . vals)) | |
477 | (let-gensyms (klet) | |
478 | (build-cps-term | |
479 | ($letk ((klet src ($kargs (name) (sym) | |
480 | ,(box-bound-var name sym | |
481 | (lp names syms vals))))) | |
482 | ,(convert val klet subst)))))))) | |
483 | ||
484 | (($ <fix> src names gensyms funs body) | |
485 | ;; Some letrecs can be contified; that happens later. | |
486 | (if (current-topbox-scope) | |
487 | (let-gensyms (self) | |
488 | (build-cps-term | |
489 | ($letrec names | |
490 | gensyms | |
491 | (map (lambda (fun) | |
492 | (match (convert fun k subst) | |
493 | (($ $continue _ (and fun ($ $fun))) | |
494 | fun))) | |
495 | funs) | |
496 | ,(convert body k subst)))) | |
497 | (let-gensyms (scope kscope) | |
498 | (build-cps-term | |
499 | ($letk ((kscope src ($kargs () () | |
500 | ,(parameterize ((current-topbox-scope scope)) | |
501 | (convert exp k subst))))) | |
502 | ,(capture-toplevel-scope src scope kscope)))))) | |
503 | ||
504 | (($ <let-values> src exp | |
505 | ($ <lambda-case> lsrc req #f rest #f () syms body #f)) | |
506 | (let ((names (append req (if rest (list rest) '())))) | |
507 | (let-gensyms (ktrunc kargs) | |
508 | (build-cps-term | |
509 | ($letk* ((kargs src ($kargs names syms | |
510 | ,(fold box-bound-var | |
511 | (convert body k subst) | |
512 | names syms))) | |
513 | (ktrunc src ($ktrunc req rest kargs))) | |
514 | ,(convert exp ktrunc subst)))))))) | |
515 | ||
516 | (define (build-subst exp) | |
517 | "Compute a mapping from lexical gensyms to substituted gensyms. The | |
518 | usual reason to replace one variable by another is assignment | |
519 | conversion. Default argument values is the other reason. | |
520 | ||
521 | Returns a list of (ORIG-SYM SUBST-SYM BOXED?). A true value for BOXED? | |
522 | indicates that the replacement variable is in a box." | |
523 | (define (box-set-vars exp subst) | |
524 | (match exp | |
525 | (($ <lexical-set> src name sym exp) | |
526 | (if (assq sym subst) | |
527 | subst | |
528 | (cons (list sym (gensym "b") #t) subst))) | |
529 | (_ subst))) | |
530 | (define (default-args exp subst) | |
531 | (match exp | |
532 | (($ <lambda-case> src req opt rest kw inits gensyms body alternate) | |
533 | (fold-formals (lambda (name sym init subst) | |
534 | (if init | |
535 | (let ((box? (match (assq-ref subst sym) | |
536 | ((box #t) #t) | |
537 | (#f #f))) | |
538 | (subst-sym (gensym (symbol->string name)))) | |
539 | (cons (list sym subst-sym box?) subst)) | |
540 | subst)) | |
541 | subst | |
542 | (make-$arity req (or opt '()) rest | |
543 | (if kw (cdr kw) '()) (and kw (car kw))) | |
544 | gensyms | |
545 | inits)) | |
546 | (_ subst))) | |
547 | (tree-il-fold box-set-vars default-args '() exp)) | |
548 | ||
549 | (define (cps-convert/thunk exp) | |
550 | (let ((src (tree-il-src exp))) | |
551 | (let-gensyms (kinit init ktail kclause kbody) | |
552 | (build-cps-exp | |
553 | ($fun '() '() | |
554 | (kinit src | |
555 | ($kentry init | |
556 | (ktail #f ($ktail)) | |
557 | ((kclause src | |
558 | ($kclause ('() '() #f '() #f) | |
559 | (kbody src | |
560 | ($kargs () () | |
561 | ,(convert exp ktail | |
562 | (build-subst exp)))))))))))))) | |
563 | ||
564 | (define *comp-module* (make-fluid)) | |
565 | ||
566 | (define %warning-passes | |
567 | `((unused-variable . ,unused-variable-analysis) | |
568 | (unused-toplevel . ,unused-toplevel-analysis) | |
569 | (unbound-variable . ,unbound-variable-analysis) | |
570 | (arity-mismatch . ,arity-analysis) | |
571 | (format . ,format-analysis))) | |
572 | ||
573 | (define (optimize-tree-il x e opts) | |
574 | (define warnings | |
575 | (or (and=> (memq #:warnings opts) cadr) | |
576 | '())) | |
577 | ||
578 | ;; Go through the warning passes. | |
579 | (let ((analyses (filter-map (lambda (kind) | |
580 | (assoc-ref %warning-passes kind)) | |
581 | warnings))) | |
582 | (analyze-tree analyses x e)) | |
583 | ||
584 | (optimize x e opts)) | |
585 | ||
586 | (define (compile-cps exp env opts) | |
587 | (values (cps-convert/thunk (optimize-tree-il exp env opts)) | |
588 | env | |
589 | env)) | |
590 | ||
591 | ;;; Local Variables: | |
592 | ;;; eval: (put 'convert-arg 'scheme-indent-function 1) | |
593 | ;;; eval: (put 'convert-args 'scheme-indent-function 1) | |
594 | ;;; End: |