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