module/language/tree-il.scm

   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)))