Commit | Line | Data |
---|---|---|
39605a34 | 1 | ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- |
94d11cb5 | 2 | |
ab422c4d | 3 | ;; Copyright (C) 2011-2013 Free Software Foundation, Inc. |
d779e73c SM |
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 | |
c7015153 | 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. | |
c7015153 | 33 | ;; Firstly, we analyze the tree by calling cconv-analyse-form. |
d779e73c | 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 | 37 | ;; |
c7015153 | 38 | ;; Then we calculate the intersection of the first and third lists returned by |
d779e73c SM |
39 | ;; cconv-analyse form to find all mutated variables that are captured by |
40 | ;; closure. | |
94d11cb5 | 41 | |
d779e73c | 42 | ;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the |
c7015153 | 43 | ;; tree recursively, 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 |
4c528aab | 58 | ;; var => (car-safe var) wherever this variable is used, and also |
d779e73c | 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 | ||
ca105506 | 68 | ;; TODO: (not just for cconv but also for the lexbind changes in general) |
ca105506 | 69 | ;; - let (e)debug find the value of lexical variables from the stack. |
e4769531 | 70 | ;; - make eval-region do the eval-sexp-add-defvars dance. |
e2abe5a1 | 71 | ;; - byte-optimize-form should be applied before cconv. |
ca105506 SM |
72 | ;; OTOH, the warnings emitted by cconv-analyze need to come before optimize |
73 | ;; since afterwards they can because obnoxious (warnings about an "unused | |
74 | ;; variable" should not be emitted when the variable use has simply been | |
75 | ;; optimized away). | |
7200d79c SM |
76 | ;; - let macros specify that some let-bindings come from the same source, |
77 | ;; so the unused warning takes all uses into account. | |
78 | ;; - let interactive specs return a function to build the args (to stash into | |
79 | ;; command-history). | |
cb9336bd SM |
80 | ;; - canonize code in macro-expand so we don't have to handle (let (var) body) |
81 | ;; and other oddities. | |
adf2aa61 | 82 | ;; - new byte codes for unwind-protect so that closures aren't needed at all. |
d032d5e7 SM |
83 | ;; - a reference to a var that is known statically to always hold a constant |
84 | ;; should be turned into a byte-constant rather than a byte-stack-ref. | |
e2abe5a1 SM |
85 | ;; Hmm... right, that's called constant propagation and could be done here, |
86 | ;; but when that constant is a function, we have to be careful to make sure | |
d032d5e7 SM |
87 | ;; the bytecomp only compiles it once. |
88 | ;; - Since we know here when a variable is not mutated, we could pass that | |
89 | ;; info to the byte-compiler, e.g. by using a new `immutable-let'. | |
e2abe5a1 | 90 | ;; - add tail-calls to bytecode.c and the byte compiler. |
29a4dcb0 | 91 | ;; - call known non-escaping functions with `goto' rather than `call'. |
6c075cd7 | 92 | ;; - optimize mapcar to a while loop. |
d032d5e7 SM |
93 | |
94 | ;; (defmacro dlet (binders &rest body) | |
95 | ;; ;; Works in both lexical and non-lexical mode. | |
208d0342 | 96 | ;; (declare (indent 1) (debug let)) |
d032d5e7 SM |
97 | ;; `(progn |
98 | ;; ,@(mapcar (lambda (binder) | |
99 | ;; `(defvar ,(if (consp binder) (car binder) binder))) | |
100 | ;; binders) | |
101 | ;; (let ,binders ,@body))) | |
102 | ||
103 | ;; (defmacro llet (binders &rest body) | |
104 | ;; ;; Only works in lexical-binding mode. | |
105 | ;; `(funcall | |
106 | ;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder)) | |
107 | ;; binders) | |
108 | ;; ,@body) | |
109 | ;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder))) | |
110 | ;; binders))) | |
111 | ||
f80efb86 | 112 | (eval-when-compile (require 'cl-lib)) |
94d11cb5 | 113 | |
d032d5e7 | 114 | (defconst cconv-liftwhen 6 |
d779e73c | 115 | "Try to do lambda lifting if the number of arguments + free variables |
94d11cb5 | 116 | is less than this number.") |
a9de04fa SM |
117 | ;; List of all the variables that are both captured by a closure |
118 | ;; and mutated. Each entry in the list takes the form | |
119 | ;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the | |
120 | ;; variable (or is just (VAR) for variables not introduced by let). | |
121 | (defvar cconv-captured+mutated) | |
d779e73c | 122 | |
a9de04fa SM |
123 | ;; List of candidates for lambda lifting. |
124 | ;; Each candidate has the form (BINDER . PARENTFORM). A candidate | |
125 | ;; is a variable that is only passed to `funcall' or `apply'. | |
126 | (defvar cconv-lambda-candidates) | |
d779e73c | 127 | |
a9de04fa SM |
128 | ;; Alist associating to each function body the list of its free variables. |
129 | (defvar cconv-freevars-alist) | |
94d11cb5 IK |
130 | |
131 | ;;;###autoload | |
295fb2ac SM |
132 | (defun cconv-closure-convert (form) |
133 | "Main entry point for closure conversion. | |
94d11cb5 IK |
134 | -- FORM is a piece of Elisp code after macroexpansion. |
135 | -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST | |
136 | ||
137 | Returns a form where all lambdas don't have any free variables." | |
b38b1ec0 | 138 | ;; (message "Entering cconv-closure-convert...") |
a9de04fa | 139 | (let ((cconv-freevars-alist '()) |
94d11cb5 | 140 | (cconv-lambda-candidates '()) |
d779e73c | 141 | (cconv-captured+mutated '())) |
c7015153 | 142 | ;; Analyze form - fill these variables with new information. |
a9de04fa SM |
143 | (cconv-analyse-form form '()) |
144 | (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) | |
0b31660d SM |
145 | (prog1 (cconv-convert form nil nil) ; Env initially empty. |
146 | (cl-assert (null cconv-freevars-alist))))) | |
147 | ||
148 | ;;;###autoload | |
149 | (defun cconv-warnings-only (form) | |
150 | "Add the warnings that closure conversion would encounter." | |
151 | (let ((cconv-freevars-alist '()) | |
152 | (cconv-lambda-candidates '()) | |
153 | (cconv-captured+mutated '())) | |
154 | ;; Analyze form - fill these variables with new information. | |
155 | (cconv-analyse-form form '()) | |
156 | ;; But don't perform the closure conversion. | |
157 | form)) | |
94d11cb5 | 158 | |
295fb2ac | 159 | (defconst cconv--dummy-var (make-symbol "ignored")) |
b38b1ec0 SM |
160 | |
161 | (defun cconv--set-diff (s1 s2) | |
162 | "Return elements of set S1 that are not in set S2." | |
163 | (let ((res '())) | |
164 | (dolist (x s1) | |
165 | (unless (memq x s2) (push x res))) | |
166 | (nreverse res))) | |
167 | ||
168 | (defun cconv--set-diff-map (s m) | |
169 | "Return elements of set S that are not in Dom(M)." | |
170 | (let ((res '())) | |
171 | (dolist (x s) | |
172 | (unless (assq x m) (push x res))) | |
173 | (nreverse res))) | |
174 | ||
175 | (defun cconv--map-diff (m1 m2) | |
176 | "Return the submap of map M1 that has Dom(M2) removed." | |
177 | (let ((res '())) | |
178 | (dolist (x m1) | |
179 | (unless (assq (car x) m2) (push x res))) | |
180 | (nreverse res))) | |
181 | ||
182 | (defun cconv--map-diff-elem (m x) | |
183 | "Return the map M minus any mapping for X." | |
184 | ;; Here we assume that X appears at most once in M. | |
185 | (let* ((b (assq x m)) | |
186 | (res (if b (remq b m) m))) | |
f80efb86 | 187 | (cl-assert (null (assq x res))) ;; Check the assumption was warranted. |
b38b1ec0 | 188 | res)) |
94d11cb5 | 189 | |
b38b1ec0 SM |
190 | (defun cconv--map-diff-set (m s) |
191 | "Return the map M minus any mapping for elements of S." | |
192 | ;; Here we assume that X appears at most once in M. | |
193 | (let ((res '())) | |
194 | (dolist (b m) | |
195 | (unless (memq (car b) s) (push b res))) | |
196 | (nreverse res))) | |
197 | ||
6c075cd7 | 198 | (defun cconv--convert-function (args body env parentform) |
f80efb86 | 199 | (cl-assert (equal body (caar cconv-freevars-alist))) |
6c075cd7 SM |
200 | (let* ((fvs (cdr (pop cconv-freevars-alist))) |
201 | (body-new '()) | |
a9de04fa | 202 | (letbind '()) |
6c075cd7 SM |
203 | (envector ()) |
204 | (i 0) | |
205 | (new-env ())) | |
206 | ;; Build the "formal and actual envs" for the closure-converted function. | |
207 | (dolist (fv fvs) | |
208 | (let ((exp (or (cdr (assq fv env)) fv))) | |
209 | (pcase exp | |
210 | ;; If `fv' is a variable that's wrapped in a cons-cell, | |
211 | ;; we want to put the cons-cell itself in the closure, | |
212 | ;; rather than just a copy of its current content. | |
4c528aab | 213 | (`(car-safe ,iexp . ,_) |
6c075cd7 | 214 | (push iexp envector) |
4c528aab | 215 | (push `(,fv . (car-safe (internal-get-closed-var ,i))) new-env)) |
6c075cd7 SM |
216 | (_ |
217 | (push exp envector) | |
218 | (push `(,fv . (internal-get-closed-var ,i)) new-env)))) | |
219 | (setq i (1+ i))) | |
220 | (setq envector (nreverse envector)) | |
221 | (setq new-env (nreverse new-env)) | |
222 | ||
223 | (dolist (arg args) | |
224 | (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) | |
225 | (if (assq arg new-env) (push `(,arg) new-env)) | |
4c528aab | 226 | (push `(,arg . (car-safe ,arg)) new-env) |
6c075cd7 | 227 | (push `(,arg (list ,arg)) letbind))) |
ca105506 | 228 | |
6c075cd7 SM |
229 | (setq body-new (mapcar (lambda (form) |
230 | (cconv-convert form new-env nil)) | |
231 | body)) | |
232 | ||
233 | (when letbind | |
234 | (let ((special-forms '())) | |
235 | ;; Keep special forms at the beginning of the body. | |
236 | (while (or (stringp (car body-new)) ;docstring. | |
237 | (memq (car-safe (car body-new)) '(interactive declare))) | |
238 | (push (pop body-new) special-forms)) | |
239 | (setq body-new | |
240 | `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) | |
a9de04fa SM |
241 | |
242 | (cond | |
6c075cd7 SM |
243 | ((null envector) ;if no freevars - do nothing |
244 | `(function (lambda ,args . ,body-new))) | |
a9de04fa SM |
245 | (t |
246 | `(internal-make-closure | |
6c075cd7 | 247 | ,args ,envector . ,body-new))))) |
a9de04fa | 248 | |
6c075cd7 | 249 | (defun cconv-convert (form env extend) |
d779e73c | 250 | ;; This function actually rewrites the tree. |
6c075cd7 SM |
251 | "Return FORM with all its lambdas changed so they are closed. |
252 | ENV is a lexical environment mapping variables to the expression | |
253 | used to get its value. This is used for variables that are copied into | |
254 | closures, moved into cons cells, ... | |
255 | ENV is a list where each entry takes the shape either: | |
4c528aab | 256 | (VAR . (car-safe EXP)): VAR has been moved into the car of a cons-cell, and EXP |
6c075cd7 SM |
257 | is an expression that evaluates to this cons-cell. |
258 | (VAR . (internal-get-closed-var N)): VAR has been copied into the closure | |
259 | environment's Nth slot. | |
260 | (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes | |
261 | additional arguments ARGs. | |
262 | EXTEND is a list of variables which might need to be accessed even from places | |
263 | where they are shadowed, because some part of ENV causes them to be used at | |
264 | places where they originally did not directly appear." | |
f80efb86 SM |
265 | (cl-assert (not (delq nil (mapcar (lambda (mapping) |
266 | (if (eq (cadr mapping) 'apply-partially) | |
267 | (cconv--set-diff (cdr (cddr mapping)) | |
268 | extend))) | |
269 | env)))) | |
ca105506 | 270 | |
d779e73c | 271 | ;; What's the difference between fvrs and envs? |
94d11cb5 IK |
272 | ;; Suppose that we have the code |
273 | ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) | |
d779e73c SM |
274 | ;; only the first occurrence of fvr should be replaced by |
275 | ;; (aref env ...). | |
94d11cb5 IK |
276 | ;; So initially envs and fvrs are the same thing, but when we descend to |
277 | ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? | |
278 | ;; Because in envs the order of variables is important. We use this list | |
d779e73c SM |
279 | ;; to find the number of a specific variable in the environment vector, |
280 | ;; so we never touch it(unless we enter to the other closure). | |
281 | ;;(if (listp form) (print (car form)) form) | |
282 | (pcase form | |
6c075cd7 | 283 | (`(,(and letsym (or `let* `let)) ,binders . ,body) |
94d11cb5 IK |
284 | |
285 | ; let and let* special forms | |
6c075cd7 SM |
286 | (let ((binders-new '()) |
287 | (new-env env) | |
288 | (new-extend extend)) | |
d779e73c | 289 | |
295fb2ac SM |
290 | (dolist (binder binders) |
291 | (let* ((value nil) | |
292 | (var (if (not (consp binder)) | |
a9de04fa | 293 | (prog1 binder (setq binder (list binder))) |
295fb2ac SM |
294 | (setq value (cadr binder)) |
295 | (car binder))) | |
296 | (new-val | |
297 | (cond | |
298 | ;; Check if var is a candidate for lambda lifting. | |
6c075cd7 SM |
299 | ((and (member (cons binder form) cconv-lambda-candidates) |
300 | (progn | |
f80efb86 SM |
301 | (cl-assert (and (eq (car value) 'function) |
302 | (eq (car (cadr value)) 'lambda))) | |
303 | (cl-assert (equal (cddr (cadr value)) | |
304 | (caar cconv-freevars-alist))) | |
6c075cd7 SM |
305 | ;; Peek at the freevars to decide whether to λ-lift. |
306 | (let* ((fvs (cdr (car cconv-freevars-alist))) | |
307 | (fun (cadr value)) | |
308 | (funargs (cadr fun)) | |
309 | (funcvars (append fvs funargs))) | |
94d11cb5 | 310 | ; lambda lifting condition |
6c075cd7 SM |
311 | (and fvs (>= cconv-liftwhen (length funcvars)))))) |
312 | ; Lift. | |
313 | (let* ((fvs (cdr (pop cconv-freevars-alist))) | |
314 | (fun (cadr value)) | |
315 | (funargs (cadr fun)) | |
316 | (funcvars (append fvs funargs)) | |
317 | (funcbody (cddr fun)) | |
318 | (funcbody-env ())) | |
319 | (push `(,var . (apply-partially ,var . ,fvs)) new-env) | |
320 | (dolist (fv fvs) | |
f80efb86 | 321 | (cl-pushnew fv new-extend) |
4c528aab | 322 | (if (and (eq 'car-safe (car-safe (cdr (assq fv env)))) |
6c075cd7 | 323 | (not (memq fv funargs))) |
4c528aab | 324 | (push `(,fv . (car-safe ,fv)) funcbody-env))) |
6c075cd7 SM |
325 | `(function (lambda ,funcvars . |
326 | ,(mapcar (lambda (form) | |
327 | (cconv-convert | |
328 | form funcbody-env nil)) | |
329 | funcbody))))) | |
295fb2ac SM |
330 | |
331 | ;; Check if it needs to be turned into a "ref-cell". | |
a9de04fa | 332 | ((member (cons binder form) cconv-captured+mutated) |
295fb2ac | 333 | ;; Declared variable is mutated and captured. |
4c528aab | 334 | (push `(,var . (car-safe ,var)) new-env) |
6c075cd7 | 335 | `(list ,(cconv-convert value env extend))) |
295fb2ac SM |
336 | |
337 | ;; Normal default case. | |
338 | (t | |
6c075cd7 SM |
339 | (if (assq var new-env) (push `(,var) new-env)) |
340 | (cconv-convert value env extend))))) | |
341 | ||
342 | ;; The piece of code below letbinds free variables of a λ-lifted | |
343 | ;; function if they are redefined in this let, example: | |
344 | ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) | |
345 | ;; Here we can not pass y as parameter because it is redefined. | |
346 | ;; So we add a (closed-y y) declaration. We do that even if the | |
347 | ;; function is not used inside this let(*). The reason why we | |
348 | ;; ignore this case is that we can't "look forward" to see if the | |
349 | ;; function is called there or not. To treat this case better we'd | |
350 | ;; need to traverse the tree one more time to collect this data, and | |
351 | ;; I think that it's not worth it. | |
352 | (when (memq var new-extend) | |
353 | (let ((closedsym | |
354 | (make-symbol (concat "closed-" (symbol-name var))))) | |
355 | (setq new-env | |
356 | (mapcar (lambda (mapping) | |
357 | (if (not (eq (cadr mapping) 'apply-partially)) | |
358 | mapping | |
f80efb86 | 359 | (cl-assert (eq (car mapping) (nth 2 mapping))) |
2ee3d7f0 SM |
360 | `(,(car mapping) |
361 | apply-partially | |
362 | ,(car mapping) | |
363 | ,@(mapcar (lambda (arg) | |
364 | (if (eq var arg) | |
365 | closedsym arg)) | |
366 | (nthcdr 3 mapping))))) | |
6c075cd7 SM |
367 | new-env)) |
368 | (setq new-extend (remq var new-extend)) | |
369 | (push closedsym new-extend) | |
370 | (push `(,closedsym ,var) binders-new))) | |
d779e73c | 371 | |
b38b1ec0 SM |
372 | ;; We push the element after redefined free variables are |
373 | ;; processed. This is important to avoid the bug when free | |
374 | ;; variable and the function have the same name. | |
295fb2ac | 375 | (push (list var new-val) binders-new) |
d779e73c | 376 | |
6c075cd7 SM |
377 | (when (eq letsym 'let*) |
378 | (setq env new-env) | |
379 | (setq extend new-extend)) | |
380 | )) ; end of dolist over binders | |
381 | ||
382 | `(,letsym ,(nreverse binders-new) | |
383 | . ,(mapcar (lambda (form) | |
384 | (cconv-convert | |
385 | form new-env new-extend)) | |
386 | body)))) | |
94d11cb5 IK |
387 | ;end of let let* forms |
388 | ||
d779e73c | 389 | ; first element is lambda expression |
6c075cd7 SM |
390 | (`(,(and `(lambda . ,_) fun) . ,args) |
391 | ;; FIXME: it's silly to create a closure just to call it. | |
ca105506 | 392 | ;; Running byte-optimize-form earlier will resolve this. |
6c075cd7 SM |
393 | `(funcall |
394 | ,(cconv-convert `(function ,fun) env extend) | |
395 | ,@(mapcar (lambda (form) | |
396 | (cconv-convert form env extend)) | |
397 | args))) | |
d779e73c SM |
398 | |
399 | (`(cond . ,cond-forms) ; cond special form | |
6c075cd7 SM |
400 | `(cond . ,(mapcar (lambda (branch) |
401 | (mapcar (lambda (form) | |
402 | (cconv-convert form env extend)) | |
403 | branch)) | |
404 | cond-forms))) | |
d779e73c | 405 | |
6c075cd7 SM |
406 | (`(function (lambda ,args . ,body) . ,_) |
407 | (cconv--convert-function args body env form)) | |
d779e73c | 408 | |
876c194c | 409 | (`(internal-make-closure . ,_) |
6c075cd7 SM |
410 | (byte-compile-report-error |
411 | "Internal error in compiler: cconv called twice?")) | |
876c194c | 412 | |
6c075cd7 SM |
413 | (`(quote . ,_) form) |
414 | (`(function . ,_) form) | |
94d11cb5 IK |
415 | |
416 | ;defconst, defvar | |
6c075cd7 SM |
417 | (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms) |
418 | `(,sym ,definedsymbol | |
419 | . ,(mapcar (lambda (form) (cconv-convert form env extend)) | |
420 | forms))) | |
d779e73c | 421 | |
94d11cb5 | 422 | ;condition-case |
adf2aa61 SM |
423 | ((and `(condition-case ,var ,protected-form . ,handlers) |
424 | (guard byte-compile--use-old-handlers)) | |
6c075cd7 SM |
425 | (let ((newform (cconv--convert-function |
426 | () (list protected-form) env form))) | |
295fb2ac | 427 | `(condition-case :fun-body ,newform |
adf2aa61 | 428 | ,@(mapcar (lambda (handler) |
876c194c | 429 | (list (car handler) |
6c075cd7 SM |
430 | (cconv--convert-function |
431 | (list (or var cconv--dummy-var)) | |
432 | (cdr handler) env form))) | |
876c194c | 433 | handlers)))) |
295fb2ac | 434 | |
adf2aa61 SM |
435 | ; condition-case with new byte-codes. |
436 | (`(condition-case ,var ,protected-form . ,handlers) | |
437 | `(condition-case ,var | |
438 | ,(cconv-convert protected-form env extend) | |
439 | ,@(let* ((cm (and var (member (cons (list var) form) | |
440 | cconv-captured+mutated))) | |
441 | (newenv | |
442 | (cond (cm (cons `(,var . (car-save ,var)) env)) | |
443 | ((assq var env) (cons `(,var) env)) | |
444 | (t env)))) | |
445 | (mapcar | |
446 | (lambda (handler) | |
447 | `(,(car handler) | |
448 | ,@(let ((body | |
449 | (mapcar (lambda (form) | |
450 | (cconv-convert form newenv extend)) | |
451 | (cdr handler)))) | |
452 | (if (not cm) body | |
453 | `((let ((,var (list ,var))) ,@body)))))) | |
454 | handlers)))) | |
455 | ||
456 | (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers)) | |
457 | `unwind-protect)) | |
458 | ,form . ,body) | |
6c075cd7 SM |
459 | `(,head ,(cconv-convert form env extend) |
460 | :fun-body ,(cconv--convert-function () body env form))) | |
295fb2ac | 461 | |
e0f57e65 SM |
462 | (`(track-mouse . ,body) |
463 | `(track-mouse | |
6c075cd7 | 464 | :fun-body ,(cconv--convert-function () body env form))) |
d779e73c SM |
465 | |
466 | (`(setq . ,forms) ; setq special form | |
6c075cd7 | 467 | (let ((prognlist ())) |
d779e73c | 468 | (while forms |
6c075cd7 SM |
469 | (let* ((sym (pop forms)) |
470 | (sym-new (or (cdr (assq sym env)) sym)) | |
471 | (value (cconv-convert (pop forms) env extend))) | |
472 | (push (pcase sym-new | |
473 | ((pred symbolp) `(setq ,sym-new ,value)) | |
4c528aab | 474 | (`(car-safe ,iexp) `(setcar ,iexp ,value)) |
6c075cd7 SM |
475 | ;; This "should never happen", but for variables which are |
476 | ;; mutated+captured+unused, we may end up trying to `setq' | |
477 | ;; on a closed-over variable, so just drop the setq. | |
478 | (_ ;; (byte-compile-report-error | |
479 | ;; (format "Internal error in cconv of (setq %s ..)" | |
480 | ;; sym-new)) | |
481 | value)) | |
482 | prognlist))) | |
d779e73c | 483 | (if (cdr prognlist) |
6c075cd7 | 484 | `(progn . ,(nreverse prognlist)) |
d779e73c SM |
485 | (car prognlist)))) |
486 | ||
487 | (`(,(and (or `funcall `apply) callsym) ,fun . ,args) | |
6c075cd7 SM |
488 | ;; These are not special forms but we treat them separately for the needs |
489 | ;; of lambda lifting. | |
490 | (let ((mapping (cdr (assq fun env)))) | |
491 | (pcase mapping | |
492 | (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) | |
f80efb86 | 493 | (cl-assert (eq (cadr mapping) fun)) |
6c075cd7 SM |
494 | `(,callsym ,fun |
495 | ,@(mapcar (lambda (fv) | |
496 | (let ((exp (or (cdr (assq fv env)) fv))) | |
497 | (pcase exp | |
4c528aab | 498 | (`(car-safe ,iexp . ,_) iexp) |
6c075cd7 SM |
499 | (_ exp)))) |
500 | fvs) | |
501 | ,@(mapcar (lambda (arg) | |
502 | (cconv-convert arg env extend)) | |
503 | args))) | |
504 | (_ `(,callsym ,@(mapcar (lambda (arg) | |
505 | (cconv-convert arg env extend)) | |
506 | (cons fun args))))))) | |
d779e73c | 507 | |
d032d5e7 | 508 | (`(interactive . ,forms) |
6c075cd7 SM |
509 | `(interactive . ,(mapcar (lambda (form) |
510 | (cconv-convert form nil nil)) | |
511 | forms))) | |
ca105506 | 512 | |
ba83908c | 513 | (`(declare . ,_) form) ;The args don't contain code. |
ca105506 | 514 | |
6c075cd7 SM |
515 | (`(,func . ,forms) |
516 | ;; First element is function or whatever function-like forms are: or, and, | |
adf2aa61 | 517 | ;; if, catch, progn, prog1, prog2, while, until |
6c075cd7 SM |
518 | `(,func . ,(mapcar (lambda (form) |
519 | (cconv-convert form env extend)) | |
520 | forms))) | |
521 | ||
522 | (_ (or (cdr (assq form env)) form)))) | |
43e67019 | 523 | |
a9de04fa SM |
524 | (unless (fboundp 'byte-compile-not-lexical-var-p) |
525 | ;; Only used to test the code in non-lexbind Emacs. | |
526 | (defalias 'byte-compile-not-lexical-var-p 'boundp)) | |
208d0342 | 527 | (defvar byte-compile-lexical-variables) |
a9de04fa | 528 | |
6c075cd7 | 529 | (defun cconv--analyse-use (vardata form varkind) |
e9fce1ac | 530 | "Analyze the use of a variable. |
d032d5e7 SM |
531 | VARDATA should be (BINDER READ MUTATED CAPTURED CALLED). |
532 | VARKIND is the name of the kind of variable. | |
533 | FORM is the parent form that binds this var." | |
a9de04fa SM |
534 | ;; use = `(,binder ,read ,mutated ,captured ,called) |
535 | (pcase vardata | |
d032d5e7 SM |
536 | (`(,_ nil nil nil nil) nil) |
537 | (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_) | |
538 | ,_ ,_ ,_ ,_) | |
6c075cd7 SM |
539 | (byte-compile-log-warning |
540 | (format "%s `%S' not left unused" varkind var)))) | |
d032d5e7 SM |
541 | (pcase vardata |
542 | (`((,var . ,_) nil ,_ ,_ nil) | |
543 | ;; FIXME: This gives warnings in the wrong order, with imprecise line | |
544 | ;; numbers and without function name info. | |
545 | (unless (or ;; Uninterned symbols typically come from macro-expansion, so | |
546 | ;; it is often non-trivial for the programmer to avoid such | |
547 | ;; unused vars. | |
548 | (not (intern-soft var)) | |
e67a13ab CY |
549 | (eq ?_ (aref (symbol-name var) 0)) |
550 | ;; As a special exception, ignore "ignore". | |
551 | (eq var 'ignored)) | |
d032d5e7 SM |
552 | (byte-compile-log-warning (format "Unused lexical %s `%S'" |
553 | varkind var)))) | |
a9de04fa | 554 | ;; If it's unused, there's no point converting it into a cons-cell, even if |
d032d5e7 | 555 | ;; it's captured and mutated. |
a9de04fa SM |
556 | (`(,binder ,_ t t ,_) |
557 | (push (cons binder form) cconv-captured+mutated)) | |
558 | (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) | |
6c075cd7 | 559 | (push (cons binder form) cconv-lambda-candidates)))) |
a9de04fa | 560 | |
6c075cd7 | 561 | (defun cconv--analyse-function (args body env parentform) |
a9de04fa SM |
562 | (let* ((newvars nil) |
563 | (freevars (list body)) | |
564 | ;; We analyze the body within a new environment where all uses are | |
565 | ;; nil, so we can distinguish uses within that function from uses | |
566 | ;; outside of it. | |
567 | (envcopy | |
568 | (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) | |
208d0342 | 569 | (byte-compile-bound-variables byte-compile-bound-variables) |
a9de04fa SM |
570 | (newenv envcopy)) |
571 | ;; Push it before recursing, so cconv-freevars-alist contains entries in | |
572 | ;; the order they'll be used by closure-convert-rec. | |
573 | (push freevars cconv-freevars-alist) | |
574 | (dolist (arg args) | |
575 | (cond | |
576 | ((byte-compile-not-lexical-var-p arg) | |
06788a55 | 577 | (byte-compile-log-warning |
95888bca SM |
578 | (format "Lexical argument shadows the dynamic variable %S" |
579 | arg))) | |
a9de04fa SM |
580 | ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... |
581 | (t (let ((varstruct (list arg nil nil nil nil))) | |
208d0342 | 582 | (cl-pushnew arg byte-compile-lexical-variables) |
a9de04fa SM |
583 | (push (cons (list arg) (cdr varstruct)) newvars) |
584 | (push varstruct newenv))))) | |
e9fce1ac | 585 | (dolist (form body) ;Analyze body forms. |
a9de04fa SM |
586 | (cconv-analyse-form form newenv)) |
587 | ;; Summarize resulting data about arguments. | |
588 | (dolist (vardata newvars) | |
6c075cd7 | 589 | (cconv--analyse-use vardata parentform "argument")) |
a9de04fa SM |
590 | ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; |
591 | ;; and compute free variables. | |
592 | (while env | |
f80efb86 | 593 | (cl-assert (and envcopy (eq (caar env) (caar envcopy)))) |
a9de04fa SM |
594 | (let ((free nil) |
595 | (x (cdr (car env))) | |
596 | (y (cdr (car envcopy)))) | |
597 | (while x | |
598 | (when (car y) (setcar x t) (setq free t)) | |
599 | (setq x (cdr x) y (cdr y))) | |
600 | (when free | |
2ee3d7f0 SM |
601 | (push (caar env) (cdr freevars)) |
602 | (setf (nth 3 (car env)) t)) | |
a9de04fa SM |
603 | (setq env (cdr env) envcopy (cdr envcopy)))))) |
604 | ||
605 | (defun cconv-analyse-form (form env) | |
606 | "Find mutated variables and variables captured by closure. | |
c7015153 | 607 | Analyze lambdas if they are suitable for lambda lifting. |
d032d5e7 SM |
608 | - FORM is a piece of Elisp code after macroexpansion. |
609 | - ENV is an alist mapping each enclosing lexical variable to its info. | |
a9de04fa SM |
610 | I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). |
611 | This function does not return anything but instead fills the | |
612 | `cconv-captured+mutated' and `cconv-lambda-candidates' variables | |
613 | and updates the data stored in ENV." | |
94d11cb5 IK |
614 | (pcase form |
615 | ; let special form | |
43e67019 | 616 | (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) |
d779e73c | 617 | |
43e67019 | 618 | (let ((orig-env env) |
a9de04fa | 619 | (newvars nil) |
d779e73c | 620 | (var nil) |
208d0342 | 621 | (byte-compile-bound-variables byte-compile-bound-variables) |
43e67019 SM |
622 | (value nil)) |
623 | (dolist (binder binders) | |
624 | (if (not (consp binder)) | |
d779e73c | 625 | (progn |
43e67019 | 626 | (setq var binder) ; treat the form (let (x) ...) well |
a9de04fa | 627 | (setq binder (list binder)) |
43e67019 SM |
628 | (setq value nil)) |
629 | (setq var (car binder)) | |
630 | (setq value (cadr binder)) | |
631 | ||
a9de04fa | 632 | (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) |
43e67019 | 633 | |
ce5b520a | 634 | (unless (byte-compile-not-lexical-var-p var) |
208d0342 | 635 | (cl-pushnew var byte-compile-lexical-variables) |
a9de04fa SM |
636 | (let ((varstruct (list var nil nil nil nil))) |
637 | (push (cons binder (cdr varstruct)) newvars) | |
638 | (push varstruct env)))) | |
43e67019 | 639 | |
e9fce1ac | 640 | (dolist (form body-forms) ; Analyze body forms. |
a9de04fa | 641 | (cconv-analyse-form form env)) |
43e67019 | 642 | |
a9de04fa | 643 | (dolist (vardata newvars) |
6c075cd7 | 644 | (cconv--analyse-use vardata form "variable")))) |
43e67019 | 645 | |
43e67019 | 646 | (`(function (lambda ,vrs . ,body-forms)) |
6c075cd7 | 647 | (cconv--analyse-function vrs body-forms env form)) |
ca105506 | 648 | |
43e67019 SM |
649 | (`(setq . ,forms) |
650 | ;; If a local variable (member of env) is modified by setq then | |
651 | ;; it is a mutated variable. | |
d779e73c | 652 | (while forms |
43e67019 | 653 | (let ((v (assq (car forms) env))) ; v = non nil if visible |
2ee3d7f0 | 654 | (when v (setf (nth 2 v) t))) |
a9de04fa | 655 | (cconv-analyse-form (cadr forms) env) |
43e67019 SM |
656 | (setq forms (cddr forms)))) |
657 | ||
0d42eb3e SM |
658 | (`((lambda . ,_) . ,_) ; First element is lambda expression. |
659 | (byte-compile-log-warning | |
208d0342 SM |
660 | (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) |
661 | t :warning) | |
d779e73c | 662 | (dolist (exp `((function ,(car form)) . ,(cdr form))) |
a9de04fa | 663 | (cconv-analyse-form exp env))) |
d779e73c SM |
664 | |
665 | (`(cond . ,cond-forms) ; cond special form | |
43e67019 | 666 | (dolist (forms cond-forms) |
d032d5e7 | 667 | (dolist (form forms) (cconv-analyse-form form env)))) |
d779e73c SM |
668 | |
669 | (`(quote . ,_) nil) ; quote form | |
d779e73c SM |
670 | (`(function . ,_) nil) ; same as quote |
671 | ||
adf2aa61 SM |
672 | ((and `(condition-case ,var ,protected-form . ,handlers) |
673 | (guard byte-compile--use-old-handlers)) | |
43e67019 | 674 | ;; FIXME: The bytecode for condition-case forces us to wrap the |
adf2aa61 | 675 | ;; form and handlers in closures. |
6c075cd7 | 676 | (cconv--analyse-function () (list protected-form) env form) |
43e67019 | 677 | (dolist (handler handlers) |
adf2aa61 SM |
678 | (cconv--analyse-function (if var (list var)) (cdr handler) |
679 | env form))) | |
43e67019 | 680 | |
adf2aa61 SM |
681 | (`(condition-case ,var ,protected-form . ,handlers) |
682 | (cconv-analyse-form protected-form env) | |
683 | (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) | |
684 | (byte-compile-log-warning | |
685 | (format "Lexical variable shadows the dynamic variable %S" var))) | |
686 | (let* ((varstruct (list var nil nil nil nil))) | |
687 | (if var (push varstruct env)) | |
688 | (dolist (handler handlers) | |
689 | (dolist (form (cdr handler)) | |
690 | (cconv-analyse-form form env))) | |
691 | (if var (cconv--analyse-use (cons (list var) (cdr varstruct)) | |
692 | form "variable")))) | |
693 | ||
694 | ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. | |
695 | (`(,(or (and `catch (guard byte-compile--use-old-handlers)) | |
696 | `unwind-protect) | |
697 | ,form . ,body) | |
a9de04fa | 698 | (cconv-analyse-form form env) |
6c075cd7 | 699 | (cconv--analyse-function () body env form)) |
43e67019 | 700 | |
ca105506 SM |
701 | ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body. |
702 | ;; `track-mouse' really should be made into a macro. | |
e0f57e65 | 703 | (`(track-mouse . ,body) |
6c075cd7 | 704 | (cconv--analyse-function () body env form)) |
43e67019 | 705 | |
208d0342 | 706 | (`(defvar ,var) (push var byte-compile-bound-variables)) |
43e67019 SM |
707 | (`(,(or `defconst `defvar) ,var ,value . ,_) |
708 | (push var byte-compile-bound-variables) | |
a9de04fa | 709 | (cconv-analyse-form value env)) |
d779e73c SM |
710 | |
711 | (`(,(or `funcall `apply) ,fun . ,args) | |
43e67019 SM |
712 | ;; Here we ignore fun because funcall and apply are the only two |
713 | ;; functions where we can pass a candidate for lambda lifting as | |
714 | ;; argument. So, if we see fun elsewhere, we'll delete it from | |
715 | ;; lambda candidate list. | |
a9de04fa SM |
716 | (let ((fdata (and (symbolp fun) (assq fun env)))) |
717 | (if fdata | |
2ee3d7f0 | 718 | (setf (nth 4 fdata) t) |
a9de04fa | 719 | (cconv-analyse-form fun env))) |
d032d5e7 SM |
720 | (dolist (form args) (cconv-analyse-form form env))) |
721 | ||
722 | (`(interactive . ,forms) | |
723 | ;; These appear within the function body but they don't have access | |
724 | ;; to the function's arguments. | |
725 | ;; We could extend this to allow interactive specs to refer to | |
726 | ;; variables in the function's enclosing environment, but it doesn't | |
727 | ;; seem worth the trouble. | |
728 | (dolist (form forms) (cconv-analyse-form form nil))) | |
ba83908c | 729 | |
208d0342 SM |
730 | ;; `declare' should now be macro-expanded away (and if they're not, we're |
731 | ;; in trouble because they *can* contain code nowadays). | |
732 | ;; (`(declare . ,_) nil) ;The args don't contain code. | |
ca105506 | 733 | |
43e67019 | 734 | (`(,_ . ,body-forms) ; First element is a function or whatever. |
d032d5e7 | 735 | (dolist (form body-forms) (cconv-analyse-form form env))) |
43e67019 SM |
736 | |
737 | ((pred symbolp) | |
738 | (let ((dv (assq form env))) ; dv = declared and visible | |
739 | (when dv | |
2ee3d7f0 | 740 | (setf (nth 1 dv) t)))))) |
94d11cb5 IK |
741 | |
742 | (provide 'cconv) | |
743 | ;;; cconv.el ends here |