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

   1 ;;; Guile VM code converters
   2
   3 ;; Copyright (C) 2001, 2009, 2012 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          (let ((body (recurse body))
 265                (doc (assq-ref meta 'documentation)))
 266            (if (not doc)
 267                body
 268                (match body
 269                  (('lambda formals body ...)
 270                   `(lambda ,formals ,doc ,@body))
 271                  (('lambda* formals body ...)
 272                   `(lambda* ,formals ,doc ,@body))
 273                  (('case-lambda (formals body ...) clauses ...)
 274                   `(case-lambda (,formals ,doc ,@body) ,@clauses))
 275                  (('case-lambda* (formals body ...) clauses ...)
 276                   `(case-lambda* (,formals ,doc ,@body) ,@clauses))
 277                  (e e)))))
 278
 279         ((<lambda-case> req opt rest kw inits gensyms body alternate)
 280          (let ((names (map output-name gensyms)))
 281            (cond
 282             ((and (not opt) (not kw) (not alternate))
 283              `(lambda ,(if rest (apply cons* names) names)
 284                 ,@(recurse-body body)))
 285             ((and (not opt) (not kw))
 286              (let ((alt-expansion (recurse alternate))
 287                    (formals (if rest (apply cons* names) names)))
 288                (case (car alt-expansion)
 289                  ((lambda)
 290                   `(case-lambda (,formals ,@(recurse-body body))
 291                                 ,(cdr alt-expansion)))
 292                  ((lambda*)
 293                   `(case-lambda* (,formals ,@(recurse-body body))
 294                                  ,(cdr alt-expansion)))
 295                  ((case-lambda)
 296                   `(case-lambda (,formals ,@(recurse-body body))
 297                                 ,@(cdr alt-expansion)))
 298                  ((case-lambda*)
 299                   `(case-lambda* (,formals ,@(recurse-body body))
 300                                  ,@(cdr alt-expansion))))))
 301             (else
 302              (let* ((alt-expansion (and alternate (recurse alternate)))
 303                     (nreq (length req))
 304                     (nopt (if opt (length opt) 0))
 305                     (restargs (if rest (list-ref names (+ nreq nopt)) '()))
 306                     (reqargs (list-head names nreq))
 307                     (optargs (if opt
 308                                  `(#:optional
 309                                    ,@(map list
 310                                           (list-head (list-tail names nreq) nopt)
 311                                           (map recurse
 312                                                (list-head inits nopt))))
 313                                  '()))
 314                     (kwargs (if kw
 315                                 `(#:key
 316                                   ,@(map list
 317                                          (map output-name (map caddr (cdr kw)))
 318                                          (map recurse
 319                                               (list-tail inits nopt))
 320                                          (map car (cdr kw)))
 321                                   ,@(if (car kw)
 322                                         '(#:allow-other-keys)
 323                                         '()))
 324                                 '()))
 325                     (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
 326                (if (not alt-expansion)
 327                    `(lambda* ,formals ,@(recurse-body body))
 328                    (case (car alt-expansion)
 329                      ((lambda lambda*)
 330                       `(case-lambda* (,formals ,@(recurse-body body))
 331                                      ,(cdr alt-expansion)))
 332                      ((case-lambda case-lambda*)
 333                       `(case-lambda* (,formals ,@(recurse-body body))
 334                                      ,@(cdr alt-expansion))))))))))
 335
 336         ((<conditional> test consequent alternate)
 337          (define (simplify-test e)
 338            (match e
 339              (('if ('eqv? (? atom? v) ('quote a)) #t ('eqv? v ('quote b)))
 340               `(memv ,v '(,a ,b)))
 341              (('if ('eqv? (? atom? v) ('quote a)) #t ('memv v ('quote (bs ...))))
 342               `(memv ,v '(,a ,@bs)))
 343              (('case (? atom? v)
 344                 ((datum) #t) ...
 345                 ('else ('eqv? v ('quote last-datum))))
 346               `(memv ,v '(,@datum ,last-datum)))
 347              (_ e)))
 348          (match `(if ,(simplify-test (recurse test))
 349                      ,(recurse consequent)
 350                      ,@(if (void? alternate) '()
 351                            (list (recurse alternate))))
 352            (('if test ('if ('and xs ...) consequent))
 353             (build-if (build-and (cons test xs))
 354                       consequent
 355                       (build-void)))
 356            ((? (const use-derived-syntax?)
 357                ('if test1 ('if test2 consequent)))
 358             (build-if (build-and (list test1 test2))
 359                       consequent
 360                       (build-void)))
 361            (('if (? atom? x) x ('or ys ...))
 362             (build-or (cons x ys)))
 363            ((? (const use-derived-syntax?)
 364                ('if (? atom? x) x y))
 365             (build-or (list x y)))
 366            (('if test consequent)
 367             `(if ,test ,consequent))
 368            (('if test ('and xs ...) #f)
 369             (build-and (cons test xs)))
 370            ((? (const use-derived-syntax?)
 371                ('if test consequent #f))
 372             (build-and (list test consequent)))
 373            ((? (const use-derived-syntax?)
 374                ('if test1 consequent1
 375                     ('if test2 consequent2 . alternate*)))
 376             (build-cond-or-case (list test1 test2)
 377                                 (list consequent1 consequent2)
 378                                 (build-begin alternate*)))
 379            (('if test consequent ('cond clauses ...))
 380             `(cond (,test ,@(build-begin-body consequent))
 381                    ,@clauses))
 382            (('if ('memv (? atom? v) ('quote (xs ...))) consequent
 383                  ('case v clauses ...))
 384             `(case ,v (,xs ,@(build-begin-body consequent))
 385                    ,@clauses))
 386            (('if ('eqv? (? atom? v) ('quote x)) consequent
 387                  ('case v clauses ...))
 388             `(case ,v ((,x) ,@(build-begin-body consequent))
 389                    ,@clauses))
 390            (e e)))
 391
 392         ((<let> gensyms vals body)
 393          (match (build-let (map output-name gensyms)
 394                            (map recurse vals)
 395                            (recurse body))
 396            (('let ((v e)) ('or v xs ...))
 397             (=> failure)
 398             (if (and (not (null? gensyms))
 399                      (= 3 (occurrence-count (car gensyms))))
 400                 `(or ,e ,@xs)
 401                 (failure)))
 402            (('let ((v e)) ('case v clauses ...))
 403             (=> failure)
 404             (if (and (not (null? gensyms))
 405                      ;; FIXME: This fails if any of the 'memv's were
 406                      ;; optimized into multiple 'eqv?'s, because the
 407                      ;; occurrence count will be higher than we expect.
 408                      (= (occurrence-count (car gensyms))
 409                         (1+ (length (clauses+tail clauses)))))
 410                 `(case ,e ,@clauses)
 411                 (failure)))
 412            (e e)))
 413
 414         ((<letrec> in-order? gensyms vals body)
 415          (build-letrec in-order?
 416                        (map output-name gensyms)
 417                        (map recurse vals)
 418                        (recurse body)))
 419
 420         ((<fix> gensyms vals body)
 421          ;; not a typo, we really do translate back to letrec. use letrec* since it
 422          ;; doesn't matter, and the naive letrec* transformation does not require an
 423          ;; inner let.
 424          (build-letrec #t
 425                        (map output-name gensyms)
 426                        (map recurse vals)
 427                        (recurse body)))
 428
 429         ((<let-values> exp body)
 430          `(call-with-values (lambda () ,@(recurse-body exp))
 431             ,(recurse (make-lambda #f '() body))))
 432
 433         ((<dynwind> body winder unwinder)
 434          `(dynamic-wind ,(recurse winder)
 435                         (lambda () ,@(recurse-body body))
 436                         ,(recurse unwinder)))
 437
 438         ((<dynlet> fluids vals body)
 439          `(with-fluids ,(map list
 440                              (map recurse fluids)
 441                              (map recurse vals))
 442             ,@(recurse-body body)))
 443
 444         ((<dynref> fluid)
 445          `(fluid-ref ,(recurse fluid)))
 446
 447         ((<dynset> fluid exp)
 448          `(fluid-set! ,(recurse fluid) ,(recurse exp)))
 449
 450         ((<prompt> tag body handler)
 451          `(call-with-prompt
 452            ,(recurse tag)
 453            (lambda () ,@(recurse-body body))
 454            ,(recurse handler)))
 455
 456
 457         ((<abort> tag args tail)
 458          `(apply abort ,(recurse tag) ,@(map recurse args)
 459                  ,(recurse tail)))))
 460     (values (recurse e) env)))
 461
 462 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 463 ;;
 464 ;; Algorithm for choosing better variable names
 465 ;; ============================================
 466 ;;
 467 ;; First we perform an analysis pass, collecting the following
 468 ;; information:
 469 ;;
 470 ;; * For each gensym: how many occurrences will occur in the output?
 471 ;;
 472 ;; * For each gensym A: which gensyms does A conflict with?  Gensym A
 473 ;;   and gensym B conflict if they have the same base name (usually the
 474 ;;   same as the source name, but see below), and if giving them the
 475 ;;   same name would cause a bad variable reference due to unintentional
 476 ;;   variable capture.
 477 ;;
 478 ;; The occurrence counter is indexed by gensym and is global (within each
 479 ;; invocation of the algorithm), implemented using a hash table.  We also
 480 ;; keep a global mapping from gensym to source name as provided by the
 481 ;; binding construct (we prefer not to trust the source names in the
 482 ;; lexical ref or set).
 483 ;;
 484 ;; As we recurse down into lexical binding forms, we keep track of a
 485 ;; mapping from base name to an ordered list of bindings, innermost
 486 ;; first.  When we encounter a variable occurrence, we increment the
 487 ;; counter, look up the base name (preferring not to trust the 'name' in
 488 ;; the lexical ref or set), and then look up the bindings currently in
 489 ;; effect for that base name.  Hopefully our gensym will be the first
 490 ;; (innermost) binding.  If not, we register a conflict between the
 491 ;; referenced gensym and the other bound gensyms with the same base name
 492 ;; that shadow the binding we want.  These are simply the gensyms on the
 493 ;; binding list that come before our gensym.
 494 ;;
 495 ;; Top-level bindings are treated specially.  Whenever top-level
 496 ;; references are found, they conflict with every lexical binding
 497 ;; currently in effect with the same base name.  They are guaranteed to
 498 ;; be assigned to their source names.  For purposes of recording
 499 ;; conflicts (which are normally keyed on gensyms) top-level identifiers
 500 ;; are assigned a pseudo-gensym that is an interned pair of the form
 501 ;; (top-level . <name>).  This allows them to be compared using 'eq?'
 502 ;; like other gensyms.
 503 ;;
 504 ;; The base name is normally just the source name.  However, if the
 505 ;; source name has a suffix of the form "-N" (where N is a positive
 506 ;; integer without leading zeroes), then we strip that suffix (multiple
 507 ;; times if necessary) to form the base name.  We must do this because
 508 ;; we add suffixes of that form in order to resolve conflicts, and we
 509 ;; must ensure that only identifiers with the same base name can
 510 ;; possibly conflict with each other.
 511 ;;
 512 ;; XXX FIXME: Currently, primitives are treated exactly like top-level
 513 ;; bindings.  This handles conflicting lexical bindings properly, but
 514 ;; does _not_ handle the case where top-level bindings conflict with the
 515 ;; needed primitives.
 516 ;;
 517 ;; Also note that this requires that 'choose-output-names' be kept in
 518 ;; sync with 'tree-il->scheme'.  Primitives that are introduced by
 519 ;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
 520 ;;
 521 ;; We also ensure that lexically-bound identifiers found in operator
 522 ;; position will never be assigned one of the standard primitive names.
 523 ;; This is needed because 'tree-il->scheme' recognizes primitive names
 524 ;; in operator position and assumes that they have the standard
 525 ;; bindings.
 526 ;;
 527 ;;
 528 ;; How we assign an output name to each gensym
 529 ;; ===========================================
 530 ;;
 531 ;; We process the gensyms in order of decreasing occurrence count, with
 532 ;; each gensym choosing the best output name possible, as long as it
 533 ;; isn't the same name as any of the previously-chosen output names of
 534 ;; conflicting gensyms.
 535 ;;
 536
 537
 538 ;;
 539 ;; 'choose-output-names' analyzes the top-level form e, chooses good
 540 ;; variable names that are as close as possible to the source names,
 541 ;; and returns two values:
 542 ;;
 543 ;;  * a hash table mapping gensym to output name
 544 ;;  * a hash table mapping gensym to number of occurrences
 545 ;;
 546 (define choose-output-names
 547   (let ()
 548     (define primitive?
 549       ;; This is a list of primitives that 'tree-il->scheme' assumes
 550       ;; will have the standard bindings when found in operator
 551       ;; position.
 552       (let* ((primitives '(if quote @ @@ set! define define*
 553                               begin let let* letrec letrec*
 554                               and or cond case
 555                               lambda lambda* case-lambda case-lambda*
 556                               apply call-with-values dynamic-wind
 557                               with-fluids fluid-ref fluid-set!
 558                               call-with-prompt abort memv eqv?))
 559              (table (make-hash-table (length primitives))))
 560         (for-each (cut hashq-set! table <> #t) primitives)
 561         (lambda (name) (hashq-ref table name))))
 562
 563     ;; Repeatedly strip suffix of the form "-N", where N is a string
 564     ;; that could be produced by number->string given a positive
 565     ;; integer.  In other words, the first digit of N may not be 0.
 566     (define compute-base-name
 567       (let ((digits (string->char-set "0123456789")))
 568         (define (base-name-string str)
 569           (let ((i (string-skip-right str digits)))
 570             (if (and i (< (1+ i) (string-length str))
 571                      (eq? #\- (string-ref str i))
 572                      (not (eq? #\0 (string-ref str (1+ i)))))
 573                 (base-name-string (substring str 0 i))
 574                 str)))
 575         (lambda (sym)
 576           (string->symbol (base-name-string (symbol->string sym))))))
 577
 578     ;; choose-output-names
 579     (lambda (e use-derived-syntax? strip-numeric-suffixes?)
 580
 581       (define lexical-gensyms '())
 582
 583       (define top-level-intern!
 584         (let ((table (make-hash-table)))
 585           (lambda (name)
 586             (let ((h (hashq-create-handle! table name #f)))
 587               (or (cdr h) (begin (set-cdr! h (cons 'top-level name))
 588                                  (cdr h)))))))
 589       (define (top-level? s) (pair? s))
 590       (define (top-level-name s) (cdr s))
 591
 592       (define occurrence-count-table (make-hash-table))
 593       (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
 594       (define (increment-occurrence-count! s)
 595         (let ((h (hashq-create-handle! occurrence-count-table s 0)))
 596           (if (zero? (cdr h))
 597               (set! lexical-gensyms (cons s lexical-gensyms)))
 598           (set-cdr! h (1+ (cdr h)))))
 599
 600       (define base-name
 601         (let ((table (make-hash-table)))
 602           (lambda (name)
 603             (let ((h (hashq-create-handle! table name #f)))
 604               (or (cdr h) (begin (set-cdr! h (compute-base-name name))
 605                                  (cdr h)))))))
 606
 607       (define source-name-table (make-hash-table))
 608       (define (set-source-name! s name)
 609         (if (not (top-level? s))
 610             (let ((name (if strip-numeric-suffixes?
 611                             (base-name name)
 612                             name)))
 613               (hashq-set! source-name-table s name))))
 614       (define (source-name s)
 615         (if (top-level? s)
 616             (top-level-name s)
 617             (hashq-ref source-name-table s)))
 618
 619       (define conflict-table (make-hash-table))
 620       (define (conflicts s) (or (hashq-ref conflict-table s) '()))
 621       (define (add-conflict! a b)
 622         (define (add! a b)
 623           (if (not (top-level? a))
 624               (let ((h (hashq-create-handle! conflict-table a '())))
 625                 (if (not (memq b (cdr h)))
 626                     (set-cdr! h (cons b (cdr h)))))))
 627         (add! a b)
 628         (add! b a))
 629
 630       (let recurse-with-bindings ((e e) (bindings vlist-null))
 631         (let recurse ((e e))
 632
 633           ;; We call this whenever we encounter a top-level ref or set
 634           (define (top-level name)
 635             (let ((bname (base-name name)))
 636               (let ((s (top-level-intern! name))
 637                     (conflicts (vhash-foldq* cons '() bname bindings)))
 638                 (for-each (cut add-conflict! s <>) conflicts))))
 639
 640           ;; We call this whenever we encounter a primitive reference.
 641           ;; We must also call it for every primitive that might be
 642           ;; inserted by 'tree-il->scheme'.  It is okay to call this
 643           ;; even when 'tree-il->scheme' will not insert the named
 644           ;; primitive; the worst that will happen is for a lexical
 645           ;; variable of the same name to be renamed unnecessarily.
 646           (define (primitive name) (top-level name))
 647
 648           ;; We call this whenever we encounter a lexical ref or set.
 649           (define (lexical s)
 650             (increment-occurrence-count! s)
 651             (let ((conflicts
 652                    (take-while
 653                     (lambda (s*) (not (eq? s s*)))
 654                     (reverse! (vhash-foldq* cons
 655                                             '()
 656                                             (base-name (source-name s))
 657                                             bindings)))))
 658               (for-each (cut add-conflict! s <>) conflicts)))
 659
 660           (record-case e
 661             ((<void>)  (primitive 'if)) ; (if #f #f)
 662             ((<const>) (primitive 'quote))
 663
 664             ((<call> proc args)
 665              (if (lexical-ref? proc)
 666                  (let* ((gensym (lexical-ref-gensym proc))
 667                         (name (source-name gensym)))
 668                    ;; If the operator position contains a bare variable
 669                    ;; reference with the same source name as a standard
 670                    ;; primitive, we must ensure that it will be given a
 671                    ;; different name, so that 'tree-il->scheme' will not
 672                    ;; misinterpret the resulting expression.
 673                    (if (primitive? name)
 674                        (add-conflict! gensym (top-level-intern! name)))))
 675              (recurse proc)
 676              (for-each recurse args))
 677
 678             ((<primitive-ref> name) (primitive name))
 679             ((<primcall> name args) (primitive name) (for-each recurse args))
 680
 681             ((<lexical-ref> gensym) (lexical gensym))
 682             ((<lexical-set> gensym exp)
 683              (primitive 'set!) (lexical gensym) (recurse exp))
 684
 685             ((<module-ref> public?) (primitive (if public? '@ '@@)))
 686             ((<module-set> public? exp)
 687              (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
 688
 689             ((<toplevel-ref> name) (top-level name))
 690             ((<toplevel-set> name exp)
 691              (primitive 'set!) (top-level name) (recurse exp))
 692             ((<toplevel-define> name exp) (top-level name) (recurse exp))
 693
 694             ((<conditional> test consequent alternate)
 695              (cond (use-derived-syntax?
 696                     (primitive 'and) (primitive 'or)
 697                     (primitive 'cond) (primitive 'case)
 698                     (primitive 'else) (primitive '=>)))
 699              (primitive 'if)
 700              (recurse test) (recurse consequent) (recurse alternate))
 701
 702             ((<seq> head tail)
 703              (primitive 'begin) (recurse head) (recurse tail))
 704
 705             ((<lambda> body) (recurse body))
 706
 707             ((<lambda-case> req opt rest kw inits gensyms body alternate)
 708              (primitive 'lambda)
 709              (cond ((or opt kw alternate)
 710                     (primitive 'lambda*)
 711                     (primitive 'case-lambda)
 712                     (primitive 'case-lambda*)))
 713              (primitive 'let)
 714              (if use-derived-syntax? (primitive 'let*))
 715              (let* ((names (append req (or opt '()) (if rest (list rest) '())
 716                                    (map cadr (if kw (cdr kw) '()))))
 717                     (base-names (map base-name names))
 718                     (body-bindings
 719                      (fold vhash-consq bindings base-names gensyms)))
 720                (for-each increment-occurrence-count! gensyms)
 721                (for-each set-source-name! gensyms names)
 722                (for-each recurse inits)
 723                (recurse-with-bindings body body-bindings)
 724                (if alternate (recurse alternate))))
 725
 726             ((<let> names gensyms vals body)
 727              (primitive 'let)
 728              (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
 729              (for-each increment-occurrence-count! gensyms)
 730              (for-each set-source-name! gensyms names)
 731              (for-each recurse vals)
 732              (recurse-with-bindings
 733               body (fold vhash-consq bindings (map base-name names) gensyms)))
 734
 735             ((<letrec> in-order? names gensyms vals body)
 736              (primitive 'let)
 737              (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
 738              (primitive (if in-order? 'letrec* 'letrec))
 739              (for-each increment-occurrence-count! gensyms)
 740              (for-each set-source-name! gensyms names)
 741              (let* ((base-names (map base-name names))
 742                     (bindings (fold vhash-consq bindings base-names gensyms)))
 743                (for-each (cut recurse-with-bindings <> bindings) vals)
 744                (recurse-with-bindings body bindings)))
 745
 746             ((<fix> names gensyms vals body)
 747              (primitive 'let)
 748              (primitive 'letrec*)
 749              (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
 750              (for-each increment-occurrence-count! gensyms)
 751              (for-each set-source-name! gensyms names)
 752              (let* ((base-names (map base-name names))
 753                     (bindings (fold vhash-consq bindings base-names gensyms)))
 754                (for-each (cut recurse-with-bindings <> bindings) vals)
 755                (recurse-with-bindings body bindings)))
 756
 757             ((<let-values> exp body)
 758              (primitive 'call-with-values)
 759              (recurse exp) (recurse body))
 760
 761             ((<dynwind> winder body unwinder)
 762              (primitive 'dynamic-wind)
 763              (recurse winder) (recurse body) (recurse unwinder))
 764
 765             ((<dynlet> fluids vals body)
 766              (primitive 'with-fluids)
 767              (for-each recurse fluids)
 768              (for-each recurse vals)
 769              (recurse body))
 770
 771             ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
 772             ((<dynset> fluid exp)
 773              (primitive 'fluid-set!) (recurse fluid) (recurse exp))
 774
 775             ((<prompt> tag body handler)
 776              (primitive 'call-with-prompt)
 777              (primitive 'lambda)
 778              (recurse tag) (recurse body) (recurse handler))
 779
 780             ((<abort> tag args tail)
 781              (primitive 'apply)
 782              (primitive 'abort)
 783              (recurse tag) (for-each recurse args) (recurse tail)))))
 784
 785       (let ()
 786         (define output-name-table (make-hash-table))
 787         (define (set-output-name! s name)
 788           (hashq-set! output-name-table s name))
 789         (define (output-name s)
 790           (if (top-level? s)
 791               (top-level-name s)
 792               (hashq-ref output-name-table s)))
 793
 794         (define sorted-lexical-gensyms
 795           (sort-list lexical-gensyms
 796                      (lambda (a b) (> (occurrence-count a)
 797                                       (occurrence-count b)))))
 798
 799         (for-each (lambda (s)
 800                     (set-output-name!
 801                      s
 802                      (let ((the-conflicts (conflicts s))
 803                            (the-source-name (source-name s)))
 804                        (define (not-yet-taken? name)
 805                          (not (any (lambda (s*)
 806                                      (and=> (output-name s*)
 807                                             (cut eq? name <>)))
 808                                    the-conflicts)))
 809                        (if (not-yet-taken? the-source-name)
 810                            the-source-name
 811                            (let ((prefix (string-append
 812                                           (symbol->string the-source-name)
 813                                           "-")))
 814                              (let loop ((i 1) (name the-source-name))
 815                                (if (not-yet-taken? name)
 816                                    name
 817                                    (loop (+ i 1)
 818                                          (string->symbol
 819                                           (string-append
 820                                            prefix
 821                                            (number->string i)))))))))))
 822                   sorted-lexical-gensyms)
 823         (values output-name-table occurrence-count-table)))))