1 ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: nil -*-
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 (v1 ...) ... fv ...) =>
51 ;; (curry (lambda (env v1 ...) ... env ...) env)
52 ;; if the function has only 1 free variable
55 ;; (lambda (v1 ...) ... fv1 fv2 ...) =>
56 ;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2))
57 ;; if the function has 2 or more free variables.
59 ;; If the function has no free variables, we don't do anything.
61 ;; If a variable is mutated (updated by setq), and it is used in a closure
62 ;; we wrap it's definition with list: (list val) and we also replace
63 ;; var => (car var) wherever this variable is used, and also
64 ;; (setq var value) => (setcar var value) where it is updated.
66 ;; If defun argument is closure mutable, we letbind it and wrap it's
67 ;; definition with list.
68 ;; (defun foo (... mutable-arg ...) ...) =>
69 ;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...))
73 (eval-when-compile (require 'cl))
75 (defconst cconv-liftwhen 3
76 "Try to do lambda lifting if the number of arguments + free variables
77 is less than this number.")
78 (defvar cconv-mutated nil
79 "List of mutated variables in current form")
80 (defvar cconv-captured nil
81 "List of closure captured variables in current form")
82 (defvar cconv-captured+mutated nil
83 "An intersection between cconv-mutated and cconv-captured lists.")
84 (defvar cconv-lambda-candidates nil
85 "List of candidates for lambda lifting.
86 Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).")
88 (defun cconv-not-lexical-var-p (var)
89 (or (not (symbolp var)) ; form is not a list
90 (if (eval-when-compile (fboundp 'special-variable-p))
91 (special-variable-p var)
93 ;; byte-compile-bound-variables normally holds both the
94 ;; dynamic and lexical vars, but the bytecomp.el should
95 ;; only call us at the top-level so there shouldn't be
96 ;; any lexical vars in it here.
97 (memq var byte-compile-bound-variables)
101 (defun cconv-freevars (form &optional fvrs)
102 "Find all free variables of given form.
104 -- FORM is a piece of Elisp code after macroexpansion.
105 -- FVRS(optional) is a list of variables already found. Used for recursive tree
108 Returns a list of free variables."
109 ;; If a leaf in the tree is a symbol, but it is not a global variable, not a
110 ;; keyword, not 'nil or 't we consider this leaf as a variable.
111 ;; Free variables are the variables that are not declared above in this tree.
112 ;; For example free variables of (lambda (a1 a2 ..) body-forms) are
113 ;; free variables of body-forms excluding a1, a2 ..
114 ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are
115 ;; free variables of body-forms excluding v1, v2 ...
118 ;; A list of free variables already found(FVRS) is passed in parameter
119 ;; to try to use cons or push where possible, and to minimize the usage
122 ;; This function can return duplicates (because we use 'append instead
123 ;; of union of two sets - for performance reasons).
125 (`(let ,varsvalues . ,body-forms) ; let special form
127 (dolist (exp body-forms)
128 (setq fvrs-1 (cconv-freevars exp fvrs-1)))
129 (dolist (elm varsvalues)
130 (setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1)))
131 (setq fvrs (nconc fvrs-1 fvrs))
132 (dolist (exp varsvalues)
133 (when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs))))
136 (`(let* ,varsvalues . ,body-forms) ; let* special form
139 (dolist (exp varsvalues)
142 (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))
143 (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1)))
144 (push (car exp) vrs))
146 (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1)))
148 (dolist (exp body-forms)
149 (setq fvrs-1 (cconv-freevars exp fvrs-1)))
150 (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1)))
151 (append fvrs fvrs-1)))
153 (`((lambda . ,_) . ,_) ; first element is lambda expression
154 (dolist (exp `((function ,(car form)) . ,(cdr form)))
155 (setq fvrs (cconv-freevars exp fvrs))) fvrs)
157 (`(cond . ,cond-forms) ; cond special form
158 (dolist (exp1 cond-forms)
160 (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs)
162 (`(quote . ,_) fvrs) ; quote form
164 (`(function . ((lambda ,vars . ,body-forms)))
165 (let ((functionform (cadr form)) (fvrs-1 '()))
166 (dolist (exp body-forms)
167 (setq fvrs-1 (cconv-freevars exp fvrs-1)))
168 (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1)))
169 (append fvrs fvrs-1))) ; function form
171 (`(function . ,_) fvrs) ; same as quote
173 (`(condition-case ,var ,protected-form . ,conditions-bodies)
175 (dolist (exp conditions-bodies)
176 (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)))
177 (setq fvrs-1 (delq var fvrs-1))
178 (setq fvrs-1 (cconv-freevars protected-form fvrs-1))
179 (append fvrs fvrs-1)))
181 (`(,(and sym (or `defun `defconst `defvar)) . ,_)
182 ;; We call cconv-freevars only for functions(lambdas)
183 ;; defun, defconst, defvar are not allowed to be inside
184 ;; a function (lambda).
185 ;; FIXME: should be a byte-compile-report-error!
186 (error "Invalid form: %s inside a function" sym))
188 (`(,_ . ,body-forms) ; First element is (like) a function.
189 (dolist (exp body-forms)
190 (setq fvrs (cconv-freevars exp fvrs))) fvrs)
192 (_ (if (cconv-not-lexical-var-p form)
197 (defun cconv-closure-convert (form)
198 "Main entry point for closure conversion.
199 -- FORM is a piece of Elisp code after macroexpansion.
200 -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
202 Returns a form where all lambdas don't have any free variables."
203 (message "Entering cconv-closure-convert...")
204 (let ((cconv-mutated '())
205 (cconv-lambda-candidates '())
207 (cconv-captured+mutated '()))
208 ;; Analyse form - fill these variables with new information
209 (cconv-analyse-form form '() 0)
210 ;; Calculate an intersection of cconv-mutated and cconv-captured
211 (dolist (mvr cconv-mutated)
212 (when (memq mvr cconv-captured) ;
213 (push mvr cconv-captured+mutated)))
214 (cconv-closure-convert-rec
217 '() ; fvrs initially empty
218 '() ; envs initially empty
222 (defun cconv-lookup-let (table var binder form)
225 (when (and (eq (nth 2 elem) binder)
226 (eq (nth 3 elem) form))
227 (assert (eq (car elem) var))
231 (defconst cconv--dummy-var (make-symbol "ignored"))
233 (defun cconv-closure-convert-rec
234 (form emvrs fvrs envs lmenvs)
235 ;; This function actually rewrites the tree.
236 "Eliminates all free variables of all lambdas in given forms.
238 -- FORM is a piece of Elisp code after macroexpansion.
239 -- LMENVS is a list of environments used for lambda-lifting. Initially empty.
240 -- EMVRS is a list that contains mutated variables that are visible
241 within current environment.
242 -- ENVS is an environment(list of free variables) of current closure.
244 -- FVRS is a list of variables to substitute in each context.
247 Returns a form where all lambdas don't have any free variables."
248 ;; What's the difference between fvrs and envs?
249 ;; Suppose that we have the code
250 ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
251 ;; only the first occurrence of fvr should be replaced by
253 ;; So initially envs and fvrs are the same thing, but when we descend to
254 ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
255 ;; Because in envs the order of variables is important. We use this list
256 ;; to find the number of a specific variable in the environment vector,
257 ;; so we never touch it(unless we enter to the other closure).
258 ;;(if (listp form) (print (car form)) form)
260 (`(,(and letsym (or `let* `let)) ,binders . ,body-forms)
262 ; let and let* special forms
263 (let ((body-forms-new '())
265 ;; next for variables needed for delayed push
266 ;; because we should process <value(s)>
267 ;; before we change any arguments
268 (lmenvs-new '()) ;needed only in case of let
269 (emvrs-new '()) ;needed only in case of let
270 (emvr-push) ;needed only in case of let*
271 (lmenv-push)) ;needed only in case of let*
273 (dolist (binder binders)
275 (var (if (not (consp binder))
277 (setq value (cadr binder))
281 ;; Check if var is a candidate for lambda lifting.
282 ((cconv-lookup-let cconv-lambda-candidates var binder form)
284 (let* ((fv (delete-dups (cconv-freevars value '())))
285 (funargs (cadr (cadr value)))
286 (funcvars (append fv funargs))
287 (funcbodies (cddadr value)) ; function bodies
288 (funcbodies-new '()))
289 ; lambda lifting condition
290 (if (or (not fv) (< cconv-liftwhen (length funcvars)))
292 (cconv-closure-convert-rec
293 value emvrs fvrs envs lmenvs)
296 (dolist (elm2 funcbodies)
297 (push ; convert function bodies
298 (cconv-closure-convert-rec
299 elm2 emvrs nil envs lmenvs)
301 (if (eq letsym 'let*)
302 (setq lmenv-push (cons var fv))
303 (push (cons var fv) lmenvs-new))
304 ; push lifted function
308 ,(reverse funcbodies-new))))))))
310 ;; Check if it needs to be turned into a "ref-cell".
311 ((cconv-lookup-let cconv-captured+mutated var binder form)
312 ;; Declared variable is mutated and captured.
314 `(list ,(cconv-closure-convert-rec
317 (if (eq letsym 'let*)
319 (push var emvrs-new))))
321 ;; Normal default case.
323 (cconv-closure-convert-rec
324 value emvrs fvrs envs lmenvs)))))
326 ;; this piece of code below letbinds free
327 ;; variables of a lambda lifted function
328 ;; if they are redefined in this let
330 ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
331 ;; Here we can not pass y as parameter because it is
332 ;; redefined. We add a (closed-y y) declaration.
333 ;; We do that even if the function is not used inside
334 ;; this let(*). The reason why we ignore this case is
335 ;; that we can't "look forward" to see if the function
336 ;; is called there or not. To treat well this case we
337 ;; need to traverse the tree one more time to collect this
338 ;; data, and I think that it's not worth it.
340 (when (eq letsym 'let*)
341 (let ((closedsym '())
344 (dolist (lmenv lmenvs)
345 (when (memq var (cdr lmenv))
348 (concat "closed-" (symbol-name var))))
349 (setq new-lmenv (list (car lmenv)))
350 (dolist (frv (cdr lmenv)) (if (eq frv var)
351 (push closedsym new-lmenv)
352 (push frv new-lmenv)))
353 (setq new-lmenv (reverse new-lmenv))
354 (setq old-lmenv lmenv)))
356 (setq lmenvs (remq old-lmenv lmenvs))
357 (push new-lmenv lmenvs)
358 (push `(,closedsym ,var) binders-new))))
359 ;; we push the element after redefined free variables
360 ;; are processes. this is important to avoid the bug
361 ;; when free variable and the function have the same
363 (push (list var new-val) binders-new)
365 (when (eq letsym 'let*) ; update fvrs
366 (setq fvrs (remq var fvrs))
367 (setq emvrs (remq var emvrs)) ; remove if redefined
369 (push emvr-push emvrs)
370 (setq emvr-push nil))
371 (let (lmenvs-1) ; remove var from lmenvs if redefined
372 (dolist (iter lmenvs)
373 (when (not (assq var lmenvs))
374 (push iter lmenvs-1)))
375 (setq lmenvs lmenvs-1))
377 (push lmenv-push lmenvs)
378 (setq lmenv-push nil)))
379 )) ; end of dolist over binders
380 (when (eq letsym 'let)
382 (let (var fvrs-1 emvrs-1 lmenvs-1)
383 ;; Here we update emvrs, fvrs and lmenvs lists
386 (when (not (assq vr binders-new)) (push vr fvrs-1)))
390 (when (not (assq vr binders-new)) (push vr emvrs-1)))
393 (setq emvrs (append emvrs emvrs-new))
395 (when (not (assq (car vr) binders-new))
397 (setq lmenvs (append lmenvs lmenvs-new)))
399 ;; Here we do the same letbinding as for let* above
400 ;; to avoid situation when a free variable of a lambda lifted
401 ;; function got redefined.
407 (dolist (binder binders)
408 (setq var (if (consp binder) (car binder) binder))
410 (let ((lmenvs-1 lmenvs)) ; just to avoid manipulating
411 (dolist (lmenv lmenvs-1) ; the counter inside the loop
412 (when (memq var (cdr lmenv))
413 (setq closedsym (make-symbol
417 (setq new-lmenv (list (car lmenv)))
418 (dolist (frv (cdr lmenv)) (if (eq frv var)
419 (push closedsym new-lmenv)
420 (push frv new-lmenv)))
421 (setq new-lmenv (reverse new-lmenv))
422 (setq lmenvs (remq lmenv lmenvs))
423 (push new-lmenv lmenvs)
424 (push `(,closedsym ,var) letbinds)
426 (setq binders-new (append binders-new letbinds))))
428 (dolist (elm body-forms) ; convert body forms
429 (push (cconv-closure-convert-rec
430 elm emvrs fvrs envs lmenvs)
432 `(,letsym ,(reverse binders-new) . ,(reverse body-forms-new))))
433 ;end of let let* forms
435 ; first element is lambda expression
436 (`(,(and `(lambda . ,_) fun) . ,other-body-forms)
438 (let ((other-body-forms-new '()))
439 (dolist (elm other-body-forms)
440 (push (cconv-closure-convert-rec
441 elm emvrs fvrs envs lmenvs)
442 other-body-forms-new))
444 ,(cconv-closure-convert-rec
445 (list 'function fun) emvrs fvrs envs lmenvs)
446 ,@(nreverse other-body-forms-new))))
448 (`(cond . ,cond-forms) ; cond special form
449 (let ((cond-forms-new '()))
450 (dolist (elm cond-forms)
451 (push (let ((elm-new '()))
454 (cconv-closure-convert-rec
455 elm-2 emvrs fvrs envs lmenvs)
460 (reverse cond-forms-new))))
462 (`(quote . ,_) form) ; quote form
464 (`(function . ((lambda ,vars . ,body-forms))) ; function form
465 (let (fvrs-new) ; we remove vars from fvrs
466 (dolist (elm fvrs) ;i use such a tricky way to avoid side effects
467 (when (not (memq elm vars))
468 (push elm fvrs-new)))
469 (setq fvrs fvrs-new))
470 (let* ((fv (delete-dups (cconv-freevars form '())))
471 (leave fvrs) ; leave = non nil if we should leave env unchanged
477 ;; Here we form our environment vector.
478 ;; If outer closure contains all
479 ;; free variables of this function(and nothing else)
480 ;; then we use the same environment vector as for outer closure,
481 ;; i.e. we leave the environment vector unchanged
482 ;; otherwise we build a new environmet vector
483 (if (eq (length envs) (length fv))
485 (while (and fv-temp leave)
486 (when (not (memq (car fv-temp) fvrs)) (setq leave nil))
487 (setq fv-temp (cdr fv-temp))))
494 (cconv-closure-convert-rec
495 elm (remq elm emvrs) fvrs envs lmenvs)
496 envector)) ; process vars for closure vector
497 (setq envector (reverse envector))
499 (setq envector `(env))) ; leave unchanged
500 (setq fvrs fv)) ; update substitution list
502 ;; the difference between envs and fvrs is explained
503 ;; in comment in the beginning of the function
504 (dolist (elm cconv-captured+mutated) ; find mutated arguments
505 (setq mv (car elm)) ; used in inner closures
506 (when (and (memq mv vars) (eq form (caddr elm)))
507 (progn (push mv emvrs)
508 (push `(,mv (list ,mv)) letbind))))
509 (dolist (elm body-forms) ; convert function body
510 (push (cconv-closure-convert-rec
511 elm emvrs fvrs envs lmenvs)
515 (if letbind `((let ,letbind . ,(reverse body-forms-new)))
516 (reverse body-forms-new)))
519 ;if no freevars - do nothing
521 `(function (lambda ,vars . ,body-forms-new)))
522 ; 1 free variable - do not build vector
523 ((null (cdr envector))
525 (function (lambda (env . ,vars) . ,body-forms-new))
527 ; >=2 free variables - build vector
530 (function (lambda (env . ,vars) . ,body-forms-new))
531 (vector . ,envector))))))
533 (`(function . ,_) form) ; same as quote
536 (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms)
538 (let ((body-forms-new '()))
539 (dolist (elm body-forms)
540 (push (cconv-closure-convert-rec
541 elm emvrs fvrs envs lmenvs)
543 (setq body-forms-new (reverse body-forms-new))
544 `(,sym ,definedsymbol . ,body-forms-new)))
547 (`(,(and sym (or `defun `defmacro))
548 ,func ,vars . ,body-forms)
549 (let ((body-new '()) ; the whole body
550 (body-forms-new '()) ; body w\o docstring and interactive
552 ; find mutable arguments
553 (let ((lmutated cconv-captured+mutated) ismutated)
556 (while (and lmutated (not ismutated))
557 (when (and (eq (caar lmutated) elm)
558 (eq (cadar lmutated) form))
560 (setq lmutated (cdr lmutated)))
564 ;transform body-forms
565 (when (stringp (car body-forms)) ; treat docstring well
566 (push (car body-forms) body-new)
567 (setq body-forms (cdr body-forms)))
568 (when (eq (car-safe (car body-forms)) 'interactive)
569 (push (cconv-closure-convert-rec
571 emvrs fvrs envs lmenvs)
573 (setq body-forms (cdr body-forms)))
575 (dolist (elm body-forms)
576 (push (cconv-closure-convert-rec
577 elm emvrs fvrs envs lmenvs)
579 (setq body-forms-new (reverse body-forms-new))
582 ; letbind mutable arguments
583 (let ((binders-new '()))
584 (dolist (elm letbind) (push `(,elm (list ,elm))
586 (push `(let ,(reverse binders-new) .
587 ,body-forms-new) body-new)
588 (setq body-new (reverse body-new)))
589 (setq body-new (append (reverse body-new) body-forms-new)))
591 `(,sym ,func ,vars . ,body-new)))
594 (`(condition-case ,var ,protected-form . ,handlers)
595 (let ((handlers-new '())
596 (newform (cconv-closure-convert-rec
597 `(function (lambda () ,protected-form))
598 emvrs fvrs envs lmenvs)))
599 (setq fvrs (remq var fvrs))
600 (dolist (handler handlers)
601 (push (list (car handler)
602 (cconv-closure-convert-rec
603 `(function (lambda (,(or var cconv--dummy-var))
605 emvrs fvrs envs lmenvs))
607 `(condition-case :fun-body ,newform
608 ,@(nreverse handlers-new))))
610 (`(,(and head (or `catch `unwind-protect)) ,form . ,body)
611 `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs)
613 ,(cconv-closure-convert-rec `(function (lambda () ,@body))
614 emvrs fvrs envs lmenvs)))
616 (`(,(and head (or `save-window-excursion `track-mouse)) . ,body)
619 ,(cconv-closure-convert-rec `(function (lambda () ,@body))
620 emvrs fvrs envs lmenvs)))
622 (`(setq . ,forms) ; setq special form
623 (let (prognlist sym sym-new value)
625 (setq sym (car forms))
626 (setq sym-new (cconv-closure-convert-rec
628 (remq sym emvrs) fvrs envs lmenvs))
630 (cconv-closure-convert-rec
631 (cadr forms) emvrs fvrs envs lmenvs))
633 (push `(setcar ,sym-new ,value) prognlist)
634 (if (symbolp sym-new)
635 (push `(setq ,sym-new ,value) prognlist)
636 (push `(set ,sym-new ,value) prognlist)))
637 (setq forms (cddr forms)))
639 `(progn . ,(reverse prognlist))
642 (`(,(and (or `funcall `apply) callsym) ,fun . ,args)
643 ; funcall is not a special form
644 ; but we treat it separately
645 ; for the needs of lambda lifting
646 (let ((fv (cdr (assq fun lmenvs))))
650 ;; All args (free variables and actual arguments)
651 ;; should be processed, because they can be fvrs
652 ;; (free variables of another closure)
654 (push (cconv-closure-convert-rec
658 (setq processed-fv (reverse processed-fv))
660 (push (cconv-closure-convert-rec
661 elm emvrs fvrs envs lmenvs)
663 (setq args-new (append processed-fv (reverse args-new)))
664 (setq fun (cconv-closure-convert-rec
665 fun emvrs fvrs envs lmenvs))
666 `(,callsym ,fun . ,args-new))
668 (dolist (elm (cdr form))
669 (push (cconv-closure-convert-rec
670 elm emvrs fvrs envs lmenvs)
672 `(,callsym . ,(reverse cdr-new))))))
674 (`(,func . ,body-forms) ; first element is function or whatever
675 ; function-like forms are:
676 ; or, and, if, progn, prog1, prog2,
678 (let ((body-forms-new '()))
679 (dolist (elm body-forms)
680 (push (cconv-closure-convert-rec
681 elm emvrs fvrs envs lmenvs)
683 (setq body-forms-new (reverse body-forms-new))
684 `(,func . ,body-forms-new)))
687 (let ((free (memq form fvrs)))
688 (if free ;form is a free variable
689 (let* ((numero (- (length fvrs) (length free)))
692 (if (null (cdr envs))
696 (setq var `(aref env ,numero)))
697 (if (memq form emvrs) ; form => (car (aref env #)) if mutable
700 (if (memq form emvrs) ; if form is a mutable variable
701 `(car ,form) ; replace form => (car form)
704 (defun cconv-analyse-function (args body env parentform inclosure)
707 ((cconv-not-lexical-var-p arg)
708 (byte-compile-report-error
709 (format "Argument %S is not a lexical variable" arg)))
710 ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
711 (t (push (list arg inclosure parentform) env)))) ;Push vrs to vars.
712 (dolist (form body) ;Analyse body forms.
713 (cconv-analyse-form form env inclosure)))
715 (defun cconv-analyse-form (form env inclosure)
716 "Find mutated variables and variables captured by closure. Analyse
717 lambdas if they are suitable for lambda lifting.
718 -- FORM is a piece of Elisp code after macroexpansion.
719 -- ENV is a list of variables visible in current lexical environment.
720 Each entry has the form (VAR INCLOSURE BINDER PARENTFORM)
721 for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments.
722 -- INCLOSURE is the nesting level within lambdas."
725 (`(,(and (or `let* `let) letsym) ,binders . ,body-forms)
730 (dolist (binder binders)
731 (if (not (consp binder))
733 (setq var binder) ; treat the form (let (x) ...) well
735 (setq var (car binder))
736 (setq value (cadr binder))
738 (cconv-analyse-form value (if (eq letsym 'let*) env orig-env)
741 (unless (cconv-not-lexical-var-p var)
742 (let ((varstruct (list var inclosure binder form)))
743 (push varstruct env) ; Push a new one.
746 (`(function (lambda . ,_))
747 ;; If var is a function push it to lambda list.
748 (push varstruct cconv-lambda-candidates)))))))
750 (dolist (form body-forms) ; Analyse body forms.
751 (cconv-analyse-form form env inclosure)))
754 (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
756 (byte-compile-log-warning
757 (format "Function %S will ignore its context %S"
758 func (mapcar #'car env))
760 (cconv-analyse-function vrs body-forms nil form 0))
762 (`(function (lambda ,vrs . ,body-forms))
763 (cconv-analyse-function vrs body-forms env form (1+ inclosure)))
766 ;; If a local variable (member of env) is modified by setq then
767 ;; it is a mutated variable.
769 (let ((v (assq (car forms) env))) ; v = non nil if visible
771 (push v cconv-mutated)
772 ;; Delete from candidate list for lambda lifting.
773 (setq cconv-lambda-candidates (delq v cconv-lambda-candidates))
774 (unless (eq inclosure (cadr v)) ;Bound in a different closure level.
775 (push v cconv-captured))))
776 (cconv-analyse-form (cadr forms) env inclosure)
777 (setq forms (cddr forms))))
779 (`((lambda . ,_) . ,_) ; first element is lambda expression
780 (dolist (exp `((function ,(car form)) . ,(cdr form)))
781 (cconv-analyse-form exp env inclosure)))
783 (`(cond . ,cond-forms) ; cond special form
784 (dolist (forms cond-forms)
786 (cconv-analyse-form form env inclosure))))
788 (`(quote . ,_) nil) ; quote form
789 (`(function . ,_) nil) ; same as quote
791 (`(condition-case ,var ,protected-form . ,handlers)
792 ;; FIXME: The bytecode for condition-case forces us to wrap the
793 ;; form and handlers in closures (for handlers, it's probably
794 ;; unavoidable, but not for the protected form).
795 (setq inclosure (1+ inclosure))
796 (cconv-analyse-form protected-form env inclosure)
797 (push (list var inclosure form) env)
798 (dolist (handler handlers)
799 (dolist (form (cdr handler))
800 (cconv-analyse-form form env inclosure))))
802 ;; FIXME: The bytecode for catch forces us to wrap the body.
803 (`(,(or `catch `unwind-protect) ,form . ,body)
804 (cconv-analyse-form form env inclosure)
805 (setq inclosure (1+ inclosure))
807 (cconv-analyse-form form env inclosure)))
809 ;; FIXME: The bytecode for save-window-excursion and the lack of
810 ;; bytecode for track-mouse forces us to wrap the body.
811 (`(,(or `save-window-excursion `track-mouse) . ,body)
812 (setq inclosure (1+ inclosure))
814 (cconv-analyse-form form env inclosure)))
816 (`(,(or `defconst `defvar) ,var ,value . ,_)
817 (push var byte-compile-bound-variables)
818 (cconv-analyse-form value env inclosure))
820 (`(,(or `funcall `apply) ,fun . ,args)
821 ;; Here we ignore fun because funcall and apply are the only two
822 ;; functions where we can pass a candidate for lambda lifting as
823 ;; argument. So, if we see fun elsewhere, we'll delete it from
824 ;; lambda candidate list.
826 (let ((lv (assq fun cconv-lambda-candidates)))
828 (unless (eq (cadr lv) inclosure)
829 (push lv cconv-captured)
830 ;; If this funcall and the definition of fun are in
831 ;; different closures - we delete fun from candidate
832 ;; list, because it is too complicated to manage free
833 ;; variables in this case.
834 (setq cconv-lambda-candidates
835 (delq lv cconv-lambda-candidates)))))
836 (cconv-analyse-form fun env inclosure))
838 (cconv-analyse-form form env inclosure)))
840 (`(,_ . ,body-forms) ; First element is a function or whatever.
841 (dolist (form body-forms)
842 (cconv-analyse-form form env inclosure)))
845 (let ((dv (assq form env))) ; dv = declared and visible
847 (unless (eq inclosure (cadr dv)) ; capturing condition
848 (push dv cconv-captured))
849 ;; Delete lambda if it is found here, since it escapes.
850 (setq cconv-lambda-candidates
851 (delq dv cconv-lambda-candidates)))))))
854 ;;; cconv.el ends here