Commit | Line | Data |
---|---|---|
43e67019 | 1 | ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: nil -*- |
94d11cb5 | 2 | |
d779e73c SM |
3 | ;; Copyright (C) 2011 Free Software Foundation, Inc. |
4 | ||
5 | ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> | |
6 | ;; Maintainer: FSF | |
7 | ;; Keywords: lisp | |
8 | ;; Package: emacs | |
9 | ||
10 | ;; This file is part of GNU Emacs. | |
11 | ||
12 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
13 | ;; it under the terms of the GNU General Public License as published by | |
14 | ;; the Free Software Foundation, either version 3 of the License, or | |
15 | ;; (at your option) any later version. | |
16 | ||
17 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;; GNU General Public License for more details. | |
21 | ||
22 | ;; You should have received a copy of the GNU General Public License | |
23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
94d11cb5 IK |
24 | |
25 | ;;; Commentary: | |
26 | ||
27 | ;; This takes a piece of Elisp code, and eliminates all free variables from | |
28 | ;; lambda expressions. The user entry points are cconv-closure-convert and | |
29 | ;; cconv-closure-convert-toplevel(for toplevel forms). | |
d779e73c SM |
30 | ;; All macros should be expanded beforehand. |
31 | ;; | |
32 | ;; Here is a brief explanation how this code works. | |
33 | ;; Firstly, we analyse the tree by calling cconv-analyse-form. | |
34 | ;; This function finds all mutated variables, all functions that are suitable | |
94d11cb5 IK |
35 | ;; for lambda lifting and all variables captured by closure. It passes the tree |
36 | ;; once, returning a list of three lists. | |
d779e73c SM |
37 | ;; |
38 | ;; Then we calculate the intersection of first and third lists returned by | |
39 | ;; cconv-analyse form to find all mutated variables that are captured by | |
40 | ;; closure. | |
94d11cb5 | 41 | |
d779e73c SM |
42 | ;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the |
43 | ;; tree recursivly, lifting lambdas where possible, building closures where it | |
94d11cb5 IK |
44 | ;; is needed and eliminating mutable variables used in closure. |
45 | ;; | |
46 | ;; We do following replacements : | |
47 | ;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) | |
48 | ;; if the function is suitable for lambda lifting (if all calls are known) | |
49 | ;; | |
d779e73c | 50 | ;; (lambda (v1 ...) ... fv ...) => |
94d11cb5 IK |
51 | ;; (curry (lambda (env v1 ...) ... env ...) env) |
52 | ;; if the function has only 1 free variable | |
53 | ;; | |
d779e73c SM |
54 | ;; and finally |
55 | ;; (lambda (v1 ...) ... fv1 fv2 ...) => | |
94d11cb5 | 56 | ;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2)) |
d779e73c | 57 | ;; if the function has 2 or more free variables. |
94d11cb5 IK |
58 | ;; |
59 | ;; If the function has no free variables, we don't do anything. | |
94d11cb5 | 60 | ;; |
d779e73c SM |
61 | ;; If a variable is mutated (updated by setq), and it is used in a closure |
62 | ;; we wrap it's definition with list: (list val) and we also replace | |
63 | ;; var => (car var) wherever this variable is used, and also | |
64 | ;; (setq var value) => (setcar var value) where it is updated. | |
94d11cb5 | 65 | ;; |
d779e73c SM |
66 | ;; If defun argument is closure mutable, we letbind it and wrap it's |
67 | ;; definition with list. | |
68 | ;; (defun foo (... mutable-arg ...) ...) => | |
69 | ;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) | |
94d11cb5 IK |
70 | ;; |
71 | ;;; Code: | |
72 | ||
b38b1ec0 SM |
73 | ;;; TODO: |
74 | ;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp | |
75 | ;; should turn into building corresponding byte-code function. | |
76 | ;; - don't use `curry', instead build a new compiled-byte-code object | |
77 | ;; (merge the closure env into the static constants pool). | |
78 | ;; - use relative addresses for byte-code-stack-ref. | |
79 | ;; - warn about unused lexical vars. | |
80 | ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. | |
81 | ||
94d11cb5 IK |
82 | (eval-when-compile (require 'cl)) |
83 | ||
84 | (defconst cconv-liftwhen 3 | |
d779e73c | 85 | "Try to do lambda lifting if the number of arguments + free variables |
94d11cb5 | 86 | is less than this number.") |
d779e73c | 87 | (defvar cconv-mutated nil |
94d11cb5 | 88 | "List of mutated variables in current form") |
d779e73c | 89 | (defvar cconv-captured nil |
94d11cb5 | 90 | "List of closure captured variables in current form") |
d779e73c | 91 | (defvar cconv-captured+mutated nil |
94d11cb5 | 92 | "An intersection between cconv-mutated and cconv-captured lists.") |
d779e73c | 93 | (defvar cconv-lambda-candidates nil |
43e67019 SM |
94 | "List of candidates for lambda lifting. |
95 | Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).") | |
96 | ||
94d11cb5 IK |
97 | (defun cconv-freevars (form &optional fvrs) |
98 | "Find all free variables of given form. | |
99 | Arguments: | |
100 | -- FORM is a piece of Elisp code after macroexpansion. | |
101 | -- FVRS(optional) is a list of variables already found. Used for recursive tree | |
102 | traversal | |
103 | ||
104 | Returns a list of free variables." | |
105 | ;; If a leaf in the tree is a symbol, but it is not a global variable, not a | |
106 | ;; keyword, not 'nil or 't we consider this leaf as a variable. | |
107 | ;; Free variables are the variables that are not declared above in this tree. | |
d779e73c | 108 | ;; For example free variables of (lambda (a1 a2 ..) body-forms) are |
94d11cb5 | 109 | ;; free variables of body-forms excluding a1, a2 .. |
d779e73c | 110 | ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are |
94d11cb5 | 111 | ;; free variables of body-forms excluding v1, v2 ... |
d779e73c | 112 | ;; and so on. |
94d11cb5 | 113 | |
d779e73c | 114 | ;; A list of free variables already found(FVRS) is passed in parameter |
94d11cb5 | 115 | ;; to try to use cons or push where possible, and to minimize the usage |
d779e73c | 116 | ;; of append. |
94d11cb5 | 117 | |
d779e73c | 118 | ;; This function can return duplicates (because we use 'append instead |
94d11cb5 IK |
119 | ;; of union of two sets - for performance reasons). |
120 | (pcase form | |
d779e73c SM |
121 | (`(let ,varsvalues . ,body-forms) ; let special form |
122 | (let ((fvrs-1 '())) | |
123 | (dolist (exp body-forms) | |
124 | (setq fvrs-1 (cconv-freevars exp fvrs-1))) | |
125 | (dolist (elm varsvalues) | |
126 | (setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1))) | |
127 | (setq fvrs (nconc fvrs-1 fvrs)) | |
128 | (dolist (exp varsvalues) | |
129 | (when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs)))) | |
130 | fvrs)) | |
131 | ||
132 | (`(let* ,varsvalues . ,body-forms) ; let* special form | |
133 | (let ((vrs '()) | |
134 | (fvrs-1 '())) | |
135 | (dolist (exp varsvalues) | |
136 | (if (consp exp) | |
137 | (progn | |
138 | (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)) | |
139 | (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) | |
140 | (push (car exp) vrs)) | |
141 | (progn | |
142 | (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) | |
143 | (push exp vrs)))) | |
144 | (dolist (exp body-forms) | |
145 | (setq fvrs-1 (cconv-freevars exp fvrs-1))) | |
146 | (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) | |
147 | (append fvrs fvrs-1))) | |
148 | ||
149 | (`((lambda . ,_) . ,_) ; first element is lambda expression | |
150 | (dolist (exp `((function ,(car form)) . ,(cdr form))) | |
151 | (setq fvrs (cconv-freevars exp fvrs))) fvrs) | |
152 | ||
153 | (`(cond . ,cond-forms) ; cond special form | |
154 | (dolist (exp1 cond-forms) | |
155 | (dolist (exp2 exp1) | |
156 | (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs) | |
157 | ||
158 | (`(quote . ,_) fvrs) ; quote form | |
159 | ||
160 | (`(function . ((lambda ,vars . ,body-forms))) | |
161 | (let ((functionform (cadr form)) (fvrs-1 '())) | |
162 | (dolist (exp body-forms) | |
163 | (setq fvrs-1 (cconv-freevars exp fvrs-1))) | |
164 | (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1))) | |
165 | (append fvrs fvrs-1))) ; function form | |
166 | ||
167 | (`(function . ,_) fvrs) ; same as quote | |
94d11cb5 | 168 | ;condition-case |
d779e73c SM |
169 | (`(condition-case ,var ,protected-form . ,conditions-bodies) |
170 | (let ((fvrs-1 '())) | |
171 | (dolist (exp conditions-bodies) | |
172 | (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))) | |
173 | (setq fvrs-1 (delq var fvrs-1)) | |
174 | (setq fvrs-1 (cconv-freevars protected-form fvrs-1)) | |
175 | (append fvrs fvrs-1))) | |
176 | ||
177 | (`(,(and sym (or `defun `defconst `defvar)) . ,_) | |
43e67019 | 178 | ;; We call cconv-freevars only for functions(lambdas) |
d779e73c | 179 | ;; defun, defconst, defvar are not allowed to be inside |
43e67019 SM |
180 | ;; a function (lambda). |
181 | ;; FIXME: should be a byte-compile-report-error! | |
d779e73c SM |
182 | (error "Invalid form: %s inside a function" sym)) |
183 | ||
43e67019 | 184 | (`(,_ . ,body-forms) ; First element is (like) a function. |
d779e73c SM |
185 | (dolist (exp body-forms) |
186 | (setq fvrs (cconv-freevars exp fvrs))) fvrs) | |
187 | ||
ce5b520a | 188 | (_ (if (byte-compile-not-lexical-var-p form) |
d779e73c SM |
189 | fvrs |
190 | (cons form fvrs))))) | |
94d11cb5 IK |
191 | |
192 | ;;;###autoload | |
295fb2ac SM |
193 | (defun cconv-closure-convert (form) |
194 | "Main entry point for closure conversion. | |
94d11cb5 IK |
195 | -- FORM is a piece of Elisp code after macroexpansion. |
196 | -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST | |
197 | ||
198 | Returns a form where all lambdas don't have any free variables." | |
b38b1ec0 | 199 | ;; (message "Entering cconv-closure-convert...") |
94d11cb5 IK |
200 | (let ((cconv-mutated '()) |
201 | (cconv-lambda-candidates '()) | |
202 | (cconv-captured '()) | |
d779e73c | 203 | (cconv-captured+mutated '())) |
b38b1ec0 | 204 | ;; Analyse form - fill these variables with new information. |
43e67019 | 205 | (cconv-analyse-form form '() 0) |
b38b1ec0 | 206 | ;; Calculate an intersection of cconv-mutated and cconv-captured. |
d779e73c SM |
207 | (dolist (mvr cconv-mutated) |
208 | (when (memq mvr cconv-captured) ; | |
209 | (push mvr cconv-captured+mutated))) | |
210 | (cconv-closure-convert-rec | |
211 | form ; the tree | |
212 | '() ; | |
213 | '() ; fvrs initially empty | |
214 | '() ; envs initially empty | |
94d11cb5 | 215 | '() |
295fb2ac | 216 | ))) |
94d11cb5 | 217 | |
295fb2ac SM |
218 | (defun cconv-lookup-let (table var binder form) |
219 | (let ((res nil)) | |
220 | (dolist (elem table) | |
221 | (when (and (eq (nth 2 elem) binder) | |
222 | (eq (nth 3 elem) form)) | |
223 | (assert (eq (car elem) var)) | |
224 | (setq res elem))) | |
225 | res)) | |
94d11cb5 | 226 | |
295fb2ac | 227 | (defconst cconv--dummy-var (make-symbol "ignored")) |
b38b1ec0 SM |
228 | (defconst cconv--env-var (make-symbol "env")) |
229 | ||
230 | (defun cconv--set-diff (s1 s2) | |
231 | "Return elements of set S1 that are not in set S2." | |
232 | (let ((res '())) | |
233 | (dolist (x s1) | |
234 | (unless (memq x s2) (push x res))) | |
235 | (nreverse res))) | |
236 | ||
237 | (defun cconv--set-diff-map (s m) | |
238 | "Return elements of set S that are not in Dom(M)." | |
239 | (let ((res '())) | |
240 | (dolist (x s) | |
241 | (unless (assq x m) (push x res))) | |
242 | (nreverse res))) | |
243 | ||
244 | (defun cconv--map-diff (m1 m2) | |
245 | "Return the submap of map M1 that has Dom(M2) removed." | |
246 | (let ((res '())) | |
247 | (dolist (x m1) | |
248 | (unless (assq (car x) m2) (push x res))) | |
249 | (nreverse res))) | |
250 | ||
251 | (defun cconv--map-diff-elem (m x) | |
252 | "Return the map M minus any mapping for X." | |
253 | ;; Here we assume that X appears at most once in M. | |
254 | (let* ((b (assq x m)) | |
255 | (res (if b (remq b m) m))) | |
256 | (assert (null (assq x res))) ;; Check the assumption was warranted. | |
257 | res)) | |
94d11cb5 | 258 | |
b38b1ec0 SM |
259 | (defun cconv--map-diff-set (m s) |
260 | "Return the map M minus any mapping for elements of S." | |
261 | ;; Here we assume that X appears at most once in M. | |
262 | (let ((res '())) | |
263 | (dolist (b m) | |
264 | (unless (memq (car b) s) (push b res))) | |
265 | (nreverse res))) | |
266 | ||
267 | (defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs) | |
d779e73c | 268 | ;; This function actually rewrites the tree. |
94d11cb5 IK |
269 | "Eliminates all free variables of all lambdas in given forms. |
270 | Arguments: | |
271 | -- FORM is a piece of Elisp code after macroexpansion. | |
b38b1ec0 | 272 | -- LMENVS is a list of environments used for lambda-lifting. Initially empty. |
94d11cb5 IK |
273 | -- EMVRS is a list that contains mutated variables that are visible |
274 | within current environment. | |
d779e73c SM |
275 | -- ENVS is an environment(list of free variables) of current closure. |
276 | Initially empty. | |
277 | -- FVRS is a list of variables to substitute in each context. | |
278 | Initially empty. | |
94d11cb5 IK |
279 | |
280 | Returns a form where all lambdas don't have any free variables." | |
d779e73c | 281 | ;; What's the difference between fvrs and envs? |
94d11cb5 IK |
282 | ;; Suppose that we have the code |
283 | ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) | |
d779e73c SM |
284 | ;; only the first occurrence of fvr should be replaced by |
285 | ;; (aref env ...). | |
94d11cb5 IK |
286 | ;; So initially envs and fvrs are the same thing, but when we descend to |
287 | ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? | |
288 | ;; Because in envs the order of variables is important. We use this list | |
d779e73c SM |
289 | ;; to find the number of a specific variable in the environment vector, |
290 | ;; so we never touch it(unless we enter to the other closure). | |
291 | ;;(if (listp form) (print (car form)) form) | |
292 | (pcase form | |
295fb2ac | 293 | (`(,(and letsym (or `let* `let)) ,binders . ,body-forms) |
94d11cb5 IK |
294 | |
295 | ; let and let* special forms | |
d779e73c | 296 | (let ((body-forms-new '()) |
295fb2ac | 297 | (binders-new '()) |
d779e73c SM |
298 | ;; next for variables needed for delayed push |
299 | ;; because we should process <value(s)> | |
300 | ;; before we change any arguments | |
301 | (lmenvs-new '()) ;needed only in case of let | |
302 | (emvrs-new '()) ;needed only in case of let | |
303 | (emvr-push) ;needed only in case of let* | |
304 | (lmenv-push)) ;needed only in case of let* | |
305 | ||
295fb2ac SM |
306 | (dolist (binder binders) |
307 | (let* ((value nil) | |
308 | (var (if (not (consp binder)) | |
309 | binder | |
310 | (setq value (cadr binder)) | |
311 | (car binder))) | |
312 | (new-val | |
313 | (cond | |
314 | ;; Check if var is a candidate for lambda lifting. | |
315 | ((cconv-lookup-let cconv-lambda-candidates var binder form) | |
316 | ||
317 | (let* ((fv (delete-dups (cconv-freevars value '()))) | |
318 | (funargs (cadr (cadr value))) | |
319 | (funcvars (append fv funargs)) | |
320 | (funcbodies (cddadr value)) ; function bodies | |
321 | (funcbodies-new '())) | |
94d11cb5 | 322 | ; lambda lifting condition |
295fb2ac | 323 | (if (or (not fv) (< cconv-liftwhen (length funcvars))) |
94d11cb5 | 324 | ; do not lift |
295fb2ac SM |
325 | (cconv-closure-convert-rec |
326 | value emvrs fvrs envs lmenvs) | |
94d11cb5 | 327 | ; lift |
295fb2ac SM |
328 | (progn |
329 | (dolist (elm2 funcbodies) | |
330 | (push ; convert function bodies | |
331 | (cconv-closure-convert-rec | |
332 | elm2 emvrs nil envs lmenvs) | |
333 | funcbodies-new)) | |
334 | (if (eq letsym 'let*) | |
335 | (setq lmenv-push (cons var fv)) | |
336 | (push (cons var fv) lmenvs-new)) | |
94d11cb5 IK |
337 | ; push lifted function |
338 | ||
295fb2ac SM |
339 | `(function . |
340 | ((lambda ,funcvars . | |
341 | ,(reverse funcbodies-new)))))))) | |
342 | ||
343 | ;; Check if it needs to be turned into a "ref-cell". | |
344 | ((cconv-lookup-let cconv-captured+mutated var binder form) | |
345 | ;; Declared variable is mutated and captured. | |
346 | (prog1 | |
347 | `(list ,(cconv-closure-convert-rec | |
348 | value emvrs | |
349 | fvrs envs lmenvs)) | |
d779e73c SM |
350 | (if (eq letsym 'let*) |
351 | (setq emvr-push var) | |
295fb2ac SM |
352 | (push var emvrs-new)))) |
353 | ||
354 | ;; Normal default case. | |
355 | (t | |
356 | (cconv-closure-convert-rec | |
357 | value emvrs fvrs envs lmenvs))))) | |
d779e73c SM |
358 | |
359 | ;; this piece of code below letbinds free | |
360 | ;; variables of a lambda lifted function | |
361 | ;; if they are redefined in this let | |
362 | ;; example: | |
363 | ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) | |
364 | ;; Here we can not pass y as parameter because it is | |
365 | ;; redefined. We add a (closed-y y) declaration. | |
366 | ;; We do that even if the function is not used inside | |
367 | ;; this let(*). The reason why we ignore this case is | |
368 | ;; that we can't "look forward" to see if the function | |
369 | ;; is called there or not. To treat well this case we | |
370 | ;; need to traverse the tree one more time to collect this | |
371 | ;; data, and I think that it's not worth it. | |
372 | ||
373 | (when (eq letsym 'let*) | |
374 | (let ((closedsym '()) | |
375 | (new-lmenv '()) | |
376 | (old-lmenv '())) | |
377 | (dolist (lmenv lmenvs) | |
378 | (when (memq var (cdr lmenv)) | |
379 | (setq closedsym | |
380 | (make-symbol | |
381 | (concat "closed-" (symbol-name var)))) | |
382 | (setq new-lmenv (list (car lmenv))) | |
383 | (dolist (frv (cdr lmenv)) (if (eq frv var) | |
384 | (push closedsym new-lmenv) | |
385 | (push frv new-lmenv))) | |
386 | (setq new-lmenv (reverse new-lmenv)) | |
387 | (setq old-lmenv lmenv))) | |
388 | (when new-lmenv | |
389 | (setq lmenvs (remq old-lmenv lmenvs)) | |
390 | (push new-lmenv lmenvs) | |
295fb2ac | 391 | (push `(,closedsym ,var) binders-new)))) |
b38b1ec0 SM |
392 | ;; We push the element after redefined free variables are |
393 | ;; processed. This is important to avoid the bug when free | |
394 | ;; variable and the function have the same name. | |
295fb2ac | 395 | (push (list var new-val) binders-new) |
d779e73c SM |
396 | |
397 | (when (eq letsym 'let*) ; update fvrs | |
398 | (setq fvrs (remq var fvrs)) | |
399 | (setq emvrs (remq var emvrs)) ; remove if redefined | |
400 | (when emvr-push | |
401 | (push emvr-push emvrs) | |
402 | (setq emvr-push nil)) | |
b38b1ec0 | 403 | (setq lmenvs (cconv--map-diff-elem lmenvs var)) |
d779e73c SM |
404 | (when lmenv-push |
405 | (push lmenv-push lmenvs) | |
406 | (setq lmenv-push nil))) | |
295fb2ac | 407 | )) ; end of dolist over binders |
d779e73c SM |
408 | (when (eq letsym 'let) |
409 | ||
410 | (let (var fvrs-1 emvrs-1 lmenvs-1) | |
411 | ;; Here we update emvrs, fvrs and lmenvs lists | |
b38b1ec0 SM |
412 | (setq fvrs (cconv--set-diff-map fvrs binders-new)) |
413 | (setq emvrs (cconv--set-diff-map emvrs binders-new)) | |
d779e73c | 414 | (setq emvrs (append emvrs emvrs-new)) |
b38b1ec0 | 415 | (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) |
d779e73c SM |
416 | (setq lmenvs (append lmenvs lmenvs-new))) |
417 | ||
418 | ;; Here we do the same letbinding as for let* above | |
419 | ;; to avoid situation when a free variable of a lambda lifted | |
420 | ;; function got redefined. | |
421 | ||
422 | (let ((new-lmenv) | |
423 | (var nil) | |
424 | (closedsym nil) | |
295fb2ac SM |
425 | (letbinds '())) |
426 | (dolist (binder binders) | |
427 | (setq var (if (consp binder) (car binder) binder)) | |
d779e73c SM |
428 | |
429 | (let ((lmenvs-1 lmenvs)) ; just to avoid manipulating | |
430 | (dolist (lmenv lmenvs-1) ; the counter inside the loop | |
431 | (when (memq var (cdr lmenv)) | |
432 | (setq closedsym (make-symbol | |
433 | (concat "closed-" | |
434 | (symbol-name var)))) | |
435 | ||
436 | (setq new-lmenv (list (car lmenv))) | |
b38b1ec0 SM |
437 | (dolist (frv (cdr lmenv)) |
438 | (push (if (eq frv var) closedsym frv) | |
439 | new-lmenv)) | |
d779e73c SM |
440 | (setq new-lmenv (reverse new-lmenv)) |
441 | (setq lmenvs (remq lmenv lmenvs)) | |
442 | (push new-lmenv lmenvs) | |
443 | (push `(,closedsym ,var) letbinds) | |
444 | )))) | |
295fb2ac | 445 | (setq binders-new (append binders-new letbinds)))) |
d779e73c SM |
446 | |
447 | (dolist (elm body-forms) ; convert body forms | |
448 | (push (cconv-closure-convert-rec | |
295fb2ac | 449 | elm emvrs fvrs envs lmenvs) |
d779e73c | 450 | body-forms-new)) |
295fb2ac | 451 | `(,letsym ,(reverse binders-new) . ,(reverse body-forms-new)))) |
94d11cb5 IK |
452 | ;end of let let* forms |
453 | ||
d779e73c SM |
454 | ; first element is lambda expression |
455 | (`(,(and `(lambda . ,_) fun) . ,other-body-forms) | |
456 | ||
457 | (let ((other-body-forms-new '())) | |
458 | (dolist (elm other-body-forms) | |
459 | (push (cconv-closure-convert-rec | |
295fb2ac | 460 | elm emvrs fvrs envs lmenvs) |
d779e73c | 461 | other-body-forms-new)) |
295fb2ac SM |
462 | `(funcall |
463 | ,(cconv-closure-convert-rec | |
464 | (list 'function fun) emvrs fvrs envs lmenvs) | |
465 | ,@(nreverse other-body-forms-new)))) | |
d779e73c SM |
466 | |
467 | (`(cond . ,cond-forms) ; cond special form | |
468 | (let ((cond-forms-new '())) | |
469 | (dolist (elm cond-forms) | |
470 | (push (let ((elm-new '())) | |
471 | (dolist (elm-2 elm) | |
472 | (push | |
473 | (cconv-closure-convert-rec | |
295fb2ac | 474 | elm-2 emvrs fvrs envs lmenvs) |
d779e73c SM |
475 | elm-new)) |
476 | (reverse elm-new)) | |
477 | cond-forms-new)) | |
478 | (cons 'cond | |
479 | (reverse cond-forms-new)))) | |
480 | ||
481 | (`(quote . ,_) form) ; quote form | |
482 | ||
483 | (`(function . ((lambda ,vars . ,body-forms))) ; function form | |
b38b1ec0 SM |
484 | (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. |
485 | (fv (delete-dups (cconv-freevars form '()))) | |
486 | (leave fvrs-new) ; leave=non-nil if we should leave env unchanged. | |
d779e73c SM |
487 | (body-forms-new '()) |
488 | (letbind '()) | |
489 | (mv nil) | |
490 | (envector nil)) | |
491 | (when fv | |
492 | ;; Here we form our environment vector. | |
493 | ;; If outer closure contains all | |
494 | ;; free variables of this function(and nothing else) | |
495 | ;; then we use the same environment vector as for outer closure, | |
496 | ;; i.e. we leave the environment vector unchanged | |
497 | ;; otherwise we build a new environmet vector | |
498 | (if (eq (length envs) (length fv)) | |
499 | (let ((fv-temp fv)) | |
500 | (while (and fv-temp leave) | |
b38b1ec0 | 501 | (when (not (memq (car fv-temp) fvrs-new)) (setq leave nil)) |
d779e73c SM |
502 | (setq fv-temp (cdr fv-temp)))) |
503 | (setq leave nil)) | |
504 | ||
505 | (if (not leave) | |
506 | (progn | |
507 | (dolist (elm fv) | |
508 | (push | |
509 | (cconv-closure-convert-rec | |
b38b1ec0 SM |
510 | ;; Remove `elm' from `emvrs' for this call because in case |
511 | ;; `elm' is a variable that's wrapped in a cons-cell, we | |
512 | ;; want to put the cons-cell itself in the closure, rather | |
513 | ;; than just a copy of its current content. | |
295fb2ac | 514 | elm (remq elm emvrs) fvrs envs lmenvs) |
b38b1ec0 | 515 | envector)) ; Process vars for closure vector. |
d779e73c SM |
516 | (setq envector (reverse envector)) |
517 | (setq envs fv)) | |
b38b1ec0 SM |
518 | (setq envector `(,cconv--env-var))) ; Leave unchanged. |
519 | (setq fvrs-new fv)) ; Update substitution list. | |
520 | ||
521 | (setq emvrs (cconv--set-diff emvrs vars)) | |
522 | (setq lmenvs (cconv--map-diff-set lmenvs vars)) | |
523 | ||
524 | ;; The difference between envs and fvrs is explained | |
525 | ;; in comment in the beginning of the function. | |
526 | (dolist (elm cconv-captured+mutated) ; Find mutated arguments | |
527 | (setq mv (car elm)) ; used in inner closures. | |
d779e73c SM |
528 | (when (and (memq mv vars) (eq form (caddr elm))) |
529 | (progn (push mv emvrs) | |
530 | (push `(,mv (list ,mv)) letbind)))) | |
531 | (dolist (elm body-forms) ; convert function body | |
532 | (push (cconv-closure-convert-rec | |
b38b1ec0 | 533 | elm emvrs fvrs-new envs lmenvs) |
d779e73c SM |
534 | body-forms-new)) |
535 | ||
536 | (setq body-forms-new | |
537 | (if letbind `((let ,letbind . ,(reverse body-forms-new))) | |
538 | (reverse body-forms-new))) | |
539 | ||
540 | (cond | |
94d11cb5 | 541 | ;if no freevars - do nothing |
d779e73c SM |
542 | ((null envector) |
543 | `(function (lambda ,vars . ,body-forms-new))) | |
544 | ; 1 free variable - do not build vector | |
545 | ((null (cdr envector)) | |
546 | `(curry | |
b38b1ec0 | 547 | (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) |
d779e73c SM |
548 | ,(car envector))) |
549 | ; >=2 free variables - build vector | |
550 | (t | |
551 | `(curry | |
b38b1ec0 | 552 | (function (lambda (,cconv--env-var . ,vars) . ,body-forms-new)) |
d779e73c SM |
553 | (vector . ,envector)))))) |
554 | ||
555 | (`(function . ,_) form) ; same as quote | |
94d11cb5 IK |
556 | |
557 | ;defconst, defvar | |
d779e73c SM |
558 | (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms) |
559 | ||
295fb2ac SM |
560 | (let ((body-forms-new '())) |
561 | (dolist (elm body-forms) | |
562 | (push (cconv-closure-convert-rec | |
563 | elm emvrs fvrs envs lmenvs) | |
564 | body-forms-new)) | |
565 | (setq body-forms-new (reverse body-forms-new)) | |
566 | `(,sym ,definedsymbol . ,body-forms-new))) | |
d779e73c SM |
567 | |
568 | ;defun, defmacro | |
569 | (`(,(and sym (or `defun `defmacro)) | |
570 | ,func ,vars . ,body-forms) | |
295fb2ac SM |
571 | (let ((body-new '()) ; the whole body |
572 | (body-forms-new '()) ; body w\o docstring and interactive | |
573 | (letbind '())) | |
94d11cb5 | 574 | ; find mutable arguments |
295fb2ac SM |
575 | (let ((lmutated cconv-captured+mutated) ismutated) |
576 | (dolist (elm vars) | |
577 | (setq ismutated nil) | |
578 | (while (and lmutated (not ismutated)) | |
579 | (when (and (eq (caar lmutated) elm) | |
580 | (eq (cadar lmutated) form)) | |
581 | (setq ismutated t)) | |
582 | (setq lmutated (cdr lmutated))) | |
583 | (when ismutated | |
584 | (push elm letbind) | |
585 | (push elm emvrs)))) | |
43e67019 | 586 | ;transform body-forms |
295fb2ac SM |
587 | (when (stringp (car body-forms)) ; treat docstring well |
588 | (push (car body-forms) body-new) | |
589 | (setq body-forms (cdr body-forms))) | |
590 | (when (eq (car-safe (car body-forms)) 'interactive) | |
591 | (push (cconv-closure-convert-rec | |
592 | (car body-forms) | |
593 | emvrs fvrs envs lmenvs) | |
594 | body-new) | |
595 | (setq body-forms (cdr body-forms))) | |
596 | ||
597 | (dolist (elm body-forms) | |
598 | (push (cconv-closure-convert-rec | |
599 | elm emvrs fvrs envs lmenvs) | |
600 | body-forms-new)) | |
601 | (setq body-forms-new (reverse body-forms-new)) | |
d779e73c | 602 | |
295fb2ac | 603 | (if letbind |
94d11cb5 | 604 | ; letbind mutable arguments |
295fb2ac SM |
605 | (let ((binders-new '())) |
606 | (dolist (elm letbind) (push `(,elm (list ,elm)) | |
607 | binders-new)) | |
608 | (push `(let ,(reverse binders-new) . | |
609 | ,body-forms-new) body-new) | |
610 | (setq body-new (reverse body-new))) | |
611 | (setq body-new (append (reverse body-new) body-forms-new))) | |
94d11cb5 | 612 | |
295fb2ac | 613 | `(,sym ,func ,vars . ,body-new))) |
94d11cb5 | 614 | |
94d11cb5 | 615 | ;condition-case |
295fb2ac SM |
616 | (`(condition-case ,var ,protected-form . ,handlers) |
617 | (let ((handlers-new '()) | |
618 | (newform (cconv-closure-convert-rec | |
619 | `(function (lambda () ,protected-form)) | |
620 | emvrs fvrs envs lmenvs))) | |
d779e73c | 621 | (setq fvrs (remq var fvrs)) |
295fb2ac SM |
622 | (dolist (handler handlers) |
623 | (push (list (car handler) | |
624 | (cconv-closure-convert-rec | |
625 | `(function (lambda (,(or var cconv--dummy-var)) | |
626 | ,@(cdr handler))) | |
627 | emvrs fvrs envs lmenvs)) | |
628 | handlers-new)) | |
629 | `(condition-case :fun-body ,newform | |
630 | ,@(nreverse handlers-new)))) | |
631 | ||
632 | (`(,(and head (or `catch `unwind-protect)) ,form . ,body) | |
633 | `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs) | |
634 | :fun-body | |
635 | ,(cconv-closure-convert-rec `(function (lambda () ,@body)) | |
636 | emvrs fvrs envs lmenvs))) | |
637 | ||
e0f57e65 SM |
638 | (`(track-mouse . ,body) |
639 | `(track-mouse | |
295fb2ac SM |
640 | :fun-body |
641 | ,(cconv-closure-convert-rec `(function (lambda () ,@body)) | |
642 | emvrs fvrs envs lmenvs))) | |
d779e73c SM |
643 | |
644 | (`(setq . ,forms) ; setq special form | |
645 | (let (prognlist sym sym-new value) | |
646 | (while forms | |
647 | (setq sym (car forms)) | |
648 | (setq sym-new (cconv-closure-convert-rec | |
649 | sym | |
295fb2ac | 650 | (remq sym emvrs) fvrs envs lmenvs)) |
d779e73c SM |
651 | (setq value |
652 | (cconv-closure-convert-rec | |
295fb2ac | 653 | (cadr forms) emvrs fvrs envs lmenvs)) |
d779e73c SM |
654 | (if (memq sym emvrs) |
655 | (push `(setcar ,sym-new ,value) prognlist) | |
656 | (if (symbolp sym-new) | |
657 | (push `(setq ,sym-new ,value) prognlist) | |
658 | (push `(set ,sym-new ,value) prognlist))) | |
659 | (setq forms (cddr forms))) | |
660 | (if (cdr prognlist) | |
661 | `(progn . ,(reverse prognlist)) | |
662 | (car prognlist)))) | |
663 | ||
664 | (`(,(and (or `funcall `apply) callsym) ,fun . ,args) | |
665 | ; funcall is not a special form | |
666 | ; but we treat it separately | |
667 | ; for the needs of lambda lifting | |
668 | (let ((fv (cdr (assq fun lmenvs)))) | |
669 | (if fv | |
670 | (let ((args-new '()) | |
671 | (processed-fv '())) | |
672 | ;; All args (free variables and actual arguments) | |
673 | ;; should be processed, because they can be fvrs | |
674 | ;; (free variables of another closure) | |
675 | (dolist (fvr fv) | |
676 | (push (cconv-closure-convert-rec | |
677 | fvr (remq fvr emvrs) | |
295fb2ac | 678 | fvrs envs lmenvs) |
d779e73c SM |
679 | processed-fv)) |
680 | (setq processed-fv (reverse processed-fv)) | |
681 | (dolist (elm args) | |
682 | (push (cconv-closure-convert-rec | |
295fb2ac | 683 | elm emvrs fvrs envs lmenvs) |
d779e73c SM |
684 | args-new)) |
685 | (setq args-new (append processed-fv (reverse args-new))) | |
686 | (setq fun (cconv-closure-convert-rec | |
295fb2ac | 687 | fun emvrs fvrs envs lmenvs)) |
d779e73c SM |
688 | `(,callsym ,fun . ,args-new)) |
689 | (let ((cdr-new '())) | |
690 | (dolist (elm (cdr form)) | |
691 | (push (cconv-closure-convert-rec | |
295fb2ac | 692 | elm emvrs fvrs envs lmenvs) |
d779e73c SM |
693 | cdr-new)) |
694 | `(,callsym . ,(reverse cdr-new)))))) | |
695 | ||
696 | (`(,func . ,body-forms) ; first element is function or whatever | |
697 | ; function-like forms are: | |
698 | ; or, and, if, progn, prog1, prog2, | |
699 | ; while, until | |
700 | (let ((body-forms-new '())) | |
701 | (dolist (elm body-forms) | |
702 | (push (cconv-closure-convert-rec | |
295fb2ac | 703 | elm emvrs fvrs envs lmenvs) |
d779e73c SM |
704 | body-forms-new)) |
705 | (setq body-forms-new (reverse body-forms-new)) | |
706 | `(,func . ,body-forms-new))) | |
707 | ||
708 | (_ | |
43e67019 SM |
709 | (let ((free (memq form fvrs))) |
710 | (if free ;form is a free variable | |
711 | (let* ((numero (- (length fvrs) (length free))) | |
b38b1ec0 SM |
712 | (var (if (null (cdr envs)) |
713 | cconv--env-var | |
714 | ;; Replace form => (aref env #) | |
715 | `(aref ,cconv--env-var ,numero)))) | |
43e67019 SM |
716 | (if (memq form emvrs) ; form => (car (aref env #)) if mutable |
717 | `(car ,var) | |
718 | var)) | |
719 | (if (memq form emvrs) ; if form is a mutable variable | |
720 | `(car ,form) ; replace form => (car form) | |
721 | form)))))) | |
722 | ||
723 | (defun cconv-analyse-function (args body env parentform inclosure) | |
724 | (dolist (arg args) | |
725 | (cond | |
ce5b520a | 726 | ((byte-compile-not-lexical-var-p arg) |
43e67019 SM |
727 | (byte-compile-report-error |
728 | (format "Argument %S is not a lexical variable" arg))) | |
729 | ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... | |
730 | (t (push (list arg inclosure parentform) env)))) ;Push vrs to vars. | |
731 | (dolist (form body) ;Analyse body forms. | |
732 | (cconv-analyse-form form env inclosure))) | |
733 | ||
734 | (defun cconv-analyse-form (form env inclosure) | |
d779e73c SM |
735 | "Find mutated variables and variables captured by closure. Analyse |
736 | lambdas if they are suitable for lambda lifting. | |
94d11cb5 | 737 | -- FORM is a piece of Elisp code after macroexpansion. |
43e67019 SM |
738 | -- ENV is a list of variables visible in current lexical environment. |
739 | Each entry has the form (VAR INCLOSURE BINDER PARENTFORM) | |
740 | for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments. | |
741 | -- INCLOSURE is the nesting level within lambdas." | |
94d11cb5 IK |
742 | (pcase form |
743 | ; let special form | |
43e67019 | 744 | (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) |
d779e73c | 745 | |
43e67019 | 746 | (let ((orig-env env) |
d779e73c | 747 | (var nil) |
43e67019 SM |
748 | (value nil)) |
749 | (dolist (binder binders) | |
750 | (if (not (consp binder)) | |
d779e73c | 751 | (progn |
43e67019 SM |
752 | (setq var binder) ; treat the form (let (x) ...) well |
753 | (setq value nil)) | |
754 | (setq var (car binder)) | |
755 | (setq value (cadr binder)) | |
756 | ||
757 | (cconv-analyse-form value (if (eq letsym 'let*) env orig-env) | |
758 | inclosure)) | |
759 | ||
ce5b520a | 760 | (unless (byte-compile-not-lexical-var-p var) |
43e67019 SM |
761 | (let ((varstruct (list var inclosure binder form))) |
762 | (push varstruct env) ; Push a new one. | |
763 | ||
764 | (pcase value | |
765 | (`(function (lambda . ,_)) | |
766 | ;; If var is a function push it to lambda list. | |
767 | (push varstruct cconv-lambda-candidates))))))) | |
768 | ||
769 | (dolist (form body-forms) ; Analyse body forms. | |
770 | (cconv-analyse-form form env inclosure))) | |
771 | ||
94d11cb5 | 772 | ; defun special form |
d779e73c | 773 | (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) |
43e67019 SM |
774 | (when env |
775 | (byte-compile-log-warning | |
776 | (format "Function %S will ignore its context %S" | |
777 | func (mapcar #'car env)) | |
778 | t :warning)) | |
779 | (cconv-analyse-function vrs body-forms nil form 0)) | |
780 | ||
781 | (`(function (lambda ,vrs . ,body-forms)) | |
782 | (cconv-analyse-function vrs body-forms env form (1+ inclosure))) | |
783 | ||
784 | (`(setq . ,forms) | |
785 | ;; If a local variable (member of env) is modified by setq then | |
786 | ;; it is a mutated variable. | |
d779e73c | 787 | (while forms |
43e67019 | 788 | (let ((v (assq (car forms) env))) ; v = non nil if visible |
d779e73c SM |
789 | (when v |
790 | (push v cconv-mutated) | |
43e67019 | 791 | ;; Delete from candidate list for lambda lifting. |
d779e73c | 792 | (setq cconv-lambda-candidates (delq v cconv-lambda-candidates)) |
43e67019 SM |
793 | (unless (eq inclosure (cadr v)) ;Bound in a different closure level. |
794 | (push v cconv-captured)))) | |
795 | (cconv-analyse-form (cadr forms) env inclosure) | |
796 | (setq forms (cddr forms)))) | |
797 | ||
798 | (`((lambda . ,_) . ,_) ; first element is lambda expression | |
d779e73c | 799 | (dolist (exp `((function ,(car form)) . ,(cdr form))) |
43e67019 | 800 | (cconv-analyse-form exp env inclosure))) |
d779e73c SM |
801 | |
802 | (`(cond . ,cond-forms) ; cond special form | |
43e67019 SM |
803 | (dolist (forms cond-forms) |
804 | (dolist (form forms) | |
805 | (cconv-analyse-form form env inclosure)))) | |
d779e73c SM |
806 | |
807 | (`(quote . ,_) nil) ; quote form | |
d779e73c SM |
808 | (`(function . ,_) nil) ; same as quote |
809 | ||
43e67019 SM |
810 | (`(condition-case ,var ,protected-form . ,handlers) |
811 | ;; FIXME: The bytecode for condition-case forces us to wrap the | |
812 | ;; form and handlers in closures (for handlers, it's probably | |
813 | ;; unavoidable, but not for the protected form). | |
814 | (setq inclosure (1+ inclosure)) | |
815 | (cconv-analyse-form protected-form env inclosure) | |
816 | (push (list var inclosure form) env) | |
817 | (dolist (handler handlers) | |
818 | (dolist (form (cdr handler)) | |
819 | (cconv-analyse-form form env inclosure)))) | |
820 | ||
821 | ;; FIXME: The bytecode for catch forces us to wrap the body. | |
822 | (`(,(or `catch `unwind-protect) ,form . ,body) | |
823 | (cconv-analyse-form form env inclosure) | |
824 | (setq inclosure (1+ inclosure)) | |
825 | (dolist (form body) | |
826 | (cconv-analyse-form form env inclosure))) | |
827 | ||
828 | ;; FIXME: The bytecode for save-window-excursion and the lack of | |
829 | ;; bytecode for track-mouse forces us to wrap the body. | |
e0f57e65 | 830 | (`(track-mouse . ,body) |
43e67019 SM |
831 | (setq inclosure (1+ inclosure)) |
832 | (dolist (form body) | |
833 | (cconv-analyse-form form env inclosure))) | |
834 | ||
835 | (`(,(or `defconst `defvar) ,var ,value . ,_) | |
836 | (push var byte-compile-bound-variables) | |
837 | (cconv-analyse-form value env inclosure)) | |
d779e73c SM |
838 | |
839 | (`(,(or `funcall `apply) ,fun . ,args) | |
43e67019 SM |
840 | ;; Here we ignore fun because funcall and apply are the only two |
841 | ;; functions where we can pass a candidate for lambda lifting as | |
842 | ;; argument. So, if we see fun elsewhere, we'll delete it from | |
843 | ;; lambda candidate list. | |
844 | (if (symbolp fun) | |
845 | (let ((lv (assq fun cconv-lambda-candidates))) | |
846 | (when lv | |
847 | (unless (eq (cadr lv) inclosure) | |
848 | (push lv cconv-captured) | |
849 | ;; If this funcall and the definition of fun are in | |
850 | ;; different closures - we delete fun from candidate | |
851 | ;; list, because it is too complicated to manage free | |
852 | ;; variables in this case. | |
853 | (setq cconv-lambda-candidates | |
854 | (delq lv cconv-lambda-candidates))))) | |
855 | (cconv-analyse-form fun env inclosure)) | |
856 | (dolist (form args) | |
857 | (cconv-analyse-form form env inclosure))) | |
858 | ||
859 | (`(,_ . ,body-forms) ; First element is a function or whatever. | |
860 | (dolist (form body-forms) | |
861 | (cconv-analyse-form form env inclosure))) | |
862 | ||
863 | ((pred symbolp) | |
864 | (let ((dv (assq form env))) ; dv = declared and visible | |
865 | (when dv | |
866 | (unless (eq inclosure (cadr dv)) ; capturing condition | |
867 | (push dv cconv-captured)) | |
868 | ;; Delete lambda if it is found here, since it escapes. | |
869 | (setq cconv-lambda-candidates | |
870 | (delq dv cconv-lambda-candidates))))))) | |
94d11cb5 IK |
871 | |
872 | (provide 'cconv) | |
873 | ;;; cconv.el ends here |