Commit | Line | Data |
---|---|---|
699ed8ce | 1 | ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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) |
99b4da8f | 22 | #:use-module (ice-9 match) |
811d10f5 | 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 | |
178a4092 | 42 | ;; idea: arity |
b0c8c187 | 43 | lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw |
93f63467 | 44 | lambda-case-inits lambda-case-gensyms |
3a88cb3b | 45 | lambda-case-body lambda-case-alternate |
93f63467 | 46 | <let> let? make-let let-src let-names let-gensyms let-vals let-body |
fb6e61ca | 47 | <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body |
93f63467 | 48 | <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body |
8a4ca0ea | 49 | <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body |
178a4092 | 50 | <prompt> prompt? make-prompt prompt-src prompt-escape-only? prompt-tag prompt-body prompt-handler |
2d026f04 | 51 | <abort> abort? make-abort abort-src abort-tag abort-args abort-tail |
f4aa0f10 | 52 | |
6fc3eae4 AW |
53 | list->seq |
54 | ||
9efc833d AW |
55 | parse-tree-il |
56 | unparse-tree-il | |
cb28c085 AW |
57 | tree-il->scheme |
58 | ||
f4aa0f10 | 59 | tree-il-fold |
4dcd8499 | 60 | make-tree-il-folder |
403d78f9 | 61 | post-order |
25450a0d | 62 | pre-order |
1fb39dc5 AW |
63 | |
64 | tree-il=? | |
65 | tree-il-hash)) | |
811d10f5 | 66 | |
4ffa8275 | 67 | (define (print-tree-il exp port) |
7cd6d77c | 68 | (format port "#<tree-il ~S>" (unparse-tree-il exp))) |
4ffa8275 | 69 | |
f7b61b39 AW |
70 | (define-syntax borrow-core-vtables |
71 | (lambda (x) | |
72 | (syntax-case x () | |
73 | ((_) | |
74 | (let lp ((n 0) (out '())) | |
75 | (if (< n (vector-length %expanded-vtables)) | |
76 | (lp (1+ n) | |
77 | (let* ((vtable (vector-ref %expanded-vtables n)) | |
78 | (stem (struct-ref vtable (+ vtable-offset-user 0))) | |
79 | (fields (struct-ref vtable (+ vtable-offset-user 2))) | |
80 | (sfields (map | |
81 | (lambda (f) (datum->syntax x f)) | |
82 | fields)) | |
83 | (type (datum->syntax x (symbol-append '< stem '>))) | |
84 | (ctor (datum->syntax x (symbol-append 'make- stem))) | |
85 | (pred (datum->syntax x (symbol-append stem '?)))) | |
86 | (let lp ((n 0) (fields fields) | |
87 | (out (cons* | |
88 | #`(define (#,ctor #,@sfields) | |
89 | (make-struct #,type 0 #,@sfields)) | |
90 | #`(define (#,pred x) | |
91 | (and (struct? x) | |
92 | (eq? (struct-vtable x) #,type))) | |
4ffa8275 AW |
93 | #`(struct-set! #,type vtable-index-printer |
94 | print-tree-il) | |
f7b61b39 AW |
95 | #`(define #,type |
96 | (vector-ref %expanded-vtables #,n)) | |
97 | out))) | |
98 | (if (null? fields) | |
99 | out | |
100 | (lp (1+ n) | |
101 | (cdr fields) | |
102 | (let ((acc (datum->syntax | |
103 | x (symbol-append stem '- (car fields))))) | |
104 | (cons #`(define #,acc | |
105 | (make-procedure-with-setter | |
106 | (lambda (x) (struct-ref x #,n)) | |
107 | (lambda (x v) (struct-set! x #,n v)))) | |
108 | out))))))) | |
109 | #`(begin #,@(reverse out)))))))) | |
110 | ||
111 | (borrow-core-vtables) | |
112 | ||
113 | ;; (<void>) | |
114 | ;; (<const> exp) | |
115 | ;; (<primitive-ref> name) | |
116 | ;; (<lexical-ref> name gensym) | |
117 | ;; (<lexical-set> name gensym exp) | |
118 | ;; (<module-ref> mod name public?) | |
119 | ;; (<module-set> mod name public? exp) | |
120 | ;; (<toplevel-ref> name) | |
121 | ;; (<toplevel-set> name exp) | |
122 | ;; (<toplevel-define> name exp) | |
123 | ;; (<conditional> test consequent alternate) | |
7081d4f9 | 124 | ;; (<call> proc args) |
a881a4ae | 125 | ;; (<primcall> name args) |
6fc3eae4 | 126 | ;; (<seq> head tail) |
f7b61b39 AW |
127 | ;; (<lambda> meta body) |
128 | ;; (<lambda-case> req opt rest kw inits gensyms body alternate) | |
129 | ;; (<let> names gensyms vals body) | |
fb6e61ca | 130 | ;; (<letrec> in-order? names gensyms vals body) |
f7b61b39 | 131 | |
4ffa8275 | 132 | (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il) |
93f63467 | 133 | (<fix> names gensyms vals body) |
1c297a38 | 134 | (<let-values> exp body) |
178a4092 | 135 | (<prompt> escape-only? tag body handler) |
2d026f04 | 136 | (<abort> tag args tail)) |
d26a26f6 | 137 | |
811d10f5 AW |
138 | \f |
139 | ||
6fc3eae4 AW |
140 | ;; A helper. |
141 | (define (list->seq loc exps) | |
142 | (if (null? (cdr exps)) | |
143 | (car exps) | |
144 | (make-seq loc (car exps) (list->seq #f (cdr exps))))) | |
145 | ||
146 | \f | |
147 | ||
811d10f5 AW |
148 | (define (location x) |
149 | (and (pair? x) | |
150 | (let ((props (source-properties x))) | |
81fd3152 | 151 | (and (pair? props) props)))) |
811d10f5 | 152 | |
ce09ee19 | 153 | (define (parse-tree-il exp) |
811d10f5 | 154 | (let ((loc (location exp)) |
ce09ee19 | 155 | (retrans (lambda (x) (parse-tree-il x)))) |
f852e05e AW |
156 | (match exp |
157 | (('void) | |
cf10678f AW |
158 | (make-void loc)) |
159 | ||
f852e05e | 160 | (('call proc . args) |
7081d4f9 | 161 | (make-call loc (retrans proc) (map retrans args))) |
811d10f5 | 162 | |
f852e05e | 163 | (('primcall name . args) |
a881a4ae AW |
164 | (make-primcall loc name (map retrans args))) |
165 | ||
f852e05e | 166 | (('if test consequent alternate) |
b6d93b11 | 167 | (make-conditional loc (retrans test) (retrans consequent) (retrans alternate))) |
811d10f5 | 168 | |
f852e05e | 169 | (('primitive (and name (? symbol?))) |
811d10f5 AW |
170 | (make-primitive-ref loc name)) |
171 | ||
f852e05e | 172 | (('lexical (and name (? symbol?))) |
811d10f5 AW |
173 | (make-lexical-ref loc name name)) |
174 | ||
f852e05e | 175 | (('lexical (and name (? symbol?)) (and sym (? symbol?))) |
811d10f5 AW |
176 | (make-lexical-ref loc name sym)) |
177 | ||
f852e05e | 178 | (('set! ('lexical (and name (? symbol?))) exp) |
5c27902e AW |
179 | (make-lexical-set loc name name (retrans exp))) |
180 | ||
f852e05e | 181 | (('set! ('lexical (and name (? symbol?)) (and sym (? symbol?))) exp) |
811d10f5 AW |
182 | (make-lexical-set loc name sym (retrans exp))) |
183 | ||
f852e05e | 184 | (('@ ((and mod (? symbol?)) ...) (and name (? symbol?))) |
811d10f5 AW |
185 | (make-module-ref loc mod name #t)) |
186 | ||
f852e05e | 187 | (('set! ('@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp) |
811d10f5 AW |
188 | (make-module-set loc mod name #t (retrans exp))) |
189 | ||
f852e05e | 190 | (('@@ ((and mod (? symbol?)) ...) (and name (? symbol?))) |
811d10f5 AW |
191 | (make-module-ref loc mod name #f)) |
192 | ||
f852e05e | 193 | (('set! ('@@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp) |
811d10f5 AW |
194 | (make-module-set loc mod name #f (retrans exp))) |
195 | ||
f852e05e | 196 | (('toplevel (and name (? symbol?))) |
811d10f5 AW |
197 | (make-toplevel-ref loc name)) |
198 | ||
f852e05e | 199 | (('set! ('toplevel (and name (? symbol?))) exp) |
811d10f5 AW |
200 | (make-toplevel-set loc name (retrans exp))) |
201 | ||
f852e05e | 202 | (('define (and name (? symbol?)) exp) |
811d10f5 AW |
203 | (make-toplevel-define loc name (retrans exp))) |
204 | ||
f852e05e | 205 | (('lambda meta body) |
8a4ca0ea | 206 | (make-lambda loc meta (retrans body))) |
811d10f5 | 207 | |
f852e05e | 208 | (('lambda-case ((req opt rest kw inits gensyms) body) alternate) |
d26a26f6 | 209 | (make-lambda-case loc req opt rest kw |
93f63467 | 210 | (map retrans inits) gensyms |
8a4ca0ea | 211 | (retrans body) |
3a88cb3b | 212 | (and=> alternate retrans))) |
811d10f5 | 213 | |
f852e05e | 214 | (('lambda-case ((req opt rest kw inits gensyms) body)) |
b0c8c187 | 215 | (make-lambda-case loc req opt rest kw |
93f63467 | 216 | (map retrans inits) gensyms |
7e01997e AW |
217 | (retrans body) |
218 | #f)) | |
219 | ||
f852e05e | 220 | (('const exp) |
811d10f5 AW |
221 | (make-const loc exp)) |
222 | ||
f852e05e | 223 | (('seq head tail) |
6fc3eae4 AW |
224 | (make-seq loc (retrans head) (retrans tail))) |
225 | ||
226 | ;; Convenience. | |
f852e05e | 227 | (('begin . exps) |
6fc3eae4 | 228 | (list->seq loc (map retrans exps))) |
811d10f5 | 229 | |
f852e05e | 230 | (('let names gensyms vals body) |
93f63467 | 231 | (make-let loc names gensyms (map retrans vals) (retrans body))) |
f4aa8d53 | 232 | |
f852e05e | 233 | (('letrec names gensyms vals body) |
fb6e61ca AW |
234 | (make-letrec loc #f names gensyms (map retrans vals) (retrans body))) |
235 | ||
f852e05e | 236 | (('letrec* names gensyms vals body) |
fb6e61ca | 237 | (make-letrec loc #t names gensyms (map retrans vals) (retrans body))) |
811d10f5 | 238 | |
f852e05e | 239 | (('fix names gensyms vals body) |
93f63467 | 240 | (make-fix loc names gensyms (map retrans vals) (retrans body))) |
c21c89b1 | 241 | |
f852e05e | 242 | (('let-values exp body) |
8a4ca0ea | 243 | (make-let-values loc (retrans exp) (retrans body))) |
811d10f5 | 244 | |
178a4092 AW |
245 | (('prompt escape-only? tag body handler) |
246 | (make-prompt loc escape-only? | |
247 | (retrans tag) (retrans body) (retrans handler))) | |
f852e05e AW |
248 | |
249 | (('abort tag args tail) | |
2d026f04 | 250 | (make-abort loc (retrans tag) (map retrans args) (retrans tail))) |
1c297a38 | 251 | |
811d10f5 AW |
252 | (else |
253 | (error "unrecognized tree-il" exp))))) | |
254 | ||
255 | (define (unparse-tree-il tree-il) | |
98f778ea AW |
256 | (match tree-il |
257 | (($ <void> src) | |
cf10678f AW |
258 | '(void)) |
259 | ||
98f778ea | 260 | (($ <call> src proc args) |
7081d4f9 | 261 | `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) |
811d10f5 | 262 | |
98f778ea | 263 | (($ <primcall> src name args) |
a881a4ae AW |
264 | `(primcall ,name ,@(map unparse-tree-il args))) |
265 | ||
98f778ea AW |
266 | (($ <conditional> src test consequent alternate) |
267 | `(if ,(unparse-tree-il test) | |
268 | ,(unparse-tree-il consequent) | |
269 | ,(unparse-tree-il alternate))) | |
811d10f5 | 270 | |
98f778ea | 271 | (($ <primitive-ref> src name) |
811d10f5 AW |
272 | `(primitive ,name)) |
273 | ||
98f778ea | 274 | (($ <lexical-ref> src name gensym) |
811d10f5 AW |
275 | `(lexical ,name ,gensym)) |
276 | ||
98f778ea | 277 | (($ <lexical-set> src name gensym exp) |
811d10f5 AW |
278 | `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) |
279 | ||
98f778ea | 280 | (($ <module-ref> src mod name public?) |
811d10f5 AW |
281 | `(,(if public? '@ '@@) ,mod ,name)) |
282 | ||
98f778ea | 283 | (($ <module-set> src mod name public? exp) |
811d10f5 AW |
284 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) |
285 | ||
98f778ea | 286 | (($ <toplevel-ref> src name) |
811d10f5 AW |
287 | `(toplevel ,name)) |
288 | ||
98f778ea | 289 | (($ <toplevel-set> src name exp) |
811d10f5 AW |
290 | `(set! (toplevel ,name) ,(unparse-tree-il exp))) |
291 | ||
98f778ea | 292 | (($ <toplevel-define> src name exp) |
811d10f5 AW |
293 | `(define ,name ,(unparse-tree-il exp))) |
294 | ||
98f778ea | 295 | (($ <lambda> src meta body) |
19113f1c AW |
296 | (if body |
297 | `(lambda ,meta ,(unparse-tree-il body)) | |
298 | `(lambda ,meta (lambda-case)))) | |
8a4ca0ea | 299 | |
98f778ea | 300 | (($ <lambda-case> src req opt rest kw inits gensyms body alternate) |
93f63467 | 301 | `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) |
8a4ca0ea | 302 | ,(unparse-tree-il body)) |
3a88cb3b | 303 | . ,(if alternate (list (unparse-tree-il alternate)) '()))) |
811d10f5 | 304 | |
98f778ea | 305 | (($ <const> src exp) |
811d10f5 AW |
306 | `(const ,exp)) |
307 | ||
98f778ea | 308 | (($ <seq> src head tail) |
6fc3eae4 AW |
309 | `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail))) |
310 | ||
98f778ea | 311 | (($ <let> src names gensyms vals body) |
93f63467 | 312 | `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) |
811d10f5 | 313 | |
98f778ea | 314 | (($ <letrec> src in-order? names gensyms vals body) |
fb6e61ca AW |
315 | `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms |
316 | ,(map unparse-tree-il vals) ,(unparse-tree-il body))) | |
f4aa8d53 | 317 | |
98f778ea | 318 | (($ <fix> src names gensyms vals body) |
93f63467 | 319 | `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) |
c21c89b1 | 320 | |
98f778ea | 321 | (($ <let-values> src exp body) |
1c297a38 AW |
322 | `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) |
323 | ||
178a4092 AW |
324 | (($ <prompt> src escape-only? tag body handler) |
325 | `(prompt ,escape-only? | |
326 | ,(unparse-tree-il tag) | |
98f778ea AW |
327 | ,(unparse-tree-il body) |
328 | ,(unparse-tree-il handler))) | |
d26a26f6 | 329 | |
98f778ea | 330 | (($ <abort> src tag args tail) |
2d026f04 AW |
331 | `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) |
332 | ,(unparse-tree-il tail))))) | |
811d10f5 | 333 | |
72ee0ef7 MW |
334 | (define* (tree-il->scheme e #:optional (env #f) (opts '())) |
335 | (values ((@ (language scheme decompile-tree-il) | |
336 | decompile-tree-il) | |
337 | e env opts))) | |
cb28c085 | 338 | |
f4aa0f10 | 339 | \f |
0c65f52c AW |
340 | (define-syntax-rule (make-tree-il-folder seed ...) |
341 | (lambda (tree down up seed ...) | |
342 | (define (fold-values proc exps seed ...) | |
343 | (if (null? exps) | |
344 | (values seed ...) | |
345 | (let-values (((seed ...) (proc (car exps) seed ...))) | |
346 | (fold-values proc (cdr exps) seed ...)))) | |
347 | (let foldts ((tree tree) (seed seed) ...) | |
348 | (let*-values | |
349 | (((seed ...) (down tree seed ...)) | |
350 | ((seed ...) | |
b34b66b3 AW |
351 | (match tree |
352 | (($ <lexical-set> src name gensym exp) | |
0c65f52c | 353 | (foldts exp seed ...)) |
b34b66b3 | 354 | (($ <module-set> src mod name public? exp) |
0c65f52c | 355 | (foldts exp seed ...)) |
b34b66b3 | 356 | (($ <toplevel-set> src name exp) |
0c65f52c | 357 | (foldts exp seed ...)) |
b34b66b3 | 358 | (($ <toplevel-define> src name exp) |
0c65f52c | 359 | (foldts exp seed ...)) |
b34b66b3 | 360 | (($ <conditional> src test consequent alternate) |
0c65f52c AW |
361 | (let*-values (((seed ...) (foldts test seed ...)) |
362 | ((seed ...) (foldts consequent seed ...))) | |
363 | (foldts alternate seed ...))) | |
b34b66b3 | 364 | (($ <call> src proc args) |
0c65f52c AW |
365 | (let-values (((seed ...) (foldts proc seed ...))) |
366 | (fold-values foldts args seed ...))) | |
b34b66b3 | 367 | (($ <primcall> src name args) |
ca128245 | 368 | (fold-values foldts args seed ...)) |
b34b66b3 | 369 | (($ <seq> src head tail) |
ca128245 AW |
370 | (let-values (((seed ...) (foldts head seed ...))) |
371 | (foldts tail seed ...))) | |
b34b66b3 | 372 | (($ <lambda> src meta body) |
19113f1c AW |
373 | (if body |
374 | (foldts body seed ...) | |
375 | (values seed ...))) | |
b34b66b3 AW |
376 | (($ <lambda-case> src req opt rest kw inits gensyms body |
377 | alternate) | |
0c65f52c AW |
378 | (let-values (((seed ...) (fold-values foldts inits seed ...))) |
379 | (if alternate | |
380 | (let-values (((seed ...) (foldts body seed ...))) | |
381 | (foldts alternate seed ...)) | |
382 | (foldts body seed ...)))) | |
b34b66b3 | 383 | (($ <let> src names gensyms vals body) |
0c65f52c AW |
384 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) |
385 | (foldts body seed ...))) | |
b34b66b3 | 386 | (($ <letrec> src in-order? names gensyms vals body) |
0c65f52c AW |
387 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) |
388 | (foldts body seed ...))) | |
b34b66b3 | 389 | (($ <fix> src names gensyms vals body) |
0c65f52c AW |
390 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) |
391 | (foldts body seed ...))) | |
b34b66b3 | 392 | (($ <let-values> src exp body) |
0c65f52c AW |
393 | (let*-values (((seed ...) (foldts exp seed ...))) |
394 | (foldts body seed ...))) | |
178a4092 | 395 | (($ <prompt> src escape-only? tag body handler) |
0c65f52c AW |
396 | (let*-values (((seed ...) (foldts tag seed ...)) |
397 | ((seed ...) (foldts body seed ...))) | |
398 | (foldts handler seed ...))) | |
b34b66b3 | 399 | (($ <abort> src tag args tail) |
0c65f52c AW |
400 | (let*-values (((seed ...) (foldts tag seed ...)) |
401 | ((seed ...) (fold-values foldts args seed ...))) | |
402 | (foldts tail seed ...))) | |
b34b66b3 | 403 | (_ |
0c65f52c AW |
404 | (values seed ...))))) |
405 | (up tree seed ...))))) | |
4dcd8499 | 406 | |
007f671a AW |
407 | (define (tree-il-fold down up seed tree) |
408 | "Traverse TREE, calling DOWN before visiting a sub-tree, and UP when | |
409 | after visiting it. Each of these procedures is invoked as `(PROC TREE | |
410 | SEED)', where TREE is the sub-tree considered and SEED is the current | |
411 | result, intially seeded with SEED. | |
412 | ||
413 | This is an implementation of `foldts' as described by Andy Wingo in | |
414 | ``Applications of fold to XML transformation''." | |
415 | ;; Multi-valued fold naturally puts the seeds at the end, whereas | |
416 | ;; normal fold puts the traversable at the end. Adapt to the expected | |
417 | ;; argument order. | |
418 | ((make-tree-il-folder tree) tree down up seed)) | |
419 | ||
403d78f9 | 420 | (define (pre-post-order pre post x) |
699ed8ce AW |
421 | (define (elts-eq? a b) |
422 | (or (null? a) | |
423 | (and (eq? (car a) (car b)) | |
424 | (elts-eq? (cdr a) (cdr b))))) | |
cb28c085 | 425 | (let lp ((x x)) |
403d78f9 | 426 | (post |
699ed8ce AW |
427 | (let ((x (pre x))) |
428 | (match x | |
429 | ((or ($ <void>) | |
430 | ($ <const>) | |
431 | ($ <primitive-ref>) | |
432 | ($ <lexical-ref>) | |
433 | ($ <module-ref>) | |
434 | ($ <toplevel-ref>)) | |
435 | x) | |
436 | ||
437 | (($ <lexical-set> src name gensym exp) | |
438 | (let ((exp* (lp exp))) | |
439 | (if (eq? exp exp*) | |
440 | x | |
441 | (make-lexical-set src name gensym exp*)))) | |
442 | ||
443 | (($ <module-set> src mod name public? exp) | |
444 | (let ((exp* (lp exp))) | |
445 | (if (eq? exp exp*) | |
446 | x | |
447 | (make-module-set src mod name public? exp*)))) | |
448 | ||
449 | (($ <toplevel-set> src name exp) | |
450 | (let ((exp* (lp exp))) | |
451 | (if (eq? exp exp*) | |
452 | x | |
453 | (make-toplevel-set src name exp*)))) | |
454 | ||
455 | (($ <toplevel-define> src name exp) | |
456 | (let ((exp* (lp exp))) | |
457 | (if (eq? exp exp*) | |
458 | x | |
459 | (make-toplevel-define src name exp*)))) | |
460 | ||
461 | (($ <conditional> src test consequent alternate) | |
462 | (let ((test* (lp test)) | |
463 | (consequent* (lp consequent)) | |
464 | (alternate* (lp alternate))) | |
465 | (if (and (eq? test test*) | |
466 | (eq? consequent consequent*) | |
467 | (eq? alternate alternate*)) | |
468 | x | |
469 | (make-conditional src test* consequent* alternate*)))) | |
470 | ||
471 | (($ <call> src proc args) | |
472 | (let ((proc* (lp proc)) | |
473 | (args* (map lp args))) | |
474 | (if (and (eq? proc proc*) | |
475 | (elts-eq? args args*)) | |
476 | x | |
477 | (make-call src proc* args*)))) | |
478 | ||
479 | (($ <primcall> src name args) | |
480 | (let ((args* (map lp args))) | |
481 | (if (elts-eq? args args*) | |
482 | x | |
483 | (make-primcall src name args*)))) | |
484 | ||
485 | (($ <seq> src head tail) | |
486 | (let ((head* (lp head)) | |
487 | (tail* (lp tail))) | |
488 | (if (and (eq? head head*) | |
489 | (eq? tail tail*)) | |
490 | x | |
491 | (make-seq src head* tail*)))) | |
6fc3eae4 | 492 | |
699ed8ce AW |
493 | (($ <lambda> src meta body) |
494 | (let ((body* (and body (lp body)))) | |
495 | (if (eq? body body*) | |
496 | x | |
497 | (make-lambda src meta body*)))) | |
498 | ||
499 | (($ <lambda-case> src req opt rest kw inits gensyms body alternate) | |
500 | (let ((inits* (map lp inits)) | |
501 | (body* (lp body)) | |
502 | (alternate* (and alternate (lp alternate)))) | |
503 | (if (and (elts-eq? inits inits*) | |
504 | (eq? body body*) | |
505 | (eq? alternate alternate*)) | |
506 | x | |
507 | (make-lambda-case src req opt rest kw inits* gensyms body* | |
508 | alternate*)))) | |
509 | ||
510 | (($ <let> src names gensyms vals body) | |
511 | (let ((vals* (map lp vals)) | |
512 | (body* (lp body))) | |
513 | (if (and (elts-eq? vals vals*) | |
514 | (eq? body body*)) | |
515 | x | |
516 | (make-let src names gensyms vals* body*)))) | |
517 | ||
518 | (($ <letrec> src in-order? names gensyms vals body) | |
519 | (let ((vals* (map lp vals)) | |
520 | (body* (lp body))) | |
521 | (if (and (elts-eq? vals vals*) | |
522 | (eq? body body*)) | |
523 | x | |
524 | (make-letrec src in-order? names gensyms vals* body*)))) | |
525 | ||
526 | (($ <fix> src names gensyms vals body) | |
527 | (let ((vals* (map lp vals)) | |
528 | (body* (lp body))) | |
529 | (if (and (elts-eq? vals vals*) | |
530 | (eq? body body*)) | |
531 | x | |
532 | (make-fix src names gensyms vals* body*)))) | |
533 | ||
534 | (($ <let-values> src exp body) | |
535 | (let ((exp* (lp exp)) | |
536 | (body* (lp body))) | |
537 | (if (and (eq? exp exp*) | |
538 | (eq? body body*)) | |
539 | x | |
540 | (make-let-values src exp* body*)))) | |
541 | ||
542 | (($ <prompt> src escape-only? tag body handler) | |
543 | (let ((tag* (lp tag)) | |
544 | (body* (lp body)) | |
545 | (handler* (lp handler))) | |
546 | (if (and (eq? tag tag*) | |
547 | (eq? body body*) | |
548 | (eq? handler handler*)) | |
549 | x | |
550 | (make-prompt src escape-only? tag* body* handler*)))) | |
551 | ||
552 | (($ <abort> src tag args tail) | |
553 | (let ((tag* (lp tag)) | |
554 | (args* (map lp args)) | |
555 | (tail* (lp tail))) | |
556 | (if (and (eq? tag tag*) | |
557 | (elts-eq? args args*) | |
558 | (eq? tail tail*)) | |
559 | x | |
560 | (make-abort src tag* args* tail*))))))))) | |
403d78f9 AW |
561 | |
562 | (define (post-order f x) | |
563 | (pre-post-order (lambda (x) x) f x)) | |
cb28c085 | 564 | |
25450a0d AW |
565 | (define (pre-order f x) |
566 | (pre-post-order f (lambda (x) x) x)) | |
1fb39dc5 AW |
567 | |
568 | ;; FIXME: We should have a better primitive than this. | |
569 | (define (struct-nfields x) | |
570 | (/ (string-length (symbol->string (struct-layout x))) 2)) | |
571 | ||
572 | (define (tree-il=? a b) | |
573 | (cond | |
574 | ((struct? a) | |
575 | (and (struct? b) | |
576 | (eq? (struct-vtable a) (struct-vtable b)) | |
577 | ;; Assume that all structs are tree-il, so we skip over the | |
578 | ;; src slot. | |
579 | (let lp ((n (1- (struct-nfields a)))) | |
580 | (or (zero? n) | |
581 | (and (tree-il=? (struct-ref a n) (struct-ref b n)) | |
582 | (lp (1- n))))))) | |
583 | ((pair? a) | |
584 | (and (pair? b) | |
585 | (tree-il=? (car a) (car b)) | |
586 | (tree-il=? (cdr a) (cdr b)))) | |
587 | (else | |
588 | (equal? a b)))) | |
589 | ||
590 | (define-syntax hash-bits | |
591 | (make-variable-transformer | |
592 | (lambda (x) | |
593 | (syntax-case x () | |
594 | (var | |
595 | (identifier? #'var) | |
596 | (logcount most-positive-fixnum)))))) | |
597 | ||
598 | (define (tree-il-hash exp) | |
599 | (let ((hash-depth 4) | |
600 | (hash-width 3)) | |
601 | (define (hash-exp exp depth) | |
602 | (define (rotate x bits) | |
603 | (logior (ash x (- bits)) | |
604 | (ash (logand x (1- (ash 1 bits))) (- hash-bits bits)))) | |
605 | (define (mix h1 h2) | |
606 | (logxor h1 (rotate h2 8))) | |
607 | (define (hash-struct s) | |
608 | (let ((len (struct-nfields s)) | |
609 | (h (hashq (struct-vtable s) most-positive-fixnum))) | |
610 | (if (zero? depth) | |
611 | h | |
612 | (let lp ((i (max (- len hash-width) 1)) (h h)) | |
613 | (if (< i len) | |
614 | (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h)) | |
615 | h))))) | |
616 | (define (hash-list l) | |
617 | (let ((h (hashq 'list most-positive-fixnum))) | |
618 | (if (zero? depth) | |
619 | h | |
620 | (let lp ((l l) (width 0) (h h)) | |
621 | (if (< width hash-width) | |
622 | (lp (cdr l) (1+ width) | |
623 | (mix (hash-exp (car l) (1+ depth)) h)) | |
624 | h))))) | |
625 | (cond | |
626 | ((struct? exp) (hash-struct exp)) | |
627 | ((list? exp) (hash-list exp)) | |
628 | (else (hash exp most-positive-fixnum)))) | |
629 | ||
630 | (hash-exp exp 0))) |