| 1 | ;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
| 2 | ;;;; |
| 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 |
| 6 | ;;;; version 3 of the License, or (at your option) any later version. |
| 7 | ;;;; |
| 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. |
| 12 | ;;;; |
| 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 |
| 16 | ;;;; |
| 17 | \f |
| 18 | |
| 19 | (define-module (language tree-il) |
| 20 | #:use-module (srfi srfi-1) |
| 21 | #:use-module (srfi srfi-11) |
| 22 | #:use-module (ice-9 match) |
| 23 | #:use-module (system base syntax) |
| 24 | #:export (tree-il-src |
| 25 | |
| 26 | <void> void? make-void void-src |
| 27 | <const> const? make-const const-src const-exp |
| 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 |
| 36 | <conditional> conditional? make-conditional conditional-src conditional-test conditional-consequent conditional-alternate |
| 37 | <call> call? make-call call-src call-proc call-args |
| 38 | <primcall> primcall? make-primcall primcall-src primcall-name primcall-args |
| 39 | <seq> seq? make-seq seq-src seq-head seq-tail |
| 40 | <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body |
| 41 | <lambda-case> lambda-case? make-lambda-case lambda-case-src |
| 42 | ;; idea: arity |
| 43 | lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw |
| 44 | lambda-case-inits lambda-case-gensyms |
| 45 | lambda-case-body lambda-case-alternate |
| 46 | <let> let? make-let let-src let-names let-gensyms let-vals let-body |
| 47 | <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body |
| 48 | <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body |
| 49 | <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body |
| 50 | <prompt> prompt? make-prompt prompt-src prompt-escape-only? prompt-tag prompt-body prompt-handler |
| 51 | <abort> abort? make-abort abort-src abort-tag abort-args abort-tail |
| 52 | |
| 53 | list->seq |
| 54 | |
| 55 | parse-tree-il |
| 56 | unparse-tree-il |
| 57 | tree-il->scheme |
| 58 | |
| 59 | tree-il-fold |
| 60 | make-tree-il-folder |
| 61 | post-order |
| 62 | pre-order |
| 63 | |
| 64 | tree-il=? |
| 65 | tree-il-hash)) |
| 66 | |
| 67 | (define (print-tree-il exp port) |
| 68 | (format port "#<tree-il ~S>" (unparse-tree-il exp))) |
| 69 | |
| 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))) |
| 93 | #`(struct-set! #,type vtable-index-printer |
| 94 | print-tree-il) |
| 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) |
| 124 | ;; (<call> proc args) |
| 125 | ;; (<primcall> name args) |
| 126 | ;; (<seq> head tail) |
| 127 | ;; (<lambda> meta body) |
| 128 | ;; (<lambda-case> req opt rest kw inits gensyms body alternate) |
| 129 | ;; (<let> names gensyms vals body) |
| 130 | ;; (<letrec> in-order? names gensyms vals body) |
| 131 | |
| 132 | (define-type (<tree-il> #:common-slots (src) #:printer print-tree-il) |
| 133 | (<fix> names gensyms vals body) |
| 134 | (<let-values> exp body) |
| 135 | (<prompt> escape-only? tag body handler) |
| 136 | (<abort> tag args tail)) |
| 137 | |
| 138 | \f |
| 139 | |
| 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 | |
| 148 | (define (location x) |
| 149 | (and (pair? x) |
| 150 | (let ((props (source-properties x))) |
| 151 | (and (pair? props) props)))) |
| 152 | |
| 153 | (define (parse-tree-il exp) |
| 154 | (let ((loc (location exp)) |
| 155 | (retrans (lambda (x) (parse-tree-il x)))) |
| 156 | (match exp |
| 157 | (('void) |
| 158 | (make-void loc)) |
| 159 | |
| 160 | (('call proc . args) |
| 161 | (make-call loc (retrans proc) (map retrans args))) |
| 162 | |
| 163 | (('primcall name . args) |
| 164 | (make-primcall loc name (map retrans args))) |
| 165 | |
| 166 | (('if test consequent alternate) |
| 167 | (make-conditional loc (retrans test) (retrans consequent) (retrans alternate))) |
| 168 | |
| 169 | (('primitive (and name (? symbol?))) |
| 170 | (make-primitive-ref loc name)) |
| 171 | |
| 172 | (('lexical (and name (? symbol?))) |
| 173 | (make-lexical-ref loc name name)) |
| 174 | |
| 175 | (('lexical (and name (? symbol?)) (and sym (? symbol?))) |
| 176 | (make-lexical-ref loc name sym)) |
| 177 | |
| 178 | (('set! ('lexical (and name (? symbol?))) exp) |
| 179 | (make-lexical-set loc name name (retrans exp))) |
| 180 | |
| 181 | (('set! ('lexical (and name (? symbol?)) (and sym (? symbol?))) exp) |
| 182 | (make-lexical-set loc name sym (retrans exp))) |
| 183 | |
| 184 | (('@ ((and mod (? symbol?)) ...) (and name (? symbol?))) |
| 185 | (make-module-ref loc mod name #t)) |
| 186 | |
| 187 | (('set! ('@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp) |
| 188 | (make-module-set loc mod name #t (retrans exp))) |
| 189 | |
| 190 | (('@@ ((and mod (? symbol?)) ...) (and name (? symbol?))) |
| 191 | (make-module-ref loc mod name #f)) |
| 192 | |
| 193 | (('set! ('@@ ((and mod (? symbol?)) ...) (and name (? symbol?))) exp) |
| 194 | (make-module-set loc mod name #f (retrans exp))) |
| 195 | |
| 196 | (('toplevel (and name (? symbol?))) |
| 197 | (make-toplevel-ref loc name)) |
| 198 | |
| 199 | (('set! ('toplevel (and name (? symbol?))) exp) |
| 200 | (make-toplevel-set loc name (retrans exp))) |
| 201 | |
| 202 | (('define (and name (? symbol?)) exp) |
| 203 | (make-toplevel-define loc name (retrans exp))) |
| 204 | |
| 205 | (('lambda meta body) |
| 206 | (make-lambda loc meta (retrans body))) |
| 207 | |
| 208 | (('lambda-case ((req opt rest kw inits gensyms) body) alternate) |
| 209 | (make-lambda-case loc req opt rest kw |
| 210 | (map retrans inits) gensyms |
| 211 | (retrans body) |
| 212 | (and=> alternate retrans))) |
| 213 | |
| 214 | (('lambda-case ((req opt rest kw inits gensyms) body)) |
| 215 | (make-lambda-case loc req opt rest kw |
| 216 | (map retrans inits) gensyms |
| 217 | (retrans body) |
| 218 | #f)) |
| 219 | |
| 220 | (('const exp) |
| 221 | (make-const loc exp)) |
| 222 | |
| 223 | (('seq head tail) |
| 224 | (make-seq loc (retrans head) (retrans tail))) |
| 225 | |
| 226 | ;; Convenience. |
| 227 | (('begin . exps) |
| 228 | (list->seq loc (map retrans exps))) |
| 229 | |
| 230 | (('let names gensyms vals body) |
| 231 | (make-let loc names gensyms (map retrans vals) (retrans body))) |
| 232 | |
| 233 | (('letrec names gensyms vals body) |
| 234 | (make-letrec loc #f names gensyms (map retrans vals) (retrans body))) |
| 235 | |
| 236 | (('letrec* names gensyms vals body) |
| 237 | (make-letrec loc #t names gensyms (map retrans vals) (retrans body))) |
| 238 | |
| 239 | (('fix names gensyms vals body) |
| 240 | (make-fix loc names gensyms (map retrans vals) (retrans body))) |
| 241 | |
| 242 | (('let-values exp body) |
| 243 | (make-let-values loc (retrans exp) (retrans body))) |
| 244 | |
| 245 | (('prompt escape-only? tag body handler) |
| 246 | (make-prompt loc escape-only? |
| 247 | (retrans tag) (retrans body) (retrans handler))) |
| 248 | |
| 249 | (('abort tag args tail) |
| 250 | (make-abort loc (retrans tag) (map retrans args) (retrans tail))) |
| 251 | |
| 252 | (else |
| 253 | (error "unrecognized tree-il" exp))))) |
| 254 | |
| 255 | (define (unparse-tree-il tree-il) |
| 256 | (match tree-il |
| 257 | (($ <void> src) |
| 258 | '(void)) |
| 259 | |
| 260 | (($ <call> src proc args) |
| 261 | `(call ,(unparse-tree-il proc) ,@(map unparse-tree-il args))) |
| 262 | |
| 263 | (($ <primcall> src name args) |
| 264 | `(primcall ,name ,@(map unparse-tree-il args))) |
| 265 | |
| 266 | (($ <conditional> src test consequent alternate) |
| 267 | `(if ,(unparse-tree-il test) |
| 268 | ,(unparse-tree-il consequent) |
| 269 | ,(unparse-tree-il alternate))) |
| 270 | |
| 271 | (($ <primitive-ref> src name) |
| 272 | `(primitive ,name)) |
| 273 | |
| 274 | (($ <lexical-ref> src name gensym) |
| 275 | `(lexical ,name ,gensym)) |
| 276 | |
| 277 | (($ <lexical-set> src name gensym exp) |
| 278 | `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp))) |
| 279 | |
| 280 | (($ <module-ref> src mod name public?) |
| 281 | `(,(if public? '@ '@@) ,mod ,name)) |
| 282 | |
| 283 | (($ <module-set> src mod name public? exp) |
| 284 | `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp))) |
| 285 | |
| 286 | (($ <toplevel-ref> src name) |
| 287 | `(toplevel ,name)) |
| 288 | |
| 289 | (($ <toplevel-set> src name exp) |
| 290 | `(set! (toplevel ,name) ,(unparse-tree-il exp))) |
| 291 | |
| 292 | (($ <toplevel-define> src name exp) |
| 293 | `(define ,name ,(unparse-tree-il exp))) |
| 294 | |
| 295 | (($ <lambda> src meta body) |
| 296 | (if body |
| 297 | `(lambda ,meta ,(unparse-tree-il body)) |
| 298 | `(lambda ,meta (lambda-case)))) |
| 299 | |
| 300 | (($ <lambda-case> src req opt rest kw inits gensyms body alternate) |
| 301 | `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms) |
| 302 | ,(unparse-tree-il body)) |
| 303 | . ,(if alternate (list (unparse-tree-il alternate)) '()))) |
| 304 | |
| 305 | (($ <const> src exp) |
| 306 | `(const ,exp)) |
| 307 | |
| 308 | (($ <seq> src head tail) |
| 309 | `(seq ,(unparse-tree-il head) ,(unparse-tree-il tail))) |
| 310 | |
| 311 | (($ <let> src names gensyms vals body) |
| 312 | `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) |
| 313 | |
| 314 | (($ <letrec> src in-order? names gensyms vals body) |
| 315 | `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms |
| 316 | ,(map unparse-tree-il vals) ,(unparse-tree-il body))) |
| 317 | |
| 318 | (($ <fix> src names gensyms vals body) |
| 319 | `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body))) |
| 320 | |
| 321 | (($ <let-values> src exp body) |
| 322 | `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body))) |
| 323 | |
| 324 | (($ <prompt> src escape-only? tag body handler) |
| 325 | `(prompt ,escape-only? |
| 326 | ,(unparse-tree-il tag) |
| 327 | ,(unparse-tree-il body) |
| 328 | ,(unparse-tree-il handler))) |
| 329 | |
| 330 | (($ <abort> src tag args tail) |
| 331 | `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args) |
| 332 | ,(unparse-tree-il tail))))) |
| 333 | |
| 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))) |
| 338 | |
| 339 | \f |
| 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 ...) |
| 351 | (match tree |
| 352 | (($ <lexical-set> src name gensym exp) |
| 353 | (foldts exp seed ...)) |
| 354 | (($ <module-set> src mod name public? exp) |
| 355 | (foldts exp seed ...)) |
| 356 | (($ <toplevel-set> src name exp) |
| 357 | (foldts exp seed ...)) |
| 358 | (($ <toplevel-define> src name exp) |
| 359 | (foldts exp seed ...)) |
| 360 | (($ <conditional> src test consequent alternate) |
| 361 | (let*-values (((seed ...) (foldts test seed ...)) |
| 362 | ((seed ...) (foldts consequent seed ...))) |
| 363 | (foldts alternate seed ...))) |
| 364 | (($ <call> src proc args) |
| 365 | (let-values (((seed ...) (foldts proc seed ...))) |
| 366 | (fold-values foldts args seed ...))) |
| 367 | (($ <primcall> src name args) |
| 368 | (fold-values foldts args seed ...)) |
| 369 | (($ <seq> src head tail) |
| 370 | (let-values (((seed ...) (foldts head seed ...))) |
| 371 | (foldts tail seed ...))) |
| 372 | (($ <lambda> src meta body) |
| 373 | (if body |
| 374 | (foldts body seed ...) |
| 375 | (values seed ...))) |
| 376 | (($ <lambda-case> src req opt rest kw inits gensyms body |
| 377 | alternate) |
| 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 ...)))) |
| 383 | (($ <let> src names gensyms vals body) |
| 384 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) |
| 385 | (foldts body seed ...))) |
| 386 | (($ <letrec> src in-order? names gensyms vals body) |
| 387 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) |
| 388 | (foldts body seed ...))) |
| 389 | (($ <fix> src names gensyms vals body) |
| 390 | (let*-values (((seed ...) (fold-values foldts vals seed ...))) |
| 391 | (foldts body seed ...))) |
| 392 | (($ <let-values> src exp body) |
| 393 | (let*-values (((seed ...) (foldts exp seed ...))) |
| 394 | (foldts body seed ...))) |
| 395 | (($ <prompt> src escape-only? tag body handler) |
| 396 | (let*-values (((seed ...) (foldts tag seed ...)) |
| 397 | ((seed ...) (foldts body seed ...))) |
| 398 | (foldts handler seed ...))) |
| 399 | (($ <abort> src tag args tail) |
| 400 | (let*-values (((seed ...) (foldts tag seed ...)) |
| 401 | ((seed ...) (fold-values foldts args seed ...))) |
| 402 | (foldts tail seed ...))) |
| 403 | (_ |
| 404 | (values seed ...))))) |
| 405 | (up tree seed ...))))) |
| 406 | |
| 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 | |
| 420 | (define (pre-post-order pre post x) |
| 421 | (define (elts-eq? a b) |
| 422 | (or (null? a) |
| 423 | (and (eq? (car a) (car b)) |
| 424 | (elts-eq? (cdr a) (cdr b))))) |
| 425 | (let lp ((x x)) |
| 426 | (post |
| 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*)))) |
| 492 | |
| 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*))))))))) |
| 561 | |
| 562 | (define (post-order f x) |
| 563 | (pre-post-order (lambda (x) x) f x)) |
| 564 | |
| 565 | (define (pre-order f x) |
| 566 | (pre-post-order f (lambda (x) x) x)) |
| 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))) |