fix-letrec.scm 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315
  1. ;;; transformation of letrec into simpler forms
  2. ;; Copyright (C) 2009-2013,2016,2019,2021,2023 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. (define-module (language tree-il fix-letrec)
  17. #:use-module (srfi srfi-1)
  18. #:use-module (srfi srfi-11)
  19. #:use-module (ice-9 match)
  20. #:use-module (language tree-il)
  21. #:use-module (language tree-il effects)
  22. #:use-module (language cps graphs)
  23. #:use-module (language cps intmap)
  24. #:use-module (language cps intset)
  25. #:export (fix-letrec))
  26. ;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
  27. ;; Efficient Implementation of Scheme's Recursive Binding Construct", by
  28. ;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig, as well as
  29. ;; "Fixing Letrec (reloaded)", by Abdulaziz Ghuloum and R. Kent Dybvig.
  30. (define fix-fold (make-tree-il-folder))
  31. (define (analyze-lexicals x)
  32. (define referenced (make-hash-table))
  33. (define assigned (make-hash-table))
  34. ;; Functional hash sets would be nice.
  35. (fix-fold x
  36. (match-lambda
  37. (($ <lexical-ref> src name gensym)
  38. (hashq-set! referenced gensym #t)
  39. (values))
  40. (($ <lexical-set> src name gensym)
  41. (hashq-set! assigned gensym #t)
  42. (values))
  43. (_
  44. (values)))
  45. (lambda (x)
  46. (values)))
  47. (values referenced assigned))
  48. (define (make-seq* src head tail)
  49. (match head
  50. ((or ($ <lambda>) ($ <const>) ($ <lexical-ref>) ($ <void>)) tail)
  51. (else (make-seq src head tail))))
  52. (define (free-variables expr cache)
  53. (define (adjoin elt set)
  54. (lset-adjoin eq? set elt))
  55. (define (union set1 set2)
  56. (lset-union eq? set1 set2))
  57. (define (difference set1 set2)
  58. (lset-difference eq? set1 set2))
  59. (define fix-fold (make-tree-il-folder))
  60. (define (recurse expr)
  61. (free-variables expr cache))
  62. (define (recurse* exprs)
  63. (fold (lambda (expr free)
  64. (union (recurse expr) free))
  65. '()
  66. exprs))
  67. (define (visit expr)
  68. (match expr
  69. ((or ($ <void>) ($ <const>) ($ <primitive-ref>)
  70. ($ <module-ref>) ($ <toplevel-ref>))
  71. '())
  72. (($ <lexical-ref> src name gensym)
  73. (list gensym))
  74. (($ <lexical-set> src name gensym exp)
  75. (adjoin gensym (recurse exp)))
  76. (($ <module-set> src mod name public? exp)
  77. (recurse exp))
  78. (($ <toplevel-set> src mod name exp)
  79. (recurse exp))
  80. (($ <toplevel-define> src mod name exp)
  81. (recurse exp))
  82. (($ <conditional> src test consequent alternate)
  83. (union (recurse test)
  84. (union (recurse consequent)
  85. (recurse alternate))))
  86. (($ <call> src proc args)
  87. (recurse* (cons proc args)))
  88. (($ <primcall> src name args)
  89. (recurse* args))
  90. (($ <seq> src head tail)
  91. (union (recurse head)
  92. (recurse tail)))
  93. (($ <lambda> src meta body)
  94. (recurse body))
  95. (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
  96. (union (difference (union (recurse* inits)
  97. (recurse body))
  98. gensyms)
  99. (if alternate
  100. (recurse alternate)
  101. '())))
  102. (($ <let> src names gensyms vals body)
  103. (union (recurse* vals)
  104. (difference (recurse body)
  105. gensyms)))
  106. (($ <letrec> src in-order? names gensyms vals body)
  107. (difference (union (recurse* vals)
  108. (recurse body))
  109. gensyms))
  110. (($ <fix> src names gensyms vals body)
  111. (difference (union (recurse* vals)
  112. (recurse body))
  113. gensyms))
  114. (($ <let-values> src exp body)
  115. (union (recurse exp)
  116. (recurse body)))
  117. (($ <prompt> src escape-only? tag body handler)
  118. (union (recurse tag)
  119. (union (recurse body)
  120. (recurse handler))))
  121. (($ <abort> src tag args tail)
  122. (union (recurse tag)
  123. (union (recurse* args)
  124. (recurse tail))))))
  125. (or (hashq-ref cache expr)
  126. (let ((res (visit expr)))
  127. (hashq-set! cache expr res)
  128. res)))
  129. (define (enumerate elts)
  130. (fold2 (lambda (x out id)
  131. (values (intmap-add out id x) (1+ id)))
  132. elts empty-intmap 0))
  133. (define (compute-complex id->sym id->init assigned)
  134. (define compute-effects
  135. (make-effects-analyzer (lambda (x) (hashq-ref assigned x))))
  136. (intmap-fold
  137. (lambda (id sym complex)
  138. (if (or (hashq-ref assigned sym)
  139. (let ((effects (compute-effects (intmap-ref id->init id))))
  140. (not (constant? (exclude-effects effects &allocation)))))
  141. (intset-add complex id)
  142. complex))
  143. id->sym empty-intset))
  144. (define (compute-sccs names syms inits in-order? fv-cache assigned)
  145. (define id->name (enumerate names))
  146. (define id->sym (enumerate syms))
  147. (define id->init (enumerate inits))
  148. (define sym->id (intmap-fold (lambda (id sym out) (acons sym id out))
  149. id->sym '()))
  150. (define (var-list->intset vars)
  151. (fold1 (lambda (sym out)
  152. (intset-add out (assq-ref sym->id sym)))
  153. vars empty-intset))
  154. (define (free-in-init init)
  155. (var-list->intset
  156. (lset-intersection eq? syms (free-variables init fv-cache))))
  157. (define fv-edges
  158. (fold2 (lambda (init fv i)
  159. (values
  160. (intmap-add fv i (free-in-init init))
  161. (1+ i)))
  162. inits empty-intmap 0))
  163. (define order-edges
  164. (if in-order?
  165. (let ((complex (compute-complex id->sym id->init assigned)))
  166. (intmap-fold (lambda (id sym out prev)
  167. (values
  168. (intmap-add out id (intset-intersect complex prev))
  169. (intset-add prev id)))
  170. id->sym empty-intmap empty-intset))
  171. empty-intmap))
  172. (define sccs
  173. (reverse
  174. (compute-sorted-strongly-connected-components
  175. (invert-graph (intmap-union fv-edges order-edges intset-union)))))
  176. (map (lambda (ids)
  177. (intset-fold-right (lambda (id out)
  178. (cons (list (intmap-ref id->name id)
  179. (intmap-ref id->sym id)
  180. (intmap-ref id->init id))
  181. out))
  182. ids '()))
  183. sccs))
  184. (define (fix-scc src binds body fv-cache referenced assigned)
  185. (match binds
  186. (((name sym init))
  187. ;; Case of an SCC containing just a single binding.
  188. (cond
  189. ((not (hashq-ref referenced sym))
  190. (make-seq* src init body))
  191. ((and (lambda? init) (not (hashq-ref assigned sym)))
  192. (make-fix src (list name) (list sym) (list init) body))
  193. ((memq sym (free-variables init fv-cache))
  194. (make-let src (list name) (list sym) (list (make-void src))
  195. (make-seq src
  196. (make-lexical-set src name sym init)
  197. body)))
  198. (else
  199. (make-let src (list name) (list sym) (list init)
  200. body))))
  201. (_
  202. (call-with-values (lambda ()
  203. (partition
  204. (lambda (bind)
  205. (match bind
  206. ((name sym init)
  207. (and (lambda? init)
  208. (not (hashq-ref assigned sym))))))
  209. binds))
  210. (lambda (l c)
  211. (define (bind-complex-vars body)
  212. (if (null? c)
  213. body
  214. (let ((inits (map (lambda (x) (make-void #f)) c)))
  215. (make-let src (map car c) (map cadr c) inits body))))
  216. (define (bind-lambdas body)
  217. (if (null? l)
  218. body
  219. (make-fix src (map car l) (map cadr l) (map caddr l) body)))
  220. (define (initialize-complex body)
  221. (fold-right (lambda (bind body)
  222. (match bind
  223. ((name sym init)
  224. (make-seq src
  225. (make-lexical-set src name sym init)
  226. body))))
  227. body c))
  228. (bind-complex-vars
  229. (bind-lambdas
  230. (initialize-complex body))))))))
  231. (define (fix-term src in-order? names gensyms vals body
  232. fv-cache referenced assigned)
  233. (fold-right (lambda (binds body)
  234. (fix-scc src binds body fv-cache referenced assigned))
  235. body
  236. (compute-sccs names gensyms vals in-order? fv-cache
  237. assigned)))
  238. ;; For letrec*, try to minimize false dependencies introduced by
  239. ;; ordering.
  240. (define (reorder-bindings bindings)
  241. (define (possibly-references? expr bindings)
  242. (let visit ((expr expr))
  243. (match expr
  244. ((or ($ <void>) ($ <const>) ($ <primitive-ref>) ($ <module-ref>)) #f)
  245. (($ <lexical-ref> _ name var)
  246. (or-map (match-lambda (#(name var' val) (eq? var' var)))
  247. bindings))
  248. (($ <seq> _ head tail)
  249. (or (visit head) (visit tail)))
  250. (($ <primcall> _ name args) (or-map visit args))
  251. (($ <conditional> _ test consequent alternate)
  252. (or (visit test) (visit consequent) (visit alternate)))
  253. (_ #t))))
  254. (let visit ((bindings bindings) (sunk-lambdas '()) (sunk-exprs '()))
  255. (match bindings
  256. (() (append sunk-lambdas (reverse sunk-exprs)))
  257. ((binding . bindings)
  258. (match binding
  259. (#(_ _ ($ <lambda>))
  260. (visit bindings (cons binding sunk-lambdas) sunk-exprs))
  261. (#(_ _ expr)
  262. (cond
  263. ((possibly-references? expr bindings)
  264. ;; Init expression might refer to later bindings.
  265. ;; Serialize.
  266. (append sunk-lambdas (reverse sunk-exprs)
  267. (cons binding (visit bindings '() '()))))
  268. (else
  269. (visit bindings sunk-lambdas (cons binding sunk-exprs))))))))))
  270. (define (fix-letrec x)
  271. (let-values (((referenced assigned) (analyze-lexicals x)))
  272. (define fv-cache (make-hash-table))
  273. (post-order
  274. (lambda (x)
  275. (match x
  276. ;; Sets to unreferenced variables may be replaced by their
  277. ;; expression, called for effect.
  278. (($ <lexical-set> src name gensym exp)
  279. (if (hashq-ref referenced gensym)
  280. x
  281. (make-seq* #f exp (make-void #f))))
  282. (($ <letrec> src in-order? names gensyms vals body)
  283. (if in-order?
  284. (match (reorder-bindings (map vector names gensyms vals))
  285. ((#(names gensyms vals) ...)
  286. (fix-term src #t names gensyms vals body
  287. fv-cache referenced assigned)))
  288. (fix-term src #f names gensyms vals body
  289. fv-cache referenced assigned)))
  290. (($ <let> src names gensyms vals body)
  291. ;; Apply the same algorithm to <let> that binds <lambda>
  292. (if (or-map lambda? vals)
  293. (fix-term src #f names gensyms vals body
  294. fv-cache referenced assigned)
  295. x))
  296. (_ x)))
  297. x)))