1 ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*-
3 ;; Copyright (C) 2011 Free Software Foundation, Inc.
5 ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
10 ;; This file is part of GNU Emacs.
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.
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.
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/>.
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).
30 ;; All macros should be expanded beforehand.
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
35 ;; for lambda lifting and all variables captured by closure. It passes the tree
36 ;; once, returning a list of three lists.
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
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
44 ;; is needed and eliminating mutable variables used in closure.
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)
50 ;; (lambda (v0 ...) ... fv0 .. fv1 ...) =>
51 ;; (internal-make-closure (v0 ...) (fv1 ...)
52 ;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...)
54 ;; If the function has no free variables, we don't do anything.
56 ;; If a variable is mutated (updated by setq), and it is used in a closure
57 ;; we wrap its definition with list: (list val) and we also replace
58 ;; var => (car var) wherever this variable is used, and also
59 ;; (setq var value) => (setcar var value) where it is updated.
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))) ...))
69 ;; - canonize code in macro-expand so we don't have to handle (let (var) body)
70 ;; and other oddities.
71 ;; - Change new byte-code representation, so it directly gives the
72 ;; number of mandatory and optional arguments as well as whether or
73 ;; not there's a &rest arg.
74 ;; - clean up cconv-closure-convert-rec, especially the `let' binding part.
75 ;; - new byte codes for unwind-protect, catch, and condition-case so that
76 ;; closures aren't needed at all.
77 ;; - a reference to a var that is known statically to always hold a constant
78 ;; should be turned into a byte-constant rather than a byte-stack-ref.
79 ;; Hmm... right, that's called constant propagation and could be done here
80 ;; But when that constant is a function, we have to be careful to make sure
81 ;; the bytecomp only compiles it once.
82 ;; - Since we know here when a variable is not mutated, we could pass that
83 ;; info to the byte-compiler, e.g. by using a new `immutable-let'.
84 ;; - add tail-calls to bytecode.c and the bytecompiler.
86 ;; (defmacro dlet (binders &rest body)
87 ;; ;; Works in both lexical and non-lexical mode.
89 ;; ,@(mapcar (lambda (binder)
90 ;; `(defvar ,(if (consp binder) (car binder) binder)))
92 ;; (let ,binders ,@body)))
94 ;; (defmacro llet (binders &rest body)
95 ;; ;; Only works in lexical-binding mode.
97 ;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
100 ;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
103 ;; (defmacro letrec (binders &rest body)
104 ;; ;; Only useful in lexical-binding mode.
105 ;; ;; As a special-form, we could implement it more efficiently (and cleanly,
106 ;; ;; making the vars actually unbound during evaluation of the binders).
107 ;; `(let ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder))
109 ;; ,@(delq nil (mapcar (lambda (binder) (if (consp binder) `(setq ,@binder)))
113 (eval-when-compile (require 'cl
))
115 (defconst cconv-liftwhen
6
116 "Try to do lambda lifting if the number of arguments + free variables
117 is less than this number.")
118 ;; List of all the variables that are both captured by a closure
119 ;; and mutated. Each entry in the list takes the form
120 ;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the
121 ;; variable (or is just (VAR) for variables not introduced by let).
122 (defvar cconv-captured
+mutated
)
124 ;; List of candidates for lambda lifting.
125 ;; Each candidate has the form (BINDER . PARENTFORM). A candidate
126 ;; is a variable that is only passed to `funcall' or `apply'.
127 (defvar cconv-lambda-candidates
)
129 ;; Alist associating to each function body the list of its free variables.
130 (defvar cconv-freevars-alist
)
133 (defun cconv-closure-convert (form)
134 "Main entry point for closure conversion.
135 -- FORM is a piece of Elisp code after macroexpansion.
136 -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
138 Returns a form where all lambdas don't have any free variables."
139 ;; (message "Entering cconv-closure-convert...")
140 (let ((cconv-freevars-alist '())
141 (cconv-lambda-candidates '())
142 (cconv-captured+mutated
'()))
143 ;; Analyse form - fill these variables with new information.
144 (cconv-analyse-form form
'())
145 (setq cconv-freevars-alist
(nreverse cconv-freevars-alist
))
146 (cconv-closure-convert-rec
149 '() ; fvrs initially empty
150 '() ; envs initially empty
154 (defconst cconv--dummy-var
(make-symbol "ignored"))
156 (defun cconv--set-diff (s1 s2
)
157 "Return elements of set S1 that are not in set S2."
160 (unless (memq x s2
) (push x res
)))
163 (defun cconv--set-diff-map (s m
)
164 "Return elements of set S that are not in Dom(M)."
167 (unless (assq x m
) (push x res
)))
170 (defun cconv--map-diff (m1 m2
)
171 "Return the submap of map M1 that has Dom(M2) removed."
174 (unless (assq (car x
) m2
) (push x res
)))
177 (defun cconv--map-diff-elem (m x
)
178 "Return the map M minus any mapping for X."
179 ;; Here we assume that X appears at most once in M.
180 (let* ((b (assq x m
))
181 (res (if b
(remq b m
) m
)))
182 (assert (null (assq x res
))) ;; Check the assumption was warranted.
185 (defun cconv--map-diff-set (m s
)
186 "Return the map M minus any mapping for elements of S."
187 ;; Here we assume that X appears at most once in M.
190 (unless (memq (car b
) s
) (push b res
)))
193 (defun cconv-closure-convert-function (fvrs vars emvrs envs lmenvs body-forms
195 (assert (equal body-forms
(caar cconv-freevars-alist
)))
196 (let* ((fvrs-new (cconv--set-diff fvrs vars
)) ; Remove vars from fvrs.
197 (fv (cdr (pop cconv-freevars-alist
)))
202 ;; Here we form our environment vector.
206 (cconv-closure-convert-rec
207 ;; Remove `elm' from `emvrs' for this call because in case
208 ;; `elm' is a variable that's wrapped in a cons-cell, we
209 ;; want to put the cons-cell itself in the closure, rather
210 ;; than just a copy of its current content.
211 elm
(remq elm emvrs
) fvrs envs lmenvs
)
212 envector
)) ; Process vars for closure vector.
213 (setq envector
(reverse envector
))
215 (setq fvrs-new fv
)) ; Update substitution list.
217 (setq emvrs
(cconv--set-diff emvrs vars
))
218 (setq lmenvs
(cconv--map-diff-set lmenvs vars
))
220 ;; The difference between envs and fvrs is explained
221 ;; in comment in the beginning of the function.
223 (when (member (cons (list var
) parentform
) cconv-captured
+mutated
)
225 (push `(,var
(list ,var
)) letbind
)))
226 (dolist (elm body-forms
) ; convert function body
227 (push (cconv-closure-convert-rec
228 elm emvrs fvrs-new envs lmenvs
)
232 (if letbind
`((let ,letbind .
,(reverse body-forms-new
)))
233 (reverse body-forms-new
)))
236 ;if no freevars - do nothing
238 `(function (lambda ,vars .
,body-forms-new
)))
239 ; 1 free variable - do not build vector
241 `(internal-make-closure
242 ,vars
,envector .
,body-forms-new
)))))
244 (defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs
)
245 ;; This function actually rewrites the tree.
246 "Eliminates all free variables of all lambdas in given forms.
248 - FORM is a piece of Elisp code after macroexpansion.
249 - LMENVS is a list of environments used for lambda-lifting. Initially empty.
250 - EMVRS is a list that contains mutated variables that are visible
251 within current environment.
252 - ENVS is an environment(list of free variables) of current closure.
254 - FVRS is a list of variables to substitute in each context.
257 Returns a form where all lambdas don't have any free variables."
258 ;; What's the difference between fvrs and envs?
259 ;; Suppose that we have the code
260 ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
261 ;; only the first occurrence of fvr should be replaced by
263 ;; So initially envs and fvrs are the same thing, but when we descend to
264 ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
265 ;; Because in envs the order of variables is important. We use this list
266 ;; to find the number of a specific variable in the environment vector,
267 ;; so we never touch it(unless we enter to the other closure).
268 ;;(if (listp form) (print (car form)) form)
270 (`(,(and letsym
(or `let
* `let
)) ,binders .
,body-forms
)
272 ; let and let* special forms
273 (let ((body-forms-new '())
275 ;; next for variables needed for delayed push
276 ;; because we should process <value(s)>
277 ;; before we change any arguments
278 (lmenvs-new '()) ;needed only in case of let
279 (emvrs-new '()) ;needed only in case of let
280 (emvr-push) ;needed only in case of let*
281 (lmenv-push)) ;needed only in case of let*
283 (dolist (binder binders
)
285 (var (if (not (consp binder
))
286 (prog1 binder
(setq binder
(list binder
)))
287 (setq value
(cadr binder
))
291 ;; Check if var is a candidate for lambda lifting.
292 ((member (cons binder form
) cconv-lambda-candidates
)
293 (assert (and (eq (car value
) 'function
)
294 (eq (car (cadr value
)) 'lambda
)))
295 (assert (equal (cddr (cadr value
))
296 (caar cconv-freevars-alist
)))
297 ;; Peek at the freevars to decide whether to λ-lift.
298 (let* ((fv (cdr (car cconv-freevars-alist
)))
299 (funargs (cadr (cadr value
)))
300 (funcvars (append fv funargs
))
301 (funcbodies (cddadr value
)) ; function bodies
302 (funcbodies-new '()))
303 ; lambda lifting condition
304 (if (or (not fv
) (< cconv-liftwhen
(length funcvars
)))
307 ;; (byte-compile-log-warning
308 ;; (format "Not λ-lifting `%S': %d > %d"
309 ;; var (length funcvars) cconv-liftwhen))
311 (cconv-closure-convert-rec
312 value emvrs fvrs envs lmenvs
))
315 ;; (byte-compile-log-warning
316 ;; (format "λ-lifting `%S'" var))
317 (setq cconv-freevars-alist
318 ;; Now that we know we'll λ-lift, consume the
320 (cdr cconv-freevars-alist
))
321 (dolist (elm2 funcbodies
)
322 (push ; convert function bodies
323 (cconv-closure-convert-rec
324 elm2 emvrs nil envs lmenvs
)
326 (if (eq letsym
'let
*)
327 (setq lmenv-push
(cons var fv
))
328 (push (cons var fv
) lmenvs-new
))
329 ; push lifted function
333 ,(reverse funcbodies-new
))))))))
335 ;; Check if it needs to be turned into a "ref-cell".
336 ((member (cons binder form
) cconv-captured
+mutated
)
337 ;; Declared variable is mutated and captured.
339 `(list ,(cconv-closure-convert-rec
342 (if (eq letsym
'let
*)
344 (push var emvrs-new
))))
346 ;; Normal default case.
348 (cconv-closure-convert-rec
349 value emvrs fvrs envs lmenvs
)))))
351 ;; this piece of code below letbinds free
352 ;; variables of a lambda lifted function
353 ;; if they are redefined in this let
355 ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
356 ;; Here we can not pass y as parameter because it is
357 ;; redefined. We add a (closed-y y) declaration.
358 ;; We do that even if the function is not used inside
359 ;; this let(*). The reason why we ignore this case is
360 ;; that we can't "look forward" to see if the function
361 ;; is called there or not. To treat well this case we
362 ;; need to traverse the tree one more time to collect this
363 ;; data, and I think that it's not worth it.
365 (when (eq letsym
'let
*)
366 (let ((closedsym '())
369 (dolist (lmenv lmenvs
)
370 (when (memq var
(cdr lmenv
))
373 (concat "closed-" (symbol-name var
))))
374 (setq new-lmenv
(list (car lmenv
)))
375 (dolist (frv (cdr lmenv
)) (if (eq frv var
)
376 (push closedsym new-lmenv
)
377 (push frv new-lmenv
)))
378 (setq new-lmenv
(reverse new-lmenv
))
379 (setq old-lmenv lmenv
)))
381 (setq lmenvs
(remq old-lmenv lmenvs
))
382 (push new-lmenv lmenvs
)
383 (push `(,closedsym
,var
) binders-new
))))
384 ;; We push the element after redefined free variables are
385 ;; processed. This is important to avoid the bug when free
386 ;; variable and the function have the same name.
387 (push (list var new-val
) binders-new
)
389 (when (eq letsym
'let
*) ; update fvrs
390 (setq fvrs
(remq var fvrs
))
391 (setq emvrs
(remq var emvrs
)) ; remove if redefined
393 (push emvr-push emvrs
)
394 (setq emvr-push nil
))
395 (setq lmenvs
(cconv--map-diff-elem lmenvs var
))
397 (push lmenv-push lmenvs
)
398 (setq lmenv-push nil
)))
399 )) ; end of dolist over binders
400 (when (eq letsym
'let
)
402 ;; Here we update emvrs, fvrs and lmenvs lists
403 (setq fvrs
(cconv--set-diff-map fvrs binders-new
))
404 (setq emvrs
(cconv--set-diff-map emvrs binders-new
))
405 (setq emvrs
(append emvrs emvrs-new
))
406 (setq lmenvs
(cconv--set-diff-map lmenvs binders-new
))
407 (setq lmenvs
(append lmenvs lmenvs-new
))
409 ;; Here we do the same letbinding as for let* above
410 ;; to avoid situation when a free variable of a lambda lifted
411 ;; function got redefined.
417 (dolist (binder binders
)
418 (setq var
(if (consp binder
) (car binder
) binder
))
420 (let ((lmenvs-1 lmenvs
)) ; just to avoid manipulating
421 (dolist (lmenv lmenvs-1
) ; the counter inside the loop
422 (when (memq var
(cdr lmenv
))
423 (setq closedsym
(make-symbol
427 (setq new-lmenv
(list (car lmenv
)))
428 (dolist (frv (cdr lmenv
))
429 (push (if (eq frv var
) closedsym frv
)
431 (setq new-lmenv
(reverse new-lmenv
))
432 (setq lmenvs
(remq lmenv lmenvs
))
433 (push new-lmenv lmenvs
)
434 (push `(,closedsym
,var
) letbinds
)
436 (setq binders-new
(append binders-new letbinds
))))
438 (dolist (elm body-forms
) ; convert body forms
439 (push (cconv-closure-convert-rec
440 elm emvrs fvrs envs lmenvs
)
442 `(,letsym
,(reverse binders-new
) .
,(reverse body-forms-new
))))
443 ;end of let let* forms
445 ; first element is lambda expression
446 (`(,(and `(lambda .
,_
) fun
) .
,other-body-forms
)
448 (let ((other-body-forms-new '()))
449 (dolist (elm other-body-forms
)
450 (push (cconv-closure-convert-rec
451 elm emvrs fvrs envs lmenvs
)
452 other-body-forms-new
))
454 ,(cconv-closure-convert-rec
455 (list 'function fun
) emvrs fvrs envs lmenvs
)
456 ,@(nreverse other-body-forms-new
))))
458 (`(cond .
,cond-forms
) ; cond special form
459 (let ((cond-forms-new '()))
460 (dolist (elm cond-forms
)
461 (push (let ((elm-new '()))
464 (cconv-closure-convert-rec
465 elm-2 emvrs fvrs envs lmenvs
)
470 (reverse cond-forms-new
))))
474 (`(function (lambda ,vars .
,body-forms
)) ; function form
475 (cconv-closure-convert-function
476 fvrs vars emvrs envs lmenvs body-forms form
))
478 (`(internal-make-closure .
,_
)
479 (error "Internal byte-compiler error: cconv called twice"))
481 (`(function .
,_
) form
) ; Same as quote.
484 (`(,(and sym
(or `defconst
`defvar
)) ,definedsymbol .
,body-forms
)
486 (let ((body-forms-new '()))
487 (dolist (elm body-forms
)
488 (push (cconv-closure-convert-rec
489 elm emvrs fvrs envs lmenvs
)
491 (setq body-forms-new
(reverse body-forms-new
))
492 `(,sym
,definedsymbol .
,body-forms-new
)))
495 (`(,(and sym
(or `defun
`defmacro
))
496 ,func
,vars .
,body-forms
)
498 ;; The freevar data was pushed onto cconv-freevars-alist
499 ;; but we don't need it.
500 (assert (equal body-forms
(caar cconv-freevars-alist
)))
501 (assert (null (cdar cconv-freevars-alist
)))
502 (setq cconv-freevars-alist
(cdr cconv-freevars-alist
))
504 (let ((body-new '()) ; The whole body.
505 (body-forms-new '()) ; Body w\o docstring and interactive.
507 ; Find mutable arguments.
509 (when (member (cons (list elm
) form
) cconv-captured
+mutated
)
512 ;Transform body-forms.
513 (when (stringp (car body-forms
)) ; Treat docstring well.
514 (push (car body-forms
) body-new
)
515 (setq body-forms
(cdr body-forms
)))
516 (when (eq (car-safe (car body-forms
)) 'interactive
)
517 (push (cconv-closure-convert-rec
519 emvrs fvrs envs lmenvs
)
521 (setq body-forms
(cdr body-forms
)))
523 (dolist (elm body-forms
)
524 (push (cconv-closure-convert-rec
525 elm emvrs fvrs envs lmenvs
)
527 (setq body-forms-new
(reverse body-forms-new
))
530 ; Letbind mutable arguments.
531 (let ((binders-new '()))
532 (dolist (elm letbind
) (push `(,elm
(list ,elm
))
534 (push `(let ,(reverse binders-new
) .
535 ,body-forms-new
) body-new
)
536 (setq body-new
(reverse body-new
)))
537 (setq body-new
(append (reverse body-new
) body-forms-new
)))
539 `(,sym
,func
,vars .
,body-new
)))
542 (`(condition-case ,var
,protected-form .
,handlers
)
543 (let ((newform (cconv-closure-convert-rec
544 `(function (lambda () ,protected-form
))
545 emvrs fvrs envs lmenvs
)))
546 (setq fvrs
(remq var fvrs
))
547 `(condition-case :fun-body
,newform
548 ,@(mapcar (lambda (handler)
550 (cconv-closure-convert-rec
551 (let ((arg (or var cconv--dummy-var
)))
552 `(function (lambda (,arg
) ,@(cdr handler
))))
553 emvrs fvrs envs lmenvs
)))
556 (`(,(and head
(or `catch
`unwind-protect
)) ,form .
,body
)
557 `(,head
,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs
)
559 ,(cconv-closure-convert-rec `(function (lambda () ,@body
))
560 emvrs fvrs envs lmenvs
)))
562 (`(track-mouse .
,body
)
565 ,(cconv-closure-convert-rec `(function (lambda () ,@body
))
566 emvrs fvrs envs lmenvs
)))
568 (`(setq .
,forms
) ; setq special form
569 (let (prognlist sym sym-new value
)
571 (setq sym
(car forms
))
572 (setq sym-new
(cconv-closure-convert-rec
574 (remq sym emvrs
) fvrs envs lmenvs
))
576 (cconv-closure-convert-rec
577 (cadr forms
) emvrs fvrs envs lmenvs
))
579 ((memq sym emvrs
) (push `(setcar ,sym-new
,value
) prognlist
))
580 ((symbolp sym-new
) (push `(setq ,sym-new
,value
) prognlist
))
581 ;; This should never happen, but for variables which are
582 ;; mutated+captured+unused, we may end up trying to `setq'
583 ;; on a closed-over variable, so just drop the setq.
584 (t (push value prognlist
)))
585 (setq forms
(cddr forms
)))
587 `(progn .
,(reverse prognlist
))
590 (`(,(and (or `funcall
`apply
) callsym
) ,fun .
,args
)
591 ; funcall is not a special form
592 ; but we treat it separately
593 ; for the needs of lambda lifting
594 (let ((fv (cdr (assq fun lmenvs
))))
598 ;; All args (free variables and actual arguments)
599 ;; should be processed, because they can be fvrs
600 ;; (free variables of another closure)
602 (push (cconv-closure-convert-rec
606 (setq processed-fv
(reverse processed-fv
))
608 (push (cconv-closure-convert-rec
609 elm emvrs fvrs envs lmenvs
)
611 (setq args-new
(append processed-fv
(reverse args-new
)))
612 (setq fun
(cconv-closure-convert-rec
613 fun emvrs fvrs envs lmenvs
))
614 `(,callsym
,fun .
,args-new
))
616 (dolist (elm (cdr form
))
617 (push (cconv-closure-convert-rec
618 elm emvrs fvrs envs lmenvs
)
620 `(,callsym .
,(reverse cdr-new
))))))
622 (`(interactive .
,forms
)
624 ,@(mapcar (lambda (form)
625 (cconv-closure-convert-rec form nil nil nil nil
))
628 (`(,func .
,body-forms
) ; first element is function or whatever
629 ; function-like forms are:
630 ; or, and, if, progn, prog1, prog2,
632 (let ((body-forms-new '()))
633 (dolist (elm body-forms
)
634 (push (cconv-closure-convert-rec
635 elm emvrs fvrs envs lmenvs
)
637 (setq body-forms-new
(reverse body-forms-new
))
638 `(,func .
,body-forms-new
)))
641 (let ((free (memq form fvrs
)))
642 (if free
;form is a free variable
643 (let* ((numero (- (length fvrs
) (length free
)))
644 ;; Replace form => (aref env #)
645 (var `(internal-get-closed-var ,numero
)))
646 (if (memq form emvrs
) ; form => (car (aref env #)) if mutable
649 (if (memq form emvrs
) ; if form is a mutable variable
650 `(car ,form
) ; replace form => (car form)
653 (unless (fboundp 'byte-compile-not-lexical-var-p
)
654 ;; Only used to test the code in non-lexbind Emacs.
655 (defalias 'byte-compile-not-lexical-var-p
'boundp
))
657 (defun cconv-analyse-use (vardata form varkind
)
658 "Analyse the use of a variable.
659 VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
660 VARKIND is the name of the kind of variable.
661 FORM is the parent form that binds this var."
662 ;; use = `(,binder ,read ,mutated ,captured ,called)
664 (`(,_ nil nil nil nil
) nil
)
665 (`((,(and (pred (lambda (var) (eq ?_
(aref (symbol-name var
) 0)))) var
) .
,_
)
667 (byte-compile-log-warning (format "%s `%S' not left unused" varkind var
)))
668 ((or `(,_
,_
,_
,_
,_
) dontcare
) nil
))
670 (`((,var .
,_
) nil
,_
,_ nil
)
671 ;; FIXME: This gives warnings in the wrong order, with imprecise line
672 ;; numbers and without function name info.
673 (unless (or ;; Uninterned symbols typically come from macro-expansion, so
674 ;; it is often non-trivial for the programmer to avoid such
676 (not (intern-soft var
))
677 (eq ?_
(aref (symbol-name var
) 0)))
678 (byte-compile-log-warning (format "Unused lexical %s `%S'"
680 ;; If it's unused, there's no point converting it into a cons-cell, even if
681 ;; it's captured and mutated.
682 (`(,binder
,_ t t
,_
)
683 (push (cons binder form
) cconv-captured
+mutated
))
684 (`(,(and binder
`(,_
(function (lambda .
,_
)))) nil nil nil t
)
685 (push (cons binder form
) cconv-lambda-candidates
))
686 (`(,_
,_
,_
,_
,_
) nil
)
689 (defun cconv-analyse-function (args body env parentform
)
691 (freevars (list body
))
692 ;; We analyze the body within a new environment where all uses are
693 ;; nil, so we can distinguish uses within that function from uses
696 (mapcar (lambda (vdata) (list (car vdata
) nil nil nil nil
)) env
))
698 ;; Push it before recursing, so cconv-freevars-alist contains entries in
699 ;; the order they'll be used by closure-convert-rec.
700 (push freevars cconv-freevars-alist
)
703 ((byte-compile-not-lexical-var-p arg
)
704 (byte-compile-report-error
705 (format "Argument %S is not a lexical variable" arg
)))
706 ((eq ?
& (aref (symbol-name arg
) 0)) nil
) ;Ignore &rest, &optional, ...
707 (t (let ((varstruct (list arg nil nil nil nil
)))
708 (push (cons (list arg
) (cdr varstruct
)) newvars
)
709 (push varstruct newenv
)))))
710 (dolist (form body
) ;Analyse body forms.
711 (cconv-analyse-form form newenv
))
712 ;; Summarize resulting data about arguments.
713 (dolist (vardata newvars
)
714 (cconv-analyse-use vardata parentform
"argument"))
715 ;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
716 ;; and compute free variables.
718 (assert (and envcopy
(eq (caar env
) (caar envcopy
))))
721 (y (cdr (car envcopy
))))
723 (when (car y
) (setcar x t
) (setq free t
))
724 (setq x
(cdr x
) y
(cdr y
)))
726 (push (caar env
) (cdr freevars
))
727 (setf (nth 3 (car env
)) t
))
728 (setq env
(cdr env
) envcopy
(cdr envcopy
))))))
730 (defun cconv-analyse-form (form env
)
731 "Find mutated variables and variables captured by closure.
732 Analyse lambdas if they are suitable for lambda lifting.
733 - FORM is a piece of Elisp code after macroexpansion.
734 - ENV is an alist mapping each enclosing lexical variable to its info.
735 I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)).
736 This function does not return anything but instead fills the
737 `cconv-captured+mutated' and `cconv-lambda-candidates' variables
738 and updates the data stored in ENV."
741 (`(,(and (or `let
* `let
) letsym
) ,binders .
,body-forms
)
747 (dolist (binder binders
)
748 (if (not (consp binder
))
750 (setq var binder
) ; treat the form (let (x) ...) well
751 (setq binder
(list binder
))
753 (setq var
(car binder
))
754 (setq value
(cadr binder
))
756 (cconv-analyse-form value
(if (eq letsym
'let
*) env orig-env
)))
758 (unless (byte-compile-not-lexical-var-p var
)
759 (let ((varstruct (list var nil nil nil nil
)))
760 (push (cons binder
(cdr varstruct
)) newvars
)
761 (push varstruct env
))))
763 (dolist (form body-forms
) ; Analyse body forms.
764 (cconv-analyse-form form env
))
766 (dolist (vardata newvars
)
767 (cconv-analyse-use vardata form
"variable"))))
770 (`(,(or `defun
`defmacro
) ,func
,vrs .
,body-forms
)
772 (byte-compile-log-warning
773 (format "Function %S will ignore its context %S"
774 func
(mapcar #'car env
))
776 (cconv-analyse-function vrs body-forms nil form
))
778 (`(function (lambda ,vrs .
,body-forms
))
779 (cconv-analyse-function vrs body-forms env form
))
782 ;; If a local variable (member of env) is modified by setq then
783 ;; it is a mutated variable.
785 (let ((v (assq (car forms
) env
))) ; v = non nil if visible
786 (when v
(setf (nth 2 v
) t
)))
787 (cconv-analyse-form (cadr forms
) env
)
788 (setq forms
(cddr forms
))))
790 (`((lambda .
,_
) .
,_
) ; first element is lambda expression
791 (dolist (exp `((function ,(car form
)) .
,(cdr form
)))
792 (cconv-analyse-form exp env
)))
794 (`(cond .
,cond-forms
) ; cond special form
795 (dolist (forms cond-forms
)
796 (dolist (form forms
) (cconv-analyse-form form env
))))
798 (`(quote .
,_
) nil
) ; quote form
799 (`(function .
,_
) nil
) ; same as quote
801 (`(condition-case ,var
,protected-form .
,handlers
)
802 ;; FIXME: The bytecode for condition-case forces us to wrap the
803 ;; form and handlers in closures (for handlers, it's probably
804 ;; unavoidable, but not for the protected form).
805 (cconv-analyse-function () (list protected-form
) env form
)
806 (dolist (handler handlers
)
807 (cconv-analyse-function (if var
(list var
)) (cdr handler
) env form
)))
809 ;; FIXME: The bytecode for catch forces us to wrap the body.
810 (`(,(or `catch
`unwind-protect
) ,form .
,body
)
811 (cconv-analyse-form form env
)
812 (cconv-analyse-function () body env form
))
814 ;; FIXME: The bytecode for save-window-excursion and the lack of
815 ;; bytecode for track-mouse forces us to wrap the body.
816 (`(track-mouse .
,body
)
817 (cconv-analyse-function () body env form
))
819 (`(,(or `defconst
`defvar
) ,var
,value .
,_
)
820 (push var byte-compile-bound-variables
)
821 (cconv-analyse-form value env
))
823 (`(,(or `funcall
`apply
) ,fun .
,args
)
824 ;; Here we ignore fun because funcall and apply are the only two
825 ;; functions where we can pass a candidate for lambda lifting as
826 ;; argument. So, if we see fun elsewhere, we'll delete it from
827 ;; lambda candidate list.
828 (let ((fdata (and (symbolp fun
) (assq fun env
))))
830 (setf (nth 4 fdata
) t
)
831 (cconv-analyse-form fun env
)))
832 (dolist (form args
) (cconv-analyse-form form env
)))
834 (`(interactive .
,forms
)
835 ;; These appear within the function body but they don't have access
836 ;; to the function's arguments.
837 ;; We could extend this to allow interactive specs to refer to
838 ;; variables in the function's enclosing environment, but it doesn't
839 ;; seem worth the trouble.
840 (dolist (form forms
) (cconv-analyse-form form nil
)))
842 (`(,_ .
,body-forms
) ; First element is a function or whatever.
843 (dolist (form body-forms
) (cconv-analyse-form form env
)))
846 (let ((dv (assq form env
))) ; dv = declared and visible
848 (setf (nth 1 dv
) t
))))))
851 ;;; cconv.el ends here