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