Commit | Line | Data |
---|---|---|
19113f1c | 1 | ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. |
d26a26f6 | 2 | ;;;; |
811d10f5 AW |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
53befeb7 | 6 | ;;;; version 3 of the License, or (at your option) any later version. |
d26a26f6 | 7 | ;;;; |
811d10f5 AW |
8 | ;;;; This library is distributed in the hope that it will be useful, |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | ;;;; Lesser General Public License for more details. | |
d26a26f6 | 12 | ;;;; |
811d10f5 AW |
13 | ;;;; You should have received a copy of the GNU Lesser General Public |
14 | ;;;; License along with this library; if not, write to the Free Software | |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
d26a26f6 | 16 | ;;;; |
811d10f5 AW |
17 | \f |
18 | ||
19 | (define-module (language tree-il) | |
f4aa0f10 | 20 | #:use-module (srfi srfi-1) |
4dcd8499 | 21 | #:use-module (srfi srfi-11) |
811d10f5 AW |
22 | #:use-module (system base pmatch) |
23 | #:use-module (system base syntax) | |
9efc833d | 24 | #:export (tree-il-src |
811d10f5 | 25 | |
cf10678f | 26 | <void> void? make-void void-src |
81fd3152 | 27 | <const> const? make-const const-src const-exp |
cb28c085 AW |
28 | <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name |
29 | <lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym | |
30 | <lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp | |
31 | <module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public? | |
32 | <module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp | |
33 | <toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name | |
34 | <toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp | |
35 | <toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp | |
b6d93b11 | 36 | <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate |
7081d4f9 | 37 | <call> call? make-call call-src call-proc call-args |
a881a4ae | 38 | <primcall> primcall? make-primcall primcall-src primcall-name primcall-args |
d019ef92 | 39 | <seq> seq? make-seq seq-src seq-head seq-tail |
8a4ca0ea AW |
40 | <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body |
41 | <lambda-case> lambda-case? make-lambda-case lambda-case-src | |
b0c8c187 | 42 | lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw |
93f63467 | 43 | lambda-case-inits lambda-case-gensyms |
3a88cb3b | 44 | lambda-case-body lambda-case-alternate |
93f63467 | 45 | <let> let? make-let let-src let-names let-gensyms let-vals let-body |
fb6e61ca | 46 | <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body |
93f63467 | 47 | <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body |
8a4ca0ea | 48 | <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body |
880e7948 | 49 | <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-pre dynwind-body dynwind-post dynwind-unwinder |
d7c53a86 | 50 | <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body |
d26a26f6 | 51 | <dynref> dynref? make-dynref dynref-src dynref-fluid |
706a705e | 52 | <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp |
07a0c7d5 | 53 | <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler |
2d026f04 | 54 | <abort> abort? make-abort abort-src abort-tag abort-args abort-tail |
f4aa0f10 | 55 | |
6fc3eae4 AW |
56 | list->seq |
57 | ||
9efc833d AW |
58 | parse-tree-il |
59 | unparse-tree-il | |
cb28c085 AW |
60 | tree-il->scheme |
61 | ||
f4aa0f10 | 62 | tree-il-fold |
4dcd8499 | 63 | make-tree-il-folder |
cb28c085 | 64 | post-order! |
1fb39dc5 AW |
65 | pre-order! |
66 | ||
67 | tree-il=? | |
68 | tree-il-hash)) | |
811d10f5 | 69 | |
4ffa8275 | 70 | (define (print-tree-il exp port) |
7cd6d77c | 71 | (format port "#<tree-il ~S>" (unparse-tree-il exp))) |
4ffa8275 | 72 | |
f7b61b39 AW |
73 | (define-syntax borrow-core-vtables |
74 | (lambda (x) | |
75 | (syntax-case x () | |
76 | ((_) | |
77 | (let lp ((n 0) (out '())) | |
78 | (if (< n (vector-length %expanded-vtables)) | |
79 | (lp (1+ n) | |
80 | (let* ((vtable (vector-ref %expanded-vtables n)) | |
81 | (stem (struct-ref vtable (+ vtable-offset-user 0))) | |
82 | (fields (struct-ref vtable (+ vtable-offset-user 2))) | |
83 | (sfields (map | |
84 | (lambda (f) (datum->syntax x f)) | |
85 | fields)) | |
86 | (type (datum->syntax x (symbol-append '< stem '>))) | |
87 | (ctor (datum->syntax x (symbol-append 'make- stem))) | |
88 | (pred (datum->syntax x (symbol-append stem '?)))) | |
89 | (let lp ((n 0) (fields fields) | |
90 | (out (cons* | |
91 | #`(define (#,ctor #,@sfields) | |
92 | (make-struct #,type 0 #,@sfields)) | |
93 | #`(define (#,pred x) | |
94 | (and (struct? x) | |
95 | (eq? (struct-vtable x) #,type))) | |
4ffa8275 AW |
96 | #`(struct-set! #,type vtable-index-printer |
97 | print-tree-il) | |
f7b61b39 AW |
98 | #`(define #,type |
99 | (vector-ref %expanded-vtables #,n)) | |
100 | out))) | |
101 | (if (null? fields) | |
102 | out | |
103 | (lp (1+ n) | |
104 | (cdr fields) | |
105 | (let ((acc (datum->syntax | |
106 | x (symbol-append stem '- (car fields))))) | |
107 | (cons #`(define #,acc | |
108 | (make-procedure-with-setter | |
109 | (lambda (x) (struct-ref x #,n)) | |
110 | (lambda (x v) (struct-set! x #,n v)))) | |
111 | out))))))) | |
112 | #`(begin #,@(reverse out)))))))) | |
113 | ||
114 | (borrow-core-vtables) | |
115 | ||
116 | ;; (<void>) | |
117 | ;; (<const> exp) | |
118 | ;; (<primitive-ref> name) | |
119 | ;; (<lexical-ref> name gensym) | |
120 | ;; (<lexical-set> name gensym exp) | |
121 | ;; (<module-ref> mod name public?) | |
122 | ;; (<module-set> mod name public? exp) | |
123 | ;; (<toplevel-ref> name) | |
124 | ;; (<toplevel-set> name exp) | |
125 | ;; (<toplevel-define> name exp) | |
126 | ;; (<conditional> test consequent alternate) | |
7081d4f9 | 127 | ;; (<call> proc args) |
a881a4ae | 128 | ;; (<primcall> name args) |
6fc3eae4 | 129 | ;; (<seq> head tail) |
f7b61b39 AW |
130 | ;; (<lambda> meta body) |
131 | ;; (<lambda-case> req opt rest kw inits gensyms body alternate) | |
132 | ;; (<let> names gensyms vals body) | |
fb6e61ca | 133 | ;; (<letrec> in-order? names gensyms vals body) |
f7b61b39 AW |
134 | ;; (<dynlet> fluids vals body) |
135 | ||
4ffa8275 | 136 | (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il) |
93f63467 | 137 | (<fix> names gensyms vals body) |
1c297a38 | 138 | (<let-values> exp body) |
880e7948 | 139 | (<dynwind> winder pre body post unwinder) |
706a705e AW |
140 | (<dynref> fluid) |
141 | (<dynset> fluid exp) | |
07a0c7d5 | 142 | (<prompt> tag body handler) |
2d026f04 | 143 | (<abort> tag args tail)) |
d26a26f6 | 144 | |
811d10f5 AW |
145 | \f |
146 | ||
6fc3eae4 AW |
147 | ;; A helper. |
148 | (define (list->seq loc exps) | |
149 | (if (null? (cdr exps)) | |
150 | (car exps) | |
151 | (make-seq loc (car exps) (list->seq #f (cdr exps))))) | |
152 | ||
153 | \f | |
154 | ||
811d10f5 AW |
155 | (define (location x) |
156 | (and (pair? x) | |
157 | (let ((props (source-properties x))) | |
81fd3152 | 158 | (and (pair? props) props)))) |
811d10f5 | 159 | |
ce09ee19 | 160 | (define (parse-tree-il exp) |
811d10f5 | 161 | (let ((loc (location exp)) |
ce09ee19 | 162 | (retrans (lambda (x) (parse-tree-il x)))) |
811d10f5 | 163 | (pmatch exp |
cf10678f AW |
164 | ((void) |
165 | (make-void loc)) | |
166 | ||
7081d4f9 AW |
167 | ((call ,proc . ,args) |
168 | (make-call loc (retrans proc) (map retrans args))) | |
811d10f5 | 169 | |
a881a4ae AW |
170 | ((primcall ,name . ,args) |
171 | (make-primcall loc name (map retrans args))) | |
172 | ||
b6d93b11 AW |
173 | ((if ,test ,consequent ,alternate) |
174 | (make-conditional loc (retrans test) (retrans consequent) (retrans alternate))) | |
811d10f5 AW |
175 | |
176 | ((primitive ,name) (guard (symbol? name)) | |
177 | (make-primitive-ref loc name)) | |
178 | ||
179 | ((lexical ,name) (guard (symbol? name)) | |
180 | (make-lexical-ref loc name name)) | |
181 | ||
182 | ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym)) | |
183 | (make-lexical-ref loc name sym)) | |
184 | ||
5c27902e AW |
185 | ((set! (lexical ,name) ,exp) (guard (symbol? name)) |
186 | (make-lexical-set loc name name (retrans exp))) | |
187 | ||
811d10f5 AW |
188 | ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym)) |
189 | (make-lexical-set loc name sym (retrans exp))) | |
190 | ||
191 | ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
192 | (make-module-ref loc mod name #t)) | |
193 | ||
194 | ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) | |
195 | (make-module-set loc mod name #t (retrans exp))) | |
196 | ||
197 | ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name)) | |
198 | (make-module-ref loc mod name #f)) | |
199 | ||
ce09ee19 | 200 | ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name)) |
811d10f5 AW |
201 | (make-module-set loc mod name #f (retrans exp))) |
202 | ||
203 | ((toplevel ,name) (guard (symbol? name)) | |
204 | (make-toplevel-ref loc name)) | |
205 | ||
ce09ee19 | 206 | ((set! (toplevel ,name) ,exp) (guard (symbol? name)) |
811d10f5 AW |
207 | (make-toplevel-set loc name (retrans exp))) |
208 | ||
ce09ee19 | 209 | ((define ,name ,exp) (guard (symbol? name)) |
811d10f5 AW |
210 | (make-toplevel-define loc name (retrans exp))) |
211 | ||
8a4ca0ea AW |
212 | ((lambda ,meta ,body) |
213 | (make-lambda loc meta (retrans body))) | |
811d10f5 | 214 | |
93f63467 | 215 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate) |
d26a26f6 | 216 | (make-lambda-case loc req opt rest kw |
93f63467 | 217 | (map retrans inits) gensyms |
8a4ca0ea | 218 | (retrans body) |
3a88cb3b | 219 | (and=> alternate retrans))) |
811d10f5 | 220 | |
93f63467 | 221 | ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body)) |
b0c8c187 | 222 | (make-lambda-case loc req opt rest kw |
93f63467 | 223 | (map retrans inits) gensyms |
7e01997e AW |
224 | (retrans body) |
225 | #f)) | |
226 | ||
811d10f5 AW |
227 | ((const ,exp) |
228 | (make-const loc exp)) | |
229 | ||
6fc3eae4 AW |
230 | ((seq ,head ,tail) |
231 | (make-seq loc (retrans head) (retrans tail))) | |
232 | ||
233 | ;; Convenience. | |
811d10f5 | 234 | ((begin . ,exps) |
6fc3eae4 | 235 | (list->seq loc (map retrans exps))) |
811d10f5 | 236 | |
93f63467 AW |
237 | ((let ,names ,gensyms ,vals ,body) |
238 | (make-let loc names gensyms (map retrans vals) (retrans body))) | |
f4aa8d53 | 239 | |
93f63467 | 240 | ((letrec ,names ,gensyms ,vals ,body) |
fb6e61ca AW |
241 | (make-letrec loc #f names gensyms (map retrans vals) (retrans body))) |
242 | ||
243 | ((letrec* ,names ,gensyms ,vals ,body) | |
244 | (make-letrec loc #t names gensyms (map retrans vals) (retrans body))) | |
811d10f5 | 245 | |
93f63467 AW |
246 | ((fix ,names ,gensyms ,vals ,body) |
247 | (make-fix loc names gensyms (map retrans vals) (retrans body))) | |
c21c89b1 | 248 | |
8a4ca0ea AW |
249 | ((let-values ,exp ,body) |
250 | (make-let-values loc (retrans exp) (retrans body))) | |
811d10f5 | 251 | |
880e7948 AW |
252 | ((dynwind ,winder ,pre ,body ,post ,unwinder) |
253 | (make-dynwind loc (retrans winder) (retrans pre) | |
254 | (retrans body) | |
255 | (retrans post) (retrans unwinder))) | |
d26a26f6 | 256 | |
d7c53a86 AW |
257 | ((dynlet ,fluids ,vals ,body) |
258 | (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body))) | |
d26a26f6 | 259 | |
706a705e AW |
260 | ((dynref ,fluid) |
261 | (make-dynref loc (retrans fluid))) | |
d26a26f6 | 262 | |
706a705e AW |
263 | ((dynset ,fluid ,exp) |
264 | (make-dynset loc (retrans fluid) (retrans exp))) | |
d26a26f6 | 265 | |
07a0c7d5 AW |
266 | ((prompt ,tag ,body ,handler) |
267 | (make-prompt loc (retrans tag) (retrans body) (retrans handler))) | |
d26a26f6 | 268 | |
2d026f04 AW |
269 | ((abort ,tag ,args ,tail) |
270 | (make-abort loc (retrans tag) (map retrans args) (retrans tail))) | |
1c297a38 | 271 | |
811d10f5 AW |
272 | (else |
273 | (error "unrecognized tree-il" exp))))) | |
274 | ||
275 | (define (unparse-tree-il tree-il) | |
276 | (record-case tree-il | |
cf10678f AW |
277 | ((<void>) |
278 | '(void)) | |
279 | ||
7081d4f9 AW |
280 | ((<call> proc args) |
281 | `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) | |
811d10f5 | 282 | |
a881a4ae AW |
283 | ((<primcall> name args) |
284 | `(primcall ,name ,@(map unparse-tree-il args))) | |
285 | ||
b6d93b11 AW |
286 | ((<conditional> test consequent alternate) |
287 | `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate))) | |
811d10f5 AW |
288 | |
289 | ((<primitive-ref> name) | |
290 | `(primitive ,name)) | |
291 | ||
292 | ((<lexical-ref> name gensym) | |
293 | `(lexical ,name ,gensym)) | |
294 | ||
295 | ((<lexical-set> name gensym exp) | |
296 | `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) | |
297 | ||
298 | ((<module-ref> mod name public?) | |
299 | `(,(if public? '@ '@@) ,mod ,name)) | |
300 | ||
301 | ((<module-set> mod name public? exp) | |
302 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) | |
303 | ||
304 | ((<toplevel-ref> name) | |
305 | `(toplevel ,name)) | |
306 | ||
307 | ((<toplevel-set> name exp) | |
308 | `(set! (toplevel ,name) ,(unparse-tree-il exp))) | |
309 | ||
310 | ((<toplevel-define> name exp) | |
311 | `(define ,name ,(unparse-tree-il exp))) | |
312 | ||
8a4ca0ea | 313 | ((<lambda> meta body) |
19113f1c AW |
314 | (if body |
315 | `(lambda ,meta ,(unparse-tree-il body)) | |
316 | `(lambda ,meta (lambda-case)))) | |
8a4ca0ea | 317 | |
93f63467 AW |
318 | ((<lambda-case> req opt rest kw inits gensyms body alternate) |
319 | `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) | |
8a4ca0ea | 320 | ,(unparse-tree-il body)) |
3a88cb3b | 321 | . ,(if alternate (list (unparse-tree-il alternate)) '()))) |
811d10f5 AW |
322 | |
323 | ((<const> exp) | |
324 | `(const ,exp)) | |
325 | ||
6fc3eae4 AW |
326 | ((<seq> head tail) |
327 | `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail))) | |
328 | ||
93f63467 AW |
329 | ((<let> names gensyms vals body) |
330 | `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
811d10f5 | 331 | |
fb6e61ca AW |
332 | ((<letrec> in-order? names gensyms vals body) |
333 | `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms | |
334 | ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
f4aa8d53 | 335 | |
93f63467 AW |
336 | ((<fix> names gensyms vals body) |
337 | `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
c21c89b1 | 338 | |
8a4ca0ea | 339 | ((<let-values> exp body) |
1c297a38 AW |
340 | `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) |
341 | ||
880e7948 AW |
342 | ((<dynwind> winder pre body post unwinder) |
343 | `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il pre) | |
344 | ,(unparse-tree-il body) | |
345 | ,(unparse-tree-il post) ,(unparse-tree-il unwinder))) | |
d26a26f6 | 346 | |
d7c53a86 AW |
347 | ((<dynlet> fluids vals body) |
348 | `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals) | |
349 | ,(unparse-tree-il body))) | |
d26a26f6 | 350 | |
706a705e AW |
351 | ((<dynref> fluid) |
352 | `(dynref ,(unparse-tree-il fluid))) | |
d26a26f6 | 353 | |
706a705e | 354 | ((<dynset> fluid exp) |
b5ae223d | 355 | `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp))) |
d26a26f6 | 356 | |
07a0c7d5 | 357 | ((<prompt> tag body handler) |
2bcf97a6 | 358 | `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler))) |
d26a26f6 | 359 | |
2d026f04 AW |
360 | ((<abort> tag args tail) |
361 | `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) | |
362 | ,(unparse-tree-il tail))))) | |
811d10f5 | 363 | |
72ee0ef7 MW |
364 | (define* (tree-il->scheme e #:optional (env #f) (opts '())) |
365 | (values ((@ (language scheme decompile-tree-il) | |
366 | decompile-tree-il) | |
367 | e env opts))) | |
cb28c085 | 368 | |
f4aa0f10 LC |
369 | \f |
370 | (define (tree-il-fold leaf down up seed tree) | |
371 | "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent | |
372 | into a sub-tree, and UP when leaving a sub-tree. Each of these procedures is | |
373 | invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered | |
374 | and SEED is the current result, intially seeded with SEED. | |
375 | ||
376 | This is an implementation of `foldts' as described by Andy Wingo in | |
7081d4f9 | 377 | ``Calls of fold to XML transformation''." |
f4aa0f10 LC |
378 | (let loop ((tree tree) |
379 | (result seed)) | |
380 | (if (or (null? tree) (pair? tree)) | |
381 | (fold loop result tree) | |
382 | (record-case tree | |
383 | ((<lexical-set> exp) | |
384 | (up tree (loop exp (down tree result)))) | |
385 | ((<module-set> exp) | |
386 | (up tree (loop exp (down tree result)))) | |
387 | ((<toplevel-set> exp) | |
388 | (up tree (loop exp (down tree result)))) | |
389 | ((<toplevel-define> exp) | |
390 | (up tree (loop exp (down tree result)))) | |
b6d93b11 AW |
391 | ((<conditional> test consequent alternate) |
392 | (up tree (loop alternate | |
393 | (loop consequent | |
f4aa0f10 | 394 | (loop test (down tree result)))))) |
7081d4f9 | 395 | ((<call> proc args) |
f4aa0f10 | 396 | (up tree (loop (cons proc args) (down tree result)))) |
a881a4ae AW |
397 | ((<primcall> name args) |
398 | (up tree (loop args (down tree result)))) | |
6fc3eae4 AW |
399 | ((<seq> head tail) |
400 | (up tree (loop tail (loop head (down tree result))))) | |
f4aa0f10 | 401 | ((<lambda> body) |
19113f1c AW |
402 | (let ((result (down tree result))) |
403 | (up tree | |
404 | (if body | |
405 | (loop body result) | |
406 | result)))) | |
3a88cb3b AW |
407 | ((<lambda-case> inits body alternate) |
408 | (up tree (if alternate | |
409 | (loop alternate | |
1e2a8edb AW |
410 | (loop body (loop inits (down tree result)))) |
411 | (loop body (loop inits (down tree result)))))) | |
f4aa0f10 LC |
412 | ((<let> vals body) |
413 | (up tree (loop body | |
414 | (loop vals | |
415 | (down tree result))))) | |
416 | ((<letrec> vals body) | |
417 | (up tree (loop body | |
418 | (loop vals | |
419 | (down tree result))))) | |
c21c89b1 AW |
420 | ((<fix> vals body) |
421 | (up tree (loop body | |
422 | (loop vals | |
423 | (down tree result))))) | |
4dcd8499 AW |
424 | ((<let-values> exp body) |
425 | (up tree (loop body (loop exp (down tree result))))) | |
880e7948 | 426 | ((<dynwind> winder pre body post unwinder) |
1c297a38 | 427 | (up tree (loop unwinder |
880e7948 AW |
428 | (loop post |
429 | (loop body | |
430 | (loop pre | |
431 | (loop winder | |
432 | (down tree result)))))))) | |
d7c53a86 AW |
433 | ((<dynlet> fluids vals body) |
434 | (up tree (loop body | |
435 | (loop vals | |
436 | (loop fluids (down tree result)))))) | |
706a705e AW |
437 | ((<dynref> fluid) |
438 | (up tree (loop fluid (down tree result)))) | |
439 | ((<dynset> fluid exp) | |
440 | (up tree (loop exp (loop fluid (down tree result))))) | |
07a0c7d5 AW |
441 | ((<prompt> tag body handler) |
442 | (up tree | |
443 | (loop tag (loop body (loop handler | |
444 | (down tree result)))))) | |
2d026f04 AW |
445 | ((<abort> tag args tail) |
446 | (up tree (loop tail (loop args (loop tag (down tree result)))))) | |
f4aa0f10 LC |
447 | (else |
448 | (leaf tree result)))))) | |
449 | ||
4dcd8499 | 450 | |
0c65f52c AW |
451 | (define-syntax-rule (make-tree-il-folder seed ...) |
452 | (lambda (tree down up seed ...) | |
453 | (define (fold-values proc exps seed ...) | |
454 | (if (null? exps) | |
455 | (values seed ...) | |
456 | (let-values (((seed ...) (proc (car exps) seed ...))) | |
457 | (fold-values proc (cdr exps) seed ...)))) | |
458 | (let foldts ((tree tree) (seed seed) ...) | |
459 | (let*-values | |
460 | (((seed ...) (down tree seed ...)) | |
461 | ((seed ...) | |
462 | (record-case tree | |
463 | ((<lexical-set> exp) | |
464 | (foldts exp seed ...)) | |
465 | ((<module-set> exp) | |
466 | (foldts exp seed ...)) | |
467 | ((<toplevel-set> exp) | |
468 | (foldts exp seed ...)) | |
469 | ((<toplevel-define> exp) | |
470 | (foldts exp seed ...)) | |
471 | ((<conditional> test consequent alternate) | |
472 | (let*-values (((seed ...) (foldts test seed ...)) | |
473 | ((seed ...) (foldts consequent seed ...))) | |
474 | (foldts alternate seed ...))) | |
ca128245 | 475 | ((<call> proc args) |
0c65f52c AW |
476 | (let-values (((seed ...) (foldts proc seed ...))) |
477 | (fold-values foldts args seed ...))) | |
ca128245 AW |
478 | ((<primcall> name args) |
479 | (fold-values foldts args seed ...)) | |
480 | ((<seq> head tail) | |
481 | (let-values (((seed ...) (foldts head seed ...))) | |
482 | (foldts tail seed ...))) | |
0c65f52c | 483 | ((<lambda> body) |
19113f1c AW |
484 | (if body |
485 | (foldts body seed ...) | |
486 | (values seed ...))) | |
0c65f52c AW |
487 | ((<lambda-case> inits body alternate) |
488 | (let-values (((seed ...) (fold-values foldts inits seed ...))) | |
489 | (if alternate | |
490 | (let-values (((seed ...) (foldts body seed ...))) | |
491 | (foldts alternate seed ...)) | |
492 | (foldts body seed ...)))) | |
493 | ((<let> vals body) | |
494 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
495 | (foldts body seed ...))) | |
496 | ((<letrec> vals body) | |
497 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
498 | (foldts body seed ...))) | |
499 | ((<fix> vals body) | |
500 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) | |
501 | (foldts body seed ...))) | |
502 | ((<let-values> exp body) | |
503 | (let*-values (((seed ...) (foldts exp seed ...))) | |
504 | (foldts body seed ...))) | |
880e7948 AW |
505 | ((<dynwind> winder pre body post unwinder) |
506 | (let*-values (((seed ...) (foldts winder seed ...)) | |
507 | ((seed ...) (foldts pre seed ...)) | |
508 | ((seed ...) (foldts body seed ...)) | |
509 | ((seed ...) (foldts post seed ...))) | |
0c65f52c AW |
510 | (foldts unwinder seed ...))) |
511 | ((<dynlet> fluids vals body) | |
512 | (let*-values (((seed ...) (fold-values foldts fluids seed ...)) | |
513 | ((seed ...) (fold-values foldts vals seed ...))) | |
514 | (foldts body seed ...))) | |
515 | ((<dynref> fluid) | |
516 | (foldts fluid seed ...)) | |
517 | ((<dynset> fluid exp) | |
518 | (let*-values (((seed ...) (foldts fluid seed ...))) | |
519 | (foldts exp seed ...))) | |
520 | ((<prompt> tag body handler) | |
521 | (let*-values (((seed ...) (foldts tag seed ...)) | |
522 | ((seed ...) (foldts body seed ...))) | |
523 | (foldts handler seed ...))) | |
524 | ((<abort> tag args tail) | |
525 | (let*-values (((seed ...) (foldts tag seed ...)) | |
526 | ((seed ...) (fold-values foldts args seed ...))) | |
527 | (foldts tail seed ...))) | |
528 | (else | |
529 | (values seed ...))))) | |
530 | (up tree seed ...))))) | |
4dcd8499 | 531 | |
cb28c085 AW |
532 | (define (post-order! f x) |
533 | (let lp ((x x)) | |
534 | (record-case x | |
7081d4f9 AW |
535 | ((<call> proc args) |
536 | (set! (call-proc x) (lp proc)) | |
537 | (set! (call-args x) (map lp args))) | |
cb28c085 | 538 | |
a881a4ae AW |
539 | ((<primcall> name args) |
540 | (set! (primcall-args x) (map lp args))) | |
541 | ||
b6d93b11 | 542 | ((<conditional> test consequent alternate) |
cb28c085 | 543 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
544 | (set! (conditional-consequent x) (lp consequent)) |
545 | (set! (conditional-alternate x) (lp alternate))) | |
d26a26f6 | 546 | |
cb28c085 | 547 | ((<lexical-set> name gensym exp) |
f4aa8d53 | 548 | (set! (lexical-set-exp x) (lp exp))) |
d26a26f6 | 549 | |
cb28c085 | 550 | ((<module-set> mod name public? exp) |
f4aa8d53 | 551 | (set! (module-set-exp x) (lp exp))) |
d26a26f6 | 552 | |
cb28c085 | 553 | ((<toplevel-set> name exp) |
f4aa8d53 | 554 | (set! (toplevel-set-exp x) (lp exp))) |
d26a26f6 | 555 | |
cb28c085 | 556 | ((<toplevel-define> name exp) |
f4aa8d53 | 557 | (set! (toplevel-define-exp x) (lp exp))) |
d26a26f6 | 558 | |
8a4ca0ea | 559 | ((<lambda> body) |
19113f1c AW |
560 | (if body |
561 | (set! (lambda-body x) (lp body)))) | |
d26a26f6 | 562 | |
3a88cb3b | 563 | ((<lambda-case> inits body alternate) |
b0c8c187 | 564 | (set! inits (map lp inits)) |
8a4ca0ea | 565 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b AW |
566 | (if alternate |
567 | (set! (lambda-case-alternate x) (lp alternate)))) | |
d26a26f6 | 568 | |
6fc3eae4 AW |
569 | ((<seq> head tail) |
570 | (set! (seq-head x) (lp head)) | |
571 | (set! (seq-tail x) (lp tail))) | |
572 | ||
93f63467 | 573 | ((<let> gensyms vals body) |
cb28c085 | 574 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 575 | (set! (let-body x) (lp body))) |
d26a26f6 | 576 | |
93f63467 | 577 | ((<letrec> gensyms vals body) |
cb28c085 | 578 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 | 579 | (set! (letrec-body x) (lp body))) |
d26a26f6 | 580 | |
93f63467 | 581 | ((<fix> gensyms vals body) |
c21c89b1 AW |
582 | (set! (fix-vals x) (map lp vals)) |
583 | (set! (fix-body x) (lp body))) | |
d26a26f6 | 584 | |
8a4ca0ea | 585 | ((<let-values> exp body) |
f4aa8d53 AW |
586 | (set! (let-values-exp x) (lp exp)) |
587 | (set! (let-values-body x) (lp body))) | |
d26a26f6 | 588 | |
880e7948 | 589 | ((<dynwind> winder pre body post unwinder) |
8da6ab34 | 590 | (set! (dynwind-winder x) (lp winder)) |
880e7948 AW |
591 | (set! (dynwind-pre x) (lp pre)) |
592 | (set! (dynwind-body x) (lp body)) | |
593 | (set! (dynwind-post x) (lp post)) | |
8da6ab34 | 594 | (set! (dynwind-unwinder x) (lp unwinder))) |
d26a26f6 | 595 | |
d7c53a86 AW |
596 | ((<dynlet> fluids vals body) |
597 | (set! (dynlet-fluids x) (map lp fluids)) | |
598 | (set! (dynlet-vals x) (map lp vals)) | |
599 | (set! (dynlet-body x) (lp body))) | |
d26a26f6 | 600 | |
706a705e AW |
601 | ((<dynref> fluid) |
602 | (set! (dynref-fluid x) (lp fluid))) | |
d26a26f6 | 603 | |
706a705e AW |
604 | ((<dynset> fluid exp) |
605 | (set! (dynset-fluid x) (lp fluid)) | |
606 | (set! (dynset-exp x) (lp exp))) | |
d26a26f6 | 607 | |
07a0c7d5 | 608 | ((<prompt> tag body handler) |
1c297a38 AW |
609 | (set! (prompt-tag x) (lp tag)) |
610 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 611 | (set! (prompt-handler x) (lp handler))) |
d26a26f6 | 612 | |
2d026f04 | 613 | ((<abort> tag args tail) |
6e84cb95 | 614 | (set! (abort-tag x) (lp tag)) |
2d026f04 AW |
615 | (set! (abort-args x) (map lp args)) |
616 | (set! (abort-tail x) (lp tail))) | |
d26a26f6 | 617 | |
f4aa8d53 | 618 | (else #f)) |
d26a26f6 | 619 | |
f4aa8d53 | 620 | (or (f x) x))) |
cb28c085 AW |
621 | |
622 | (define (pre-order! f x) | |
623 | (let lp ((x x)) | |
624 | (let ((x (or (f x) x))) | |
625 | (record-case x | |
7081d4f9 AW |
626 | ((<call> proc args) |
627 | (set! (call-proc x) (lp proc)) | |
628 | (set! (call-args x) (map lp args))) | |
cb28c085 | 629 | |
a881a4ae AW |
630 | ((<primcall> name args) |
631 | (set! (primcall-args x) (map lp args))) | |
632 | ||
b6d93b11 | 633 | ((<conditional> test consequent alternate) |
cb28c085 | 634 | (set! (conditional-test x) (lp test)) |
b6d93b11 AW |
635 | (set! (conditional-consequent x) (lp consequent)) |
636 | (set! (conditional-alternate x) (lp alternate))) | |
cb28c085 | 637 | |
e5f5113c | 638 | ((<lexical-set> exp) |
cb28c085 | 639 | (set! (lexical-set-exp x) (lp exp))) |
d26a26f6 | 640 | |
e5f5113c | 641 | ((<module-set> exp) |
cb28c085 AW |
642 | (set! (module-set-exp x) (lp exp))) |
643 | ||
e5f5113c | 644 | ((<toplevel-set> exp) |
cb28c085 AW |
645 | (set! (toplevel-set-exp x) (lp exp))) |
646 | ||
e5f5113c | 647 | ((<toplevel-define> exp) |
cb28c085 AW |
648 | (set! (toplevel-define-exp x) (lp exp))) |
649 | ||
e5f5113c | 650 | ((<lambda> body) |
19113f1c AW |
651 | (if body |
652 | (set! (lambda-body x) (lp body)))) | |
cb28c085 | 653 | |
3a88cb3b | 654 | ((<lambda-case> inits body alternate) |
b0c8c187 | 655 | (set! inits (map lp inits)) |
8a4ca0ea | 656 | (set! (lambda-case-body x) (lp body)) |
3a88cb3b | 657 | (if alternate (set! (lambda-case-alternate x) (lp alternate)))) |
8a4ca0ea | 658 | |
6fc3eae4 AW |
659 | ((<seq> head tail) |
660 | (set! (seq-head x) (lp head)) | |
661 | (set! (seq-tail x) (lp tail))) | |
662 | ||
e5f5113c | 663 | ((<let> vals body) |
cb28c085 | 664 | (set! (let-vals x) (map lp vals)) |
f4aa8d53 | 665 | (set! (let-body x) (lp body))) |
cb28c085 | 666 | |
e5f5113c | 667 | ((<letrec> vals body) |
cb28c085 | 668 | (set! (letrec-vals x) (map lp vals)) |
f4aa8d53 AW |
669 | (set! (letrec-body x) (lp body))) |
670 | ||
e5f5113c | 671 | ((<fix> vals body) |
c21c89b1 AW |
672 | (set! (fix-vals x) (map lp vals)) |
673 | (set! (fix-body x) (lp body))) | |
674 | ||
e5f5113c | 675 | ((<let-values> exp body) |
f4aa8d53 AW |
676 | (set! (let-values-exp x) (lp exp)) |
677 | (set! (let-values-body x) (lp body))) | |
cb28c085 | 678 | |
880e7948 | 679 | ((<dynwind> winder pre body post unwinder) |
8da6ab34 | 680 | (set! (dynwind-winder x) (lp winder)) |
880e7948 AW |
681 | (set! (dynwind-pre x) (lp pre)) |
682 | (set! (dynwind-body x) (lp body)) | |
683 | (set! (dynwind-post x) (lp post)) | |
8da6ab34 | 684 | (set! (dynwind-unwinder x) (lp unwinder))) |
d26a26f6 | 685 | |
d7c53a86 AW |
686 | ((<dynlet> fluids vals body) |
687 | (set! (dynlet-fluids x) (map lp fluids)) | |
688 | (set! (dynlet-vals x) (map lp vals)) | |
689 | (set! (dynlet-body x) (lp body))) | |
d26a26f6 | 690 | |
706a705e AW |
691 | ((<dynref> fluid) |
692 | (set! (dynref-fluid x) (lp fluid))) | |
d26a26f6 | 693 | |
706a705e AW |
694 | ((<dynset> fluid exp) |
695 | (set! (dynset-fluid x) (lp fluid)) | |
696 | (set! (dynset-exp x) (lp exp))) | |
d26a26f6 | 697 | |
07a0c7d5 | 698 | ((<prompt> tag body handler) |
1c297a38 AW |
699 | (set! (prompt-tag x) (lp tag)) |
700 | (set! (prompt-body x) (lp body)) | |
07a0c7d5 | 701 | (set! (prompt-handler x) (lp handler))) |
d26a26f6 | 702 | |
2d026f04 | 703 | ((<abort> tag args tail) |
6e84cb95 | 704 | (set! (abort-tag x) (lp tag)) |
2d026f04 AW |
705 | (set! (abort-args x) (map lp args)) |
706 | (set! (abort-tail x) (lp tail))) | |
d26a26f6 | 707 | |
cb28c085 AW |
708 | (else #f)) |
709 | x))) | |
1fb39dc5 AW |
710 | |
711 | ;; FIXME: We should have a better primitive than this. | |
712 | (define (struct-nfields x) | |
713 | (/ (string-length (symbol->string (struct-layout x))) 2)) | |
714 | ||
715 | (define (tree-il=? a b) | |
716 | (cond | |
717 | ((struct? a) | |
718 | (and (struct? b) | |
719 | (eq? (struct-vtable a) (struct-vtable b)) | |
720 | ;; Assume that all structs are tree-il, so we skip over the | |
721 | ;; src slot. | |
722 | (let lp ((n (1- (struct-nfields a)))) | |
723 | (or (zero? n) | |
724 | (and (tree-il=? (struct-ref a n) (struct-ref b n)) | |
725 | (lp (1- n))))))) | |
726 | ((pair? a) | |
727 | (and (pair? b) | |
728 | (tree-il=? (car a) (car b)) | |
729 | (tree-il=? (cdr a) (cdr b)))) | |
730 | (else | |
731 | (equal? a b)))) | |
732 | ||
733 | (define-syntax hash-bits | |
734 | (make-variable-transformer | |
735 | (lambda (x) | |
736 | (syntax-case x () | |
737 | (var | |
738 | (identifier? #'var) | |
739 | (logcount most-positive-fixnum)))))) | |
740 | ||
741 | (define (tree-il-hash exp) | |
742 | (let ((hash-depth 4) | |
743 | (hash-width 3)) | |
744 | (define (hash-exp exp depth) | |
745 | (define (rotate x bits) | |
746 | (logior (ash x (- bits)) | |
747 | (ash (logand x (1- (ash 1 bits))) (- hash-bits bits)))) | |
748 | (define (mix h1 h2) | |
749 | (logxor h1 (rotate h2 8))) | |
750 | (define (hash-struct s) | |
751 | (let ((len (struct-nfields s)) | |
752 | (h (hashq (struct-vtable s) most-positive-fixnum))) | |
753 | (if (zero? depth) | |
754 | h | |
755 | (let lp ((i (max (- len hash-width) 1)) (h h)) | |
756 | (if (< i len) | |
757 | (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h)) | |
758 | h))))) | |
759 | (define (hash-list l) | |
760 | (let ((h (hashq 'list most-positive-fixnum))) | |
761 | (if (zero? depth) | |
762 | h | |
763 | (let lp ((l l) (width 0) (h h)) | |
764 | (if (< width hash-width) | |
765 | (lp (cdr l) (1+ width) | |
766 | (mix (hash-exp (car l) (1+ depth)) h)) | |
767 | h))))) | |
768 | (cond | |
769 | ((struct? exp) (hash-struct exp)) | |
770 | ((list? exp) (hash-list exp)) | |
771 | (else (hash exp most-positive-fixnum)))) | |
772 | ||
773 | (hash-exp exp 0))) |