decompile-tree-il.scm 32 KB

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