Hello all,
Here's a preliminary patch that greatly improves our 'tree-il->scheme'
decompiler. With this patch, psyntax-pp.scm is now less than half of
its previous size (over 800 kilobytes saved), and is _far_ more
readable. In almost all cases the original source identifiers are used
instead of gensyms, while adding minimal suffixes to the least-used
variables where needed to avoid unintended variable capture. The
derived syntactic forms 'cond', 'and', 'or', and 'let*' are now
generated when appropriate, and 'begin' is no longer inserted in
contexts that provide an implicit 'begin'.
I've also disabled the use of partial evaluation when generating
psyntax-pp.scm. This is by far the biggest improvement in the size and
readability of psyntax-pp.scm, since it avoids the aggressive inlining.
Peval will still be applied when it's compiled to a .go file.
Again, this patch is preliminary, but it seems to work very well for me.
Comments and suggestions solicited.
Mark
>From 7edbbdfa277f2449e022e5d549d6a6bfb7504389 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <m...@netris.org>
Date: Wed, 22 Feb 2012 21:11:53 -0500
Subject: [PATCH] tree-il->scheme: avoid gensyms and begin; use cond, and, or,
and let*
* module/language/tree-il.scm (choose-output-names): New internal
procedure.
(tree-il->scheme): Print source identifiers where possible, otherwise
use minimal numeric suffixes. Previously we printed the gensyms.
Avoid 'begin' in contexts that provide an implicit 'begin'. Produce
'cond', 'and', 'or', and 'let*' where appropriate. Add keyword
arguments to disable the production of these derived syntactic forms,
either globally or only within top-level definitions (a hack for use
in bootstrapping psyntax).
* module/ice-9/compile-psyntax.scm: Disable partial evaluation when
producing psyntax-pp.scm, in order to limit code growth and
obfuscation due to procedure inlining. Pass #:booting-psyntax #t
keyword argument to 'tree-il->scheme'. Pretty-print using a width
of 120 characters.
* module/ice-9/psyntax-pp.scm: Regenerate. It is now less than half of
its previous size!
---
module/ice-9/compile-psyntax.scm | 5 +-
module/ice-9/psyntax-pp.scm |37906 ++++++++++++--------------------------
module/language/tree-il.scm | 617 +-
3 files changed, 12769 insertions(+), 25759 deletions(-)
diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm
index 3d803e9..d7572e4 100644
--- a/module/ice-9/compile-psyntax.scm
+++ b/module/ice-9/compile-psyntax.scm
@@ -44,8 +44,9 @@
(optimize!
(macroexpand x 'c '(compile load eval))
(current-module)
- '())))
- out)
+ '(#:partial-eval? #f)))
+ #:booting-psyntax? #t)
+ out #:width 120)
(newline out)
(loop (read in))))))
(system (format #f "mv -f ~s.tmp ~s" target target)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index 1d391c4..407bed4 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -19,6 +19,9 @@
(define-module (language tree-il)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 vlist)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@@ -331,155 +334,244 @@
`(abort ,(unparse-tree-il tag) ,(map unparse-tree-il args)
,(unparse-tree-il tail)))))
-(define (tree-il->scheme e)
- (record-case e
- ((<void>)
- '(if #f #f))
-
- ((<application> proc args)
- `(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
-
- ((<conditional> test consequent alternate)
- (if (void? alternate)
- `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent))
- `(if ,(tree-il->scheme test) ,(tree-il->scheme consequent) ,(tree-il->scheme alternate))))
-
- ((<primitive-ref> name)
- name)
-
- ((<lexical-ref> gensym)
- gensym)
-
- ((<lexical-set> gensym exp)
- `(set! ,gensym ,(tree-il->scheme exp)))
+(define* (tree-il->scheme
+ e #:key (use-derived-syntax? #t) (booting-psyntax? #f))
+
+ (receive (output-name-table occurrence-count-table)
+ (choose-output-names e use-derived-syntax?)
+
+ (define (output-name s) (hashq-ref output-name-table s))
+ (define (occurrence-count s) (hashq-ref occurrence-count-table s))
+
+ (define (false? e)
+ (and (const? e) (eq? #f (const-exp e))))
+ (define (lex-var? gensym e)
+ (and (lexical-ref? e)
+ (eq? gensym (lexical-ref-gensym e))))
+ (define (let-1? e)
+ (and (let? e) (= 1 (length (let-gensyms e)))))
+ (define (or-expr? e)
+ (and (let-1? e)
+ (let ((t (car (let-gensyms e)))
+ (c (let-body e)))
+ (and (conditional? c)
+ (lex-var? t (conditional-test c))
+ (lex-var? t (conditional-consequent c))
+ (= 3 (occurrence-count t))))))
+
+ (let recurse-with-options ((e e) (use-derived-syntax? use-derived-syntax?))
+ (let recurse ((e e))
+ (define (recurse-body e)
+ (map recurse (if (sequence? e)
+ (sequence-exps e)
+ (list e))))
+
+ (record-case e
+ ((<void>)
+ '(if #f #f))
+
+ ((<const> exp)
+ (if (and (self-evaluating? exp) (not (vector? exp)))
+ exp
+ (list 'quote exp)))
- ((<module-ref> mod name public?)
- `(,(if public? '@ '@@) ,mod ,name))
-
- ((<module-set> mod name public? exp)
- `(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
-
- ((<toplevel-ref> name)
- name)
-
- ((<toplevel-set> name exp)
- `(set! ,name ,(tree-il->scheme exp)))
-
- ((<toplevel-define> name exp)
- `(define ,name ,(tree-il->scheme exp)))
-
- ((<lambda> meta body)
- ;; fixme: put in docstring
- (tree-il->scheme body))
+ ((<sequence> exps)
+ `(begin ,@(map recurse exps)))
- ((<lambda-case> req opt rest kw inits gensyms body alternate)
- (cond
- ((and (not opt) (not kw) (not alternate))
- `(lambda ,(if rest (apply cons* gensyms) gensyms)
- ,(tree-il->scheme body)))
- ((and (not opt) (not kw))
- (let ((alt-expansion (tree-il->scheme alternate))
- (formals (if rest (apply cons* gensyms) gensyms)))
- (case (car alt-expansion)
- ((lambda)
- `(case-lambda (,formals ,(tree-il->scheme body))
- ,(cdr alt-expansion)))
- ((lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,(cdr alt-expansion)))
- ((case-lambda)
- `(case-lambda (,formals ,(tree-il->scheme body))
- ,@(cdr alt-expansion)))
- ((case-lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,@(cdr alt-expansion))))))
- (else
- (let* ((alt-expansion (and alternate (tree-il->scheme alternate)))
- (nreq (length req))
- (nopt (if opt (length opt) 0))
- (restargs (if rest (list-ref gensyms (+ nreq nopt)) '()))
- (reqargs (list-head gensyms nreq))
- (optargs (if opt
- `(#:optional
- ,@(map list
- (list-head (list-tail gensyms nreq) nopt)
- (map tree-il->scheme
- (list-head inits nopt))))
- '()))
- (kwargs (if kw
- `(#:key
- ,@(map list
- (map caddr (cdr kw))
- (map tree-il->scheme
- (list-tail inits nopt))
- (map car (cdr kw)))
- ,@(if (car kw)
- '(#:allow-other-keys)
+ ((<application> proc args)
+ `(,(recurse proc) ,@(map recurse args)))
+
+ ((<primitive-ref> name)
+ name)
+
+ ((<lexical-ref> gensym)
+ (output-name gensym))
+
+ ((<lexical-set> gensym exp)
+ `(set! ,(output-name gensym) ,(recurse exp)))
+
+ ((<module-ref> mod name public?)
+ `(,(if public? '@ '@@) ,mod ,name))
+
+ ((<module-set> mod name public? exp)
+ `(set! (,(if public? '@ '@@) ,mod ,name) ,(recurse exp)))
+
+ ((<toplevel-ref> name)
+ name)
+
+ ((<toplevel-set> name exp)
+ `(set! ,name ,(recurse exp)))
+
+ ((<toplevel-define> name exp)
+ `(define ,name ,(if booting-psyntax?
+ (recurse-with-options exp #f)
+ (recurse exp))))
+
+ ((<lambda> meta body)
+ ;; FIXME: include the docstring
+ (recurse body))
+
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (let ((names (map output-name gensyms)))
+ (cond
+ ((and (not opt) (not kw) (not alternate))
+ `(lambda ,(if rest (apply cons* names) names)
+ ,@(recurse-body body)))
+ ((and (not opt) (not kw))
+ (let ((alt-expansion (recurse alternate))
+ (formals (if rest (apply cons* names) names)))
+ (case (car alt-expansion)
+ ((lambda)
+ `(case-lambda (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((case-lambda)
+ `(case-lambda (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion)))
+ ((case-lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion))))))
+ (else
+ (let* ((alt-expansion (and alternate (recurse alternate)))
+ (nreq (length req))
+ (nopt (if opt (length opt) 0))
+ (restargs (if rest (list-ref names (+ nreq nopt)) '()))
+ (reqargs (list-head names nreq))
+ (optargs (if opt
+ `(#:optional
+ ,@(map list
+ (list-head (list-tail names nreq) nopt)
+ (map recurse
+ (list-head inits nopt))))
+ '()))
+ (kwargs (if kw
+ `(#:key
+ ,@(map list
+ (map output-name (map caddr (cdr kw)))
+ (map recurse
+ (list-tail inits nopt))
+ (map car (cdr kw)))
+ ,@(if (car kw)
+ '(#:allow-other-keys)
+ '()))
'()))
- '()))
- (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
- (if (not alt-expansion)
- `(lambda* ,formals ,(tree-il->scheme body))
- (case (car alt-expansion)
- ((lambda lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,(cdr alt-expansion)))
- ((case-lambda case-lambda*)
- `(case-lambda* (,formals ,(tree-il->scheme body))
- ,@(cdr alt-expansion)))))))))
+ (formals `(,@reqargs ,@optargs ,@kwargs . ,restargs)))
+ (if (not alt-expansion)
+ `(lambda* ,formals ,@(recurse-body body))
+ (case (car alt-expansion)
+ ((lambda lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,(cdr alt-expansion)))
+ ((case-lambda case-lambda*)
+ `(case-lambda* (,formals ,@(recurse-body body))
+ ,@(cdr alt-expansion))))))))))
- ((<const> exp)
- (if (and (self-evaluating? exp) (not (vector? exp)))
- exp
- (list 'quote exp)))
-
- ((<sequence> exps)
- `(begin ,@(map tree-il->scheme exps)))
-
- ((<let> gensyms vals body)
- `(let ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
-
- ((<letrec> in-order? gensyms vals body)
- `(,(if in-order? 'letrec* 'letrec)
- ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
-
- ((<fix> gensyms vals body)
- ;; not a typo, we really do translate back to letrec. use letrec* since it
- ;; doesn't matter, and the naive letrec* transformation does not require an
- ;; inner let.
- `(letrec* ,(map list gensyms (map tree-il->scheme vals)) ,(tree-il->scheme body)))
+ ((<conditional> test consequent alternate)
+ (cond ((and use-derived-syntax? (false? alternate))
+ (let loop ((exps (list test))
+ (consequent consequent))
+ (if (and (conditional? consequent)
+ (false? (conditional-alternate consequent)))
+ (loop (cons (conditional-test consequent) exps)
+ (conditional-consequent consequent))
+ `(and ,@(reverse! (map recurse exps))
+ ,(recurse consequent)))))
+ ((and use-derived-syntax? (conditional? alternate))
+ (let loop ((tests (list test))
+ (bodies (list (recurse-body consequent)))
+ (rest alternate))
+ (cond ((conditional? rest)
+ (loop (cons (conditional-test rest) tests)
+ (cons (recurse-body
+ (conditional-consequent rest))
+ bodies)
+ (conditional-alternate rest)))
+ ((or-expr? rest)
+ (loop (append (let-vals rest) tests)
+ (cons '() bodies)
+ (conditional-alternate (let-body rest))))
+ (else
+ `(cond ,@(reverse!
+ (append (if (void? rest)
+ '()
+ `((else ,@(recurse-body rest))))
+ (map cons
+ (map recurse tests)
+ bodies))))))))
+ ((void? alternate)
+ `(if ,(recurse test) ,(recurse consequent)))
+ (else
+ `(if ,(recurse test) ,(recurse consequent)
+ ,(recurse alternate)))))
+
+ ((<let> gensyms vals body)
+ (cond ((and use-derived-syntax?
+ (or-expr? e))
+ (let loop ((vals vals) (body (conditional-alternate body)))
+ (if (or-expr? body)
+ (loop (append (let-vals body) vals)
+ (conditional-alternate (let-body body)))
+ `(or ,@(reverse! (map recurse vals))
+ ,(recurse body)))))
+ ((and use-derived-syntax? (let-1? e) (let-1? body))
+ (let loop ((gensyms gensyms) (vals vals) (body body))
+ (if (and (let-1? body) (not (or-expr? body)))
+ (loop (append (let-gensyms body) gensyms)
+ (append (let-vals body) vals)
+ (let-body body))
+ `(let* ,(reverse! (map list
+ (map output-name gensyms)
+ (map recurse vals)))
+ ,@(recurse-body body)))))
+ (else
+ `(let ,(map list (map output-name gensyms) (map recurse vals))
+ ,@(recurse-body body)))))
+
+ ((<letrec> in-order? gensyms vals body)
+ `(,(if in-order? 'letrec* 'letrec)
+ ,(map list (map output-name gensyms) (map recurse vals))
+ ,@(recurse-body body)))
+
+ ((<fix> gensyms vals body)
+ ;; not a typo, we really do translate back to letrec. use letrec* since it
+ ;; doesn't matter, and the naive letrec* transformation does not require an
+ ;; inner let.
+ `(letrec* ,(map list (map output-name gensyms) (map recurse vals))
+ ,@(recurse-body body)))
- ((<let-values> exp body)
- `(call-with-values (lambda () ,(tree-il->scheme exp))
- ,(tree-il->scheme (make-lambda #f '() body))))
+ ((<let-values> exp body)
+ `(call-with-values (lambda () ,@(recurse-body exp))
+ ,(recurse (make-lambda #f '() body))))
- ((<dynwind> body winder unwinder)
- `(dynamic-wind ,(tree-il->scheme winder)
- (lambda () ,(tree-il->scheme body))
- ,(tree-il->scheme unwinder)))
+ ((<dynwind> body winder unwinder)
+ `(dynamic-wind ,(recurse winder)
+ (lambda () ,@(recurse-body body))
+ ,(recurse unwinder)))
- ((<dynlet> fluids vals body)
- `(with-fluids ,(map list
- (map tree-il->scheme fluids)
- (map tree-il->scheme vals))
- ,(tree-il->scheme body)))
+ ((<dynlet> fluids vals body)
+ `(with-fluids ,(map list
+ (map recurse fluids)
+ (map recurse vals))
+ ,@(recurse-body body)))
- ((<dynref> fluid)
- `(fluid-ref ,(tree-il->scheme fluid)))
+ ((<dynref> fluid)
+ `(fluid-ref ,(recurse fluid)))
- ((<dynset> fluid exp)
- `(fluid-set! ,(tree-il->scheme fluid) ,(tree-il->scheme exp)))
+ ((<dynset> fluid exp)
+ `(fluid-set! ,(recurse fluid) ,(recurse exp)))
- ((<prompt> tag body handler)
- `(call-with-prompt
- ,(tree-il->scheme tag)
- (lambda () ,(tree-il->scheme body))
- ,(tree-il->scheme handler)))
+ ((<prompt> tag body handler)
+ `(call-with-prompt
+ ,(recurse tag)
+ (lambda () ,@(recurse-body body))
+ ,(recurse handler)))
- ((<abort> tag args tail)
- `(apply abort ,(tree-il->scheme tag) ,@(map tree-il->scheme args)
- ,(tree-il->scheme tail)))))
+ ((<abort> tag args tail)
+ `(apply abort ,(recurse tag) ,@(map recurse args)
+ ,(recurse tail))))))))
(define (tree-il-fold leaf down up seed tree)
@@ -792,3 +884,252 @@ This is an implementation of `foldts' as described by Andy Wingo in
(else #f))
x)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Algorithm for choosing better variable names
+;; ============================================
+;;
+;; First we perform an analysis pass, collecting the following
+;; information:
+;;
+;; * For each gensym: how many occurrences will occur in the output?
+;;
+;; * For each gensym A: which gensyms does A conflict with? Gensym A and
+;; gensym B conflict if they have the same source name, and if giving
+;; them the same name would cause a bad variable reference due to
+;; unintentional variable capture.
+;;
+;; The occurrence counter is indexed by gensym and is global (within each
+;; invocation of the algorithm), implemented using a hash table. We also
+;; keep a global mapping from gensym to source name as provided by the
+;; binding construct (we prefer not to trust the source names in the
+;; lexical ref or set).
+;;
+;; As we recurse down into lexical binding forms, we keep track of a
+;; mapping from source name to an ordered list of bindings, innermost
+;; first. When we encounter a variable occurrence, we increment the
+;; counter, map to source name (preferring not to trust the 'name' in
+;; the lexical ref or set), and then look up the bindings currently in
+;; effect for that source name. Hopefully our gensym will be the first
+;; (innermost) binding. If not, we register a conflict between the
+;; referenced gensym and the other bound gensyms with the same source
+;; name that shadow the one we want. These are simply the gensyms on
+;; the binding list that come before our gensym.
+;;
+;; Top-level variables are treated specially. Whenever they occur, they
+;; register a conflict with every lexical binding currently in effect
+;; with the same source name. They are guaranteed to be assigned to
+;; their source names.
+;;
+;; XXX FIXME: Currently, primitives are treated exactly like top-level
+;; bindings. This handles conflicting lexical bindings properly, but
+;; does _not_ handle the case where top-level bindings conflict with the
+;; needed primitives.
+;;
+;; Also note that this requires that 'choose-output-names' be kept in
+;; sync with 'tree-il->scheme'. Primitives that are introduced by
+;; 'tree-il->scheme' must be anticipated by 'choose-output-name'.
+;;
+;;
+;; How we assign an output name to each gensym
+;; ===========================================
+;;
+;; We process the gensyms in order of decreasing occurrence count, with
+;; each gensym choosing the best output name possible, as long as it
+;; isn't the same name as any of the previously-chosen output names of
+;; conflicting gensyms.
+;;
+
+
+;;
+;; 'choose-output-names' analyzes the top-level form e, chooses good
+;; variable names that are as close as possible to the source names,
+;; and returns two values:
+;;
+;; * a hash table mapping gensym to output name
+;; * a hash table mapping gensym to number of occurrences
+;;
+(define (choose-output-names e use-derived-syntax?)
+ (define gensyms '())
+
+ (define occurrence-count-table (make-hash-table))
+ (define (occurrence-count s) (or (hashq-ref occurrence-count-table s) 0))
+ (define (increment-occurrence-count! s)
+ (let ((h (hashq-create-handle! occurrence-count-table s 0)))
+ (if (zero? (cdr h))
+ (set! gensyms (cons s gensyms)))
+ (set-cdr! h (+ 1 (cdr h)))))
+
+ (define source-name-table (make-hash-table))
+ (define (set-source-name! s name) (hashq-set! source-name-table s name))
+ (define (source-name s)
+ (if (pair? s) (cdr s) (hashq-ref source-name-table s)))
+
+ (define conflict-table (make-hash-table))
+ (define (conflicts s) (or (hashq-ref conflict-table s) '()))
+ (define (add-conflict! a b)
+ (define (add! a b)
+ (if (not (pair? a))
+ (let ((h (hashq-create-handle! conflict-table a '())))
+ (if (not (memq b (cdr h)))
+ (set-cdr! h (cons b (cdr h)))))))
+ (add! a b)
+ (add! b a))
+
+ (define top-level-intern!
+ (let ((table (make-hash-table)))
+ (lambda (name)
+ (cdr (hashq-create-handle! table name (cons 'top-level name))))))
+
+ (let recurse-with-bindings ((e e) (bindings vlist-null))
+ (let recurse ((e e))
+
+ (define done #t)
+
+ (define (top-level name)
+ (let ((s (top-level-intern! name))
+ (conflicts (vhash-foldq* cons '() name bindings)))
+ (for-each (cut add-conflict! s <>) conflicts)))
+
+ ;; XXX FIXME: Currently, primitives are treated exactly like
+ ;; top-level bindings. This handles conflicting lexical bindings
+ ;; properly, but does _not_ handle the case where top-level
+ ;; bindings conflict with the needed primitives.
+ (define (primitive name) (top-level name))
+
+ (define (lexical s)
+ (increment-occurrence-count! s)
+ (let ((conflicts
+ (take-while (lambda (s*) (not (eq? s s*)))
+ (reverse!
+ (vhash-foldq*
+ cons '() (source-name s) bindings)))))
+ (for-each (cut add-conflict! s <>) conflicts)))
+
+ (record-case e
+ ((<void>) (primitive 'if))
+ ((<const>) done)
+
+ ((<application> proc args)
+ (for-each recurse (cons proc args)))
+
+ ((<primitive-ref> name) (primitive name))
+
+ ((<lexical-ref> gensym) (lexical gensym))
+ ((<lexical-set> gensym exp)
+ (primitive 'set!) (lexical gensym) (recurse exp))
+
+ ((<module-ref> public?) (primitive (if public? '@ '@@)))
+ ((<module-set> public? exp)
+ (primitive 'set!) (primitive (if public? '@ '@@)) (recurse exp))
+
+ ((<toplevel-ref> name) (top-level name))
+ ((<toplevel-set> name exp) (top-level name) (recurse exp))
+ ((<toplevel-define> name exp) (top-level name) (recurse exp))
+
+ ((<conditional> test consequent alternate)
+ (define (false? e) (and (const? e) (eq? #f (const-exp e))))
+ (cond ((and use-derived-syntax? (false? alternate))
+ (primitive 'and))
+ ((and use-derived-syntax? (conditional? alternate))
+ (primitive 'cond)
+ (primitive 'else)))
+ (primitive 'if)
+ (recurse test) (recurse consequent) (recurse alternate))
+
+ ((<sequence> exps) (primitive 'begin) (for-each recurse exps))
+ ((<lambda> body) (recurse body))
+
+ ((<lambda-case> req opt rest kw inits gensyms body alternate)
+ (primitive 'lambda)
+ (cond ((or opt kw alternate)
+ (primitive 'lambda*)
+ (primitive 'case-lambda)))
+ (let* ((names (append req (or opt '()) (if rest (list rest) '())
+ (map cadr (if kw (cdr kw) '()))))
+ (body-bindings (fold vhash-consq bindings names gensyms)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (for-each recurse inits)
+ (recurse-with-bindings body body-bindings)
+ (if alternate (recurse alternate))))
+
+ ((<let> names gensyms vals body)
+ (primitive 'let)
+ (cond (use-derived-syntax? (primitive 'let*) (primitive 'or)))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (for-each recurse vals)
+ (recurse-with-bindings body (fold vhash-consq bindings names gensyms)))
+
+ ((<letrec> in-order? names gensyms vals body)
+ (primitive (if in-order? 'letrec* 'letrec))
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (let ((bindings (fold vhash-consq bindings names gensyms)))
+ (for-each (cut recurse-with-bindings <> bindings) vals)
+ (recurse-with-bindings body bindings)))
+
+ ((<fix> names gensyms vals body)
+ (primitive 'letrec*)
+ (for-each increment-occurrence-count! gensyms)
+ (for-each set-source-name! gensyms names)
+ (let ((bindings (fold vhash-consq bindings names gensyms)))
+ (for-each (cut recurse-with-bindings <> bindings) vals)
+ (recurse-with-bindings body bindings)))
+
+ ((<let-values> exp body)
+ (primitive 'call-with-values)
+ (recurse exp) (recurse body))
+
+ ((<dynwind> winder body unwinder)
+ (primitive 'dynamic-wind)
+ (recurse winder) (recurse body) (recurse unwinder))
+
+ ((<dynlet> fluids vals body)
+ (primitive 'with-fluids)
+ (for-each recurse fluids)
+ (for-each recurse vals)
+ (recurse body))
+
+ ((<dynref> fluid) (primitive 'fluid-ref) (recurse fluid))
+ ((<dynset> fluid exp)
+ (primitive 'fluid-set!) (recurse fluid) (recurse exp))
+
+ ((<prompt> tag body handler)
+ (primitive 'call-with-prompt)
+ (primitive 'lambda)
+ (recurse tag) (recurse body) (recurse handler))
+
+ ((<abort> tag args tail)
+ (primitive 'apply)
+ (primitive 'abort)
+ (recurse tag) (for-each recurse args) (recurse tail)))))
+
+ (let ()
+ (define output-name-table (make-hash-table))
+ (define (set-output-name! s name) (hashq-set! output-name-table s name))
+ (define (output-name s)
+ (if (pair? s) (cdr s) (hashq-ref output-name-table s)))
+
+ (define sorted-gensyms
+ (sort-list gensyms (lambda (a b) (> (occurrence-count a)
+ (occurrence-count b)))))
+
+ (for-each (lambda (s)
+ (let* ((conflicts (conflicts s))
+ (sname (source-name s))
+ (prefix (string-append (symbol->string sname) "-")))
+ (let loop ((i 1) (name sname))
+ (if (any (lambda (s*)
+ (and=> (output-name s*)
+ (cut eq? name <>)))
+ conflicts)
+ (loop (+ i 1)
+ (string->symbol (string-append
+ prefix
+ (number->string i))))
+ (set-output-name! s name)))))
+ sorted-gensyms)
+ (values output-name-table occurrence-count-table)))
--
1.7.5.4
