module/language/scheme/decompile-tree-il.scm

   1 ;;; Guile VM code converters
   2
   3 ;; Copyright (C) 2001, 2009, 2012, 2013 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language scheme decompile-tree-il)
  22   #:use-module (language tree-il)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (ice-9 receive)
  26   #:use-module (ice-9 vlist)
  27   #:use-module (ice-9 match)
  28   #:use-module (system base syntax)
  29   #:export (decompile-tree-il))
  30
  31 (define (decompile-tree-il e env opts)
  32   (apply do-decompile e env opts))
  33
  34 (define* (do-decompile e env
  35                        #:key
  36                        (use-derived-syntax? #t)
  37                        (avoid-lambda? #t)
  38                        (use-case? #t)
  39                        (strip-numeric-suffixes? #f)
  40                        #:allow-other-keys)
  41
  42   (receive (output-name-table occurrence-count-table)
  43       (choose-output-names e use-derived-syntax? strip-numeric-suffixes?)
  44
  45     (define (output-name s)      (hashq-ref output-name-table s))
  46     (define (occurrence-count s) (hashq-ref occurrence-count-table s))
  47
  48     (define (const x) (lambda (_) x))
  49     (define (atom? x) (not (or (pair? x) (vector? x))))
  50
  51     (define (build-void) '(if #f #f))
  52
  53     (define (build-begin es)
  54       (match es
  55         (() (build-void))
  56         ((e) e)
  57         (_ `(begin ,@es))))
  58
  59     (define (build-lambda-body e)
  60       (match e
  61         (('let () body ...) body)
  62         (('begin es ...) es)
  63         (_ (list e))))
  64
  65     (define (build-begin-body e)
  66       (match e
  67         (('begin es ...) es)
  68         (_ (list e))))
  69
  70     (define (build-define name e)
  71       (match e
  72         ((? (const avoid-lambda?)
  73             ('lambda formals body ...))
  74          `(define (,name ,@formals) ,@body))
  75         ((? (const avoid-lambda?)
  76             ('lambda* formals body ...))
  77          `(define* (,name ,@formals) ,@body))
  78         (_ `(define ,name ,e))))
  79
  80     (define (build-let names vals body)
  81       (match `(let ,(map list names vals)
  82                 ,@(build-lambda-body body))
  83         ((_ () e) e)
  84         ((_ (b) ('let* (bs ...) body ...))
  85          `(let* (,b ,@bs) ,@body))
  86         ((? (const use-derived-syntax?)
  87             (_ (b1) ('let (b2) body ...)))
  88          `(let* (,b1 ,b2) ,@body))
  89         (e e)))
  90
  91     (define (build-letrec in-order? names vals body)
  92       (match `(,(if in-order? 'letrec* 'letrec)
  93                ,(map list names vals)
  94                ,@(build-lambda-body body))
  95         ((_ () e) e)
  96         ((_ () body ...) `(let () ,@body))
  97         ((_ ((name ('lambda (formals ...) body ...)))
  98             (name args ...))
  99          (=> failure)
 100          (if (= (length formals) (length args))
 101              `(let ,name ,(map list formals args) ,@body)
 102              (failure)))
 103         ((? (const avoid-lambda?)
 104             ('letrec* _ body ...))
 105          `(let ()
 106             ,@(map build-define names vals)
 107             ,@body))
 108         (e e)))
 109
 110     (define (build-if test consequent alternate)
 111       (match alternate
 112         (('if #f _) `(if ,test ,consequent))
 113         (_ `(if ,test ,consequent ,alternate))))
 114
 115     (define (build-and xs)
 116       (match xs
 117         (() #t)
 118         ((x) x)
 119         (_ `(and ,@xs))))
 120
 121     (define (build-or xs)
 122       (match xs
 123         (() #f)
 124         ((x) x)
 125         (_ `(or ,@xs))))
 126
 127     (define (case-test-var test)
 128       (match test
 129         (('memv (? atom? v) ('quote (datums ...)))
 130          v)
 131         (('eqv? (? atom? v) ('quote datum))
 132          v)
 133         (_ #f)))
 134
 135     (define (test->datums v test)
 136       (match (cons v test)
 137         ((v 'memv v ('quote (xs ...)))
 138          xs)
 139         ((v 'eqv? v ('quote x))
 140          (list x))
 141         (_ #f)))
 142
 143     (define (build-else-tail e)
 144       (match e
 145         (('if #f _) '())
 146         (('and xs ... x) `((,(build-and xs) ,@(build-begin-body x))
 147                            (else #f)))
 148         (_ `((else ,@(build-begin-body e))))))
 149
 150     (define (build-cond-else-tail e)
 151       (match e
 152         (('cond clauses ...) clauses)
 153         (_ (build-else-tail e))))
 154
 155     (define (build-case-else-tail v e)
 156       (match (cons v e)
 157         ((v 'case v clauses ...)
 158          clauses)
 159         ((v 'if ('memv v ('quote (xs ...))) consequent . alternate*)
 160          `((,xs ,@(build-begin-body consequent))
 161            ,@(build-case-else-tail v (build-begin alternate*))))
 162         ((v 'if ('eqv? v ('quote x)) consequent . alternate*)
 163          `(((,x) ,@(build-begin-body consequent))
 164            ,@(build-case-else-tail v (build-begin alternate*))))
 165         (_ (build-else-tail e))))
 166
 167     (define (clauses+tail clauses)
 168       (match clauses
 169         ((cs ... (and c ('else . _))) (values cs (list c)))
 170         (_ (values clauses '()))))
 171
 172     (define (build-cond tests consequents alternate)
 173       (case (length tests)
 174         ((0) alternate)
 175         ((1) (build-if (car tests) (car consequents) alternate))
 176         (else `(cond ,@(map (lambda (test consequent)
 177                               `(,test ,@(build-begin-body consequent)))
 178                             tests consequents)
 179                      ,@(build-cond-else-tail alternate)))))
 180
 181     (define (build-cond-or-case tests consequents alternate)
 182       (if (not use-case?)
 183           (build-cond tests consequents alternate)
 184           (let* ((v (and (not (null? tests))
 185                          (case-test-var (car tests))))
 186                  (datum-lists (take-while identity
 187                                           (map (cut test->datums v <>)
 188                                                tests)))
 189                  (n (length datum-lists))
 190                  (tail (build-case-else-tail v (build-cond
 191                                                 (drop tests n)
 192                                                 (drop consequents n)
 193                                                 alternate))))
 194             (receive (clauses tail) (clauses+tail tail)
 195               (let ((n (+ n (length clauses)))
 196                     (datum-lists (append datum-lists
 197                                          (map car clauses)))
 198                     (consequents (append consequents
 199                                          (map build-begin
 200                                               (map cdr clauses)))))
 201                 (if (< n 2)
 202                     (build-cond tests consequents alternate)
 203                     `(case ,v
 204                        ,@(map cons datum-lists (map build-begin-body
 205                                                     (take consequents n)))
 206                        ,@tail)))))))
 207
 208     (define (recurse e)
 209
 210       (define (recurse-body e)
 211         (build-lambda-body (recurse e)))
 212
 213       (record-case e
 214         ((<void>)
 215          (build-void))
 216
 217         ((<const> exp)
 218          (if (and (self-evaluating? exp) (not (vector? exp)))
 219              exp
 220              `(quote ,exp)))
 221
 222         ((<seq> head tail)
 223          (build-begin (cons (recurse head)
 224                             (build-begin-body
 225                              (recurse tail)))))
 226
 227         ((<call> proc args)
 228          (match `(,(recurse proc) ,@(map recurse args))
 229            ((('lambda (formals ...) body ...) args ...)
 230             (=> failure)
 231             (if (= (length formals) (length args))
 232                 (build-let formals args (build-begin body))
 233                 (failure)))
 234            (e e)))
 235
 236         ((<primcall> name args)
 237          `(,name ,@(map recurse args)))
 238
 239         ((<primitive-ref> name)
 240          name)
 241
 242         ((<lexical-ref> gensym)
 243          (output-name gensym))
 244
 245         ((<lexical-set> gensym exp)
 246          `(set! ,(output-name gensym) ,(recurse exp)))
 247
 248         ((<module-ref> mod name public?)
 249          `(,(if public? '@ '@@) ,mod ,name))
 250
 251         ((<module-set> mod name public? exp)
 252          `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
 253
 254         ((<toplevel-ref> name)
 255          name)
 256
 257         ((<toplevel-set> name exp)
 258          `(set! ,name ,(recurse exp)))
 259
 260         ((<toplevel-define> name exp)
 261          (build-define name (recurse exp)))
 262
 263         ((<lambda> meta body)
 264          (if body
 265              (let ((body (recurse body))
 266                    (doc (assq-ref meta 'documentation)))
 267                (if (not doc)
 268                    body
 269                    (match body
 270                      (('lambda formals body ...)
 271                       `(lambda ,formals ,doc ,@body))
 272                      (('lambda* formals body ...)
 273                       `(lambda* ,formals ,doc ,@body))
 274                      (('case-lambda (formals body ...) clauses ...)
 275                       `(case-lambda (,formals ,doc ,@body) ,@clauses))
 276                      (('case-lambda* (formals body ...) clauses ...)
 277                       `(case-lambda* (,formals ,doc ,@body) ,@clauses))
 278                      (e e))))
 279              '(case-lambda)))
 280
 281         ((<lambda-case> req opt rest kw inits gensyms body alternate)
 282          (let ((names (map output-name gensyms)))
 283            (cond
 284             ((and (not opt) (not kw) (not alternate))
 285              `(lambda ,(if rest (apply cons* names) names)
 286                 ,@(recurse-body body)))
 287             ((and (not opt) (not kw))
 288              (let ((alt-expansion (recurse alternate))
 289                    (formals (if rest (apply cons* names) names)))
 290                (case (car alt-expansion)
 291                  ((lambda)
 292                   `(case-lambda (,formals ,@(recurse-body body))
 293                                 ,(cdr alt-expansion)))
 294                  ((lambda*)
 295                   `(case-lambda* (,formals ,@(recurse-body body))
 296                                  ,(cdr alt-expansion)))
 297                  ((case-lambda)
 298                   `(case-lambda (,formals ,@(recurse-body body))
 299                                 ,@(cdr alt-expansion)))
 300                  ((case-lambda*)
 301                   `(case-lambda* (,formals ,@(recurse-body body))
 302                                  ,@(cdr alt-expansion))))))
 303             (else
 304              (let* ((alt-expansion (and alternate (recurse alternate)))
 305                     (nreq (length req))
 306                     (nopt (if opt (length opt) 0))
 307                     (restargs (if rest (list-ref names (+ nreq nopt)) '()))
 308                     (reqargs (list-head names nreq))
 309                     (optargs (if opt
 310                                  `(#:optional
 311                                    ,@(map list
 312                                           (list-head (list-tail names nreq) nopt)
 313                                           (map recurse
 314                                                (list-head inits nopt))))
 315                                  '()))
 316                     (kwargs (if kw
 317                                 `(#:key
 318                                   ,@(map list
 319                                          (map output-name (map caddr (cdr kw)))
 320                                          (map recurse
 321                                               (list-tail inits nopt))
 322                                          (map car (cdr kw)))
 323                                   ,@(if (car kw)
 324                                         '(#:allow-other-keys)
 325                                         '()))
 326                                 '()))
 327                     (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
 328                (if (not alt-expansion)
 329                    `(lambda* ,formals ,@(recurse-body body))
 330                    (case (car alt-expansion)
 331                      ((lambda lambda*)
 332                       `(case-lambda* (,formals ,@(recurse-body body))
 333                                      ,(cdr alt-expansion)))
 334                      ((case-lambda case-lambda*)
 335                       `(case-lambda* (,formals ,@(recurse-body body))
 336                                      ,@(cdr alt-expansion))))))))))
 337
 338         ((<conditional> test consequent alternate)
 339          (define (simplify-test e)
 340            (match e
 341              (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
 342               `(memv ,v '(,a ,b)))
 343              (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...))))
 344               `(memv ,v '(,a ,@bs)))
 345              (('case (? atom? v)
 346                 ((datum) #t) ...
 347                 ('else ('eqv? v ('quote last-datum))))
 348               `(memv ,v '(,@datum ,last-datum)))
 349              (_ e)))
 350          (match `(if ,(simplify-test (recurse test))
 351                      ,(recurse consequent)
 352                      ,@(if (void? alternate) '()
 353                            (list (recurse alternate))))
 354            (('if test ('if ('and xs ...) consequent))
 355             (build-if (build-and (cons test xs))
 356                       consequent
 357                       (build-void)))
 358            ((? (const use-derived-syntax?)
 359                ('if test1 ('if test2 consequent)))
 360             (build-if (build-and (list test1 test2))
 361                       consequent
 362                       (build-void)))
 363            (('if (? atom? x) x ('or ys ...))
 364             (build-or (cons x ys)))
 365            ((? (const use-derived-syntax?)
 366                ('if (? atom? x) x y))
 367             (build-or (list x y)))
 368            (('if test consequent)
 369             `(if ,test ,consequent))
 370            (('if test ('and xs ...) #f)
 371             (build-and (cons test xs)))
 372            ((? (const use-derived-syntax?)
 373                ('if test consequent #f))
 374             (build-and (list test consequent)))
 375            ((? (const use-derived-syntax?)
 376                ('if test1 consequent1
 377                     ('if test2 consequent2 . alternate*)))
 378             (build-cond-or-case (list test1 test2)
 379                                 (list consequent1 consequent2)
 380                                 (build-begin alternate*)))
 381            (('if test consequent ('cond clauses ...))
 382             `(cond (,test ,@(build-begin-body consequent))
 383                    ,@clauses))
 384            (('if ('memv (? atom? v) ('quote (xs ...))) consequent
 385                  ('case v clauses ...))
 386             `(case ,v (,xs ,@(build-begin-body consequent))
 387                    ,@clauses))
 388            (('if ('eqv? (? atom? v) ('quote x)) consequent
 389                  ('case v clauses ...))
 390             `(case ,v ((,x) ,@(build-begin-body consequent))
 391                    ,@clauses))
 392            (e e)))
 393
 394         ((<let> gensyms vals body)
 395          (match (build-let (map output-name gensyms)
 396                            (map recurse vals)
 397                            (recurse body))
 398            (('let ((v e)) ('or v xs ...))
 399             (=> failure)
 400             (if (and (not (null? gensyms))
 401                      (= 3 (occurrence-count (car gensyms))))
 402                 `(or ,e ,@xs)
 403                 (failure)))
 404            (('let ((v e)) ('case v clauses ...))
 405             (=> failure)
 406             (if (and (not (null? gensyms))
 407                      ;; FIXME: This fails if any of the 'memv's were
 408                      ;; optimized into multiple 'eqv?'s, because the
 409                      ;; occurrence count will be higher than we expect.
 410                      (= (occurrence-count (car gensyms))
 411                         (1+ (length (clauses+tail clauses)))))
 412                 `(case ,e ,@clauses)
 413                 (failure)))
 414            (e e)))
 415
 416         ((<letrec> in-order? gensyms vals body)
 417          (build-letrec in-order?
 418                        (map output-name gensyms)
 419                        (map recurse vals)
 420                        (recurse body)))
 421
 422         ((<fix> gensyms vals body)
 423          ;; not a typo, we really do translate back to letrec. use letrec* since it
 424          ;; doesn't matter, and the naive letrec* transformation does not require an
 425          ;; inner let.
 426          (build-letrec #t
 427                        (map output-name gensyms)
 428                        (map recurse vals)
 429                        (recurse body)))
 430
 431         ((<let-values> exp body)
 432          `(call-with-values (lambda () ,@(recurse-body exp))
 433             ,(recurse (make-lambda #f '() body))))
 434
 435         ((<prompt> escape-only? tag body handler)
 436          `(call-with-prompt
 437            ,(recurse tag)
 438            ,(if escape-only?
 439                 `(lambda () ,(recurse body))
 440                 (recurse body))
 441            ,(recurse handler)))
 442
 443
 444         ((<abort> tag args tail)
 445          `(apply abort ,(recurse tag) ,@(map recurse args)
 446                  ,(recurse tail)))))
 447     (values (recurse e) env)))
 448
 449 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 450 ;;
 451 ;; Algorithm for choosing better variable names
 452 ;; ============================================
 453 ;;
 454 ;; First we perform an analysis pass, collecting the following
 455 ;; information:
 456 ;;
 457 ;; * For each gensym: how many occurrences will occur in the output?
 458 ;;
 459 ;; * For each gensym A: which gensyms does A conflict with?  Gensym A
 460 ;;   and gensym B conflict if they have the same base name (usually the
 461 ;;   same as the source name, but see below), and if giving them the
 462 ;;   same name would cause a bad variable reference due to unintentional
 463 ;;   variable capture.
 464 ;;
 465 ;; The occurrence counter is indexed by gensym and is global (within each
 466 ;; invocation of the algorithm), implemented using a hash table.  We also
 467 ;; keep a global mapping from gensym to source name as provided by the
 468 ;; binding construct (we prefer not to trust the source names in the
 469 ;; lexical ref or set).
 470 ;;
 471 ;; As we recurse down into lexical binding forms, we keep track of a
 472 ;; mapping from base name to an ordered list of bindings, innermost
 473 ;; first.  When we encounter a variable occurrence, we increment the
 474 ;; counter, look up the base name (preferring not to trust the 'name' in
 475 ;; the lexical ref or set), and then look up the bindings currently in
 476 ;; effect for that base name.  Hopefully our gensym will be the first
 477 ;; (innermost) binding.  If not, we register a conflict between the
 478 ;; referenced gensym and the other bound gensyms with the same base name
 479 ;; that shadow the binding we want.  These are simply the gensyms on the
 480 ;; binding list that come before our gensym.
 481 ;;
 482 ;; Top-level bindings are treated specially.  Whenever top-level
 483 ;; references are found, they conflict with every lexical binding
 484 ;; currently in effect with the same base name.  They are guaranteed to
 485 ;; be assigned to their source names.  For purposes of recording
 486 ;; conflicts (which are normally keyed on gensyms) top-level identifiers
 487 ;; are assigned a pseudo-gensym that is an interned pair of the form
 488 ;; (top-level . <name>).  This allows them to be compared using 'eq?'
 489 ;; like other gensyms.
 490 ;;
 491 ;; The base name is normally just the source name.  However, if the
 492 ;; source name has a suffix of the form "-N" (where N is a positive
 493 ;; integer without leading zeroes), then we strip that suffix (multiple
 494 ;; times if necessary) to form the base name.  We must do this because
 495 ;; we add suffixes of that form in order to resolve conflicts, and we
 496 ;; must ensure that only identifiers with the same base name can
 497 ;; possibly conflict with each other.
 498 ;;
 499 ;; XXX FIXME: Currently, primitives are treated exactly like top-level
 500 ;; bindings.  This handles conflicting lexical bindings properly, but
 501 ;; does _not_ handle the case where top-level bindings conflict with the
 502 ;; needed primitives.
 503 ;;
 504 ;; Also note that this requires that 'choose-output-names' be kept in
 505 ;; sync with 'tree-il->scheme'.  Primitives that are introduced by
 506 ;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
 507 ;;
 508 ;; We also ensure that lexically-bound identifiers found in operator
 509 ;; position will never be assigned one of the standard primitive names.
 510 ;; This is needed because 'tree-il->scheme' recognizes primitive names
 511 ;; in operator position and assumes that they have the standard
 512 ;; bindings.
 513 ;;
 514 ;;
 515 ;; How we assign an output name to each gensym
 516 ;; ===========================================
 517 ;;
 518 ;; We process the gensyms in order of decreasing occurrence count, with
 519 ;; each gensym choosing the best output name possible, as long as it
 520 ;; isn't the same name as any of the previously-chosen output names of
 521 ;; conflicting gensyms.
 522 ;;
 523
 524
 525 ;;
 526 ;; 'choose-output-names' analyzes the top-level form e, chooses good
 527 ;; variable names that are as close as possible to the source names,
 528 ;; and returns two values:
 529 ;;
 530 ;;  * a hash table mapping gensym to output name
 531 ;;  * a hash table mapping gensym to number of occurrences
 532 ;;
 533 (define choose-output-names
 534   (let ()
 535     (define primitive?
 536       ;; This is a list of primitives that 'tree-il->scheme' assumes
 537       ;; will have the standard bindings when found in operator
 538       ;; position.
 539       (let* ((primitives '(if quote @ @@ set! define define*
 540                               begin let let* letrec letrec*
 541                               and or cond case
 542                               lambda lambda* case-lambda case-lambda*
 543                               apply call-with-values dynamic-wind
 544                               with-fluids fluid-ref fluid-set!
 545                               call-with-prompt abort memv eqv?))
 546              (table (make-hash-table (length primitives))))
 547         (for-each (cut hashq-set! table <> #t) primitives)
 548         (lambda (name) (hashq-ref table name))))
 549
 550     ;; Repeatedly strip suffix of the form "-N", where N is a string
 551     ;; that could be produced by number->string given a positive
 552     ;; integer.  In other words, the first digit of N may not be 0.
 553     (define compute-base-name
 554       (let ((digits (string->char-set "0123456789")))
 555         (define (base-name-string str)
 556           (let ((i (string-skip-right str digits)))
 557             (if (and i (< (1+ i) (string-length str))
 558                      (eq? #\- (string-ref str i))
 559                      (not (eq? #\0 (string-ref str (1+ i)))))
 560                 (base-name-string (substring str 0 i))
 561                 str)))
 562         (lambda (sym)
 563           (string->symbol (base-name-string (symbol->string sym))))))
 564
 565     ;; choose-output-names
 566     (lambda (e use-derived-syntax? strip-numeric-suffixes?)
 567
 568       (define lexical-gensyms '())
 569
 570       (define top-level-intern!
 571         (let ((table (make-hash-table)))
 572           (lambda (name)
 573             (let ((h (hashq-create-handle! table name #f)))
 574               (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
 575                                  (cdr h)))))))
 576       (define (top-level? s) (pair? s))
 577       (define (top-level-name s) (cdr s))
 578
 579       (define occurrence-count-table (make-hash-table))
 580       (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
 581       (define (increment-occurrence-count! s)
 582         (let ((h (hashq-create-handle! occurrence-count-table s 0)))
 583           (if (zero? (cdr h))
 584               (set! lexical-gensyms (cons s lexical-gensyms)))
 585           (set-cdr! h (1+ (cdr h)))))
 586
 587       (define base-name
 588         (let ((table (make-hash-table)))
 589           (lambda (name)
 590             (let ((h (hashq-create-handle! table name #f)))
 591               (or (cdr h) (begin (set-cdr! h (compute-base-name name))
 592                                  (cdr h)))))))
 593
 594       (define source-name-table (make-hash-table))
 595       (define (set-source-name! s name)
 596         (if (not (top-level? s))
 597             (let ((name (if strip-numeric-suffixes?
 598                             (base-name name)
 599                             name)))
 600               (hashq-set! source-name-table s name))))
 601       (define (source-name s)
 602         (if (top-level? s)
 603             (top-level-name s)
 604             (hashq-ref source-name-table s)))
 605
 606       (define conflict-table (make-hash-table))
 607       (define (conflicts s) (or (hashq-ref conflict-table s) '()))
 608       (define (add-conflict! a b)
 609         (define (add! a b)
 610           (if (not (top-level? a))
 611               (let ((h (hashq-create-handle! conflict-table a '())))
 612                 (if (not (memq b (cdr h)))
 613                     (set-cdr! h (cons b (cdr h)))))))
 614         (add! a b)
 615         (add! b a))
 616
 617       (let recurse-with-bindings ((e e) (bindings vlist-null))
 618         (let recurse ((e e))
 619
 620           ;; We call this whenever we encounter a top-level ref or set
 621           (define (top-level name)
 622             (let ((bname (base-name name)))
 623               (let ((s (top-level-intern! name))
 624                     (conflicts (vhash-foldq* cons '() bname bindings)))
 625                 (for-each (cut add-conflict! s <>) conflicts))))
 626
 627           ;; We call this whenever we encounter a primitive reference.
 628           ;; We must also call it for every primitive that might be
 629           ;; inserted by 'tree-il->scheme'.  It is okay to call this
 630           ;; even when 'tree-il->scheme' will not insert the named
 631           ;; primitive; the worst that will happen is for a lexical
 632           ;; variable of the same name to be renamed unnecessarily.
 633           (define (primitive name) (top-level name))
 634
 635           ;; We call this whenever we encounter a lexical ref or set.
 636           (define (lexical s)
 637             (increment-occurrence-count! s)
 638             (let ((conflicts
 639                    (take-while
 640                     (lambda (s*) (not (eq? s s*)))
 641                     (reverse! (vhash-foldq* cons
 642                                             '()
 643                                             (base-name (source-name s))
 644                                             bindings)))))
 645               (for-each (cut add-conflict! s <>) conflicts)))
 646
 647           (record-case e
 648             ((<void>)  (primitive 'if)) ; (if #f #f)
 649             ((<const>) (primitive 'quote))
 650
 651             ((<call> proc args)
 652              (if (lexical-ref? proc)
 653                  (let* ((gensym (lexical-ref-gensym proc))
 654                         (name (source-name gensym)))
 655                    ;; If the operator position contains a bare variable
 656                    ;; reference with the same source name as a standard
 657                    ;; primitive, we must ensure that it will be given a
 658                    ;; different name, so that 'tree-il->scheme' will not
 659                    ;; misinterpret the resulting expression.
 660                    (if (primitive? name)
 661                        (add-conflict! gensym (top-level-intern! name)))))
 662              (recurse proc)
 663              (for-each recurse args))
 664
 665             ((<primitive-ref> name) (primitive name))
 666             ((<primcall> name args) (primitive name) (for-each recurse args))
 667
 668             ((<lexical-ref> gensym) (lexical gensym))
 669             ((<lexical-set> gensym exp)
 670              (primitive 'set!) (lexical gensym) (recurse exp))
 671
 672             ((<module-ref> public?) (primitive (if public? '@ '@@)))
 673             ((<module-set> public? exp)
 674              (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
 675
 676             ((<toplevel-ref> name) (top-level name))
 677             ((<toplevel-set> name exp)
 678              (primitive 'set!) (top-level name) (recurse exp))
 679             ((<toplevel-define> name exp) (top-level name) (recurse exp))
 680
 681             ((<conditional> test consequent alternate)
 682              (cond (use-derived-syntax?
 683                     (primitive 'and) (primitive 'or)
 684                     (primitive 'cond) (primitive 'case)
 685                     (primitive 'else) (primitive '=>)))
 686              (primitive 'if)
 687              (recurse test) (recurse consequent) (recurse alternate))
 688
 689             ((<seq> head tail)
 690              (primitive 'begin) (recurse head) (recurse tail))
 691
 692             ((<lambda> body)
 693              (if body (recurse body) (primitive 'case-lambda)))
 694
 695             ((<lambda-case> req opt rest kw inits gensyms body alternate)
 696              (primitive 'lambda)
 697              (cond ((or opt kw alternate)
 698                     (primitive 'lambda*)
 699                     (primitive 'case-lambda)
 700                     (primitive 'case-lambda*)))
 701              (primitive 'let)
 702              (if use-derived-syntax? (primitive 'let*))
 703              (let* ((names (append req (or opt '()) (if rest (list rest) '())
 704                                    (map cadr (if kw (cdr kw) '()))))
 705                     (base-names (map base-name names))
 706                     (body-bindings
 707                      (fold vhash-consq bindings base-names gensyms)))
 708                (for-each increment-occurrence-count! gensyms)
 709                (for-each set-source-name! gensyms names)
 710                (for-each recurse inits)
 711                (recurse-with-bindings body body-bindings)
 712                (if alternate (recurse alternate))))
 713
 714             ((<let> names gensyms vals body)
 715              (primitive 'let)
 716              (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
 717              (for-each increment-occurrence-count! gensyms)
 718              (for-each set-source-name! gensyms names)
 719              (for-each recurse vals)
 720              (recurse-with-bindings
 721               body (fold vhash-consq bindings (map base-name names) gensyms)))
 722
 723             ((<letrec> in-order? names gensyms vals body)
 724              (primitive 'let)
 725              (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
 726              (primitive (if in-order? 'letrec* 'letrec))
 727              (for-each increment-occurrence-count! gensyms)
 728              (for-each set-source-name! gensyms names)
 729              (let* ((base-names (map base-name names))
 730                     (bindings (fold vhash-consq bindings base-names gensyms)))
 731                (for-each (cut recurse-with-bindings <> bindings) vals)
 732                (recurse-with-bindings body bindings)))
 733
 734             ((<fix> names gensyms vals body)
 735              (primitive 'let)
 736              (primitive 'letrec*)
 737              (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
 738              (for-each increment-occurrence-count! gensyms)
 739              (for-each set-source-name! gensyms names)
 740              (let* ((base-names (map base-name names))
 741                     (bindings (fold vhash-consq bindings base-names gensyms)))
 742                (for-each (cut recurse-with-bindings <> bindings) vals)
 743                (recurse-with-bindings body bindings)))
 744
 745             ((<let-values> exp body)
 746              (primitive 'call-with-values)
 747              (recurse exp) (recurse body))
 748
 749             ((<prompt> tag body handler)
 750              (primitive 'call-with-prompt)
 751              (recurse tag) (recurse body) (recurse handler))
 752
 753             ((<abort> tag args tail)
 754              (primitive 'apply)
 755              (primitive 'abort)
 756              (recurse tag) (for-each recurse args) (recurse tail)))))
 757
 758       (let ()
 759         (define output-name-table (make-hash-table))
 760         (define (set-output-name! s name)
 761           (hashq-set! output-name-table s name))
 762         (define (output-name s)
 763           (if (top-level? s)
 764               (top-level-name s)
 765               (hashq-ref output-name-table s)))
 766
 767         (define sorted-lexical-gensyms
 768           (sort-list lexical-gensyms
 769                      (lambda (a b) (> (occurrence-count a)
 770                                       (occurrence-count b)))))
 771
 772         (for-each (lambda (s)
 773                     (set-output-name!
 774                      s
 775                      (let ((the-conflicts (conflicts s))
 776                            (the-source-name (source-name s)))
 777                        (define (not-yet-taken? name)
 778                          (not (any (lambda (s*)
 779                                      (and=> (output-name s*)
 780                                             (cut eq? name <>)))
 781                                    the-conflicts)))
 782                        (if (not-yet-taken? the-source-name)
 783                            the-source-name
 784                            (let ((prefix (string-append
 785                                           (symbol->string the-source-name)
 786                                           "-")))
 787                              (let loop ((i 1) (name the-source-name))
 788                                (if (not-yet-taken? name)
 789                                    name
 790                                    (loop (+ i 1)
 791                                          (string->symbol
 792                                           (string-append
 793                                            prefix
 794                                            (number->string i)))))))))))
 795                   sorted-lexical-gensyms)
 796         (values output-name-table occurrence-count-table)))))