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 | ||
222 | ((<sequence> exps) | |
223 | (build-begin (map recurse exps))) | |
224 | ||
225 | ((<application> proc args) | |
226 | (match `(,(recurse proc) ,@(map recurse args)) | |
227 | ((('lambda (formals ...) body ...) args ...) | |
228 | (=> failure) | |
229 | (if (= (length formals) (length args)) | |
230 | (build-let formals args (build-begin body)) | |
231 | (failure))) | |
232 | (e e))) | |
233 | ||
234 | ((<primitive-ref> name) | |
235 | name) | |
236 | ||
237 | ((<lexical-ref> gensym) | |
238 | (output-name gensym)) | |
239 | ||
240 | ((<lexical-set> gensym exp) | |
241 | `(set! ,(output-name gensym) ,(recurse exp))) | |
242 | ||
243 | ((<module-ref> mod name public?) | |
244 | `(,(if public? '@ '@@) ,mod ,name)) | |
245 | ||
246 | ((<module-set> mod name public? exp) | |
247 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp))) | |
248 | ||
249 | ((<toplevel-ref> name) | |
250 | name) | |
251 | ||
252 | ((<toplevel-set> name exp) | |
253 | `(set! ,name ,(recurse exp))) | |
254 | ||
255 | ((<toplevel-define> name exp) | |
256 | (build-define name (recurse exp))) | |
257 | ||
258 | ((<lambda> meta body) | |
19113f1c AW |
259 | (if body |
260 | (let ((body (recurse body)) | |
261 | (doc (assq-ref meta 'documentation))) | |
262 | (if (not doc) | |
263 | body | |
264 | (match body | |
265 | (('lambda formals body ...) | |
266 | `(lambda ,formals ,doc ,@body)) | |
267 | (('lambda* formals body ...) | |
268 | `(lambda* ,formals ,doc ,@body)) | |
269 | (('case-lambda (formals body ...) clauses ...) | |
270 | `(case-lambda (,formals ,doc ,@body) ,@clauses)) | |
271 | (('case-lambda* (formals body ...) clauses ...) | |
272 | `(case-lambda* (,formals ,doc ,@body) ,@clauses)) | |
273 | (e e)))) | |
274 | '(case-lambda))) | |
72ee0ef7 MW |
275 | |
276 | ((<lambda-case> req opt rest kw inits gensyms body alternate) | |
277 | (let ((names (map output-name gensyms))) | |
278 | (cond | |
279 | ((and (not opt) (not kw) (not alternate)) | |
280 | `(lambda ,(if rest (apply cons* names) names) | |
281 | ,@(recurse-body body))) | |
282 | ((and (not opt) (not kw)) | |
283 | (let ((alt-expansion (recurse alternate)) | |
284 | (formals (if rest (apply cons* names) names))) | |
285 | (case (car alt-expansion) | |
286 | ((lambda) | |
287 | `(case-lambda (,formals ,@(recurse-body body)) | |
288 | ,(cdr alt-expansion))) | |
289 | ((lambda*) | |
290 | `(case-lambda* (,formals ,@(recurse-body body)) | |
291 | ,(cdr alt-expansion))) | |
292 | ((case-lambda) | |
293 | `(case-lambda (,formals ,@(recurse-body body)) | |
294 | ,@(cdr alt-expansion))) | |
295 | ((case-lambda*) | |
296 | `(case-lambda* (,formals ,@(recurse-body body)) | |
297 | ,@(cdr alt-expansion)))))) | |
298 | (else | |
299 | (let* ((alt-expansion (and alternate (recurse alternate))) | |
300 | (nreq (length req)) | |
301 | (nopt (if opt (length opt) 0)) | |
302 | (restargs (if rest (list-ref names (+ nreq nopt)) '())) | |
303 | (reqargs (list-head names nreq)) | |
304 | (optargs (if opt | |
305 | `(#:optional | |
306 | ,@(map list | |
307 | (list-head (list-tail names nreq) nopt) | |
308 | (map recurse | |
309 | (list-head inits nopt)))) | |
310 | '())) | |
311 | (kwargs (if kw | |
312 | `(#:key | |
313 | ,@(map list | |
314 | (map output-name (map caddr (cdr kw))) | |
315 | (map recurse | |
316 | (list-tail inits nopt)) | |
317 | (map car (cdr kw))) | |
318 | ,@(if (car kw) | |
319 | '(#:allow-other-keys) | |
320 | '())) | |
321 | '())) | |
322 | (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs))) | |
323 | (if (not alt-expansion) | |
324 | `(lambda* ,formals ,@(recurse-body body)) | |
325 | (case (car alt-expansion) | |
326 | ((lambda lambda*) | |
327 | `(case-lambda* (,formals ,@(recurse-body body)) | |
328 | ,(cdr alt-expansion))) | |
329 | ((case-lambda case-lambda*) | |
330 | `(case-lambda* (,formals ,@(recurse-body body)) | |
331 | ,@(cdr alt-expansion)))))))))) | |
332 | ||
333 | ((<conditional> test consequent alternate) | |
334 | (define (simplify-test e) | |
335 | (match e | |
336 | (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b))) | |
337 | `(memv ,v '(,a ,b))) | |
338 | (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...)))) | |
339 | `(memv ,v '(,a ,@bs))) | |
340 | (('case (? atom? v) | |
341 | ((datum) #t) ... | |
342 | ('else ('eqv? v ('quote last-datum)))) | |
343 | `(memv ,v '(,@datum ,last-datum))) | |
344 | (_ e))) | |
345 | (match `(if ,(simplify-test (recurse test)) | |
346 | ,(recurse consequent) | |
347 | ,@(if (void? alternate) '() | |
348 | (list (recurse alternate)))) | |
349 | (('if test ('if ('and xs ...) consequent)) | |
350 | (build-if (build-and (cons test xs)) | |
351 | consequent | |
352 | (build-void))) | |
353 | ((? (const use-derived-syntax?) | |
354 | ('if test1 ('if test2 consequent))) | |
355 | (build-if (build-and (list test1 test2)) | |
356 | consequent | |
357 | (build-void))) | |
358 | (('if (? atom? x) x ('or ys ...)) | |
359 | (build-or (cons x ys))) | |
360 | ((? (const use-derived-syntax?) | |
361 | ('if (? atom? x) x y)) | |
362 | (build-or (list x y))) | |
363 | (('if test consequent) | |
364 | `(if ,test ,consequent)) | |
365 | (('if test ('and xs ...) #f) | |
366 | (build-and (cons test xs))) | |
367 | ((? (const use-derived-syntax?) | |
368 | ('if test consequent #f)) | |
369 | (build-and (list test consequent))) | |
370 | ((? (const use-derived-syntax?) | |
371 | ('if test1 consequent1 | |
372 | ('if test2 consequent2 . alternate*))) | |
373 | (build-cond-or-case (list test1 test2) | |
374 | (list consequent1 consequent2) | |
375 | (build-begin alternate*))) | |
376 | (('if test consequent ('cond clauses ...)) | |
377 | `(cond (,test ,@(build-begin-body consequent)) | |
378 | ,@clauses)) | |
379 | (('if ('memv (? atom? v) ('quote (xs ...))) consequent | |
380 | ('case v clauses ...)) | |
381 | `(case ,v (,xs ,@(build-begin-body consequent)) | |
382 | ,@clauses)) | |
383 | (('if ('eqv? (? atom? v) ('quote x)) consequent | |
384 | ('case v clauses ...)) | |
385 | `(case ,v ((,x) ,@(build-begin-body consequent)) | |
386 | ,@clauses)) | |
387 | (e e))) | |
388 | ||
389 | ((<let> gensyms vals body) | |
390 | (match (build-let (map output-name gensyms) | |
391 | (map recurse vals) | |
392 | (recurse body)) | |
393 | (('let ((v e)) ('or v xs ...)) | |
394 | (=> failure) | |
395 | (if (and (not (null? gensyms)) | |
396 | (= 3 (occurrence-count (car gensyms)))) | |
397 | `(or ,e ,@xs) | |
398 | (failure))) | |
399 | (('let ((v e)) ('case v clauses ...)) | |
400 | (=> failure) | |
401 | (if (and (not (null? gensyms)) | |
402 | ;; FIXME: This fails if any of the 'memv's were | |
403 | ;; optimized into multiple 'eqv?'s, because the | |
404 | ;; occurrence count will be higher than we expect. | |
405 | (= (occurrence-count (car gensyms)) | |
406 | (1+ (length (clauses+tail clauses))))) | |
407 | `(case ,e ,@clauses) | |
408 | (failure))) | |
409 | (e e))) | |
410 | ||
411 | ((<letrec> in-order? gensyms vals body) | |
412 | (build-letrec in-order? | |
413 | (map output-name gensyms) | |
414 | (map recurse vals) | |
415 | (recurse body))) | |
416 | ||
417 | ((<fix> gensyms vals body) | |
418 | ;; not a typo, we really do translate back to letrec. use letrec* since it | |
419 | ;; doesn't matter, and the naive letrec* transformation does not require an | |
420 | ;; inner let. | |
421 | (build-letrec #t | |
422 | (map output-name gensyms) | |
423 | (map recurse vals) | |
424 | (recurse body))) | |
425 | ||
426 | ((<let-values> exp body) | |
427 | `(call-with-values (lambda () ,@(recurse-body exp)) | |
428 | ,(recurse (make-lambda #f '() body)))) | |
429 | ||
430 | ((<dynwind> body winder unwinder) | |
431 | `(dynamic-wind ,(recurse winder) | |
432 | (lambda () ,@(recurse-body body)) | |
433 | ,(recurse unwinder))) | |
434 | ||
435 | ((<dynlet> fluids vals body) | |
436 | `(with-fluids ,(map list | |
437 | (map recurse fluids) | |
438 | (map recurse vals)) | |
439 | ,@(recurse-body body))) | |
440 | ||
441 | ((<dynref> fluid) | |
442 | `(fluid-ref ,(recurse fluid))) | |
443 | ||
444 | ((<dynset> fluid exp) | |
445 | `(fluid-set! ,(recurse fluid) ,(recurse exp))) | |
446 | ||
447 | ((<prompt> tag body handler) | |
448 | `(call-with-prompt | |
449 | ,(recurse tag) | |
450 | (lambda () ,@(recurse-body body)) | |
451 | ,(recurse handler))) | |
452 | ||
453 | ||
454 | ((<abort> tag args tail) | |
455 | `(apply abort ,(recurse tag) ,@(map recurse args) | |
456 | ,(recurse tail))))) | |
457 | (values (recurse e) env))) | |
458 | ||
459 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
460 | ;; | |
461 | ;; Algorithm for choosing better variable names | |
462 | ;; ============================================ | |
463 | ;; | |
464 | ;; First we perform an analysis pass, collecting the following | |
465 | ;; information: | |
466 | ;; | |
467 | ;; * For each gensym: how many occurrences will occur in the output? | |
468 | ;; | |
469 | ;; * For each gensym A: which gensyms does A conflict with? Gensym A | |
470 | ;; and gensym B conflict if they have the same base name (usually the | |
471 | ;; same as the source name, but see below), and if giving them the | |
472 | ;; same name would cause a bad variable reference due to unintentional | |
473 | ;; variable capture. | |
474 | ;; | |
475 | ;; The occurrence counter is indexed by gensym and is global (within each | |
476 | ;; invocation of the algorithm), implemented using a hash table. We also | |
477 | ;; keep a global mapping from gensym to source name as provided by the | |
478 | ;; binding construct (we prefer not to trust the source names in the | |
479 | ;; lexical ref or set). | |
480 | ;; | |
481 | ;; As we recurse down into lexical binding forms, we keep track of a | |
482 | ;; mapping from base name to an ordered list of bindings, innermost | |
483 | ;; first. When we encounter a variable occurrence, we increment the | |
484 | ;; counter, look up the base name (preferring not to trust the 'name' in | |
485 | ;; the lexical ref or set), and then look up the bindings currently in | |
486 | ;; effect for that base name. Hopefully our gensym will be the first | |
487 | ;; (innermost) binding. If not, we register a conflict between the | |
488 | ;; referenced gensym and the other bound gensyms with the same base name | |
489 | ;; that shadow the binding we want. These are simply the gensyms on the | |
490 | ;; binding list that come before our gensym. | |
491 | ;; | |
492 | ;; Top-level bindings are treated specially. Whenever top-level | |
493 | ;; references are found, they conflict with every lexical binding | |
494 | ;; currently in effect with the same base name. They are guaranteed to | |
495 | ;; be assigned to their source names. For purposes of recording | |
496 | ;; conflicts (which are normally keyed on gensyms) top-level identifiers | |
497 | ;; are assigned a pseudo-gensym that is an interned pair of the form | |
498 | ;; (top-level . <name>). This allows them to be compared using 'eq?' | |
499 | ;; like other gensyms. | |
500 | ;; | |
501 | ;; The base name is normally just the source name. However, if the | |
502 | ;; source name has a suffix of the form "-N" (where N is a positive | |
503 | ;; integer without leading zeroes), then we strip that suffix (multiple | |
504 | ;; times if necessary) to form the base name. We must do this because | |
505 | ;; we add suffixes of that form in order to resolve conflicts, and we | |
506 | ;; must ensure that only identifiers with the same base name can | |
507 | ;; possibly conflict with each other. | |
508 | ;; | |
509 | ;; XXX FIXME: Currently, primitives are treated exactly like top-level | |
510 | ;; bindings. This handles conflicting lexical bindings properly, but | |
511 | ;; does _not_ handle the case where top-level bindings conflict with the | |
512 | ;; needed primitives. | |
513 | ;; | |
514 | ;; Also note that this requires that 'choose-output-names' be kept in | |
515 | ;; sync with 'tree-il->scheme'. Primitives that are introduced by | |
516 | ;; 'tree-il->scheme' must be anticipated by 'choose-output-name'. | |
517 | ;; | |
518 | ;; We also ensure that lexically-bound identifiers found in operator | |
519 | ;; position will never be assigned one of the standard primitive names. | |
520 | ;; This is needed because 'tree-il->scheme' recognizes primitive names | |
521 | ;; in operator position and assumes that they have the standard | |
522 | ;; bindings. | |
523 | ;; | |
524 | ;; | |
525 | ;; How we assign an output name to each gensym | |
526 | ;; =========================================== | |
527 | ;; | |
528 | ;; We process the gensyms in order of decreasing occurrence count, with | |
529 | ;; each gensym choosing the best output name possible, as long as it | |
530 | ;; isn't the same name as any of the previously-chosen output names of | |
531 | ;; conflicting gensyms. | |
532 | ;; | |
533 | ||
534 | ||
535 | ;; | |
536 | ;; 'choose-output-names' analyzes the top-level form e, chooses good | |
537 | ;; variable names that are as close as possible to the source names, | |
538 | ;; and returns two values: | |
539 | ;; | |
540 | ;; * a hash table mapping gensym to output name | |
541 | ;; * a hash table mapping gensym to number of occurrences | |
542 | ;; | |
543 | (define choose-output-names | |
544 | (let () | |
545 | (define primitive? | |
546 | ;; This is a list of primitives that 'tree-il->scheme' assumes | |
547 | ;; will have the standard bindings when found in operator | |
548 | ;; position. | |
549 | (let* ((primitives '(if quote @ @@ set! define define* | |
550 | begin let let* letrec letrec* | |
551 | and or cond case | |
552 | lambda lambda* case-lambda case-lambda* | |
553 | apply call-with-values dynamic-wind | |
554 | with-fluids fluid-ref fluid-set! | |
555 | call-with-prompt abort memv eqv?)) | |
556 | (table (make-hash-table (length primitives)))) | |
557 | (for-each (cut hashq-set! table <> #t) primitives) | |
558 | (lambda (name) (hashq-ref table name)))) | |
559 | ||
560 | ;; Repeatedly strip suffix of the form "-N", where N is a string | |
561 | ;; that could be produced by number->string given a positive | |
562 | ;; integer. In other words, the first digit of N may not be 0. | |
563 | (define compute-base-name | |
564 | (let ((digits (string->char-set "0123456789"))) | |
565 | (define (base-name-string str) | |
566 | (let ((i (string-skip-right str digits))) | |
567 | (if (and i (< (1+ i) (string-length str)) | |
568 | (eq? #\- (string-ref str i)) | |
569 | (not (eq? #\0 (string-ref str (1+ i))))) | |
570 | (base-name-string (substring str 0 i)) | |
571 | str))) | |
572 | (lambda (sym) | |
573 | (string->symbol (base-name-string (symbol->string sym)))))) | |
574 | ||
575 | ;; choose-output-names | |
576 | (lambda (e use-derived-syntax? strip-numeric-suffixes?) | |
577 | ||
578 | (define lexical-gensyms '()) | |
579 | ||
580 | (define top-level-intern! | |
581 | (let ((table (make-hash-table))) | |
582 | (lambda (name) | |
583 | (let ((h (hashq-create-handle! table name #f))) | |
584 | (or (cdr h) (begin (set-cdr! h (cons 'top-level name)) | |
585 | (cdr h))))))) | |
586 | (define (top-level? s) (pair? s)) | |
587 | (define (top-level-name s) (cdr s)) | |
588 | ||
589 | (define occurrence-count-table (make-hash-table)) | |
590 | (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0)) | |
591 | (define (increment-occurrence-count! s) | |
592 | (let ((h (hashq-create-handle! occurrence-count-table s 0))) | |
593 | (if (zero? (cdr h)) | |
594 | (set! lexical-gensyms (cons s lexical-gensyms))) | |
595 | (set-cdr! h (1+ (cdr h))))) | |
596 | ||
597 | (define base-name | |
598 | (let ((table (make-hash-table))) | |
599 | (lambda (name) | |
600 | (let ((h (hashq-create-handle! table name #f))) | |
601 | (or (cdr h) (begin (set-cdr! h (compute-base-name name)) | |
602 | (cdr h))))))) | |
603 | ||
604 | (define source-name-table (make-hash-table)) | |
605 | (define (set-source-name! s name) | |
606 | (if (not (top-level? s)) | |
607 | (let ((name (if strip-numeric-suffixes? | |
608 | (base-name name) | |
609 | name))) | |
610 | (hashq-set! source-name-table s name)))) | |
611 | (define (source-name s) | |
612 | (if (top-level? s) | |
613 | (top-level-name s) | |
614 | (hashq-ref source-name-table s))) | |
615 | ||
616 | (define conflict-table (make-hash-table)) | |
617 | (define (conflicts s) (or (hashq-ref conflict-table s) '())) | |
618 | (define (add-conflict! a b) | |
619 | (define (add! a b) | |
620 | (if (not (top-level? a)) | |
621 | (let ((h (hashq-create-handle! conflict-table a '()))) | |
622 | (if (not (memq b (cdr h))) | |
623 | (set-cdr! h (cons b (cdr h))))))) | |
624 | (add! a b) | |
625 | (add! b a)) | |
626 | ||
627 | (let recurse-with-bindings ((e e) (bindings vlist-null)) | |
628 | (let recurse ((e e)) | |
629 | ||
630 | ;; We call this whenever we encounter a top-level ref or set | |
631 | (define (top-level name) | |
632 | (let ((bname (base-name name))) | |
633 | (let ((s (top-level-intern! name)) | |
634 | (conflicts (vhash-foldq* cons '() bname bindings))) | |
635 | (for-each (cut add-conflict! s <>) conflicts)))) | |
636 | ||
637 | ;; We call this whenever we encounter a primitive reference. | |
638 | ;; We must also call it for every primitive that might be | |
639 | ;; inserted by 'tree-il->scheme'. It is okay to call this | |
640 | ;; even when 'tree-il->scheme' will not insert the named | |
641 | ;; primitive; the worst that will happen is for a lexical | |
642 | ;; variable of the same name to be renamed unnecessarily. | |
643 | (define (primitive name) (top-level name)) | |
644 | ||
645 | ;; We call this whenever we encounter a lexical ref or set. | |
646 | (define (lexical s) | |
647 | (increment-occurrence-count! s) | |
648 | (let ((conflicts | |
649 | (take-while | |
650 | (lambda (s*) (not (eq? s s*))) | |
651 | (reverse! (vhash-foldq* cons | |
652 | '() | |
653 | (base-name (source-name s)) | |
654 | bindings))))) | |
655 | (for-each (cut add-conflict! s <>) conflicts))) | |
656 | ||
657 | (record-case e | |
658 | ((<void>) (primitive 'if)) ; (if #f #f) | |
659 | ((<const>) (primitive 'quote)) | |
660 | ||
661 | ((<application> proc args) | |
662 | (if (lexical-ref? proc) | |
663 | (let* ((gensym (lexical-ref-gensym proc)) | |
664 | (name (source-name gensym))) | |
665 | ;; If the operator position contains a bare variable | |
666 | ;; reference with the same source name as a standard | |
667 | ;; primitive, we must ensure that it will be given a | |
668 | ;; different name, so that 'tree-il->scheme' will not | |
669 | ;; misinterpret the resulting expression. | |
670 | (if (primitive? name) | |
671 | (add-conflict! gensym (top-level-intern! name))))) | |
672 | (recurse proc) | |
673 | (for-each recurse args)) | |
674 | ||
675 | ((<primitive-ref> name) (primitive name)) | |
676 | ||
677 | ((<lexical-ref> gensym) (lexical gensym)) | |
678 | ((<lexical-set> gensym exp) | |
679 | (primitive 'set!) (lexical gensym) (recurse exp)) | |
680 | ||
681 | ((<module-ref> public?) (primitive (if public? '@ '@@))) | |
682 | ((<module-set> public? exp) | |
683 | (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp)) | |
684 | ||
685 | ((<toplevel-ref> name) (top-level name)) | |
686 | ((<toplevel-set> name exp) | |
687 | (primitive 'set!) (top-level name) (recurse exp)) | |
688 | ((<toplevel-define> name exp) (top-level name) (recurse exp)) | |
689 | ||
690 | ((<conditional> test consequent alternate) | |
691 | (cond (use-derived-syntax? | |
692 | (primitive 'and) (primitive 'or) | |
693 | (primitive 'cond) (primitive 'case) | |
694 | (primitive 'else) (primitive '=>))) | |
695 | (primitive 'if) | |
696 | (recurse test) (recurse consequent) (recurse alternate)) | |
697 | ||
698 | ((<sequence> exps) (primitive 'begin) (for-each recurse exps)) | |
19113f1c AW |
699 | ((<lambda> body) |
700 | (if body (recurse body))) | |
72ee0ef7 MW |
701 | |
702 | ((<lambda-case> req opt rest kw inits gensyms body alternate) | |
703 | (primitive 'lambda) | |
704 | (cond ((or opt kw alternate) | |
705 | (primitive 'lambda*) | |
706 | (primitive 'case-lambda) | |
707 | (primitive 'case-lambda*))) | |
708 | (primitive 'let) | |
709 | (if use-derived-syntax? (primitive 'let*)) | |
710 | (let* ((names (append req (or opt '()) (if rest (list rest) '()) | |
711 | (map cadr (if kw (cdr kw) '())))) | |
712 | (base-names (map base-name names)) | |
713 | (body-bindings | |
714 | (fold vhash-consq bindings base-names gensyms))) | |
715 | (for-each increment-occurrence-count! gensyms) | |
716 | (for-each set-source-name! gensyms names) | |
717 | (for-each recurse inits) | |
718 | (recurse-with-bindings body body-bindings) | |
719 | (if alternate (recurse alternate)))) | |
720 | ||
721 | ((<let> names gensyms vals body) | |
722 | (primitive 'let) | |
723 | (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) | |
724 | (for-each increment-occurrence-count! gensyms) | |
725 | (for-each set-source-name! gensyms names) | |
726 | (for-each recurse vals) | |
727 | (recurse-with-bindings | |
728 | body (fold vhash-consq bindings (map base-name names) gensyms))) | |
729 | ||
730 | ((<letrec> in-order? names gensyms vals body) | |
731 | (primitive 'let) | |
732 | (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) | |
733 | (primitive (if in-order? 'letrec* 'letrec)) | |
734 | (for-each increment-occurrence-count! gensyms) | |
735 | (for-each set-source-name! gensyms names) | |
736 | (let* ((base-names (map base-name names)) | |
737 | (bindings (fold vhash-consq bindings base-names gensyms))) | |
738 | (for-each (cut recurse-with-bindings <> bindings) vals) | |
739 | (recurse-with-bindings body bindings))) | |
740 | ||
741 | ((<fix> names gensyms vals body) | |
742 | (primitive 'let) | |
743 | (primitive 'letrec*) | |
744 | (cond (use-derived-syntax? (primitive 'let*) (primitive 'or))) | |
745 | (for-each increment-occurrence-count! gensyms) | |
746 | (for-each set-source-name! gensyms names) | |
747 | (let* ((base-names (map base-name names)) | |
748 | (bindings (fold vhash-consq bindings base-names gensyms))) | |
749 | (for-each (cut recurse-with-bindings <> bindings) vals) | |
750 | (recurse-with-bindings body bindings))) | |
751 | ||
752 | ((<let-values> exp body) | |
753 | (primitive 'call-with-values) | |
754 | (recurse exp) (recurse body)) | |
755 | ||
756 | ((<dynwind> winder body unwinder) | |
757 | (primitive 'dynamic-wind) | |
758 | (recurse winder) (recurse body) (recurse unwinder)) | |
759 | ||
760 | ((<dynlet> fluids vals body) | |
761 | (primitive 'with-fluids) | |
762 | (for-each recurse fluids) | |
763 | (for-each recurse vals) | |
764 | (recurse body)) | |
765 | ||
766 | ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid)) | |
767 | ((<dynset> fluid exp) | |
768 | (primitive 'fluid-set!) (recurse fluid) (recurse exp)) | |
769 | ||
770 | ((<prompt> tag body handler) | |
771 | (primitive 'call-with-prompt) | |
772 | (primitive 'lambda) | |
773 | (recurse tag) (recurse body) (recurse handler)) | |
774 | ||
775 | ((<abort> tag args tail) | |
776 | (primitive 'apply) | |
777 | (primitive 'abort) | |
778 | (recurse tag) (for-each recurse args) (recurse tail))))) | |
779 | ||
780 | (let () | |
781 | (define output-name-table (make-hash-table)) | |
782 | (define (set-output-name! s name) | |
783 | (hashq-set! output-name-table s name)) | |
784 | (define (output-name s) | |
785 | (if (top-level? s) | |
786 | (top-level-name s) | |
787 | (hashq-ref output-name-table s))) | |
788 | ||
789 | (define sorted-lexical-gensyms | |
790 | (sort-list lexical-gensyms | |
791 | (lambda (a b) (> (occurrence-count a) | |
792 | (occurrence-count b))))) | |
793 | ||
794 | (for-each (lambda (s) | |
795 | (set-output-name! | |
796 | s | |
797 | (let ((the-conflicts (conflicts s)) | |
798 | (the-source-name (source-name s))) | |
799 | (define (not-yet-taken? name) | |
800 | (not (any (lambda (s*) | |
801 | (and=> (output-name s*) | |
802 | (cut eq? name <>))) | |
803 | the-conflicts))) | |
804 | (if (not-yet-taken? the-source-name) | |
805 | the-source-name | |
806 | (let ((prefix (string-append | |
807 | (symbol->string the-source-name) | |
808 | "-"))) | |
809 | (let loop ((i 1) (name the-source-name)) | |
810 | (if (not-yet-taken? name) | |
811 | name | |
812 | (loop (+ i 1) | |
813 | (string->symbol | |
814 | (string-append | |
815 | prefix | |
816 | (number->string i))))))))))) | |
817 | sorted-lexical-gensyms) | |
818 | (values output-name-table occurrence-count-table))))) |