module/language/tree-il.scm

   1 ;;;;    Copyright (C) 2009, 2010, 2011, 2012, 2013 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 (system base pmatch)
  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             <application> application? make-application application-src application-proc application-args
  38             <sequence> sequence? make-sequence sequence-src sequence-exps
  39             <lambda> lambda? make-lambda lambda-src lambda-meta lambda-body
  40             <lambda-case> lambda-case? make-lambda-case lambda-case-src
  41                           lambda-case-req lambda-case-opt lambda-case-rest lambda-case-kw
  42                           lambda-case-inits lambda-case-gensyms
  43                           lambda-case-body lambda-case-alternate
  44             <let> let? make-let let-src let-names let-gensyms let-vals let-body
  45             <letrec> letrec? make-letrec letrec-src letrec-in-order? letrec-names letrec-gensyms letrec-vals letrec-body
  46             <fix> fix? make-fix fix-src fix-names fix-gensyms fix-vals fix-body
  47             <let-values> let-values? make-let-values let-values-src let-values-exp let-values-body
  48             <dynwind> dynwind? make-dynwind dynwind-src dynwind-winder dynwind-body dynwind-unwinder
  49             <dynlet> dynlet? make-dynlet dynlet-src dynlet-fluids dynlet-vals dynlet-body
  50             <dynref> dynref? make-dynref dynref-src dynref-fluid
  51             <dynset> dynset? make-dynset dynset-src dynset-fluid dynset-exp
  52             <prompt> prompt? make-prompt prompt-src prompt-tag prompt-body prompt-handler
  53             <abort> abort? make-abort abort-src abort-tag abort-args abort-tail
  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   ;; (<application> proc args)
 125   ;; (<sequence> exps)
 126   ;; (<lambda> meta body)
 127   ;; (<lambda-case> req opt rest kw inits gensyms body alternate)
 128   ;; (<let> names gensyms vals body)
 129   ;; (<letrec> in-order? names gensyms vals body)
 130   ;; (<dynlet> fluids 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   (<dynwind> winder body unwinder)
 136   (<dynref> fluid)
 137   (<dynset> fluid exp)
 138   (<prompt> tag body handler)
 139   (<abort> tag args tail))
 140
 141 \f
 142
 143 (define (location x)
 144   (and (pair? x)
 145        (let ((props (source-properties x)))
 146          (and (pair? props) props))))
 147
 148 (define (parse-tree-il exp)
 149   (let ((loc (location exp))
 150         (retrans (lambda (x) (parse-tree-il x))))
 151     (pmatch exp
 152      ((void)
 153       (make-void loc))
 154
 155      ((apply ,proc . ,args)
 156       (make-application loc (retrans proc) (map retrans args)))
 157
 158      ((if ,test ,consequent ,alternate)
 159       (make-conditional loc (retrans test) (retrans consequent) (retrans alternate)))
 160
 161      ((primitive ,name) (guard (symbol? name))
 162       (make-primitive-ref loc name))
 163
 164      ((lexical ,name) (guard (symbol? name))
 165       (make-lexical-ref loc name name))
 166
 167      ((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
 168       (make-lexical-ref loc name sym))
 169
 170      ((set! (lexical ,name) ,exp) (guard (symbol? name))
 171       (make-lexical-set loc name name (retrans exp)))
 172
 173      ((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
 174       (make-lexical-set loc name sym (retrans exp)))
 175
 176      ((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 177       (make-module-ref loc mod name #t))
 178
 179      ((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 180       (make-module-set loc mod name #t (retrans exp)))
 181
 182      ((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
 183       (make-module-ref loc mod name #f))
 184
 185      ((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
 186       (make-module-set loc mod name #f (retrans exp)))
 187
 188      ((toplevel ,name) (guard (symbol? name))
 189       (make-toplevel-ref loc name))
 190
 191      ((set! (toplevel ,name) ,exp) (guard (symbol? name))
 192       (make-toplevel-set loc name (retrans exp)))
 193
 194      ((define ,name ,exp) (guard (symbol? name))
 195       (make-toplevel-define loc name (retrans exp)))
 196
 197      ((lambda ,meta ,body)
 198       (make-lambda loc meta (retrans body)))
 199
 200      ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body) ,alternate)
 201       (make-lambda-case loc req opt rest kw
 202                         (map retrans inits) gensyms
 203                         (retrans body)
 204                         (and=> alternate retrans)))
 205
 206      ((lambda-case ((,req ,opt ,rest ,kw ,inits ,gensyms) ,body))
 207       (make-lambda-case loc req opt rest kw
 208                         (map retrans inits) gensyms
 209                         (retrans body)
 210                         #f))
 211
 212      ((const ,exp)
 213       (make-const loc exp))
 214
 215      ((begin . ,exps)
 216       (make-sequence loc (map retrans exps)))
 217
 218      ((let ,names ,gensyms ,vals ,body)
 219       (make-let loc names gensyms (map retrans vals) (retrans body)))
 220
 221      ((letrec ,names ,gensyms ,vals ,body)
 222       (make-letrec loc #f names gensyms (map retrans vals) (retrans body)))
 223
 224      ((letrec* ,names ,gensyms ,vals ,body)
 225       (make-letrec loc #t names gensyms (map retrans vals) (retrans body)))
 226
 227      ((fix ,names ,gensyms ,vals ,body)
 228       (make-fix loc names gensyms (map retrans vals) (retrans body)))
 229
 230      ((let-values ,exp ,body)
 231       (make-let-values loc (retrans exp) (retrans body)))
 232
 233      ((dynwind ,winder ,body ,unwinder)
 234       (make-dynwind loc (retrans winder) (retrans body) (retrans unwinder)))
 235
 236      ((dynlet ,fluids ,vals ,body)
 237       (make-dynlet loc (map retrans fluids) (map retrans vals) (retrans body)))
 238
 239      ((dynref ,fluid)
 240       (make-dynref loc (retrans fluid)))
 241
 242      ((dynset ,fluid ,exp)
 243       (make-dynset loc (retrans fluid) (retrans exp)))
 244
 245      ((prompt ,tag ,body ,handler)
 246       (make-prompt loc (retrans tag) (retrans body) (retrans handler)))
 247
 248      ((abort ,tag ,args ,tail)
 249       (make-abort loc (retrans tag) (map retrans args) (retrans tail)))
 250
 251      (else
 252       (error "unrecognized tree-il" exp)))))
 253
 254 (define (unparse-tree-il tree-il)
 255   (record-case tree-il
 256     ((<void>)
 257      '(void))
 258
 259     ((<application> proc args)
 260      `(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
 261
 262     ((<conditional> test consequent alternate)
 263      `(if ,(unparse-tree-il test) ,(unparse-tree-il consequent) ,(unparse-tree-il alternate)))
 264
 265     ((<primitive-ref> name)
 266      `(primitive ,name))
 267
 268     ((<lexical-ref> name gensym)
 269      `(lexical ,name ,gensym))
 270
 271     ((<lexical-set> name gensym exp)
 272      `(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
 273
 274     ((<module-ref> mod name public?)
 275      `(,(if public? '@ '@@) ,mod ,name))
 276
 277     ((<module-set> mod name public? exp)
 278      `(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
 279
 280     ((<toplevel-ref> name)
 281      `(toplevel ,name))
 282
 283     ((<toplevel-set> name exp)
 284      `(set! (toplevel ,name) ,(unparse-tree-il exp)))
 285
 286     ((<toplevel-define> name exp)
 287      `(define ,name ,(unparse-tree-il exp)))
 288
 289     ((<lambda> meta body)
 290      (if body
 291          `(lambda ,meta ,(unparse-tree-il body))
 292          `(lambda ,meta (lambda-case))))
 293
 294     ((<lambda-case> req opt rest kw inits gensyms body alternate)
 295      `(lambda-case ((,req ,opt ,rest ,kw ,(map unparse-tree-il inits) ,gensyms)
 296                     ,(unparse-tree-il body))
 297                    . ,(if alternate (list (unparse-tree-il alternate)) '())))
 298
 299     ((<const> exp)
 300      `(const ,exp))
 301
 302     ((<sequence> exps)
 303      `(begin ,@(map unparse-tree-il exps)))
 304
 305     ((<let> names gensyms vals body)
 306      `(let ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 307
 308     ((<letrec> in-order? names gensyms vals body)
 309      `(,(if in-order? 'letrec* 'letrec) ,names ,gensyms
 310        ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 311
 312     ((<fix> names gensyms vals body)
 313      `(fix ,names ,gensyms ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
 314
 315     ((<let-values> exp body)
 316      `(let-values ,(unparse-tree-il exp) ,(unparse-tree-il body)))
 317
 318     ((<dynwind> winder body unwinder)
 319      `(dynwind ,(unparse-tree-il winder) ,(unparse-tree-il body)
 320                ,(unparse-tree-il unwinder)))
 321
 322     ((<dynlet> fluids vals body)
 323      `(dynlet ,(map unparse-tree-il fluids) ,(map unparse-tree-il vals)
 324               ,(unparse-tree-il body)))
 325
 326     ((<dynref> fluid)
 327      `(dynref ,(unparse-tree-il fluid)))
 328
 329     ((<dynset> fluid exp)
 330      `(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
 331
 332     ((<prompt> tag body handler)
 333      `(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
 334
 335     ((<abort> tag args tail)
 336      `(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
 337              ,(unparse-tree-il tail)))))
 338
 339 (define* (tree-il->scheme e #:optional (env #f) (opts '()))
 340   (values ((@ (language scheme decompile-tree-il)
 341               decompile-tree-il)
 342            e env opts)))
 343
 344 \f
 345 (define (tree-il-fold leaf down up seed tree)
 346   "Traverse TREE, calling LEAF on each leaf encountered, DOWN upon descent
 347 into a sub-tree, and UP when leaving a sub-tree.  Each of these procedures is
 348 invoked as `(PROC TREE SEED)', where TREE is the sub-tree or leaf considered
 349 and SEED is the current result, intially seeded with SEED.
 350
 351 This is an implementation of `foldts' as described by Andy Wingo in
 352 ``Applications of fold to XML transformation''."
 353   (let loop ((tree   tree)
 354              (result seed))
 355     (if (or (null? tree) (pair? tree))
 356         (fold loop result tree)
 357         (record-case tree
 358           ((<lexical-set> exp)
 359            (up tree (loop exp (down tree result))))
 360           ((<module-set> exp)
 361            (up tree (loop exp (down tree result))))
 362           ((<toplevel-set> exp)
 363            (up tree (loop exp (down tree result))))
 364           ((<toplevel-define> exp)
 365            (up tree (loop exp (down tree result))))
 366           ((<conditional> test consequent alternate)
 367            (up tree (loop alternate
 368                           (loop consequent
 369                                 (loop test (down tree result))))))
 370           ((<application> proc args)
 371            (up tree (loop (cons proc args) (down tree result))))
 372           ((<sequence> exps)
 373            (up tree (loop exps (down tree result))))
 374           ((<lambda> body)
 375            (let ((result (down tree result)))
 376              (up tree
 377                  (if body
 378                      (loop body result)
 379                      result))))
 380           ((<lambda-case> inits body alternate)
 381            (up tree (if alternate
 382                         (loop alternate
 383                               (loop body (loop inits (down tree result))))
 384                         (loop body (loop inits (down tree result))))))
 385           ((<let> vals body)
 386            (up tree (loop body
 387                           (loop vals
 388                                 (down tree result)))))
 389           ((<letrec> vals body)
 390            (up tree (loop body
 391                           (loop vals
 392                                 (down tree result)))))
 393           ((<fix> vals body)
 394            (up tree (loop body
 395                           (loop vals
 396                                 (down tree result)))))
 397           ((<let-values> exp body)
 398            (up tree (loop body (loop exp (down tree result)))))
 399           ((<dynwind> body winder unwinder)
 400            (up tree (loop unwinder
 401                           (loop winder
 402                                 (loop body (down tree result))))))
 403           ((<dynlet> fluids vals body)
 404            (up tree (loop body
 405                           (loop vals
 406                                 (loop fluids (down tree result))))))
 407           ((<dynref> fluid)
 408            (up tree (loop fluid (down tree result))))
 409           ((<dynset> fluid exp)
 410            (up tree (loop exp (loop fluid (down tree result)))))
 411           ((<prompt> tag body handler)
 412            (up tree
 413                (loop tag (loop body (loop handler
 414                                           (down tree result))))))
 415           ((<abort> tag args tail)
 416            (up tree (loop tail (loop args (loop tag (down tree result))))))
 417           (else
 418            (leaf tree result))))))
 419
 420
 421 (define-syntax-rule (make-tree-il-folder seed ...)
 422   (lambda (tree down up seed ...)
 423     (define (fold-values proc exps seed ...)
 424       (if (null? exps)
 425           (values seed ...)
 426           (let-values (((seed ...) (proc (car exps) seed ...)))
 427             (fold-values proc (cdr exps) seed ...))))
 428     (let foldts ((tree tree) (seed seed) ...)
 429       (let*-values
 430           (((seed ...) (down tree seed ...))
 431            ((seed ...)
 432             (record-case tree
 433               ((<lexical-set> exp)
 434                (foldts exp seed ...))
 435               ((<module-set> exp)
 436                (foldts exp seed ...))
 437               ((<toplevel-set> exp)
 438                (foldts exp seed ...))
 439               ((<toplevel-define> exp)
 440                (foldts exp seed ...))
 441               ((<conditional> test consequent alternate)
 442                (let*-values (((seed ...) (foldts test seed ...))
 443                              ((seed ...) (foldts consequent seed ...)))
 444                  (foldts alternate seed ...)))
 445               ((<application> proc args)
 446                (let-values (((seed ...) (foldts proc seed ...)))
 447                  (fold-values foldts args seed ...)))
 448               ((<sequence> exps)
 449                (fold-values foldts exps seed ...))
 450               ((<lambda> body)
 451                (if body
 452                    (foldts body seed ...)
 453                    (values seed ...)))
 454               ((<lambda-case> inits body alternate)
 455                (let-values (((seed ...) (fold-values foldts inits seed ...)))
 456                  (if alternate
 457                      (let-values (((seed ...) (foldts body seed ...)))
 458                        (foldts alternate seed ...))
 459                      (foldts body seed ...))))
 460               ((<let> vals body)
 461                (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 462                  (foldts body seed ...)))
 463               ((<letrec> vals body)
 464                (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 465                  (foldts body seed ...)))
 466               ((<fix> vals body)
 467                (let*-values (((seed ...) (fold-values foldts vals seed ...)))
 468                  (foldts body seed ...)))
 469               ((<let-values> exp body)
 470                (let*-values (((seed ...) (foldts exp seed ...)))
 471                  (foldts body seed ...)))
 472               ((<dynwind> body winder unwinder)
 473                (let*-values (((seed ...) (foldts body seed ...))
 474                              ((seed ...) (foldts winder seed ...)))
 475                  (foldts unwinder seed ...)))
 476               ((<dynlet> fluids vals body)
 477                (let*-values (((seed ...) (fold-values foldts fluids seed ...))
 478                              ((seed ...) (fold-values foldts vals seed ...)))
 479                  (foldts body seed ...)))
 480               ((<dynref> fluid)
 481                (foldts fluid seed ...))
 482               ((<dynset> fluid exp)
 483                (let*-values (((seed ...) (foldts fluid seed ...)))
 484                  (foldts exp seed ...)))
 485               ((<prompt> tag body handler)
 486                (let*-values (((seed ...) (foldts tag seed ...))
 487                              ((seed ...) (foldts body seed ...)))
 488                  (foldts handler seed ...)))
 489               ((<abort> tag args tail)
 490                (let*-values (((seed ...) (foldts tag seed ...))
 491                              ((seed ...) (fold-values foldts args seed ...)))
 492                  (foldts tail seed ...)))
 493               (else
 494                (values seed ...)))))
 495         (up tree seed ...)))))
 496
 497 (define (post-order! f x)
 498   (let lp ((x x))
 499     (record-case x
 500       ((<application> proc args)
 501        (set! (application-proc x) (lp proc))
 502        (set! (application-args x) (map lp args)))
 503
 504       ((<conditional> test consequent alternate)
 505        (set! (conditional-test x) (lp test))
 506        (set! (conditional-consequent x) (lp consequent))
 507        (set! (conditional-alternate x) (lp alternate)))
 508
 509       ((<lexical-set> name gensym exp)
 510        (set! (lexical-set-exp x) (lp exp)))
 511
 512       ((<module-set> mod name public? exp)
 513        (set! (module-set-exp x) (lp exp)))
 514
 515       ((<toplevel-set> name exp)
 516        (set! (toplevel-set-exp x) (lp exp)))
 517
 518       ((<toplevel-define> name exp)
 519        (set! (toplevel-define-exp x) (lp exp)))
 520
 521       ((<lambda> body)
 522        (if body
 523            (set! (lambda-body x) (lp body))))
 524
 525       ((<lambda-case> inits body alternate)
 526        (set! inits (map lp inits))
 527        (set! (lambda-case-body x) (lp body))
 528        (if alternate
 529            (set! (lambda-case-alternate x) (lp alternate))))
 530
 531       ((<sequence> exps)
 532        (set! (sequence-exps x) (map lp exps)))
 533
 534       ((<let> gensyms vals body)
 535        (set! (let-vals x) (map lp vals))
 536        (set! (let-body x) (lp body)))
 537
 538       ((<letrec> gensyms vals body)
 539        (set! (letrec-vals x) (map lp vals))
 540        (set! (letrec-body x) (lp body)))
 541
 542       ((<fix> gensyms vals body)
 543        (set! (fix-vals x) (map lp vals))
 544        (set! (fix-body x) (lp body)))
 545
 546       ((<let-values> exp body)
 547        (set! (let-values-exp x) (lp exp))
 548        (set! (let-values-body x) (lp body)))
 549
 550       ((<dynwind> body winder unwinder)
 551        (set! (dynwind-body x) (lp body))
 552        (set! (dynwind-winder x) (lp winder))
 553        (set! (dynwind-unwinder x) (lp unwinder)))
 554
 555       ((<dynlet> fluids vals body)
 556        (set! (dynlet-fluids x) (map lp fluids))
 557        (set! (dynlet-vals x) (map lp vals))
 558        (set! (dynlet-body x) (lp body)))
 559
 560       ((<dynref> fluid)
 561        (set! (dynref-fluid x) (lp fluid)))
 562
 563       ((<dynset> fluid exp)
 564        (set! (dynset-fluid x) (lp fluid))
 565        (set! (dynset-exp x) (lp exp)))
 566
 567       ((<prompt> tag body handler)
 568        (set! (prompt-tag x) (lp tag))
 569        (set! (prompt-body x) (lp body))
 570        (set! (prompt-handler x) (lp handler)))
 571
 572       ((<abort> tag args tail)
 573        (set! (abort-tag x) (lp tag))
 574        (set! (abort-args x) (map lp args))
 575        (set! (abort-tail x) (lp tail)))
 576
 577       (else #f))
 578
 579     (or (f x) x)))
 580
 581 (define (pre-order! f x)
 582   (let lp ((x x))
 583     (let ((x (or (f x) x)))
 584       (record-case x
 585         ((<application> proc args)
 586          (set! (application-proc x) (lp proc))
 587          (set! (application-args x) (map lp args)))
 588
 589         ((<conditional> test consequent alternate)
 590          (set! (conditional-test x) (lp test))
 591          (set! (conditional-consequent x) (lp consequent))
 592          (set! (conditional-alternate x) (lp alternate)))
 593
 594         ((<lexical-set> exp)
 595          (set! (lexical-set-exp x) (lp exp)))
 596
 597         ((<module-set> exp)
 598          (set! (module-set-exp x) (lp exp)))
 599
 600         ((<toplevel-set> exp)
 601          (set! (toplevel-set-exp x) (lp exp)))
 602
 603         ((<toplevel-define> exp)
 604          (set! (toplevel-define-exp x) (lp exp)))
 605
 606         ((<lambda> body)
 607          (if body
 608              (set! (lambda-body x) (lp body))))
 609
 610         ((<lambda-case> inits body alternate)
 611          (set! inits (map lp inits))
 612          (set! (lambda-case-body x) (lp body))
 613          (if alternate (set! (lambda-case-alternate x) (lp alternate))))
 614
 615         ((<sequence> exps)
 616          (set! (sequence-exps x) (map lp exps)))
 617
 618         ((<let> vals body)
 619          (set! (let-vals x) (map lp vals))
 620          (set! (let-body x) (lp body)))
 621
 622         ((<letrec> vals body)
 623          (set! (letrec-vals x) (map lp vals))
 624          (set! (letrec-body x) (lp body)))
 625
 626         ((<fix> vals body)
 627          (set! (fix-vals x) (map lp vals))
 628          (set! (fix-body x) (lp body)))
 629
 630         ((<let-values> exp body)
 631          (set! (let-values-exp x) (lp exp))
 632          (set! (let-values-body x) (lp body)))
 633
 634         ((<dynwind> body winder unwinder)
 635          (set! (dynwind-body x) (lp body))
 636          (set! (dynwind-winder x) (lp winder))
 637          (set! (dynwind-unwinder x) (lp unwinder)))
 638
 639         ((<dynlet> fluids vals body)
 640          (set! (dynlet-fluids x) (map lp fluids))
 641          (set! (dynlet-vals x) (map lp vals))
 642          (set! (dynlet-body x) (lp body)))
 643
 644         ((<dynref> fluid)
 645          (set! (dynref-fluid x) (lp fluid)))
 646
 647         ((<dynset> fluid exp)
 648          (set! (dynset-fluid x) (lp fluid))
 649          (set! (dynset-exp x) (lp exp)))
 650
 651         ((<prompt> tag body handler)
 652          (set! (prompt-tag x) (lp tag))
 653          (set! (prompt-body x) (lp body))
 654          (set! (prompt-handler x) (lp handler)))
 655
 656         ((<abort> tag args tail)
 657          (set! (abort-tag x) (lp tag))
 658          (set! (abort-args x) (map lp args))
 659          (set! (abort-tail x) (lp tail)))
 660
 661         (else #f))
 662       x)))
 663
 664 ;; FIXME: We should have a better primitive than this.
 665 (define (struct-nfields x)
 666   (/ (string-length (symbol->string (struct-layout x))) 2))
 667
 668 (define (tree-il=? a b)
 669   (cond
 670    ((struct? a)
 671     (and (struct? b)
 672          (eq? (struct-vtable a) (struct-vtable b))
 673          ;; Assume that all structs are tree-il, so we skip over the
 674          ;; src slot.
 675          (let lp ((n (1- (struct-nfields a))))
 676            (or (zero? n)
 677                (and (tree-il=? (struct-ref a n) (struct-ref b n))
 678                     (lp (1- n)))))))
 679    ((pair? a)
 680     (and (pair? b)
 681          (tree-il=? (car a) (car b))
 682          (tree-il=? (cdr a) (cdr b))))
 683    (else
 684     (equal? a b))))
 685
 686 (define-syntax hash-bits
 687   (make-variable-transformer
 688    (lambda (x)
 689      (syntax-case x ()
 690        (var
 691         (identifier? #'var)
 692         (logcount most-positive-fixnum))))))
 693
 694 (define (tree-il-hash exp)
 695   (let ((hash-depth 4)
 696         (hash-width 3))
 697     (define (hash-exp exp depth)
 698       (define (rotate x bits)
 699         (logior (ash x (- bits))
 700                 (ash (logand x (1- (ash 1 bits))) (- hash-bits bits))))
 701       (define (mix h1 h2)
 702         (logxor h1 (rotate h2 8)))
 703       (define (hash-struct s)
 704         (let ((len (struct-nfields s))
 705               (h (hashq (struct-vtable s) most-positive-fixnum)))
 706           (if (zero? depth)
 707               h
 708               (let lp ((i (max (- len hash-width) 1)) (h h))
 709                 (if (< i len)
 710                     (lp (1+ i) (mix (hash-exp (struct-ref s i) (1+ depth)) h))
 711                     h)))))
 712       (define (hash-list l)
 713         (let ((h (hashq 'list most-positive-fixnum)))
 714           (if (zero? depth)
 715               h
 716               (let lp ((l l) (width 0) (h h))
 717                 (if (< width hash-width)
 718                     (lp (cdr l) (1+ width)
 719                         (mix (hash-exp (car l) (1+ depth)) h))
 720                     h)))))
 721       (cond
 722        ((struct? exp) (hash-struct exp))
 723        ((list? exp) (hash-list exp))
 724        (else (hash exp most-positive-fixnum))))
 725
 726     (hash-exp exp 0)))