Commit | Line | Data |
---|---|---|
b81d329e AW |
1 | ;;; Guile VM code converters |
2 | ||
19113f1c | 3 | ;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc. |
b81d329e | 4 | |
53befeb7 NJ |
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 | |
b81d329e AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language scheme decompile-tree-il) | |
22 | #:use-module (language tree-il) | |
72ee0ef7 MW |
23 | #:use-module (srfi srfi-1) |
24 | #:use-module (srfi srfi-26) | |
25 | #:use-module (ice-9 receive) | |
26 | #:use-module (ice-9 vlist) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module (system base syntax) | |
b81d329e AW |
29 | #:export (decompile-tree-il)) |
30 | ||
72ee0ef7 MW |
31 | (define (decompile-tree-il e env opts) |
32 | (apply do-decompile e env opts)) | |
33 | ||
34 | (define* (do-decompile e env | |
35 | #:key | |
36 | (use-derived-syntax? #t) | |
37 | (avoid-lambda? #t) | |
38 | (use-case? #t) | |
39 | (strip-numeric-suffixes? #f) | |
40 | #:allow-other-keys) | |
41 | ||
42 | (receive (output-name-table occurrence-count-table) | |
43 | (choose-output-names e use-derived-syntax? strip-numeric-suffixes?) | |
44 | ||
45 | (define (output-name s) (hashq-ref output-name-table s)) | |
46 | (define (occurrence-count s) (hashq-ref occurrence-count-table s)) | |
47 | ||
48 | (define (const x) (lambda (_) x)) | |
49 | (define (atom? x) (not (or (pair? x) (vector? x)))) | |
50 | ||
51 | (define (build-void) '(if #f #f)) | |
52 | ||
53 | (define (build-begin es) | |
54 | (match es | |
55 | (() (build-void)) | |
56 | ((e) e) | |
57 | (_ `(begin ,@es)))) | |
58 | ||
59 | (define (build-lambda-body e) | |
60 | (match e | |
61 | (('let () body ...) body) | |
62 | (('begin es ...) es) | |
63 | (_ (list e)))) | |
64 | ||
65 | (define (build-begin-body e) | |
66 | (match e | |
67 | (('begin es ...) es) | |
68 | (_ (list e)))) | |
69 | ||
70 | (define (build-define name e) | |
71 | (match e | |
72 | ((? (const avoid-lambda?) | |
73 | ('lambda formals body ...)) | |
74 | `(define (,name ,@formals) ,@body)) | |
75 | ((? (const avoid-lambda?) | |
76 | ('lambda* formals body ...)) | |
77 | `(define* (,name ,@formals) ,@body)) | |
78 | (_ `(define ,name ,e)))) | |
79 | ||
80 | (define (build-let names vals body) | |
81 | (match `(let ,(map list names vals) | |
82 | ,@(build-lambda-body body)) | |
83 | ((_ () e) e) | |
84 | ((_ (b) ('let* (bs ...) body ...)) | |
85 | `(let* (,b ,@bs) ,@body)) | |
86 | ((? (const use-derived-syntax?) | |
87 | (_ (b1) ('let (b2) body ...))) | |
88 | `(let* (,b1 ,b2) ,@body)) | |
89 | (e e))) | |
90 | ||
91 | (define (build-letrec in-order? names vals body) | |
92 | (match `(,(if in-order? 'letrec* 'letrec) | |
93 | ,(map list names vals) | |
94 | ,@(build-lambda-body body)) | |
95 | ((_ () e) e) | |
96 | ((_ () body ...) `(let () ,@body)) | |
97 | ((_ ((name ('lambda (formals ...) body ...))) | |
98 | (name args ...)) | |
99 | (=> failure) | |
100 | (if (= (length formals) (length args)) | |
101 | `(let ,name ,(map list formals args) ,@body) | |
102 | (failure))) | |
103 | ((? (const avoid-lambda?) | |
104 | ('letrec* _ body ...)) | |
105 | `(let () | |
106 | ,@(map build-define names vals) | |
107 | ,@body)) | |
108 | (e e))) | |
109 | ||
110 | (define (build-if test consequent alternate) | |
111 | (match alternate | |
112 | (('if #f _) `(if ,test ,consequent)) | |
113 | (_ `(if ,test ,consequent ,alternate)))) | |
114 | ||
115 | (define (build-and xs) | |
116 | (match xs | |
117 | (() #t) | |
118 | ((x) x) | |
119 | (_ `(and ,@xs)))) | |
120 | ||
121 | (define (build-or xs) | |
122 | (match xs | |
123 | (() #f) | |
124 | ((x) x) | |
125 | (_ `(or ,@xs)))) | |
126 | ||
127 | (define (case-test-var test) | |
128 | (match test | |
129 | (('memv (? atom? v) ('quote (datums ...))) | |
130 | v) | |
131 | (('eqv? (? atom? v) ('quote datum)) | |
132 | v) | |
133 | (_ #f))) | |
134 | ||
135 | (define (test->datums v test) | |
136 | (match (cons v test) | |
137 | ((v 'memv v ('quote (xs ...))) | |
138 | xs) | |
139 | ((v 'eqv? v ('quote x)) | |
140 | (list x)) | |
141 | (_ #f))) | |
142 | ||
143 | (define (build-else-tail e) | |
144 | (match e | |
145 | (('if #f _) '()) | |
146 | (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x)) | |
147 | (else #f))) | |
148 | (_ `((else ,@(build-begin-body e)))))) | |
149 | ||
150 | (define (build-cond-else-tail e) | |
151 | (match e | |
152 | (('cond clauses ...) clauses) | |
153 | (_ (build-else-tail e)))) | |
154 | ||
155 | (define (build-case-else-tail v e) | |
156 | (match (cons v e) | |
157 | ((v 'case v clauses ...) | |
158 | clauses) | |
159 | ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*) | |
160 | `((,xs ,@(build-begin-body consequent)) | |
161 | ,@(build-case-else-tail v (build-begin alternate*)))) | |
162 | ((v 'if ('eqv? v ('quote x)) consequent . alternate*) | |
163 | `(((,x) ,@(build-begin-body consequent)) | |
164 | ,@(build-case-else-tail v (build-begin alternate*)))) | |
165 | (_ (build-else-tail e)))) | |
166 | ||
167 | (define (clauses+tail clauses) | |
168 | (match clauses | |
169 | ((cs ... (and c ('else . _))) (values cs (list c))) | |
170 | (_ (values clauses '())))) | |
171 | ||
172 | (define (build-cond tests consequents alternate) | |
173 | (case (length tests) | |
174 | ((0) alternate) | |
175 | ((1) (build-if (car tests) (car consequents) alternate)) | |
176 | (else `(cond ,@(map (lambda (test consequent) | |
177 | `(,test ,@(build-begin-body consequent))) | |
178 | tests consequents) | |
179 | ,@(build-cond-else-tail alternate))))) | |
180 | ||
181 | (define (build-cond-or-case tests consequents alternate) | |
182 | (if (not use-case?) | |
183 | (build-cond tests consequents alternate) | |
184 | (let* ((v (and (not (null? tests)) | |
185 | (case-test-var (car tests)))) | |
186 | (datum-lists (take-while identity | |
187 | (map (cut test->datums v <>) | |
188 | tests))) | |
189 | (n (length datum-lists)) | |
190 | (tail (build-case-else-tail v (build-cond | |
191 | (drop tests n) | |
192 | (drop consequents n) | |
193 | alternate)))) | |
194 | (receive (clauses tail) (clauses+tail tail) | |
195 | (let ((n (+ n (length clauses))) | |
196 | (datum-lists (append datum-lists | |
197 | (map car clauses))) | |
198 | (consequents (append consequents | |
199 | (map build-begin | |
200 | (map cdr clauses))))) | |
201 | (if (< n 2) | |
202 | (build-cond tests consequents alternate) | |
203 | `(case ,v | |
204 | ,@(map cons datum-lists (map build-begin-body | |
205 | (take consequents n))) | |
206 | ,@tail))))))) | |
207 | ||
208 | (define (recurse e) | |
209 | ||
210 | (define (recurse-body e) | |
211 | (build-lambda-body (recurse e))) | |
212 | ||
213 | (record-case e | |
214 | ((<void>) | |
215 | (build-void)) | |
216 | ||
217 | ((<const> exp) | |
218 | (if (and (self-evaluating? exp) (not (vector? exp))) | |
219 | exp | |
220 | `(quote ,exp))) | |
221 | ||
d019ef92 MW |
222 | ((<seq> head tail) |
223 | (build-begin (cons (recurse head) | |
224 | (build-begin-body | |
225 | (recurse tail))))) | |
72ee0ef7 | 226 | |
d019ef92 | 227 | ((<call> proc args) |
72ee0ef7 MW |
228 | (match `(,(recurse proc) ,@(map recurse args)) |
229 | ((('lambda (formals ...) body ...) args ...) | |
230 | (=> failure) | |
231 | (if (= (length formals) (length args)) | |
232 | (build-let formals args (build-begin body)) | |
233 | (failure))) | |
234 | (e e))) | |
235 | ||
d019ef92 MW |
236 | ((<primcall> name args) |
237 | `(,name ,@(map recurse args))) | |
238 | ||
72ee0ef7 MW |
239 | ((<primitive-ref> name) |
240 | name) | |
241 | ||
242 | ((<lexical-ref> gensym) | |
243 | (output-name gensym)) | |
244 | ||
245 | ((<lexical-set> gensym exp) | |
246 | `(set! ,(output-name gensym) ,(recurse exp))) | |
247 | ||
248 | ((<module-ref> mod name public?) | |
249 | `(,(if public? '@ '@@) ,mod ,name)) | |
250 | ||
251 | ((<module-set> mod name public? exp) | |
252 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp))) | |
253 | ||
254 | ((<toplevel-ref> name) | |
255 | name) | |
256 | ||
257 | ((<toplevel-set> name exp) | |
258 | `(set! ,name ,(recurse exp))) | |
259 | ||
260 | ((<toplevel-define> name exp) | |
261 | (build-define name (recurse exp))) | |
262 | ||
263 | ((<lambda> meta body) | |
19113f1c AW |
264 | (if body |
265 | (let ((body (recurse body)) | |
266 | (doc (assq-ref meta 'documentation))) | |
267 | (if (not doc) | |
268 | body | |
269 | (match body | |
270 | (('lambda formals body ...) | |
271 | `(lambda ,formals ,doc ,@body)) | |
272 | (('lambda* formals body ...) | |
273 | `(lambda* ,formals ,doc ,@body)) | |
274 | (('case-lambda (formals body ...) clauses ...) | |
275 | `(case-lambda (,formals ,doc ,@body) ,@clauses)) | |
276 | (('case-lambda* (formals body ...) clauses ...) | |
277 | `(case-lambda* (,formals ,doc ,@body) ,@clauses)) | |
278 | (e e)))) | |
279 | '(case-lambda))) | |
72ee0ef7 MW |
280 | |
281 | ((<lambda-case> req opt rest kw inits gensyms body alternate) | |
282 | (let ((names (map output-name gensyms))) | |
283 | (cond | |
284 | ((and (not opt) (not kw) (not alternate)) | |
285 | `(lambda ,(if rest (apply cons* names) names) | |
286 | ,@(recurse-body body))) | |
287 | ((and (not opt) (not kw)) | |
288 | (let ((alt-expansion (recurse alternate)) | |
289 | (formals (if rest (apply cons* names) names))) | |
290 | (case (car alt-expansion) | |
291 | ((lambda) | |
292 | `(case-lambda (,formals ,@(recurse-body body)) | |
293 | ,(cdr alt-expansion))) | |
294 | ((lambda*) | |
295 | `(case-lambda* (,formals ,@(recurse-body body)) | |
296 | ,(cdr alt-expansion))) | |
297 | ((case-lambda) | |
298 | `(case-lambda (,formals ,@(recurse-body body)) | |
299 | ,@(cdr alt-expansion))) | |
300 | ((case-lambda*) | |
301 | `(case-lambda* (,formals ,@(recurse-body body)) | |
302 | ,@(cdr alt-expansion)))))) | |
303 | (else | |
304 | (let* ((alt-expansion (and alternate (recurse alternate))) | |
305 | (nreq (length req)) | |
306 | (nopt (if opt (length opt) 0)) | |
307 | (restargs (if rest (list-ref names (+ nreq nopt)) '())) | |
308 | (reqargs (list-head names nreq)) | |
309 | (optargs (if opt | |
310 | `(#:optional | |
311 | ,@(map list | |
312 | (list-head (list-tail names nreq) nopt) | |
313 | (map recurse | |
314 | (list-head inits nopt)))) | |
315 | '())) | |
316 | (kwargs (if kw | |
317 | `(#:key | |
318 | ,@(map list | |
319 | (map output-name (map caddr (cdr kw))) | |
320 | (map recurse | |
321 | (list-tail inits nopt)) | |
322 | (map car (cdr kw))) | |
323 | ,@(if (car kw) | |
324 | '(#:allow-other-keys) | |
325 | '())) | |
326 | '())) | |
327 | (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs))) | |
328 | (if (not alt-expansion) | |
329 | `(lambda* ,formals ,@(recurse-body body)) | |
330 | (case (car alt-expansion) | |
331 | ((lambda lambda*) | |
332 | `(case-lambda* (,formals ,@(recurse-body body)) | |
333 | ,(cdr alt-expansion))) | |
334 | ((case-lambda case-lambda*) | |
335 | `(case-lambda* (,formals ,@(recurse-body body)) | |
336 | ,@(cdr alt-expansion)))))))))) | |
337 | ||
338 | ((<conditional> test consequent alternate) | |
339 | (define (simplify-test e) | |
340 | (match e | |
341 | (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b))) | |
342 | `(memv ,v '(,a ,b))) | |
343 | (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...)))) | |
344 | `(memv ,v '(,a ,@bs))) | |
345 | (('case (? atom? v) | |
346 | ((datum) #t) ... | |
347 | ('else ('eqv? v ('quote last-datum)))) | |
348 | `(memv ,v '(,@datum ,last-datum))) | |
349 | (_ e))) | |
350 | (match `(if ,(simplify-test (recurse test)) | |
351 | ,(recurse consequent) | |
352 | ,@(if (void? alternate) '() | |
353 | (list (recurse alternate)))) | |
354 | (('if test ('if ('and xs ...) consequent)) | |
355 | (build-if (build-and (cons test xs)) | |
356 | consequent | |
357 | (build-void))) | |
358 | ((? (const use-derived-syntax?) | |
359 | ('if test1 ('if test2 consequent))) | |
360 | (build-if (build-and (list test1 test2)) | |
361 | consequent | |
362 | (build-void))) | |
363 | (('if (? atom? x) x ('or ys ...)) | |
364 | (build-or (cons x ys))) | |
365 | ((? (const use-derived-syntax?) | |
366 | ('if (? atom? x) x y)) | |
367 | (build-or (list x y))) | |
368 | (('if test consequent) | |
369 | `(if ,test ,consequent)) | |
370 | (('if test ('and xs ...) #f) | |
371 | (build-and (cons test xs))) | |
372 | ((? (const use-derived-syntax?) | |
373 | ('if test consequent #f)) | |
374 | (build-and (list test consequent))) | |
375 | ((? (const use-derived-syntax?) | |
376 | ('if test1 consequent1 | |
377 | ('if test2 consequent2 . alternate*))) | |
378 | (build-cond-or-case (list test1 test2) | |
379 | (list consequent1 consequent2) | |
380 | (build-begin alternate*))) | |
381 | (('if test consequent ('cond clauses ...)) | |
382 | `(cond (,test ,@(build-begin-body consequent)) | |
383 | ,@clauses)) | |
384 | (('if ('memv (? atom? v) ('quote (xs ...))) consequent | |
385 | ('case v clauses ...)) | |
386 | `(case ,v (,xs ,@(build-begin-body consequent)) | |
387 | ,@clauses)) | |
388 | (('if ('eqv? (? atom? v) ('quote x)) consequent | |
389 | ('case v clauses ...)) | |
390 | `(case ,v ((,x) ,@(build-begin-body consequent)) | |
391 | ,@clauses)) | |
392 | (e e))) | |
393 | ||
394 | ((<let> gensyms vals body) | |
395 | (match (build-let (map output-name gensyms) | |
396 | (map recurse vals) | |
397 | (recurse body)) | |
398 | (('let ((v e)) ('or v xs ...)) | |
399 | (=> failure) | |
400 | (if (and (not (null? gensyms)) | |
401 | (= 3 (occurrence-count (car gensyms)))) | |
402 | `(or ,e ,@xs) | |
403 | (failure))) | |
404 | (('let ((v e)) ('case v clauses ...)) | |
405 | (=> failure) | |
406 | (if (and (not (null? gensyms)) | |
407 | ;; FIXME: This fails if any of the 'memv's were | |
408 | ;; optimized into multiple 'eqv?'s, because the | |
409 | ;; occurrence count will be higher than we expect. | |
410 | (= (occurrence-count (car gensyms)) | |
411 | (1+ (length (clauses+tail clauses))))) | |
412 | `(case ,e ,@clauses) | |
413 | (failure))) | |
414 | (e e))) | |
415 | ||
416 | ((<letrec> in-order? gensyms vals body) | |
417 | (build-letrec in-order? | |
418 | (map output-name gensyms) | |
419 | (map recurse vals) | |
420 | (recurse body))) | |
421 | ||
422 | ((<fix> gensyms vals body) | |
423 | ;; not a typo, we really do translate back to letrec. use letrec* since it | |
424 | ;; doesn't matter, and the naive letrec* transformation does not require an | |
425 | ;; inner let. | |
426 | (build-letrec #t | |
427 | (map output-name gensyms) | |
428 | (map recurse vals) | |
429 | (recurse body))) | |
430 | ||
431 | ((<let-values> exp body) | |
432 | `(call-with-values (lambda () ,@(recurse-body exp)) | |
433 | ,(recurse (make-lambda #f '() body)))) | |
434 | ||
72ee0ef7 MW |
435 | ((<prompt> tag body handler) |
436 | `(call-with-prompt | |
437 | ,(recurse tag) | |
438 | (lambda () ,@(recurse-body body)) | |
439 | ,(recurse handler))) | |
440 | ||
441 | ||
442 | ((<abort> tag args tail) | |
443 | `(apply abort ,(recurse tag) ,@(map recurse args) | |
444 | ,(recurse tail))))) | |
445 | (values (recurse e) env))) | |
446 | ||
447 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
448 | ;; | |
449 | ;; Algorithm for choosing better variable names | |
450 | ;; ============================================ | |
451 | ;; | |
452 | ;; First we perform an analysis pass, collecting the following | |
453 | ;; information: | |
454 | ;; | |
455 | ;; * For each gensym: how many occurrences will occur in the output? | |
456 | ;; | |
457 | ;; * For each gensym A: which gensyms does A conflict with? Gensym A | |
458 | ;; and gensym B conflict if they have the same base name (usually the | |
459 | ;; same as the source name, but see below), and if giving them the | |
460 | ;; same name would cause a bad variable reference due to unintentional | |
461 | ;; variable capture. | |
462 | ;; | |
463 | ;; The occurrence counter is indexed by gensym and is global (within each | |
464 | ;; invocation of the algorithm), implemented using a hash table. We also | |
465 | ;; keep a global mapping from gensym to source name as provided by the | |
466 | ;; binding construct (we prefer not to trust the source names in the | |
467 | ;; lexical ref or set). | |
468 | ;; | |
469 | ;; As we recurse down into lexical binding forms, we keep track of a | |
470 | ;; mapping from base name to an ordered list of bindings, innermost | |
471 | ;; first. When we encounter a variable occurrence, we increment the | |
472 | ;; counter, look up the base name (preferring not to trust the 'name' in | |
473 | ;; the lexical ref or set), and then look up the bindings currently in | |
474 | ;; effect for that base name. Hopefully our gensym will be the first | |
475 | ;; (innermost) binding. If not, we register a conflict between the | |
476 | ;; referenced gensym and the other bound gensyms with the same base name | |
477 | ;; that shadow the binding we want. These are simply the gensyms on the | |
478 | ;; binding list that come before our gensym. | |
479 | ;; | |
480 | ;; Top-level bindings are treated specially. Whenever top-level | |
481 | ;; references are found, they conflict with every lexical binding | |
482 | ;; currently in effect with the same base name. They are guaranteed to | |
483 | ;; be assigned to their source names. For purposes of recording | |
484 | ;; conflicts (which are normally keyed on gensyms) top-level identifiers | |
485 | ;; are assigned a pseudo-gensym that is an interned pair of the form | |
486 | ;; (top-level . <name>). This allows them to be compared using 'eq?' | |
487 | ;; like other gensyms. | |
488 | ;; | |
489 | ;; The base name is normally just the source name. However, if the | |
490 | ;; source name has a suffix of the form "-N" (where N is a positive | |
491 | ;; integer without leading zeroes), then we strip that suffix (multiple | |
492 | ;; times if necessary) to form the base name. We must do this because | |
493 | ;; we add suffixes of that form in order to resolve conflicts, and we | |
494 | ;; must ensure that only identifiers with the same base name can | |
495 | ;; possibly conflict with each other. | |
496 | ;; | |
497 | ;; XXX FIXME: Currently, primitives are treated exactly like top-level | |
498 | ;; bindings. This handles conflicting lexical bindings properly, but | |
499 | ;; does _not_ handle the case where top-level bindings conflict with the | |
500 | ;; needed primitives. | |
501 | ;; | |
502 | ;; Also note that this requires that 'choose-output-names' be kept in | |
503 | ;; sync with 'tree-il->scheme'. Primitives that are introduced by | |
504 | ;; 'tree-il->scheme' must be anticipated by 'choose-output-name'. | |
505 | ;; | |
506 | ;; We also ensure that lexically-bound identifiers found in operator | |
507 | ;; position will never be assigned one of the standard primitive names. | |
508 | ;; This is needed because 'tree-il->scheme' recognizes primitive names | |
509 | ;; in operator position and assumes that they have the standard | |
510 | ;; bindings. | |
511 | ;; | |
512 | ;; | |
513 | ;; How we assign an output name to each gensym | |
514 | ;; =========================================== | |
515 | ;; | |
516 | ;; We process the gensyms in order of decreasing occurrence count, with | |
517 | ;; each gensym choosing the best output name possible, as long as it | |
518 | ;; isn't the same name as any of the previously-chosen output names of | |
519 | ;; conflicting gensyms. | |
520 | ;; | |
521 | ||
522 | ||
523 | ;; | |
524 | ;; 'choose-output-names' analyzes the top-level form e, chooses good | |
525 | ;; variable names that are as close as possible to the source names, | |
526 | ;; and returns two values: | |
527 | ;; | |
528 | ;; * a hash table mapping gensym to output name | |
529 | ;; * a hash table mapping gensym to number of occurrences | |
530 | ;; | |
531 | (define choose-output-names | |
532 | (let () | |
533 | (define primitive? | |
534 | ;; This is a list of primitives that 'tree-il->scheme' assumes | |
535 | ;; will have the standard bindings when found in operator | |
536 | ;; position. | |
537 | (let* ((primitives '(if quote @ @@ set! define define* | |
538 | begin let let* letrec letrec* | |
539 | and or cond case | |
540 | lambda lambda* case-lambda case-lambda* | |
541 | apply call-with-values dynamic-wind | |
542 | with-fluids fluid-ref fluid-set! | |
543 | call-with-prompt abort memv eqv?)) | |
544 | (table (make-hash-table (length primitives)))) | |
545 | (for-each (cut hashq-set! table <> #t) primitives) | |
546 | (lambda (name) (hashq-ref table name)))) | |
547 | ||
548 | ;; Repeatedly strip suffix of the form "-N", where N is a string | |
549 | ;; that could be produced by number->string given a positive | |
550 | ;; integer. In other words, the first digit of N may not be 0. | |
551 | (define compute-base-name | |
552 | (let ((digits (string->char-set "0123456789"))) | |
553 | (define (base-name-string str) | |
554 | (let ((i (string-skip-right str digits))) | |
555 | (if (and i (< (1+ i) (string-length str)) | |
556 | (eq? #\- (string-ref str i)) | |
557 | (not (eq? #\0 (string-ref str (1+ i))))) | |
558 | (base-name-string (substring str 0 i)) | |
559 | str))) | |
560 | (lambda (sym) | |
561 | (string->symbol (base-name-string (symbol->string sym)))))) | |
562 | ||
563 | ;; choose-output-names | |
564 | (lambda (e use-derived-syntax? strip-numeric-suffixes?) | |
565 | ||
566 | (define lexical-gensyms '()) | |
567 | ||
568 | (define top-level-intern! | |
569 | (let ((table (make-hash-table))) | |
570 | (lambda (name) | |
571 | (let ((h (hashq-create-handle! table name #f))) | |
572 | (or (cdr h) (begin (set-cdr! h (cons 'top-level name)) | |
573 | (cdr h))))))) | |
574 | (define (top-level? s) (pair? s)) | |
575 | (define (top-level-name s) (cdr s)) | |
576 | ||
577 | (define occurrence-count-table (make-hash-table)) | |
578 | (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0)) | |
579 | (define (increment-occurrence-count! s) | |
580 | (let ((h (hashq-create-handle! occurrence-count-table s 0))) | |
581 | (if (zero? (cdr h)) | |
582 | (set! lexical-gensyms (cons s lexical-gensyms))) | |
583 | (set-cdr! h (1+ (cdr h))))) | |
584 | ||
585 | (define base-name | |
586 | (let ((table (make-hash-table))) | |
587 | (lambda (name) | |
588 | (let ((h (hashq-create-handle! table name #f))) | |
589 | (or (cdr h) (begin (set-cdr! h (compute-base-name name)) | |
590 | (cdr h))))))) | |
591 | ||
592 | (define source-name-table (make-hash-table)) | |
593 | (define (set-source-name! s name) | |
594 | (if (not (top-level? s)) | |
595 | (let ((name (if strip-numeric-suffixes? | |
596 | (base-name name) | |
597 | name))) | |
598 | (hashq-set! source-name-table s name)))) | |
599 | (define (source-name s) | |
600 | (if (top-level? s) | |
601 | (top-level-name s) | |
602 | (hashq-ref source-name-table s))) | |
603 | ||
604 | (define conflict-table (make-hash-table)) | |
605 | (define (conflicts s) (or (hashq-ref conflict-table s) '())) | |
606 | (define (add-conflict! a b) | |
607 | (define (add! a b) | |
608 | (if (not (top-level? a)) | |
609 | (let ((h (hashq-create-handle! conflict-table a '()))) | |
610 | (if (not (memq b (cdr h))) | |
611 | (set-cdr! h (cons b (cdr h))))))) | |
612 | (add! a b) | |
613 | (add! b a)) | |
614 | ||
615 | (let recurse-with-bindings ((e e) (bindings vlist-null)) | |
616 | (let recurse ((e e)) | |
617 | ||
618 | ;; We call this whenever we encounter a top-level ref or set | |
619 | (define (top-level name) | |
620 | (let ((bname (base-name name))) | |
621 | (let ((s (top-level-intern! name)) | |
622 | (conflicts (vhash-foldq* cons '() bname bindings))) | |
623 | (for-each (cut add-conflict! s <>) conflicts)))) | |
624 | ||
625 | ;; We call this whenever we encounter a primitive reference. | |
626 | ;; We must also call it for every primitive that might be | |
627 | ;; inserted by 'tree-il->scheme'. It is okay to call this | |
628 | ;; even when 'tree-il->scheme' will not insert the named | |
629 | ;; primitive; the worst that will happen is for a lexical | |
630 | ;; variable of the same name to be renamed unnecessarily. | |
631 | (define (primitive name) (top-level name)) | |
632 | ||
633 | ;; We call this whenever we encounter a lexical ref or set. | |
634 | (define (lexical s) | |
635 | (increment-occurrence-count! s) | |
636 | (let ((conflicts | |
637 | (take-while | |
638 | (lambda (s*) (not (eq? s s*))) | |
639 | (reverse! (vhash-foldq* cons | |
640 | '() | |
641 | (base-name (source-name s)) | |
642 | bindings))))) | |
643 | (for-each (cut add-conflict! s <>) conflicts))) | |
644 | ||
645 | (record-case e | |
646 | ((<void>) (primitive 'if)) ; (if #f #f) | |
647 | ((<const>) (primitive 'quote)) | |
648 | ||
d019ef92 | 649 | ((<call> proc args) |
72ee0ef7 MW |
650 | (if (lexical-ref? proc) |
651 | (let* ((gensym (lexical-ref-gensym proc)) | |
652 | (name (source-name gensym))) | |
653 | ;; If the operator position contains a bare variable | |
654 | ;; reference with the same source name as a standard | |
655 | ;; primitive, we must ensure that it will be given a | |
656 | ;; different name, so that 'tree-il->scheme' will not | |
657 | ;; misinterpret the resulting expression. | |
658 | (if (primitive? name) | |
659 | (add-conflict! gensym (top-level-intern! name))))) | |
660 | (recurse proc) | |
661 | (for-each recurse args)) | |
662 | ||
663 | ((<primitive-ref> name) (primitive name)) | |
d019ef92 | 664 | ((<primcall> name args) (primitive name) (for-each recurse args)) |
72ee0ef7 MW |
665 | |
666 | ((<lexical-ref> gensym) (lexical gensym)) | |
667 | ((<lexical-set> gensym exp) | |
668 | (primitive 'set!) (lexical gensym) (recurse exp)) | |
669 | ||
670 | ((<module-ref> public?) (primitive (if public? '@ '@@))) | |
671 | ((<module-set> public? exp) | |
672 | (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp)) | |
673 | ||
674 | ((<toplevel-ref> name) (top-level name)) | |
675 | ((<toplevel-set> name exp) | |
676 | (primitive 'set!) (top-level name) (recurse exp)) | |
677 | ((<toplevel-define> name exp) (top-level name) (recurse exp)) | |
678 | ||
679 | ((<conditional> test consequent alternate) | |
680 | (cond (use-derived-syntax? | |
681 | (primitive 'and) (primitive 'or) | |
682 | (primitive 'cond) (primitive 'case) | |
683 | (primitive 'else) (primitive '=>))) | |
684 | (primitive 'if) | |
685 | (recurse test) (recurse consequent) (recurse alternate)) | |
686 | ||
d019ef92 MW |
687 | ((<seq> head tail) |
688 | (primitive 'begin) (recurse head) (recurse tail)) | |
689 | ||
19113f1c AW |
690 | ((<lambda> body) |
691 | (if body (recurse body))) | |
72ee0ef7 MW |
692 | |
693 | ((<lambda-case> req opt rest kw inits gensyms body alternate) | |
694 | (primitive 'lambda) | |
695 | (cond ((or opt kw alternate) | |
696 | (primitive 'lambda*) | |
697 | (primitive 'case-lambda) | |
698 | (primitive 'case-lambda*))) | |
699 | (primitive 'let) | |
700 | (if use-derived-syntax? (primitive 'let*)) | |
701 | (let* ((names (append req (or opt '()) (if rest (list rest) '()) | |
702 | (map cadr (if kw (cdr kw) '())))) | |
703 | (base-names (map base-name names)) | |
704 | (body-bindings | |
705 | (fold vhash-consq bindings base-names gensyms))) | |
706 | (for-each increment-occurrence-count! gensyms) | |
707 | (for-each set-source-name! gensyms names) | |
708 | (for-each recurse inits) | |
709 | (recurse-with-bindings body body-bindings) | |
710 | (if alternate (recurse alternate)))) | |
711 | ||
712 | ((<let> names gensyms vals body) | |
713 | (primitive 'let) | |
714 | (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) | |
715 | (for-each increment-occurrence-count! gensyms) | |
716 | (for-each set-source-name! gensyms names) | |
717 | (for-each recurse vals) | |
718 | (recurse-with-bindings | |
719 | body (fold vhash-consq bindings (map base-name names) gensyms))) | |
720 | ||
721 | ((<letrec> in-order? names gensyms vals body) | |
722 | (primitive 'let) | |
723 | (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) | |
724 | (primitive (if in-order? 'letrec* 'letrec)) | |
725 | (for-each increment-occurrence-count! gensyms) | |
726 | (for-each set-source-name! gensyms names) | |
727 | (let* ((base-names (map base-name names)) | |
728 | (bindings (fold vhash-consq bindings base-names gensyms))) | |
729 | (for-each (cut recurse-with-bindings <> bindings) vals) | |
730 | (recurse-with-bindings body bindings))) | |
731 | ||
732 | ((<fix> names gensyms vals body) | |
733 | (primitive 'let) | |
734 | (primitive 'letrec*) | |
735 | (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) | |
736 | (for-each increment-occurrence-count! gensyms) | |
737 | (for-each set-source-name! gensyms names) | |
738 | (let* ((base-names (map base-name names)) | |
739 | (bindings (fold vhash-consq bindings base-names gensyms))) | |
740 | (for-each (cut recurse-with-bindings <> bindings) vals) | |
741 | (recurse-with-bindings body bindings))) | |
742 | ||
743 | ((<let-values> exp body) | |
744 | (primitive 'call-with-values) | |
745 | (recurse exp) (recurse body)) | |
746 | ||
72ee0ef7 MW |
747 | ((<prompt> tag body handler) |
748 | (primitive 'call-with-prompt) | |
749 | (primitive 'lambda) | |
750 | (recurse tag) (recurse body) (recurse handler)) | |
751 | ||
752 | ((<abort> tag args tail) | |
753 | (primitive 'apply) | |
754 | (primitive 'abort) | |
755 | (recurse tag) (for-each recurse args) (recurse tail))))) | |
756 | ||
757 | (let () | |
758 | (define output-name-table (make-hash-table)) | |
759 | (define (set-output-name! s name) | |
760 | (hashq-set! output-name-table s name)) | |
761 | (define (output-name s) | |
762 | (if (top-level? s) | |
763 | (top-level-name s) | |
764 | (hashq-ref output-name-table s))) | |
765 | ||
766 | (define sorted-lexical-gensyms | |
767 | (sort-list lexical-gensyms | |
768 | (lambda (a b) (> (occurrence-count a) | |
769 | (occurrence-count b))))) | |
770 | ||
771 | (for-each (lambda (s) | |
772 | (set-output-name! | |
773 | s | |
774 | (let ((the-conflicts (conflicts s)) | |
775 | (the-source-name (source-name s))) | |
776 | (define (not-yet-taken? name) | |
777 | (not (any (lambda (s*) | |
778 | (and=> (output-name s*) | |
779 | (cut eq? name <>))) | |
780 | the-conflicts))) | |
781 | (if (not-yet-taken? the-source-name) | |
782 | the-source-name | |
783 | (let ((prefix (string-append | |
784 | (symbol->string the-source-name) | |
785 | "-"))) | |
786 | (let loop ((i 1) (name the-source-name)) | |
787 | (if (not-yet-taken? name) | |
788 | name | |
789 | (loop (+ i 1) | |
790 | (string->symbol | |
791 | (string-append | |
792 | prefix | |
793 | (number->string i))))))))))) | |
794 | sorted-lexical-gensyms) | |
795 | (values output-name-table occurrence-count-table))))) |