Commit | Line | Data |
---|---|---|
39605a34 | 1 | ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- |
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 | ;; | |
876c194c SM |
50 | ;; (lambda (v0 ...) ... fv0 .. fv1 ...) => |
51 | ;; (internal-make-closure (v0 ...) (fv1 ...) | |
52 | ;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) | |
94d11cb5 IK |
53 | ;; |
54 | ;; If the function has no free variables, we don't do anything. | |
94d11cb5 | 55 | ;; |
d779e73c | 56 | ;; If a variable is mutated (updated by setq), and it is used in a closure |
876c194c | 57 | ;; we wrap its definition with list: (list val) and we also replace |
d779e73c SM |
58 | ;; var => (car var) wherever this variable is used, and also |
59 | ;; (setq var value) => (setcar var value) where it is updated. | |
94d11cb5 | 60 | ;; |
d779e73c SM |
61 | ;; If defun argument is closure mutable, we letbind it and wrap it's |
62 | ;; definition with list. | |
63 | ;; (defun foo (... mutable-arg ...) ...) => | |
64 | ;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) | |
94d11cb5 IK |
65 | ;; |
66 | ;;; Code: | |
67 | ||
b38b1ec0 | 68 | ;;; TODO: |
876c194c | 69 | ;; - pay attention to `interactive': its arg is run in an empty env. |
cb9336bd SM |
70 | ;; - canonize code in macro-expand so we don't have to handle (let (var) body) |
71 | ;; and other oddities. | |
3e21b6a7 SM |
72 | ;; - Change new byte-code representation, so it directly gives the |
73 | ;; number of mandatory and optional arguments as well as whether or | |
74 | ;; not there's a &rest arg. | |
b38b1ec0 SM |
75 | ;; - warn about unused lexical vars. |
76 | ;; - clean up cconv-closure-convert-rec, especially the `let' binding part. | |
3e21b6a7 SM |
77 | ;; - new byte codes for unwind-protect, catch, and condition-case so that |
78 | ;; closures aren't needed at all. | |
b38b1ec0 | 79 | |
94d11cb5 IK |
80 | (eval-when-compile (require 'cl)) |
81 | ||
82 | (defconst cconv-liftwhen 3 | |
d779e73c | 83 | "Try to do lambda lifting if the number of arguments + free variables |
94d11cb5 | 84 | is less than this number.") |
a9de04fa SM |
85 | ;; List of all the variables that are both captured by a closure |
86 | ;; and mutated. Each entry in the list takes the form | |
87 | ;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the | |
88 | ;; variable (or is just (VAR) for variables not introduced by let). | |
89 | (defvar cconv-captured+mutated) | |
d779e73c | 90 | |
a9de04fa SM |
91 | ;; List of candidates for lambda lifting. |
92 | ;; Each candidate has the form (BINDER . PARENTFORM). A candidate | |
93 | ;; is a variable that is only passed to `funcall' or `apply'. | |
94 | (defvar cconv-lambda-candidates) | |
d779e73c | 95 | |
a9de04fa SM |
96 | ;; Alist associating to each function body the list of its free variables. |
97 | (defvar cconv-freevars-alist) | |
94d11cb5 IK |
98 | |
99 | ;;;###autoload | |
295fb2ac SM |
100 | (defun cconv-closure-convert (form) |
101 | "Main entry point for closure conversion. | |
94d11cb5 IK |
102 | -- FORM is a piece of Elisp code after macroexpansion. |
103 | -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST | |
104 | ||
105 | Returns a form where all lambdas don't have any free variables." | |
b38b1ec0 | 106 | ;; (message "Entering cconv-closure-convert...") |
a9de04fa | 107 | (let ((cconv-freevars-alist '()) |
94d11cb5 | 108 | (cconv-lambda-candidates '()) |
d779e73c | 109 | (cconv-captured+mutated '())) |
b38b1ec0 | 110 | ;; Analyse form - fill these variables with new information. |
a9de04fa SM |
111 | (cconv-analyse-form form '()) |
112 | (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) | |
d779e73c SM |
113 | (cconv-closure-convert-rec |
114 | form ; the tree | |
115 | '() ; | |
116 | '() ; fvrs initially empty | |
117 | '() ; envs initially empty | |
94d11cb5 | 118 | '() |
295fb2ac | 119 | ))) |
94d11cb5 | 120 | |
295fb2ac | 121 | (defconst cconv--dummy-var (make-symbol "ignored")) |
b38b1ec0 SM |
122 | |
123 | (defun cconv--set-diff (s1 s2) | |
124 | "Return elements of set S1 that are not in set S2." | |
125 | (let ((res '())) | |
126 | (dolist (x s1) | |
127 | (unless (memq x s2) (push x res))) | |
128 | (nreverse res))) | |
129 | ||
130 | (defun cconv--set-diff-map (s m) | |
131 | "Return elements of set S that are not in Dom(M)." | |
132 | (let ((res '())) | |
133 | (dolist (x s) | |
134 | (unless (assq x m) (push x res))) | |
135 | (nreverse res))) | |
136 | ||
137 | (defun cconv--map-diff (m1 m2) | |
138 | "Return the submap of map M1 that has Dom(M2) removed." | |
139 | (let ((res '())) | |
140 | (dolist (x m1) | |
141 | (unless (assq (car x) m2) (push x res))) | |
142 | (nreverse res))) | |
143 | ||
144 | (defun cconv--map-diff-elem (m x) | |
145 | "Return the map M minus any mapping for X." | |
146 | ;; Here we assume that X appears at most once in M. | |
147 | (let* ((b (assq x m)) | |
148 | (res (if b (remq b m) m))) | |
149 | (assert (null (assq x res))) ;; Check the assumption was warranted. | |
150 | res)) | |
94d11cb5 | 151 | |
b38b1ec0 SM |
152 | (defun cconv--map-diff-set (m s) |
153 | "Return the map M minus any mapping for elements of S." | |
154 | ;; Here we assume that X appears at most once in M. | |
155 | (let ((res '())) | |
156 | (dolist (b m) | |
157 | (unless (memq (car b) s) (push b res))) | |
158 | (nreverse res))) | |
159 | ||
a9de04fa SM |
160 | (defun cconv-closure-convert-function (fvrs vars emvrs envs lmenvs body-forms |
161 | parentform) | |
162 | (assert (equal body-forms (caar cconv-freevars-alist))) | |
163 | (let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs. | |
164 | (fv (cdr (pop cconv-freevars-alist))) | |
165 | (body-forms-new '()) | |
166 | (letbind '()) | |
167 | (envector nil)) | |
168 | (when fv | |
169 | ;; Here we form our environment vector. | |
170 | ||
171 | (dolist (elm fv) | |
172 | (push | |
173 | (cconv-closure-convert-rec | |
174 | ;; Remove `elm' from `emvrs' for this call because in case | |
175 | ;; `elm' is a variable that's wrapped in a cons-cell, we | |
176 | ;; want to put the cons-cell itself in the closure, rather | |
177 | ;; than just a copy of its current content. | |
178 | elm (remq elm emvrs) fvrs envs lmenvs) | |
179 | envector)) ; Process vars for closure vector. | |
180 | (setq envector (reverse envector)) | |
181 | (setq envs fv) | |
182 | (setq fvrs-new fv)) ; Update substitution list. | |
183 | ||
184 | (setq emvrs (cconv--set-diff emvrs vars)) | |
185 | (setq lmenvs (cconv--map-diff-set lmenvs vars)) | |
186 | ||
187 | ;; The difference between envs and fvrs is explained | |
188 | ;; in comment in the beginning of the function. | |
189 | (dolist (var vars) | |
190 | (when (member (cons (list var) parentform) cconv-captured+mutated) | |
191 | (push var emvrs) | |
192 | (push `(,var (list ,var)) letbind))) | |
193 | (dolist (elm body-forms) ; convert function body | |
194 | (push (cconv-closure-convert-rec | |
195 | elm emvrs fvrs-new envs lmenvs) | |
196 | body-forms-new)) | |
197 | ||
198 | (setq body-forms-new | |
199 | (if letbind `((let ,letbind . ,(reverse body-forms-new))) | |
200 | (reverse body-forms-new))) | |
201 | ||
202 | (cond | |
203 | ;if no freevars - do nothing | |
204 | ((null envector) | |
205 | `(function (lambda ,vars . ,body-forms-new))) | |
206 | ; 1 free variable - do not build vector | |
207 | (t | |
208 | `(internal-make-closure | |
209 | ,vars ,envector . ,body-forms-new))))) | |
210 | ||
b38b1ec0 | 211 | (defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs) |
d779e73c | 212 | ;; This function actually rewrites the tree. |
94d11cb5 IK |
213 | "Eliminates all free variables of all lambdas in given forms. |
214 | Arguments: | |
215 | -- FORM is a piece of Elisp code after macroexpansion. | |
b38b1ec0 | 216 | -- LMENVS is a list of environments used for lambda-lifting. Initially empty. |
94d11cb5 IK |
217 | -- EMVRS is a list that contains mutated variables that are visible |
218 | within current environment. | |
d779e73c SM |
219 | -- ENVS is an environment(list of free variables) of current closure. |
220 | Initially empty. | |
221 | -- FVRS is a list of variables to substitute in each context. | |
222 | Initially empty. | |
94d11cb5 IK |
223 | |
224 | Returns a form where all lambdas don't have any free variables." | |
d779e73c | 225 | ;; What's the difference between fvrs and envs? |
94d11cb5 IK |
226 | ;; Suppose that we have the code |
227 | ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) | |
d779e73c SM |
228 | ;; only the first occurrence of fvr should be replaced by |
229 | ;; (aref env ...). | |
94d11cb5 IK |
230 | ;; So initially envs and fvrs are the same thing, but when we descend to |
231 | ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? | |
232 | ;; Because in envs the order of variables is important. We use this list | |
d779e73c SM |
233 | ;; to find the number of a specific variable in the environment vector, |
234 | ;; so we never touch it(unless we enter to the other closure). | |
235 | ;;(if (listp form) (print (car form)) form) | |
236 | (pcase form | |
295fb2ac | 237 | (`(,(and letsym (or `let* `let)) ,binders . ,body-forms) |
94d11cb5 IK |
238 | |
239 | ; let and let* special forms | |
d779e73c | 240 | (let ((body-forms-new '()) |
295fb2ac | 241 | (binders-new '()) |
d779e73c SM |
242 | ;; next for variables needed for delayed push |
243 | ;; because we should process <value(s)> | |
244 | ;; before we change any arguments | |
245 | (lmenvs-new '()) ;needed only in case of let | |
246 | (emvrs-new '()) ;needed only in case of let | |
247 | (emvr-push) ;needed only in case of let* | |
248 | (lmenv-push)) ;needed only in case of let* | |
249 | ||
295fb2ac SM |
250 | (dolist (binder binders) |
251 | (let* ((value nil) | |
252 | (var (if (not (consp binder)) | |
a9de04fa | 253 | (prog1 binder (setq binder (list binder))) |
295fb2ac SM |
254 | (setq value (cadr binder)) |
255 | (car binder))) | |
256 | (new-val | |
257 | (cond | |
258 | ;; Check if var is a candidate for lambda lifting. | |
a9de04fa SM |
259 | ((member (cons binder form) cconv-lambda-candidates) |
260 | (assert (and (eq (car value) 'function) | |
261 | (eq (car (cadr value)) 'lambda))) | |
262 | (assert (equal (cddr (cadr value)) | |
263 | (caar cconv-freevars-alist))) | |
39605a34 SM |
264 | ;; Peek at the freevars to decide whether to λ-lift. |
265 | (let* ((fv (cdr (car cconv-freevars-alist))) | |
295fb2ac SM |
266 | (funargs (cadr (cadr value))) |
267 | (funcvars (append fv funargs)) | |
268 | (funcbodies (cddadr value)) ; function bodies | |
269 | (funcbodies-new '())) | |
94d11cb5 | 270 | ; lambda lifting condition |
295fb2ac | 271 | (if (or (not fv) (< cconv-liftwhen (length funcvars))) |
94d11cb5 | 272 | ; do not lift |
39605a34 SM |
273 | (cconv-closure-convert-rec |
274 | value emvrs fvrs envs lmenvs) | |
94d11cb5 | 275 | ; lift |
295fb2ac | 276 | (progn |
39605a34 SM |
277 | (setq cconv-freevars-alist |
278 | ;; Now that we know we'll λ-lift, consume the | |
279 | ;; freevar data. | |
280 | (cdr cconv-freevars-alist)) | |
295fb2ac SM |
281 | (dolist (elm2 funcbodies) |
282 | (push ; convert function bodies | |
283 | (cconv-closure-convert-rec | |
284 | elm2 emvrs nil envs lmenvs) | |
285 | funcbodies-new)) | |
286 | (if (eq letsym 'let*) | |
287 | (setq lmenv-push (cons var fv)) | |
288 | (push (cons var fv) lmenvs-new)) | |
94d11cb5 IK |
289 | ; push lifted function |
290 | ||
295fb2ac SM |
291 | `(function . |
292 | ((lambda ,funcvars . | |
293 | ,(reverse funcbodies-new)))))))) | |
294 | ||
295 | ;; Check if it needs to be turned into a "ref-cell". | |
a9de04fa | 296 | ((member (cons binder form) cconv-captured+mutated) |
295fb2ac SM |
297 | ;; Declared variable is mutated and captured. |
298 | (prog1 | |
299 | `(list ,(cconv-closure-convert-rec | |
300 | value emvrs | |
301 | fvrs envs lmenvs)) | |
d779e73c SM |
302 | (if (eq letsym 'let*) |
303 | (setq emvr-push var) | |
295fb2ac SM |
304 | (push var emvrs-new)))) |
305 | ||
306 | ;; Normal default case. | |
307 | (t | |
308 | (cconv-closure-convert-rec | |
309 | value emvrs fvrs envs lmenvs))))) | |
d779e73c SM |
310 | |
311 | ;; this piece of code below letbinds free | |
312 | ;; variables of a lambda lifted function | |
313 | ;; if they are redefined in this let | |
314 | ;; example: | |
315 | ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) | |
316 | ;; Here we can not pass y as parameter because it is | |
317 | ;; redefined. We add a (closed-y y) declaration. | |
318 | ;; We do that even if the function is not used inside | |
319 | ;; this let(*). The reason why we ignore this case is | |
320 | ;; that we can't "look forward" to see if the function | |
321 | ;; is called there or not. To treat well this case we | |
322 | ;; need to traverse the tree one more time to collect this | |
323 | ;; data, and I think that it's not worth it. | |
324 | ||
325 | (when (eq letsym 'let*) | |
326 | (let ((closedsym '()) | |
327 | (new-lmenv '()) | |
328 | (old-lmenv '())) | |
329 | (dolist (lmenv lmenvs) | |
330 | (when (memq var (cdr lmenv)) | |
331 | (setq closedsym | |
332 | (make-symbol | |
333 | (concat "closed-" (symbol-name var)))) | |
334 | (setq new-lmenv (list (car lmenv))) | |
335 | (dolist (frv (cdr lmenv)) (if (eq frv var) | |
336 | (push closedsym new-lmenv) | |
337 | (push frv new-lmenv))) | |
338 | (setq new-lmenv (reverse new-lmenv)) | |
339 | (setq old-lmenv lmenv))) | |
340 | (when new-lmenv | |
341 | (setq lmenvs (remq old-lmenv lmenvs)) | |
342 | (push new-lmenv lmenvs) | |
295fb2ac | 343 | (push `(,closedsym ,var) binders-new)))) |
b38b1ec0 SM |
344 | ;; We push the element after redefined free variables are |
345 | ;; processed. This is important to avoid the bug when free | |
346 | ;; variable and the function have the same name. | |
295fb2ac | 347 | (push (list var new-val) binders-new) |
d779e73c SM |
348 | |
349 | (when (eq letsym 'let*) ; update fvrs | |
350 | (setq fvrs (remq var fvrs)) | |
351 | (setq emvrs (remq var emvrs)) ; remove if redefined | |
352 | (when emvr-push | |
353 | (push emvr-push emvrs) | |
354 | (setq emvr-push nil)) | |
b38b1ec0 | 355 | (setq lmenvs (cconv--map-diff-elem lmenvs var)) |
d779e73c SM |
356 | (when lmenv-push |
357 | (push lmenv-push lmenvs) | |
358 | (setq lmenv-push nil))) | |
295fb2ac | 359 | )) ; end of dolist over binders |
d779e73c SM |
360 | (when (eq letsym 'let) |
361 | ||
a9de04fa SM |
362 | ;; Here we update emvrs, fvrs and lmenvs lists |
363 | (setq fvrs (cconv--set-diff-map fvrs binders-new)) | |
364 | (setq emvrs (cconv--set-diff-map emvrs binders-new)) | |
365 | (setq emvrs (append emvrs emvrs-new)) | |
366 | (setq lmenvs (cconv--set-diff-map lmenvs binders-new)) | |
367 | (setq lmenvs (append lmenvs lmenvs-new)) | |
d779e73c SM |
368 | |
369 | ;; Here we do the same letbinding as for let* above | |
370 | ;; to avoid situation when a free variable of a lambda lifted | |
371 | ;; function got redefined. | |
372 | ||
373 | (let ((new-lmenv) | |
374 | (var nil) | |
375 | (closedsym nil) | |
295fb2ac SM |
376 | (letbinds '())) |
377 | (dolist (binder binders) | |
378 | (setq var (if (consp binder) (car binder) binder)) | |
d779e73c SM |
379 | |
380 | (let ((lmenvs-1 lmenvs)) ; just to avoid manipulating | |
381 | (dolist (lmenv lmenvs-1) ; the counter inside the loop | |
382 | (when (memq var (cdr lmenv)) | |
383 | (setq closedsym (make-symbol | |
384 | (concat "closed-" | |
385 | (symbol-name var)))) | |
386 | ||
387 | (setq new-lmenv (list (car lmenv))) | |
b38b1ec0 SM |
388 | (dolist (frv (cdr lmenv)) |
389 | (push (if (eq frv var) closedsym frv) | |
390 | new-lmenv)) | |
d779e73c SM |
391 | (setq new-lmenv (reverse new-lmenv)) |
392 | (setq lmenvs (remq lmenv lmenvs)) | |
393 | (push new-lmenv lmenvs) | |
394 | (push `(,closedsym ,var) letbinds) | |
395 | )))) | |
295fb2ac | 396 | (setq binders-new (append binders-new letbinds)))) |
d779e73c SM |
397 | |
398 | (dolist (elm body-forms) ; convert body forms | |
399 | (push (cconv-closure-convert-rec | |
295fb2ac | 400 | elm emvrs fvrs envs lmenvs) |
d779e73c | 401 | body-forms-new)) |
295fb2ac | 402 | `(,letsym ,(reverse binders-new) . ,(reverse body-forms-new)))) |
94d11cb5 IK |
403 | ;end of let let* forms |
404 | ||
d779e73c SM |
405 | ; first element is lambda expression |
406 | (`(,(and `(lambda . ,_) fun) . ,other-body-forms) | |
407 | ||
408 | (let ((other-body-forms-new '())) | |
409 | (dolist (elm other-body-forms) | |
410 | (push (cconv-closure-convert-rec | |
295fb2ac | 411 | elm emvrs fvrs envs lmenvs) |
d779e73c | 412 | other-body-forms-new)) |
295fb2ac SM |
413 | `(funcall |
414 | ,(cconv-closure-convert-rec | |
415 | (list 'function fun) emvrs fvrs envs lmenvs) | |
416 | ,@(nreverse other-body-forms-new)))) | |
d779e73c SM |
417 | |
418 | (`(cond . ,cond-forms) ; cond special form | |
419 | (let ((cond-forms-new '())) | |
420 | (dolist (elm cond-forms) | |
421 | (push (let ((elm-new '())) | |
422 | (dolist (elm-2 elm) | |
423 | (push | |
424 | (cconv-closure-convert-rec | |
295fb2ac | 425 | elm-2 emvrs fvrs envs lmenvs) |
d779e73c SM |
426 | elm-new)) |
427 | (reverse elm-new)) | |
428 | cond-forms-new)) | |
429 | (cons 'cond | |
430 | (reverse cond-forms-new)))) | |
431 | ||
3e21b6a7 | 432 | (`(quote . ,_) form) |
d779e73c | 433 | |
3e21b6a7 | 434 | (`(function (lambda ,vars . ,body-forms)) ; function form |
a9de04fa SM |
435 | (cconv-closure-convert-function |
436 | fvrs vars emvrs envs lmenvs body-forms form)) | |
d779e73c | 437 | |
876c194c SM |
438 | (`(internal-make-closure . ,_) |
439 | (error "Internal byte-compiler error: cconv called twice")) | |
440 | ||
3e21b6a7 | 441 | (`(function . ,_) form) ; Same as quote. |
94d11cb5 IK |
442 | |
443 | ;defconst, defvar | |
d779e73c SM |
444 | (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms) |
445 | ||
295fb2ac SM |
446 | (let ((body-forms-new '())) |
447 | (dolist (elm body-forms) | |
448 | (push (cconv-closure-convert-rec | |
449 | elm emvrs fvrs envs lmenvs) | |
450 | body-forms-new)) | |
451 | (setq body-forms-new (reverse body-forms-new)) | |
452 | `(,sym ,definedsymbol . ,body-forms-new))) | |
d779e73c SM |
453 | |
454 | ;defun, defmacro | |
455 | (`(,(and sym (or `defun `defmacro)) | |
456 | ,func ,vars . ,body-forms) | |
a9de04fa SM |
457 | |
458 | ;; The freevar data was pushed onto cconv-freevars-alist | |
459 | ;; but we don't need it. | |
460 | (assert (equal body-forms (caar cconv-freevars-alist))) | |
461 | (assert (null (cdar cconv-freevars-alist))) | |
462 | (setq cconv-freevars-alist (cdr cconv-freevars-alist)) | |
463 | ||
3e21b6a7 SM |
464 | (let ((body-new '()) ; The whole body. |
465 | (body-forms-new '()) ; Body w\o docstring and interactive. | |
295fb2ac | 466 | (letbind '())) |
3e21b6a7 SM |
467 | ; Find mutable arguments. |
468 | (dolist (elm vars) | |
a9de04fa SM |
469 | (when (member (cons (list elm) form) cconv-captured+mutated) |
470 | (push elm letbind) | |
471 | (push elm emvrs))) | |
3e21b6a7 SM |
472 | ;Transform body-forms. |
473 | (when (stringp (car body-forms)) ; Treat docstring well. | |
295fb2ac SM |
474 | (push (car body-forms) body-new) |
475 | (setq body-forms (cdr body-forms))) | |
476 | (when (eq (car-safe (car body-forms)) 'interactive) | |
477 | (push (cconv-closure-convert-rec | |
478 | (car body-forms) | |
479 | emvrs fvrs envs lmenvs) | |
480 | body-new) | |
481 | (setq body-forms (cdr body-forms))) | |
482 | ||
483 | (dolist (elm body-forms) | |
484 | (push (cconv-closure-convert-rec | |
485 | elm emvrs fvrs envs lmenvs) | |
486 | body-forms-new)) | |
487 | (setq body-forms-new (reverse body-forms-new)) | |
d779e73c | 488 | |
295fb2ac | 489 | (if letbind |
3e21b6a7 | 490 | ; Letbind mutable arguments. |
295fb2ac SM |
491 | (let ((binders-new '())) |
492 | (dolist (elm letbind) (push `(,elm (list ,elm)) | |
493 | binders-new)) | |
494 | (push `(let ,(reverse binders-new) . | |
495 | ,body-forms-new) body-new) | |
496 | (setq body-new (reverse body-new))) | |
497 | (setq body-new (append (reverse body-new) body-forms-new))) | |
94d11cb5 | 498 | |
295fb2ac | 499 | `(,sym ,func ,vars . ,body-new))) |
94d11cb5 | 500 | |
94d11cb5 | 501 | ;condition-case |
295fb2ac | 502 | (`(condition-case ,var ,protected-form . ,handlers) |
876c194c | 503 | (let ((newform (cconv-closure-convert-rec |
295fb2ac SM |
504 | `(function (lambda () ,protected-form)) |
505 | emvrs fvrs envs lmenvs))) | |
d779e73c | 506 | (setq fvrs (remq var fvrs)) |
295fb2ac | 507 | `(condition-case :fun-body ,newform |
876c194c SM |
508 | ,@(mapcar (lambda (handler) |
509 | (list (car handler) | |
510 | (cconv-closure-convert-rec | |
511 | (let ((arg (or var cconv--dummy-var))) | |
512 | `(function (lambda (,arg) ,@(cdr handler)))) | |
513 | emvrs fvrs envs lmenvs))) | |
514 | handlers)))) | |
295fb2ac SM |
515 | |
516 | (`(,(and head (or `catch `unwind-protect)) ,form . ,body) | |
517 | `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs) | |
518 | :fun-body | |
519 | ,(cconv-closure-convert-rec `(function (lambda () ,@body)) | |
520 | emvrs fvrs envs lmenvs))) | |
521 | ||
e0f57e65 SM |
522 | (`(track-mouse . ,body) |
523 | `(track-mouse | |
295fb2ac SM |
524 | :fun-body |
525 | ,(cconv-closure-convert-rec `(function (lambda () ,@body)) | |
526 | emvrs fvrs envs lmenvs))) | |
d779e73c SM |
527 | |
528 | (`(setq . ,forms) ; setq special form | |
529 | (let (prognlist sym sym-new value) | |
530 | (while forms | |
531 | (setq sym (car forms)) | |
532 | (setq sym-new (cconv-closure-convert-rec | |
533 | sym | |
295fb2ac | 534 | (remq sym emvrs) fvrs envs lmenvs)) |
d779e73c SM |
535 | (setq value |
536 | (cconv-closure-convert-rec | |
295fb2ac | 537 | (cadr forms) emvrs fvrs envs lmenvs)) |
a9de04fa SM |
538 | (cond |
539 | ((memq sym emvrs) (push `(setcar ,sym-new ,value) prognlist)) | |
540 | ((symbolp sym-new) (push `(setq ,sym-new ,value) prognlist)) | |
541 | ;; This should never happen, but for variables which are | |
542 | ;; mutated+captured+unused, we may end up trying to `setq' | |
543 | ;; on a closed-over variable, so just drop the setq. | |
544 | (t (push value prognlist))) | |
d779e73c SM |
545 | (setq forms (cddr forms))) |
546 | (if (cdr prognlist) | |
547 | `(progn . ,(reverse prognlist)) | |
548 | (car prognlist)))) | |
549 | ||
550 | (`(,(and (or `funcall `apply) callsym) ,fun . ,args) | |
551 | ; funcall is not a special form | |
552 | ; but we treat it separately | |
553 | ; for the needs of lambda lifting | |
554 | (let ((fv (cdr (assq fun lmenvs)))) | |
555 | (if fv | |
556 | (let ((args-new '()) | |
557 | (processed-fv '())) | |
558 | ;; All args (free variables and actual arguments) | |
559 | ;; should be processed, because they can be fvrs | |
560 | ;; (free variables of another closure) | |
561 | (dolist (fvr fv) | |
562 | (push (cconv-closure-convert-rec | |
563 | fvr (remq fvr emvrs) | |
295fb2ac | 564 | fvrs envs lmenvs) |
d779e73c SM |
565 | processed-fv)) |
566 | (setq processed-fv (reverse processed-fv)) | |
567 | (dolist (elm args) | |
568 | (push (cconv-closure-convert-rec | |
295fb2ac | 569 | elm emvrs fvrs envs lmenvs) |
d779e73c SM |
570 | args-new)) |
571 | (setq args-new (append processed-fv (reverse args-new))) | |
572 | (setq fun (cconv-closure-convert-rec | |
295fb2ac | 573 | fun emvrs fvrs envs lmenvs)) |
d779e73c SM |
574 | `(,callsym ,fun . ,args-new)) |
575 | (let ((cdr-new '())) | |
576 | (dolist (elm (cdr form)) | |
577 | (push (cconv-closure-convert-rec | |
295fb2ac | 578 | elm emvrs fvrs envs lmenvs) |
d779e73c SM |
579 | cdr-new)) |
580 | `(,callsym . ,(reverse cdr-new)))))) | |
581 | ||
582 | (`(,func . ,body-forms) ; first element is function or whatever | |
583 | ; function-like forms are: | |
584 | ; or, and, if, progn, prog1, prog2, | |
585 | ; while, until | |
586 | (let ((body-forms-new '())) | |
587 | (dolist (elm body-forms) | |
588 | (push (cconv-closure-convert-rec | |
295fb2ac | 589 | elm emvrs fvrs envs lmenvs) |
d779e73c SM |
590 | body-forms-new)) |
591 | (setq body-forms-new (reverse body-forms-new)) | |
592 | `(,func . ,body-forms-new))) | |
593 | ||
594 | (_ | |
43e67019 SM |
595 | (let ((free (memq form fvrs))) |
596 | (if free ;form is a free variable | |
597 | (let* ((numero (- (length fvrs) (length free))) | |
cb9336bd SM |
598 | ;; Replace form => (aref env #) |
599 | (var `(internal-get-closed-var ,numero))) | |
43e67019 SM |
600 | (if (memq form emvrs) ; form => (car (aref env #)) if mutable |
601 | `(car ,var) | |
602 | var)) | |
603 | (if (memq form emvrs) ; if form is a mutable variable | |
604 | `(car ,form) ; replace form => (car form) | |
605 | form)))))) | |
606 | ||
a9de04fa SM |
607 | (unless (fboundp 'byte-compile-not-lexical-var-p) |
608 | ;; Only used to test the code in non-lexbind Emacs. | |
609 | (defalias 'byte-compile-not-lexical-var-p 'boundp)) | |
610 | ||
611 | (defun cconv-analyse-use (vardata form) | |
612 | ;; use = `(,binder ,read ,mutated ,captured ,called) | |
613 | (pcase vardata | |
614 | (`(,binder nil ,_ ,_ nil) | |
615 | ;; FIXME: Don't warn about unused fun-args. | |
616 | ;; FIXME: Don't warn about uninterned vars or _ vars. | |
617 | ;; FIXME: This gives warnings in the wrong order and with wrong line | |
618 | ;; number and without function name info. | |
619 | (byte-compile-log-warning (format "Unused variable %S" (car binder)))) | |
620 | ;; If it's unused, there's no point converting it into a cons-cell, even if | |
621 | ;; it's captures and mutated. | |
622 | (`(,binder ,_ t t ,_) | |
623 | (push (cons binder form) cconv-captured+mutated)) | |
624 | (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) | |
625 | ;; This is very rare in typical Elisp code. It's probably not really | |
626 | ;; worth the trouble to try and use lambda-lifting in Elisp, but | |
627 | ;; since we coded it up, we might as well use it. | |
628 | (push (cons binder form) cconv-lambda-candidates)) | |
629 | (`(,_ ,_ ,_ ,_ ,_) nil) | |
630 | (dontcare))) | |
631 | ||
632 | (defun cconv-analyse-function (args body env parentform) | |
633 | (let* ((newvars nil) | |
634 | (freevars (list body)) | |
635 | ;; We analyze the body within a new environment where all uses are | |
636 | ;; nil, so we can distinguish uses within that function from uses | |
637 | ;; outside of it. | |
638 | (envcopy | |
639 | (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) | |
640 | (newenv envcopy)) | |
641 | ;; Push it before recursing, so cconv-freevars-alist contains entries in | |
642 | ;; the order they'll be used by closure-convert-rec. | |
643 | (push freevars cconv-freevars-alist) | |
644 | (dolist (arg args) | |
645 | (cond | |
646 | ((byte-compile-not-lexical-var-p arg) | |
647 | (byte-compile-report-error | |
648 | (format "Argument %S is not a lexical variable" arg))) | |
649 | ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... | |
650 | (t (let ((varstruct (list arg nil nil nil nil))) | |
651 | (push (cons (list arg) (cdr varstruct)) newvars) | |
652 | (push varstruct newenv))))) | |
653 | (dolist (form body) ;Analyse body forms. | |
654 | (cconv-analyse-form form newenv)) | |
655 | ;; Summarize resulting data about arguments. | |
656 | (dolist (vardata newvars) | |
657 | (cconv-analyse-use vardata parentform)) | |
658 | ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; | |
659 | ;; and compute free variables. | |
660 | (while env | |
661 | (assert (and envcopy (eq (caar env) (caar envcopy)))) | |
662 | (let ((free nil) | |
663 | (x (cdr (car env))) | |
664 | (y (cdr (car envcopy)))) | |
665 | (while x | |
666 | (when (car y) (setcar x t) (setq free t)) | |
667 | (setq x (cdr x) y (cdr y))) | |
668 | (when free | |
669 | (push (caar env) (cdr freevars)) | |
670 | (setf (nth 3 (car env)) t)) | |
671 | (setq env (cdr env) envcopy (cdr envcopy)))))) | |
672 | ||
673 | (defun cconv-analyse-form (form env) | |
674 | "Find mutated variables and variables captured by closure. | |
675 | Analyse lambdas if they are suitable for lambda lifting. | |
94d11cb5 | 676 | -- FORM is a piece of Elisp code after macroexpansion. |
a9de04fa SM |
677 | -- ENV is an alist mapping each enclosing lexical variable to its info. |
678 | I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). | |
679 | This function does not return anything but instead fills the | |
680 | `cconv-captured+mutated' and `cconv-lambda-candidates' variables | |
681 | and updates the data stored in ENV." | |
94d11cb5 IK |
682 | (pcase form |
683 | ; let special form | |
43e67019 | 684 | (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) |
d779e73c | 685 | |
43e67019 | 686 | (let ((orig-env env) |
a9de04fa | 687 | (newvars nil) |
d779e73c | 688 | (var nil) |
43e67019 SM |
689 | (value nil)) |
690 | (dolist (binder binders) | |
691 | (if (not (consp binder)) | |
d779e73c | 692 | (progn |
43e67019 | 693 | (setq var binder) ; treat the form (let (x) ...) well |
a9de04fa | 694 | (setq binder (list binder)) |
43e67019 SM |
695 | (setq value nil)) |
696 | (setq var (car binder)) | |
697 | (setq value (cadr binder)) | |
698 | ||
a9de04fa | 699 | (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) |
43e67019 | 700 | |
ce5b520a | 701 | (unless (byte-compile-not-lexical-var-p var) |
a9de04fa SM |
702 | (let ((varstruct (list var nil nil nil nil))) |
703 | (push (cons binder (cdr varstruct)) newvars) | |
704 | (push varstruct env)))) | |
43e67019 | 705 | |
a9de04fa SM |
706 | (dolist (form body-forms) ; Analyse body forms. |
707 | (cconv-analyse-form form env)) | |
43e67019 | 708 | |
a9de04fa SM |
709 | (dolist (vardata newvars) |
710 | (cconv-analyse-use vardata form)))) | |
43e67019 | 711 | |
94d11cb5 | 712 | ; defun special form |
d779e73c | 713 | (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) |
43e67019 SM |
714 | (when env |
715 | (byte-compile-log-warning | |
716 | (format "Function %S will ignore its context %S" | |
717 | func (mapcar #'car env)) | |
718 | t :warning)) | |
a9de04fa | 719 | (cconv-analyse-function vrs body-forms nil form)) |
43e67019 SM |
720 | |
721 | (`(function (lambda ,vrs . ,body-forms)) | |
a9de04fa | 722 | (cconv-analyse-function vrs body-forms env form)) |
43e67019 SM |
723 | |
724 | (`(setq . ,forms) | |
725 | ;; If a local variable (member of env) is modified by setq then | |
726 | ;; it is a mutated variable. | |
d779e73c | 727 | (while forms |
43e67019 | 728 | (let ((v (assq (car forms) env))) ; v = non nil if visible |
a9de04fa SM |
729 | (when v (setf (nth 2 v) t))) |
730 | (cconv-analyse-form (cadr forms) env) | |
43e67019 SM |
731 | (setq forms (cddr forms)))) |
732 | ||
733 | (`((lambda . ,_) . ,_) ; first element is lambda expression | |
d779e73c | 734 | (dolist (exp `((function ,(car form)) . ,(cdr form))) |
a9de04fa | 735 | (cconv-analyse-form exp env))) |
d779e73c SM |
736 | |
737 | (`(cond . ,cond-forms) ; cond special form | |
43e67019 SM |
738 | (dolist (forms cond-forms) |
739 | (dolist (form forms) | |
a9de04fa | 740 | (cconv-analyse-form form env)))) |
d779e73c SM |
741 | |
742 | (`(quote . ,_) nil) ; quote form | |
d779e73c SM |
743 | (`(function . ,_) nil) ; same as quote |
744 | ||
43e67019 SM |
745 | (`(condition-case ,var ,protected-form . ,handlers) |
746 | ;; FIXME: The bytecode for condition-case forces us to wrap the | |
747 | ;; form and handlers in closures (for handlers, it's probably | |
748 | ;; unavoidable, but not for the protected form). | |
a9de04fa | 749 | (cconv-analyse-function () (list protected-form) env form) |
43e67019 | 750 | (dolist (handler handlers) |
a9de04fa | 751 | (cconv-analyse-function (if var (list var)) (cdr handler) env form))) |
43e67019 SM |
752 | |
753 | ;; FIXME: The bytecode for catch forces us to wrap the body. | |
754 | (`(,(or `catch `unwind-protect) ,form . ,body) | |
a9de04fa SM |
755 | (cconv-analyse-form form env) |
756 | (cconv-analyse-function () body env form)) | |
43e67019 SM |
757 | |
758 | ;; FIXME: The bytecode for save-window-excursion and the lack of | |
759 | ;; bytecode for track-mouse forces us to wrap the body. | |
e0f57e65 | 760 | (`(track-mouse . ,body) |
a9de04fa | 761 | (cconv-analyse-function () body env form)) |
43e67019 SM |
762 | |
763 | (`(,(or `defconst `defvar) ,var ,value . ,_) | |
764 | (push var byte-compile-bound-variables) | |
a9de04fa | 765 | (cconv-analyse-form value env)) |
d779e73c SM |
766 | |
767 | (`(,(or `funcall `apply) ,fun . ,args) | |
43e67019 SM |
768 | ;; Here we ignore fun because funcall and apply are the only two |
769 | ;; functions where we can pass a candidate for lambda lifting as | |
770 | ;; argument. So, if we see fun elsewhere, we'll delete it from | |
771 | ;; lambda candidate list. | |
a9de04fa SM |
772 | (let ((fdata (and (symbolp fun) (assq fun env)))) |
773 | (if fdata | |
774 | (setf (nth 4 fdata) t) | |
775 | (cconv-analyse-form fun env))) | |
43e67019 | 776 | (dolist (form args) |
a9de04fa | 777 | (cconv-analyse-form form env))) |
43e67019 SM |
778 | |
779 | (`(,_ . ,body-forms) ; First element is a function or whatever. | |
780 | (dolist (form body-forms) | |
a9de04fa | 781 | (cconv-analyse-form form env))) |
43e67019 SM |
782 | |
783 | ((pred symbolp) | |
784 | (let ((dv (assq form env))) ; dv = declared and visible | |
785 | (when dv | |
a9de04fa | 786 | (setf (nth 1 dv) t)))))) |
94d11cb5 IK |
787 | |
788 | (provide 'cconv) | |
789 | ;;; cconv.el ends here |