1 ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*-
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))) ...))
74 ;; - canonize code in macro-expand so we don't have to handle (let (var) body)
75 ;; and other oddities.
76 ;; - Change new byte-code representation, so it directly gives the
77 ;; number of mandatory and optional arguments as well as whether or
78 ;; not there's a &rest arg.
79 ;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp
80 ;; should turn into building corresponding byte-code function.
81 ;; - don't use `curry', instead build a new compiled-byte-code object
82 ;; (merge the closure env into the static constants pool).
83 ;; - warn about unused lexical vars.
84 ;; - clean up cconv-closure-convert-rec, especially the `let' binding part.
85 ;; - new byte codes for unwind-protect, catch, and condition-case so that
86 ;; closures aren't needed at all.
88 (eval-when-compile (require 'cl
))
90 (defconst cconv-liftwhen
3
91 "Try to do lambda lifting if the number of arguments + free variables
92 is less than this number.")
93 (defvar cconv-mutated nil
94 "List of mutated variables in current form")
95 (defvar cconv-captured nil
96 "List of closure captured variables in current form")
97 (defvar cconv-captured
+mutated nil
98 "An intersection between cconv-mutated and cconv-captured lists.")
99 (defvar cconv-lambda-candidates nil
100 "List of candidates for lambda lifting.
101 Each candidate has the form (VAR INCLOSURE BINDER PARENTFORM).")
103 (defun cconv-freevars (form &optional fvrs
)
104 "Find all free variables of given form.
106 -- FORM is a piece of Elisp code after macroexpansion.
107 -- FVRS(optional) is a list of variables already found. Used for recursive tree
110 Returns a list of free variables."
111 ;; If a leaf in the tree is a symbol, but it is not a global variable, not a
112 ;; keyword, not 'nil or 't we consider this leaf as a variable.
113 ;; Free variables are the variables that are not declared above in this tree.
114 ;; For example free variables of (lambda (a1 a2 ..) body-forms) are
115 ;; free variables of body-forms excluding a1, a2 ..
116 ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are
117 ;; free variables of body-forms excluding v1, v2 ...
120 ;; A list of free variables already found(FVRS) is passed in parameter
121 ;; to try to use cons or push where possible, and to minimize the usage
124 ;; This function can return duplicates (because we use 'append instead
125 ;; of union of two sets - for performance reasons).
127 (`(let ,varsvalues .
,body-forms
) ; let special form
129 (dolist (exp body-forms
)
130 (setq fvrs-1
(cconv-freevars exp fvrs-1
)))
131 (dolist (elm varsvalues
)
132 (setq fvrs-1
(delq (if (consp elm
) (car elm
) elm
) fvrs-1
)))
133 (setq fvrs
(nconc fvrs-1 fvrs
))
134 (dolist (exp varsvalues
)
135 (when (consp exp
) (setq fvrs
(cconv-freevars (cadr exp
) fvrs
))))
138 (`(let* ,varsvalues .
,body-forms
) ; let* special form
141 (dolist (exp varsvalues
)
144 (setq fvrs-1
(cconv-freevars (cadr exp
) fvrs-1
))
145 (dolist (elm vrs
) (setq fvrs-1
(delq elm fvrs-1
)))
146 (push (car exp
) vrs
))
148 (dolist (elm vrs
) (setq fvrs-1
(delq elm fvrs-1
)))
150 (dolist (exp body-forms
)
151 (setq fvrs-1
(cconv-freevars exp fvrs-1
)))
152 (dolist (elm vrs
) (setq fvrs-1
(delq elm fvrs-1
)))
153 (append fvrs fvrs-1
)))
155 (`((lambda .
,_
) .
,_
) ; first element is lambda expression
156 (dolist (exp `((function ,(car form
)) .
,(cdr form
)))
157 (setq fvrs
(cconv-freevars exp fvrs
))) fvrs
)
159 (`(cond .
,cond-forms
) ; cond special form
160 (dolist (exp1 cond-forms
)
162 (setq fvrs
(cconv-freevars exp2 fvrs
)))) fvrs
)
164 (`(quote .
,_
) fvrs
) ; quote form
166 (`(function .
((lambda ,vars .
,body-forms
)))
167 (let ((functionform (cadr form
)) (fvrs-1 '()))
168 (dolist (exp body-forms
)
169 (setq fvrs-1
(cconv-freevars exp fvrs-1
)))
170 (dolist (elm vars
) (setq fvrs-1
(delq elm fvrs-1
)))
171 (append fvrs fvrs-1
))) ; function form
173 (`(function .
,_
) fvrs
) ; same as quote
175 (`(condition-case ,var
,protected-form .
,conditions-bodies
)
177 (dolist (exp conditions-bodies
)
178 (setq fvrs-1
(cconv-freevars (cadr exp
) fvrs-1
)))
179 (setq fvrs-1
(delq var fvrs-1
))
180 (setq fvrs-1
(cconv-freevars protected-form fvrs-1
))
181 (append fvrs fvrs-1
)))
183 (`(,(and sym
(or `defun
`defconst
`defvar
)) .
,_
)
184 ;; We call cconv-freevars only for functions(lambdas)
185 ;; defun, defconst, defvar are not allowed to be inside
186 ;; a function (lambda).
187 ;; FIXME: should be a byte-compile-report-error!
188 (error "Invalid form: %s inside a function" sym
))
190 (`(,_ .
,body-forms
) ; First element is (like) a function.
191 (dolist (exp body-forms
)
192 (setq fvrs
(cconv-freevars exp fvrs
))) fvrs
)
194 (_ (if (byte-compile-not-lexical-var-p form
)
199 (defun cconv-closure-convert (form)
200 "Main entry point for closure conversion.
201 -- FORM is a piece of Elisp code after macroexpansion.
202 -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
204 Returns a form where all lambdas don't have any free variables."
205 ;; (message "Entering cconv-closure-convert...")
206 (let ((cconv-mutated '())
207 (cconv-lambda-candidates '())
209 (cconv-captured+mutated
'()))
210 ;; Analyse form - fill these variables with new information.
211 (cconv-analyse-form form
'() 0)
212 ;; Calculate an intersection of cconv-mutated and cconv-captured.
213 (dolist (mvr cconv-mutated
)
214 (when (memq mvr cconv-captured
) ;
215 (push mvr cconv-captured
+mutated
)))
216 (cconv-closure-convert-rec
219 '() ; fvrs initially empty
220 '() ; envs initially empty
224 (defun cconv--lookup-let (table var binder form
)
227 (when (and (eq (nth 2 elem
) binder
)
228 (eq (nth 3 elem
) form
))
229 (assert (eq (car elem
) var
))
233 (defconst cconv--dummy-var
(make-symbol "ignored"))
235 (defun cconv--set-diff (s1 s2
)
236 "Return elements of set S1 that are not in set S2."
239 (unless (memq x s2
) (push x res
)))
242 (defun cconv--set-diff-map (s m
)
243 "Return elements of set S that are not in Dom(M)."
246 (unless (assq x m
) (push x res
)))
249 (defun cconv--map-diff (m1 m2
)
250 "Return the submap of map M1 that has Dom(M2) removed."
253 (unless (assq (car x
) m2
) (push x res
)))
256 (defun cconv--map-diff-elem (m x
)
257 "Return the map M minus any mapping for X."
258 ;; Here we assume that X appears at most once in M.
259 (let* ((b (assq x m
))
260 (res (if b
(remq b m
) m
)))
261 (assert (null (assq x res
))) ;; Check the assumption was warranted.
264 (defun cconv--map-diff-set (m s
)
265 "Return the map M minus any mapping for elements of S."
266 ;; Here we assume that X appears at most once in M.
269 (unless (memq (car b
) s
) (push b res
)))
272 (defun cconv-closure-convert-rec (form emvrs fvrs envs lmenvs
)
273 ;; This function actually rewrites the tree.
274 "Eliminates all free variables of all lambdas in given forms.
276 -- FORM is a piece of Elisp code after macroexpansion.
277 -- LMENVS is a list of environments used for lambda-lifting. Initially empty.
278 -- EMVRS is a list that contains mutated variables that are visible
279 within current environment.
280 -- ENVS is an environment(list of free variables) of current closure.
282 -- FVRS is a list of variables to substitute in each context.
285 Returns a form where all lambdas don't have any free variables."
286 ;; What's the difference between fvrs and envs?
287 ;; Suppose that we have the code
288 ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
289 ;; only the first occurrence of fvr should be replaced by
291 ;; So initially envs and fvrs are the same thing, but when we descend to
292 ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
293 ;; Because in envs the order of variables is important. We use this list
294 ;; to find the number of a specific variable in the environment vector,
295 ;; so we never touch it(unless we enter to the other closure).
296 ;;(if (listp form) (print (car form)) form)
298 (`(,(and letsym
(or `let
* `let
)) ,binders .
,body-forms
)
300 ; let and let* special forms
301 (let ((body-forms-new '())
303 ;; next for variables needed for delayed push
304 ;; because we should process <value(s)>
305 ;; before we change any arguments
306 (lmenvs-new '()) ;needed only in case of let
307 (emvrs-new '()) ;needed only in case of let
308 (emvr-push) ;needed only in case of let*
309 (lmenv-push)) ;needed only in case of let*
311 (dolist (binder binders
)
313 (var (if (not (consp binder
))
315 (setq value
(cadr binder
))
319 ;; Check if var is a candidate for lambda lifting.
320 ((cconv--lookup-let cconv-lambda-candidates var binder form
)
322 (let* ((fv (delete-dups (cconv-freevars value
'())))
323 (funargs (cadr (cadr value
)))
324 (funcvars (append fv funargs
))
325 (funcbodies (cddadr value
)) ; function bodies
326 (funcbodies-new '()))
327 ; lambda lifting condition
328 (if (or (not fv
) (< cconv-liftwhen
(length funcvars
)))
330 (cconv-closure-convert-rec
331 value emvrs fvrs envs lmenvs
)
334 (dolist (elm2 funcbodies
)
335 (push ; convert function bodies
336 (cconv-closure-convert-rec
337 elm2 emvrs nil envs lmenvs
)
339 (if (eq letsym
'let
*)
340 (setq lmenv-push
(cons var fv
))
341 (push (cons var fv
) lmenvs-new
))
342 ; push lifted function
346 ,(reverse funcbodies-new
))))))))
348 ;; Check if it needs to be turned into a "ref-cell".
349 ((cconv--lookup-let cconv-captured
+mutated var binder form
)
350 ;; Declared variable is mutated and captured.
352 `(list ,(cconv-closure-convert-rec
355 (if (eq letsym
'let
*)
357 (push var emvrs-new
))))
359 ;; Normal default case.
361 (cconv-closure-convert-rec
362 value emvrs fvrs envs lmenvs
)))))
364 ;; this piece of code below letbinds free
365 ;; variables of a lambda lifted function
366 ;; if they are redefined in this let
368 ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
369 ;; Here we can not pass y as parameter because it is
370 ;; redefined. We add a (closed-y y) declaration.
371 ;; We do that even if the function is not used inside
372 ;; this let(*). The reason why we ignore this case is
373 ;; that we can't "look forward" to see if the function
374 ;; is called there or not. To treat well this case we
375 ;; need to traverse the tree one more time to collect this
376 ;; data, and I think that it's not worth it.
378 (when (eq letsym
'let
*)
379 (let ((closedsym '())
382 (dolist (lmenv lmenvs
)
383 (when (memq var
(cdr lmenv
))
386 (concat "closed-" (symbol-name var
))))
387 (setq new-lmenv
(list (car lmenv
)))
388 (dolist (frv (cdr lmenv
)) (if (eq frv var
)
389 (push closedsym new-lmenv
)
390 (push frv new-lmenv
)))
391 (setq new-lmenv
(reverse new-lmenv
))
392 (setq old-lmenv lmenv
)))
394 (setq lmenvs
(remq old-lmenv lmenvs
))
395 (push new-lmenv lmenvs
)
396 (push `(,closedsym
,var
) binders-new
))))
397 ;; We push the element after redefined free variables are
398 ;; processed. This is important to avoid the bug when free
399 ;; variable and the function have the same name.
400 (push (list var new-val
) binders-new
)
402 (when (eq letsym
'let
*) ; update fvrs
403 (setq fvrs
(remq var fvrs
))
404 (setq emvrs
(remq var emvrs
)) ; remove if redefined
406 (push emvr-push emvrs
)
407 (setq emvr-push nil
))
408 (setq lmenvs
(cconv--map-diff-elem lmenvs var
))
410 (push lmenv-push lmenvs
)
411 (setq lmenv-push nil
)))
412 )) ; end of dolist over binders
413 (when (eq letsym
'let
)
415 (let (var fvrs-1 emvrs-1 lmenvs-1
)
416 ;; Here we update emvrs, fvrs and lmenvs lists
417 (setq fvrs
(cconv--set-diff-map fvrs binders-new
))
418 (setq emvrs
(cconv--set-diff-map emvrs binders-new
))
419 (setq emvrs
(append emvrs emvrs-new
))
420 (setq lmenvs
(cconv--set-diff-map lmenvs binders-new
))
421 (setq lmenvs
(append lmenvs lmenvs-new
)))
423 ;; Here we do the same letbinding as for let* above
424 ;; to avoid situation when a free variable of a lambda lifted
425 ;; function got redefined.
431 (dolist (binder binders
)
432 (setq var
(if (consp binder
) (car binder
) binder
))
434 (let ((lmenvs-1 lmenvs
)) ; just to avoid manipulating
435 (dolist (lmenv lmenvs-1
) ; the counter inside the loop
436 (when (memq var
(cdr lmenv
))
437 (setq closedsym
(make-symbol
441 (setq new-lmenv
(list (car lmenv
)))
442 (dolist (frv (cdr lmenv
))
443 (push (if (eq frv var
) closedsym frv
)
445 (setq new-lmenv
(reverse new-lmenv
))
446 (setq lmenvs
(remq lmenv lmenvs
))
447 (push new-lmenv lmenvs
)
448 (push `(,closedsym
,var
) letbinds
)
450 (setq binders-new
(append binders-new letbinds
))))
452 (dolist (elm body-forms
) ; convert body forms
453 (push (cconv-closure-convert-rec
454 elm emvrs fvrs envs lmenvs
)
456 `(,letsym
,(reverse binders-new
) .
,(reverse body-forms-new
))))
457 ;end of let let* forms
459 ; first element is lambda expression
460 (`(,(and `(lambda .
,_
) fun
) .
,other-body-forms
)
462 (let ((other-body-forms-new '()))
463 (dolist (elm other-body-forms
)
464 (push (cconv-closure-convert-rec
465 elm emvrs fvrs envs lmenvs
)
466 other-body-forms-new
))
468 ,(cconv-closure-convert-rec
469 (list 'function fun
) emvrs fvrs envs lmenvs
)
470 ,@(nreverse other-body-forms-new
))))
472 (`(cond .
,cond-forms
) ; cond special form
473 (let ((cond-forms-new '()))
474 (dolist (elm cond-forms
)
475 (push (let ((elm-new '()))
478 (cconv-closure-convert-rec
479 elm-2 emvrs fvrs envs lmenvs
)
484 (reverse cond-forms-new
))))
488 (`(function (lambda ,vars .
,body-forms
)) ; function form
489 (let* ((fvrs-new (cconv--set-diff fvrs vars
)) ; Remove vars from fvrs.
490 (fv (delete-dups (cconv-freevars form
'())))
491 (leave fvrs-new
) ; leave=non-nil if we should leave env unchanged.
497 ;; Here we form our environment vector.
501 (cconv-closure-convert-rec
502 ;; Remove `elm' from `emvrs' for this call because in case
503 ;; `elm' is a variable that's wrapped in a cons-cell, we
504 ;; want to put the cons-cell itself in the closure, rather
505 ;; than just a copy of its current content.
506 elm
(remq elm emvrs
) fvrs envs lmenvs
)
507 envector
)) ; Process vars for closure vector.
508 (setq envector
(reverse envector
))
510 (setq fvrs-new fv
)) ; Update substitution list.
512 (setq emvrs
(cconv--set-diff emvrs vars
))
513 (setq lmenvs
(cconv--map-diff-set lmenvs vars
))
515 ;; The difference between envs and fvrs is explained
516 ;; in comment in the beginning of the function.
517 (dolist (elm cconv-captured
+mutated
) ; Find mutated arguments
518 (setq mv
(car elm
)) ; used in inner closures.
519 (when (and (memq mv vars
) (eq form
(caddr elm
)))
520 (progn (push mv emvrs
)
521 (push `(,mv
(list ,mv
)) letbind
))))
522 (dolist (elm body-forms
) ; convert function body
523 (push (cconv-closure-convert-rec
524 elm emvrs fvrs-new envs lmenvs
)
528 (if letbind
`((let ,letbind .
,(reverse body-forms-new
)))
529 (reverse body-forms-new
)))
532 ;if no freevars - do nothing
534 `(function (lambda ,vars .
,body-forms-new
)))
535 ; 1 free variable - do not build vector
537 `(internal-make-closure
538 ,vars
,envector .
,body-forms-new
)))))
540 (`(function .
,_
) form
) ; Same as quote.
543 (`(,(and sym
(or `defconst
`defvar
)) ,definedsymbol .
,body-forms
)
545 (let ((body-forms-new '()))
546 (dolist (elm body-forms
)
547 (push (cconv-closure-convert-rec
548 elm emvrs fvrs envs lmenvs
)
550 (setq body-forms-new
(reverse body-forms-new
))
551 `(,sym
,definedsymbol .
,body-forms-new
)))
554 (`(,(and sym
(or `defun
`defmacro
))
555 ,func
,vars .
,body-forms
)
556 (let ((body-new '()) ; The whole body.
557 (body-forms-new '()) ; Body w\o docstring and interactive.
559 ; Find mutable arguments.
561 (let ((lmutated cconv-captured
+mutated
)
563 (while (and lmutated
(not ismutated
))
564 (when (and (eq (caar lmutated
) elm
)
565 (eq (caddar lmutated
) form
))
567 (setq lmutated
(cdr lmutated
)))
571 ;Transform body-forms.
572 (when (stringp (car body-forms
)) ; Treat docstring well.
573 (push (car body-forms
) body-new
)
574 (setq body-forms
(cdr body-forms
)))
575 (when (eq (car-safe (car body-forms
)) 'interactive
)
576 (push (cconv-closure-convert-rec
578 emvrs fvrs envs lmenvs
)
580 (setq body-forms
(cdr body-forms
)))
582 (dolist (elm body-forms
)
583 (push (cconv-closure-convert-rec
584 elm emvrs fvrs envs lmenvs
)
586 (setq body-forms-new
(reverse body-forms-new
))
589 ; Letbind mutable arguments.
590 (let ((binders-new '()))
591 (dolist (elm letbind
) (push `(,elm
(list ,elm
))
593 (push `(let ,(reverse binders-new
) .
594 ,body-forms-new
) body-new
)
595 (setq body-new
(reverse body-new
)))
596 (setq body-new
(append (reverse body-new
) body-forms-new
)))
598 `(,sym
,func
,vars .
,body-new
)))
601 (`(condition-case ,var
,protected-form .
,handlers
)
602 (let ((handlers-new '())
603 (newform (cconv-closure-convert-rec
604 `(function (lambda () ,protected-form
))
605 emvrs fvrs envs lmenvs
)))
606 (setq fvrs
(remq var fvrs
))
607 (dolist (handler handlers
)
608 (push (list (car handler
)
609 (cconv-closure-convert-rec
610 `(function (lambda (,(or var cconv--dummy-var
))
612 emvrs fvrs envs lmenvs
))
614 `(condition-case :fun-body
,newform
615 ,@(nreverse handlers-new
))))
617 (`(,(and head
(or `catch
`unwind-protect
)) ,form .
,body
)
618 `(,head
,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs
)
620 ,(cconv-closure-convert-rec `(function (lambda () ,@body
))
621 emvrs fvrs envs lmenvs
)))
623 (`(track-mouse .
,body
)
626 ,(cconv-closure-convert-rec `(function (lambda () ,@body
))
627 emvrs fvrs envs lmenvs
)))
629 (`(setq .
,forms
) ; setq special form
630 (let (prognlist sym sym-new value
)
632 (setq sym
(car forms
))
633 (setq sym-new
(cconv-closure-convert-rec
635 (remq sym emvrs
) fvrs envs lmenvs
))
637 (cconv-closure-convert-rec
638 (cadr forms
) emvrs fvrs envs lmenvs
))
640 (push `(setcar ,sym-new
,value
) prognlist
)
641 (if (symbolp sym-new
)
642 (push `(setq ,sym-new
,value
) prognlist
)
643 (debug) ;FIXME: When can this be right?
644 (push `(set ,sym-new
,value
) prognlist
)))
645 (setq forms
(cddr forms
)))
647 `(progn .
,(reverse prognlist
))
650 (`(,(and (or `funcall
`apply
) callsym
) ,fun .
,args
)
651 ; funcall is not a special form
652 ; but we treat it separately
653 ; for the needs of lambda lifting
654 (let ((fv (cdr (assq fun lmenvs
))))
658 ;; All args (free variables and actual arguments)
659 ;; should be processed, because they can be fvrs
660 ;; (free variables of another closure)
662 (push (cconv-closure-convert-rec
666 (setq processed-fv
(reverse processed-fv
))
668 (push (cconv-closure-convert-rec
669 elm emvrs fvrs envs lmenvs
)
671 (setq args-new
(append processed-fv
(reverse args-new
)))
672 (setq fun
(cconv-closure-convert-rec
673 fun emvrs fvrs envs lmenvs
))
674 `(,callsym
,fun .
,args-new
))
676 (dolist (elm (cdr form
))
677 (push (cconv-closure-convert-rec
678 elm emvrs fvrs envs lmenvs
)
680 `(,callsym .
,(reverse cdr-new
))))))
682 (`(,func .
,body-forms
) ; first element is function or whatever
683 ; function-like forms are:
684 ; or, and, if, progn, prog1, prog2,
686 (let ((body-forms-new '()))
687 (dolist (elm body-forms
)
688 (push (cconv-closure-convert-rec
689 elm emvrs fvrs envs lmenvs
)
691 (setq body-forms-new
(reverse body-forms-new
))
692 `(,func .
,body-forms-new
)))
695 (let ((free (memq form fvrs
)))
696 (if free
;form is a free variable
697 (let* ((numero (- (length fvrs
) (length free
)))
698 ;; Replace form => (aref env #)
699 (var `(internal-get-closed-var ,numero
)))
700 (if (memq form emvrs
) ; form => (car (aref env #)) if mutable
703 (if (memq form emvrs
) ; if form is a mutable variable
704 `(car ,form
) ; replace form => (car form)
707 (defun cconv-analyse-function (args body env parentform inclosure
)
710 ((byte-compile-not-lexical-var-p arg
)
711 (byte-compile-report-error
712 (format "Argument %S is not a lexical variable" arg
)))
713 ((eq ?
& (aref (symbol-name arg
) 0)) nil
) ;Ignore &rest, &optional, ...
714 (t (push (list arg inclosure parentform
) env
)))) ;Push vrs to vars.
715 (dolist (form body
) ;Analyse body forms.
716 (cconv-analyse-form form env inclosure
)))
718 (defun cconv-analyse-form (form env inclosure
)
719 "Find mutated variables and variables captured by closure. Analyse
720 lambdas if they are suitable for lambda lifting.
721 -- FORM is a piece of Elisp code after macroexpansion.
722 -- ENV is a list of variables visible in current lexical environment.
723 Each entry has the form (VAR INCLOSURE BINDER PARENTFORM)
724 for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments.
725 -- INCLOSURE is the nesting level within lambdas."
728 (`(,(and (or `let
* `let
) letsym
) ,binders .
,body-forms
)
733 (dolist (binder binders
)
734 (if (not (consp binder
))
736 (setq var binder
) ; treat the form (let (x) ...) well
738 (setq var
(car binder
))
739 (setq value
(cadr binder
))
741 (cconv-analyse-form value
(if (eq letsym
'let
*) env orig-env
)
744 (unless (byte-compile-not-lexical-var-p var
)
745 (let ((varstruct (list var inclosure binder form
)))
746 (push varstruct env
) ; Push a new one.
749 (`(function (lambda .
,_
))
750 ;; If var is a function push it to lambda list.
751 (push varstruct cconv-lambda-candidates
)))))))
753 (dolist (form body-forms
) ; Analyse body forms.
754 (cconv-analyse-form form env inclosure
)))
757 (`(,(or `defun
`defmacro
) ,func
,vrs .
,body-forms
)
759 (byte-compile-log-warning
760 (format "Function %S will ignore its context %S"
761 func
(mapcar #'car env
))
763 (cconv-analyse-function vrs body-forms nil form
0))
765 (`(function (lambda ,vrs .
,body-forms
))
766 (cconv-analyse-function vrs body-forms env form
(1+ inclosure
)))
769 ;; If a local variable (member of env) is modified by setq then
770 ;; it is a mutated variable.
772 (let ((v (assq (car forms
) env
))) ; v = non nil if visible
774 (push v cconv-mutated
)
775 ;; Delete from candidate list for lambda lifting.
776 (setq cconv-lambda-candidates
(delq v cconv-lambda-candidates
))
777 (unless (eq inclosure
(cadr v
)) ;Bound in a different closure level.
778 (push v cconv-captured
))))
779 (cconv-analyse-form (cadr forms
) env inclosure
)
780 (setq forms
(cddr forms
))))
782 (`((lambda .
,_
) .
,_
) ; first element is lambda expression
783 (dolist (exp `((function ,(car form
)) .
,(cdr form
)))
784 (cconv-analyse-form exp env inclosure
)))
786 (`(cond .
,cond-forms
) ; cond special form
787 (dolist (forms cond-forms
)
789 (cconv-analyse-form form env inclosure
))))
791 (`(quote .
,_
) nil
) ; quote form
792 (`(function .
,_
) nil
) ; same as quote
794 (`(condition-case ,var
,protected-form .
,handlers
)
795 ;; FIXME: The bytecode for condition-case forces us to wrap the
796 ;; form and handlers in closures (for handlers, it's probably
797 ;; unavoidable, but not for the protected form).
798 (setq inclosure
(1+ inclosure
))
799 (cconv-analyse-form protected-form env inclosure
)
800 (push (list var inclosure form
) env
)
801 (dolist (handler handlers
)
802 (dolist (form (cdr handler
))
803 (cconv-analyse-form form env inclosure
))))
805 ;; FIXME: The bytecode for catch forces us to wrap the body.
806 (`(,(or `catch
`unwind-protect
) ,form .
,body
)
807 (cconv-analyse-form form env inclosure
)
808 (setq inclosure
(1+ inclosure
))
810 (cconv-analyse-form form env inclosure
)))
812 ;; FIXME: The bytecode for save-window-excursion and the lack of
813 ;; bytecode for track-mouse forces us to wrap the body.
814 (`(track-mouse .
,body
)
815 (setq inclosure
(1+ inclosure
))
817 (cconv-analyse-form form env inclosure
)))
819 (`(,(or `defconst
`defvar
) ,var
,value .
,_
)
820 (push var byte-compile-bound-variables
)
821 (cconv-analyse-form value env inclosure
))
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.
829 (let ((lv (assq fun cconv-lambda-candidates
)))
831 (unless (eq (cadr lv
) inclosure
)
832 (push lv cconv-captured
)
833 ;; If this funcall and the definition of fun are in
834 ;; different closures - we delete fun from candidate
835 ;; list, because it is too complicated to manage free
836 ;; variables in this case.
837 (setq cconv-lambda-candidates
838 (delq lv cconv-lambda-candidates
)))))
839 (cconv-analyse-form fun env inclosure
))
841 (cconv-analyse-form form env inclosure
)))
843 (`(,_ .
,body-forms
) ; First element is a function or whatever.
844 (dolist (form body-forms
)
845 (cconv-analyse-form form env inclosure
)))
848 (let ((dv (assq form env
))) ; dv = declared and visible
850 (unless (eq inclosure
(cadr dv
)) ; capturing condition
851 (push dv cconv-captured
))
852 ;; Delete lambda if it is found here, since it escapes.
853 (setq cconv-lambda-candidates
854 (delq dv cconv-lambda-candidates
)))))))
857 ;;; cconv.el ends here