letrectify.scm 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290
  1. ;;; transformation of top-level bindings into letrec*
  2. ;; Copyright (C) 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 letrectify)
  17. #:use-module ((srfi srfi-1) #:select (fold-right))
  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. #:export (letrectify))
  23. ;; Take a sequence of top-level definitions and turn the defintions into
  24. ;; letrec*. From this:
  25. ;;
  26. ;; (begin
  27. ;; (define a 10)
  28. ;; (define b (lambda () a))
  29. ;; (foo a)
  30. ;; (define c (lambda () (set! c b) (c))))
  31. ;;
  32. ;; To this:
  33. ;;
  34. ;; (letrec* ((a-var (module-make-local-var! (current-module) 'a))
  35. ;; (a 10)
  36. ;; (_ (begin (variable-set! a-var a)))
  37. ;; (b-var (module-make-local-var! (current-module) 'b))
  38. ;; (b (lambda () a))
  39. ;; (_ (begin (variable-set! b-var b)))
  40. ;; (_ (begin (foo a) #t))
  41. ;; (c-var (module-make-local-var! (current-module) 'c)))
  42. ;; (c (lambda () (variable-set! c-var b) ((variable-ref c-var))))
  43. ;; (_ (begin (variable-set! c-var c))))
  44. ;; (void))
  45. ;;
  46. ;; Inside the compilation unit, references to "declarative" top-level
  47. ;; definitions are accessed directly as lexicals. A declarative
  48. ;; definition is a variable for which the expander knows the module,
  49. ;; which is defined in the compilation unit exactly one time, and which
  50. ;; is not assigned in the compilation unit.
  51. ;;
  52. ;; The assumption is that it's safe for the compiler to reason about the
  53. ;; *values* of declarative bindings, because they are immutable in
  54. ;; practice. Of course someone can come later from another compilation
  55. ;; unit or another module and use the private module API to mutate
  56. ;; definitions from this compilation unit; in that case, updates from
  57. ;; that third party may not be visible to users of declarative
  58. ;; definitions. That kind of use is not common, though. The letrectify
  59. ;; transformation is so important for performance that most users are
  60. ;; willing to accept the restrictions of this transformation.
  61. ;;
  62. ;; Incidentally, the later fix-letrec and peval passes should optimize
  63. ;; the above example to:
  64. ;;
  65. ;; (begin
  66. ;; (variable-set! (module-make-local-var! (current-module) 'a) 10)
  67. ;; (variable-set! (module-make-local-var! (current-module) 'b)
  68. ;; (lambda () 10))
  69. ;; (foo 10)
  70. ;; (let ((c-var (module-make-local-var! (current-module) 'c)))
  71. ;; (variable-set! c-var
  72. ;; (lambda ()
  73. ;; (variable-set! c-var (lambda () 10))
  74. ;; ((variable-ref c-var))))
  75. ;; (void)))
  76. ;;
  77. ;; As you can see, letrectification allowed for inlining of the uses of
  78. ;; both A and B.
  79. ;;
  80. (define for-each-fold (make-tree-il-folder))
  81. (define (tree-il-for-each f x)
  82. (for-each-fold x (lambda (x) (f x) (values)) (lambda (x) (values))))
  83. (define (compute-declarative-toplevels x)
  84. (define dynamic (make-hash-table))
  85. (define defined (make-hash-table))
  86. (define assigned (make-hash-table))
  87. (tree-il-for-each
  88. (lambda (x)
  89. (match x
  90. (($ <toplevel-set> src mod name)
  91. (if mod
  92. (hash-set! assigned (cons mod name) #t)
  93. (hashq-set! dynamic name #t)))
  94. (($ <toplevel-define> src mod name expr)
  95. (if mod
  96. (hash-set! (if (hash-ref defined (cons mod name))
  97. assigned
  98. defined)
  99. (cons mod name) expr)
  100. (hashq-set! dynamic name #t)))
  101. (_ (values))))
  102. x)
  103. (let ((declarative (make-hash-table)))
  104. (define (declarative-module? mod)
  105. (let ((m (resolve-module mod #f #:ensure #f)))
  106. (and m (module-declarative? m))))
  107. (hash-for-each (lambda (k expr)
  108. (match k
  109. ((mod . name)
  110. (unless (or (hash-ref assigned k)
  111. (hashq-ref dynamic name)
  112. (not (declarative-module? mod)))
  113. (hash-set! declarative k expr)))))
  114. defined)
  115. declarative))
  116. (define (compute-private-toplevels declarative)
  117. ;; Set of variables exported by the modules of declarative bindings in
  118. ;; this compilation unit.
  119. (define exports (make-hash-table))
  120. ;; If a module exports a macro, that macro could implicitly export any
  121. ;; top-level binding in a module; we have to avoid sealing private
  122. ;; bindings in that case.
  123. (define exports-macro? (make-hash-table))
  124. (hash-for-each
  125. (lambda (k _)
  126. (match k
  127. ((mod . name)
  128. (unless (hash-get-handle exports-macro? mod)
  129. (hash-set! exports-macro? mod #f)
  130. (let ((i (module-public-interface (resolve-module mod))))
  131. (when i
  132. (module-for-each
  133. (lambda (k v)
  134. (hashq-set! exports v k)
  135. (when (and (variable-bound? v) (macro? (variable-ref v)))
  136. (hash-set! exports-macro? mod #t)))
  137. i)))))))
  138. declarative)
  139. (let ((private (make-hash-table)))
  140. (hash-for-each
  141. (lambda (k _)
  142. (match k
  143. ((mod . name)
  144. (unless (or (hash-ref exports-macro? mod)
  145. (hashq-ref exports
  146. (module-local-variable (resolve-module mod) name)))
  147. (hash-set! private k #t)))))
  148. declarative)
  149. private))
  150. (define* (letrectify expr #:key (seal-private-bindings? #f))
  151. (define declarative (compute-declarative-toplevels expr))
  152. (define private
  153. (if seal-private-bindings?
  154. (compute-private-toplevels declarative)
  155. (make-hash-table)))
  156. (define declarative-box+value
  157. (let ((tab (make-hash-table)))
  158. (hash-for-each (lambda (key val)
  159. (let ((box (and (not (hash-ref private key))
  160. (gensym)))
  161. (val (gensym)))
  162. (hash-set! tab key (cons box val))))
  163. declarative)
  164. (lambda (mod name)
  165. (hash-ref tab (cons mod name)))))
  166. (define compute-effects
  167. ;; Assume all lexicals are assigned, for the purposes of this
  168. ;; transformation. (It doesn't matter.)
  169. (let ((assigned? (lambda (sym) #t)))
  170. (make-effects-analyzer assigned?)))
  171. (define (can-elide-statement? stmt)
  172. (let ((effects (compute-effects stmt)))
  173. (effect-free?
  174. (exclude-effects effects (logior &allocation &zero-values)))))
  175. (define (add-binding name var val tail)
  176. (match tail
  177. (($ <letrec> src #t names vars vals tail)
  178. (make-letrec src #t
  179. (cons name names) (cons var vars) (cons val vals)
  180. tail))
  181. (_
  182. (make-letrec (tree-il-srcv tail) #t
  183. (list name) (list var) (list val)
  184. tail))))
  185. (define (add-statement src stmt tail)
  186. (if (can-elide-statement? stmt)
  187. tail
  188. (add-binding '_ (gensym "_") (make-seq src stmt (make-void src))
  189. tail)))
  190. (define (visit-expr expr)
  191. (post-order
  192. (lambda (expr)
  193. (match expr
  194. (($ <toplevel-ref> src mod name)
  195. (match (declarative-box+value mod name)
  196. (#f expr)
  197. ((box . value)
  198. (make-lexical-ref src name value))))
  199. (_ expr)))
  200. expr))
  201. (define (visit-top-level expr mod-vars)
  202. (match expr
  203. (($ <toplevel-define> src mod name exp)
  204. (match (declarative-box+value mod name)
  205. (#f (values (visit-expr expr) mod-vars))
  206. ((#f . value)
  207. (values (add-binding name value (visit-expr exp) (make-void src))
  208. mod-vars))
  209. ((box . value)
  210. (match (assoc-ref mod-vars mod)
  211. (#f
  212. (let* ((mod-var (gensym "mod"))
  213. (mod-vars (acons mod mod-var mod-vars)))
  214. (call-with-values (lambda () (visit-top-level expr mod-vars))
  215. (lambda (tail mod-vars)
  216. (values
  217. (add-binding 'mod
  218. mod-var
  219. (make-primcall src 'current-module '())
  220. tail)
  221. mod-vars)))))
  222. (mod-var
  223. (let* ((loc
  224. (make-primcall src 'module-ensure-local-variable!
  225. (list (make-lexical-ref src 'mod mod-var)
  226. (make-const src name))))
  227. (exp (visit-expr exp))
  228. (ref (make-lexical-ref src name value))
  229. (init
  230. (make-primcall src '%variable-set!
  231. (list (make-lexical-ref src name box)
  232. ref))))
  233. (values
  234. (add-binding
  235. name box loc
  236. (add-binding
  237. name value exp
  238. (add-statement src init (make-void src))))
  239. mod-vars)))))))
  240. (($ <let> src names vars vals body)
  241. (let lp ((names names) (vars vars) (vals vals) (mod-vars mod-vars))
  242. (match (vector names vars vals)
  243. (#(() () ())
  244. (values (visit-expr body) mod-vars))
  245. (#((name . names) (var . vars) (val . vals))
  246. (let* ((val (visit-expr val))
  247. (mod-vars
  248. (match val
  249. (($ <call> _
  250. ($ <module-ref> _ '(guile) 'define-module* #f)
  251. (($ <const> _ mod) . args))
  252. (acons mod var mod-vars))
  253. (_ mod-vars))))
  254. (let-values (((exp mod-vars) (lp names vars vals mod-vars)))
  255. (values (add-binding name var val exp)
  256. mod-vars)))))))
  257. (($ <seq> src head tail)
  258. (let*-values (((head mod-vars) (visit-top-level head mod-vars))
  259. ((tail mod-vars) (visit-top-level tail mod-vars)))
  260. (values (match head
  261. (($ <letrec> src2 #t names vars vals head)
  262. (fold-right add-binding (add-statement src head tail)
  263. names vars vals))
  264. (else
  265. (add-statement src head tail)))
  266. mod-vars)))
  267. ;; What would the advantages/disadvantages be if we flattened all
  268. ;; bindings here, even those from nested let/letrec?
  269. (_ (values (visit-expr expr) mod-vars))))
  270. (values (visit-top-level expr '())))