HCoop / bpt / emacs.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
* lisp/emacs-lisp/cconv.el: New file.
[bpt/emacs.git] / lisp / emacs-lisp / cconv.el
1 ;;; -*- lexical-binding: t -*-
2 ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp.
3
4 ;; licence stuff will be added later(I don't know yet what to write here)
5
6 ;;; Commentary:
7
8 ;; This takes a piece of Elisp code, and eliminates all free variables from
9 ;; lambda expressions. The user entry points are cconv-closure-convert and
10 ;; cconv-closure-convert-toplevel(for toplevel forms).
11 ;; All macros should be expanded.
12 ;;
13 ;; Here is a brief explanation how this code works.
14 ;; Firstly, we analyse the tree by calling cconv-analyse-form.
15 ;; This function finds all mutated variables, all functions that are suitable
16 ;; for lambda lifting and all variables captured by closure. It passes the tree
17 ;; once, returning a list of three lists.
18 ;;
19 ;; Then we calculate the intersection of first and third lists returned by
20 ;; cconv-analyse form to find all mutated variables that are captured by
21 ;; closure.
22
23 ;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the
24 ;; tree recursivly, lifting lambdas where possible, building closures where it
25 ;; is needed and eliminating mutable variables used in closure.
26 ;;
27 ;; We do following replacements :
28 ;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .)
29 ;; if the function is suitable for lambda lifting (if all calls are known)
30 ;;
31 ;; (function (lambda (v1 ...) ... fv ...)) =>
32 ;; (curry (lambda (env v1 ...) ... env ...) env)
33 ;; if the function has only 1 free variable
34 ;;
35 ;; and finally
36 ;; (function (lambda (v1 ...) ... fv1 fv2 ...)) =>
37 ;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2))
38 ;; if the function has 2 or more free variables
39 ;;
40 ;; If the function has no free variables, we don't do anything.
41 ;;
42 ;; If the variable is mutable(updated by setq), and it is used in closure
43 ;; we wrap it's definition with list: (list var) and we also replace
44 ;; var => (car var) wherever this variable is used, and also
45 ;; (setq var value) => (setcar var value) where it is updated.
46 ;;
47 ;; If defun argument is closure mutable, we letbind it and wrap it's
48 ;; definition with list.
49 ;; (defun foo (... mutable-arg ...) ...) =>
50 ;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...))
51 ;;
52 ;;
53 ;;
54 ;;
55 ;;
56 ;;; Code:
57
58 (require 'pcase)
59 (eval-when-compile (require 'cl))
60
61 (defconst cconv-liftwhen 3
62 "Try to do lambda lifting if the number of arguments + free variables
63 is less than this number.")
64 (defvar cconv-mutated
65 "List of mutated variables in current form")
66 (defvar cconv-captured
67 "List of closure captured variables in current form")
68 (defvar cconv-captured+mutated
69 "An intersection between cconv-mutated and cconv-captured lists.")
70 (defvar cconv-lambda-candidates
71 "List of candidates for lambda lifting")
72
73
74
75 (defun cconv-freevars (form &optional fvrs)
76 "Find all free variables of given form.
77 Arguments:
78 -- FORM is a piece of Elisp code after macroexpansion.
79 -- FVRS(optional) is a list of variables already found. Used for recursive tree
80 traversal
81
82 Returns a list of free variables."
83 ;; If a leaf in the tree is a symbol, but it is not a global variable, not a
84 ;; keyword, not 'nil or 't we consider this leaf as a variable.
85 ;; Free variables are the variables that are not declared above in this tree.
86 ;; For example free variables of (lambda (a1 a2 ..) body-forms) are
87 ;; free variables of body-forms excluding a1, a2 ..
88 ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are
89 ;; free variables of body-forms excluding v1, v2 ...
90 ;; and so on.
91
92 ;; a list of free variables already found(FVRS) is passed in parameter
93 ;; to try to use cons or push where possible, and to minimize the usage
94 ;; of append
95
96 ;; This function can contain duplicates(because we use 'append instead
97 ;; of union of two sets - for performance reasons).
98 (pcase form
99 (`(let ,varsvalues . ,body-forms) ; let special form
100 (let ((fvrs-1 '()))
101 (dolist (exp body-forms)
102 (setq fvrs-1 (cconv-freevars exp fvrs-1)))
103 (dolist (elm varsvalues)
104 (if (listp elm)
105 (setq fvrs-1 (delq (car elm) fvrs-1))
106 (setq fvrs-1 (delq elm fvrs-1))))
107 (setq fvrs (append fvrs fvrs-1))
108 (dolist (exp varsvalues)
109 (when (listp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs))))
110 fvrs))
111
112 (`(let* ,varsvalues . ,body-forms) ; let* special form
113 (let ((vrs '())
114 (fvrs-1 '()))
115 (dolist (exp varsvalues)
116 (if (listp exp)
117 (progn
118 (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))
119 (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1)))
120 (push (car exp) vrs))
121 (progn
122 (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1)))
123 (push exp vrs))))
124 (dolist (exp body-forms)
125 (setq fvrs-1 (cconv-freevars exp fvrs-1)))
126 (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1)))
127 (append fvrs fvrs-1)))
128
129 (`((lambda . ,_) . ,_) ; first element is lambda expression
130 (dolist (exp `((function ,(car form)) . ,(cdr form)))
131 (setq fvrs (cconv-freevars exp fvrs))) fvrs)
132
133 (`(cond . ,cond-forms) ; cond special form
134 (dolist (exp1 cond-forms)
135 (dolist (exp2 exp1)
136 (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs)
137
138 (`(quote . ,_) fvrs) ; quote form
139
140 (`(function . ((lambda ,vars . ,body-forms)))
141 (let ((functionform (cadr form)) (fvrs-1 '()))
142 (dolist (exp body-forms)
143 (setq fvrs-1 (cconv-freevars exp fvrs-1)))
144 (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1)))
145 (append fvrs fvrs-1))) ; function form
146
147 (`(function . ,_) fvrs) ; same as quote
148 ;condition-case
149 (`(condition-case ,var ,protected-form . ,conditions-bodies)
150 (let ((fvrs-1 '()))
151 (setq fvrs-1 (cconv-freevars protected-form '()))
152 (dolist (exp conditions-bodies)
153 (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)))
154 (setq fvrs-1 (delq var fvrs-1))
155 (append fvrs fvrs-1)))
156
157 (`(,(and sym (or `defun `defconst `defvar)) . ,_)
158 ;; we call cconv-freevars only for functions(lambdas)
159 ;; defun, defconst, defvar are not allowed to be inside
160 ;; a function(lambda)
161 (error "Invalid form: %s inside a function" sym))
162
163 (`(,_ . ,body-forms) ; first element is a function or whatever
164 (dolist (exp body-forms)
165 (setq fvrs (cconv-freevars exp fvrs))) fvrs)
166
167 (_ (if (or (not (symbolp form)) ; form is not a list
168 (special-variable-p form)
169 (memq form '(nil t))
170 (keywordp form))
171 fvrs
172 (cons form fvrs)))))
173
174 ;;;###autoload
175 (defun cconv-closure-convert (form &optional toplevel)
176 ;; cconv-closure-convert-rec has a lot of parameters that are
177 ;; whether useless for user, whether they should contain
178 ;; specific data like a list of closure mutables or the list
179 ;; of lambdas suitable for lifting.
180 ;;
181 ;; That's why this function exists.
182 "Main entry point for non-toplevel forms.
183 -- FORM is a piece of Elisp code after macroexpansion.
184 -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST
185
186 Returns a form where all lambdas don't have any free variables."
187 (let ((cconv-mutated '())
188 (cconv-lambda-candidates '())
189 (cconv-captured '())
190 (cconv-captured+mutated '()))
191 ;; Analyse form - fill these variables with new information
192 (cconv-analyse-form form '() nil)
193 ;; Calculate an intersection of cconv-mutated and cconv-captured
194 (dolist (mvr cconv-mutated)
195 (when (memq mvr cconv-captured) ;
196 (push mvr cconv-captured+mutated)))
197 (cconv-closure-convert-rec
198 form ; the tree
199 '() ;
200 '() ; fvrs initially empty
201 '() ; envs initially empty
202 '()
203 toplevel))) ; true if the tree is a toplevel form
204
205 ;;;###autoload
206 (defun cconv-closure-convert-toplevel (form)
207 "Entry point for toplevel forms.
208 -- FORM is a piece of Elisp code after macroexpansion.
209
210 Returns a form where all lambdas don't have any free variables."
211 ;; we distinguish toplevel forms to treat def(un|var|const) correctly.
212 (cconv-closure-convert form t))
213
214 (defun cconv-closure-convert-rec
215 (form emvrs fvrs envs lmenvs defs-are-legal)
216 ;; This function actually rewrites the tree.
217 "Eliminates all free variables of all lambdas in given forms.
218 Arguments:
219 -- FORM is a piece of Elisp code after macroexpansion.
220 -- LMENVS is a list of environments used for lambda-lifting. Initially empty.
221 -- EMVRS is a list that contains mutated variables that are visible
222 within current environment.
223 -- ENVS is an environment(list of free variables) of current closure.
224 Initially empty.
225 -- FVRS is a list of variables to substitute in each context.
226 Initially empty.
227 -- DEFS-ARE-LEGAL is a boolean variable, true if def(un|var|const)
228 can be used in this form(e.g. toplevel form)
229
230 Returns a form where all lambdas don't have any free variables."
231 ;; What's the difference between fvrs and envs?
232 ;; Suppose that we have the code
233 ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1)))
234 ;; only the first occurrence of fvr should be replaced by
235 ;; (aref env ...).
236 ;; So initially envs and fvrs are the same thing, but when we descend to
237 ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs?
238 ;; Because in envs the order of variables is important. We use this list
239 ;; to find the number of a specific variable in the environment vector,
240 ;; so we never touch it(unless we enter to the other closure).
241 ;;(if (listp form) (print (car form)) form)
242 (pcase form
243 (`(,(and letsym (or `let* `let)) ,varsvalues . ,body-forms)
244
245 ; let and let* special forms
246 (let ((body-forms-new '())
247 (varsvalues-new '())
248 ;; next for variables needed for delayed push
249 ;; because we should process <value(s)>
250 ;; before we change any arguments
251 (lmenvs-new '()) ;needed only in case of let
252 (emvrs-new '()) ;needed only in case of let
253 (emvr-push) ;needed only in case of let*
254 (lmenv-push)) ;needed only in case of let*
255
256 (dolist (elm varsvalues) ;begin of dolist over varsvalues
257 (let (var value elm-new iscandidate ismutated)
258 (if (listp elm) ; (let (v1) ...) => (let ((v1 nil)) ...)
259 (progn
260 (setq var (car elm))
261 (setq value (cadr elm)))
262 (setq var elm))
263
264 ;; Check if var is a candidate for lambda lifting
265 (let ((lcandid cconv-lambda-candidates))
266 (while (and lcandid (not iscandidate))
267 (when (and (eq (caar lcandid) var)
268 (eq (caddar lcandid) elm)
269 (eq (cadr (cddar lcandid)) form))
270 (setq iscandidate t))
271 (setq lcandid (cdr lcandid))))
272
273 ; declared variable is a candidate
274 ; for lambda lifting
275 (if iscandidate
276 (let* ((func (cadr elm)) ; function(lambda) itself
277 ; free variables
278 (fv (delete-dups (cconv-freevars func '())))
279 (funcvars (append fv (cadadr func))) ;function args
280 (funcbodies (cddadr func)) ; function bodies
281 (funcbodies-new '()))
282 ; lambda lifting condition
283 (if (or (not fv) (< cconv-liftwhen (length funcvars)))
284 ; do not lift
285 (setq
286 elm-new
287 `(,var
288 ,(cconv-closure-convert-rec
289 func emvrs fvrs envs lmenvs nil)))
290 ; lift
291 (progn
292 (dolist (elm2 funcbodies)
293 (push ; convert function bodies
294 (cconv-closure-convert-rec
295 elm2 emvrs nil envs lmenvs nil)
296 funcbodies-new))
297 (if (eq letsym 'let*)
298 (setq lmenv-push (cons var fv))
299 (push (cons var fv) lmenvs-new))
300 ; push lifted function
301
302 (setq elm-new
303 `(,var
304 (function .
305 ((lambda ,funcvars .
306 ,(reverse funcbodies-new)))))))))
307
308 ;declared variable is not a function
309 (progn
310 ;; Check if var is mutated
311 (let ((lmutated cconv-captured+mutated))
312 (while (and lmutated (not ismutated))
313 (when (and (eq (caar lmutated) var)
314 (eq (caddar lmutated) elm)
315 (eq (cadr (cddar lmutated)) form))
316 (setq ismutated t))
317 (setq lmutated (cdr lmutated))))
318 (if ismutated
319 (progn ; declared variable is mutated
320 (setq elm-new
321 `(,var (list ,(cconv-closure-convert-rec
322 value emvrs
323 fvrs envs lmenvs nil))))
324 (if (eq letsym 'let*)
325 (setq emvr-push var)
326 (push var emvrs-new)))
327 (progn
328 (setq
329 elm-new
330 `(,var ; else
331 ,(cconv-closure-convert-rec
332 value emvrs fvrs envs lmenvs nil)))))))
333
334 ;; this piece of code below letbinds free
335 ;; variables of a lambda lifted function
336 ;; if they are redefined in this let
337 ;; example:
338 ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1))
339 ;; Here we can not pass y as parameter because it is
340 ;; redefined. We add a (closed-y y) declaration.
341 ;; We do that even if the function is not used inside
342 ;; this let(*). The reason why we ignore this case is
343 ;; that we can't "look forward" to see if the function
344 ;; is called there or not. To treat well this case we
345 ;; need to traverse the tree one more time to collect this
346 ;; data, and I think that it's not worth it.
347
348 (when (eq letsym 'let*)
349 (let ((closedsym '())
350 (new-lmenv '())
351 (old-lmenv '()))
352 (dolist (lmenv lmenvs)
353 (when (memq var (cdr lmenv))
354 (setq closedsym
355 (make-symbol
356 (concat "closed-" (symbol-name var))))
357 (setq new-lmenv (list (car lmenv)))
358 (dolist (frv (cdr lmenv)) (if (eq frv var)
359 (push closedsym new-lmenv)
360 (push frv new-lmenv)))
361 (setq new-lmenv (reverse new-lmenv))
362 (setq old-lmenv lmenv)))
363 (when new-lmenv
364 (setq lmenvs (remq old-lmenv lmenvs))
365 (push new-lmenv lmenvs)
366 (push `(,closedsym ,var) varsvalues-new))))
367 ;; we push the element after redefined free variables
368 ;; are processes. this is important to avoid the bug
369 ;; when free variable and the function have the same
370 ;; name
371 (push elm-new varsvalues-new)
372
373 (when (eq letsym 'let*) ; update fvrs
374 (setq fvrs (remq var fvrs))
375 (setq emvrs (remq var emvrs)) ; remove if redefined
376 (when emvr-push
377 (push emvr-push emvrs)
378 (setq emvr-push nil))
379 (let (lmenvs-1) ; remove var from lmenvs if redefined
380 (dolist (iter lmenvs)
381 (when (not (assq var lmenvs))
382 (push iter lmenvs-1)))
383 (setq lmenvs lmenvs-1))
384 (when lmenv-push
385 (push lmenv-push lmenvs)
386 (setq lmenv-push nil)))
387 )) ; end of dolist over varsvalues
388 (when (eq letsym 'let)
389
390 (let (var fvrs-1 emvrs-1 lmenvs-1)
391 ;; Here we update emvrs, fvrs and lmenvs lists
392 (dolist (vr fvrs)
393 ; safely remove
394 (when (not (assq vr varsvalues-new)) (push vr fvrs-1)))
395 (setq fvrs fvrs-1)
396 (dolist (vr emvrs)
397 ; safely remove
398 (when (not (assq vr varsvalues-new)) (push vr emvrs-1)))
399 (setq emvrs emvrs-1)
400 ; push new
401 (setq emvrs (append emvrs emvrs-new))
402 (dolist (vr lmenvs)
403 (when (not (assq (car vr) varsvalues-new))
404 (push vr lmenvs-1)))
405 (setq lmenvs (append lmenvs lmenvs-new)))
406
407 ;; Here we do the same letbinding as for let* above
408 ;; to avoid situation when a free variable of a lambda lifted
409 ;; function got redefined.
410
411 (let ((new-lmenv)
412 (var nil)
413 (closedsym nil)
414 (letbinds '())
415 (fvrs-new)) ; list of (closed-var var)
416 (dolist (elm varsvalues)
417 (if (listp elm)
418 (setq var (car elm))
419 (setq var elm))
420
421 (let ((lmenvs-1 lmenvs)) ; just to avoid manipulating
422 (dolist (lmenv lmenvs-1) ; the counter inside the loop
423 (when (memq var (cdr lmenv))
424 (setq closedsym (make-symbol
425 (concat "closed-"
426 (symbol-name var))))
427
428 (setq new-lmenv (list (car lmenv)))
429 (dolist (frv (cdr lmenv)) (if (eq frv var)
430 (push closedsym new-lmenv)
431 (push frv new-lmenv)))
432 (setq new-lmenv (reverse new-lmenv))
433 (setq lmenvs (remq lmenv lmenvs))
434 (push new-lmenv lmenvs)
435 (push `(,closedsym ,var) letbinds)
436 ))))
437 (setq varsvalues-new (append varsvalues-new letbinds))))
438
439 (dolist (elm body-forms) ; convert body forms
440 (push (cconv-closure-convert-rec
441 elm emvrs fvrs envs lmenvs nil)
442 body-forms-new))
443 `(,letsym ,(reverse varsvalues-new) . ,(reverse body-forms-new))))
444 ;end of let let* forms
445
446 ; first element is lambda expression
447 (`(,(and `(lambda . ,_) fun) . ,other-body-forms)
448
449 (let ((other-body-forms-new '()))
450 (dolist (elm other-body-forms)
451 (push (cconv-closure-convert-rec
452 elm emvrs fvrs envs lmenvs nil)
453 other-body-forms-new))
454 (cons
455 (cadr
456 (cconv-closure-convert-rec
457 (list 'function fun) emvrs fvrs envs lmenvs nil))
458 (reverse other-body-forms-new))))
459
460 (`(cond . ,cond-forms) ; cond special form
461 (let ((cond-forms-new '()))
462 (dolist (elm cond-forms)
463 (push (let ((elm-new '()))
464 (dolist (elm-2 elm)
465 (push
466 (cconv-closure-convert-rec
467 elm-2 emvrs fvrs envs lmenvs nil)
468 elm-new))
469 (reverse elm-new))
470 cond-forms-new))
471 (cons 'cond
472 (reverse cond-forms-new))))
473
474 (`(quote . ,_) form) ; quote form
475
476 (`(function . ((lambda ,vars . ,body-forms))) ; function form
477 (let (fvrs-new) ; we remove vars from fvrs
478 (dolist (elm fvrs) ;i use such a tricky way to avoid side effects
479 (when (not (memq elm vars))
480 (push elm fvrs-new)))
481 (setq fvrs fvrs-new))
482 (let* ((fv (delete-dups (cconv-freevars form '())))
483 (leave fvrs) ; leave = non nil if we should leave env unchanged
484 (body-forms-new '())
485 (letbind '())
486 (mv nil)
487 (envector nil))
488 (when fv
489 ;; Here we form our environment vector.
490 ;; If outer closure contains all
491 ;; free variables of this function(and nothing else)
492 ;; then we use the same environment vector as for outer closure,
493 ;; i.e. we leave the environment vector unchanged
494 ;; otherwise we build a new environmet vector
495 (if (eq (length envs) (length fv))
496 (let ((fv-temp fv))
497 (while (and fv-temp leave)
498 (when (not (memq (car fv-temp) fvrs)) (setq leave nil))
499 (setq fv-temp (cdr fv-temp))))
500 (setq leave nil))
501
502 (if (not leave)
503 (progn
504 (dolist (elm fv)
505 (push
506 (cconv-closure-convert-rec
507 elm (remq elm emvrs) fvrs envs lmenvs nil)
508 envector)) ; process vars for closure vector
509 (setq envector (reverse envector))
510 (setq envs fv))
511 (setq envector `(env))) ; leave unchanged
512 (setq fvrs fv)) ; update substitution list
513
514 ;; the difference between envs and fvrs is explained
515 ;; in comment in the beginning of the function
516 (dolist (elm cconv-captured+mutated) ; find mutated arguments
517 (setq mv (car elm)) ; used in inner closures
518 (when (and (memq mv vars) (eq form (caddr elm)))
519 (progn (push mv emvrs)
520 (push `(,mv (list ,mv)) letbind))))
521 (dolist (elm body-forms) ; convert function body
522 (push (cconv-closure-convert-rec
523 elm emvrs fvrs envs lmenvs nil)
524 body-forms-new))
525
526 (setq body-forms-new
527 (if letbind `((let ,letbind . ,(reverse body-forms-new)))
528 (reverse body-forms-new)))
529
530 (cond
531 ;if no freevars - do nothing
532 ((null envector)
533 `(function (lambda ,vars . ,body-forms-new)))
534 ; 1 free variable - do not build vector
535 ((null (cdr envector))
536 `(curry
537 (function (lambda (env . ,vars) . ,body-forms-new))
538 ,(car envector)))
539 ; >=2 free variables - build vector
540 (t
541 `(curry
542 (function (lambda (env . ,vars) . ,body-forms-new))
543 (vector . ,envector))))))
544
545 (`(function . ,_) form) ; same as quote
546
547 ;defconst, defvar
548 (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms)
549
550 (if defs-are-legal
551 (let ((body-forms-new '()))
552 (dolist (elm body-forms)
553 (push (cconv-closure-convert-rec
554 elm emvrs fvrs envs lmenvs nil)
555 body-forms-new))
556 (setq body-forms-new (reverse body-forms-new))
557 `(,sym ,definedsymbol . ,body-forms-new))
558 (error "Invalid form: %s inside a function" sym)))
559
560 ;defun, defmacro, defsubst
561 (`(,(and sym (or `defun `defmacro `defsubst))
562 ,func ,vars . ,body-forms)
563 (if defs-are-legal
564 (let ((body-new '()) ; the whole body
565 (body-forms-new '()) ; body w\o docstring and interactive
566 (letbind '()))
567 ; find mutable arguments
568 (let ((lmutated cconv-captured+mutated) ismutated)
569 (dolist (elm vars)
570 (setq ismutated nil)
571 (while (and lmutated (not ismutated))
572 (when (and (eq (caar lmutated) elm)
573 (eq (cadar lmutated) form))
574 (setq ismutated t))
575 (setq lmutated (cdr lmutated)))
576 (when ismutated
577 (push elm letbind)
578 (push elm emvrs))))
579 ;transform body-forms
580 (when (stringp (car body-forms)) ; treat docstring well
581 (push (car body-forms) body-new)
582 (setq body-forms (cdr body-forms)))
583 (when (and (listp (car body-forms)) ; treat (interactive) well
584 (eq (caar body-forms) 'interactive))
585 (push
586 (cconv-closure-convert-rec
587 (car body-forms)
588 emvrs fvrs envs lmenvs nil) body-new)
589 (setq body-forms (cdr body-forms)))
590
591 (dolist (elm body-forms)
592 (push (cconv-closure-convert-rec
593 elm emvrs fvrs envs lmenvs nil)
594 body-forms-new))
595 (setq body-forms-new (reverse body-forms-new))
596
597 (if letbind
598 ; letbind mutable arguments
599 (let ((varsvalues-new '()))
600 (dolist (elm letbind) (push `(,elm (list ,elm))
601 varsvalues-new))
602 (push `(let ,(reverse varsvalues-new) .
603 ,body-forms-new) body-new)
604 (setq body-new (reverse body-new)))
605 (setq body-new (append (reverse body-new) body-forms-new)))
606
607 `(,sym ,func ,vars . ,body-new))
608
609 (error "Invalid form: defun inside a function")))
610 ;condition-case
611 (`(condition-case ,var ,protected-form . ,conditions-bodies)
612 (let ((conditions-bodies-new '()))
613 (setq fvrs (remq var fvrs))
614 (dolist (elm conditions-bodies)
615 (push (let ((elm-new '()))
616 (dolist (elm-2 (cdr elm))
617 (push
618 (cconv-closure-convert-rec
619 elm-2 emvrs fvrs envs lmenvs nil)
620 elm-new))
621 (cons (car elm) (reverse elm-new)))
622 conditions-bodies-new))
623 `(condition-case
624 ,var
625 ,(cconv-closure-convert-rec
626 protected-form emvrs fvrs envs lmenvs nil)
627 . ,(reverse conditions-bodies-new))))
628
629 (`(setq . ,forms) ; setq special form
630 (let (prognlist sym sym-new value)
631 (while forms
632 (setq sym (car forms))
633 (setq sym-new (cconv-closure-convert-rec
634 sym
635 (remq sym emvrs) fvrs envs lmenvs nil))
636 (setq value
637 (cconv-closure-convert-rec
638 (cadr forms) emvrs fvrs envs lmenvs nil))
639 (if (memq sym emvrs)
640 (push `(setcar ,sym-new ,value) prognlist)
641 (if (symbolp sym-new)
642 (push `(setq ,sym-new ,value) prognlist)
643 (push `(set ,sym-new ,value) prognlist)))
644 (setq forms (cddr forms)))
645 (if (cdr prognlist)
646 `(progn . ,(reverse prognlist))
647 (car prognlist))))
648
649 (`(,(and (or `funcall `apply) callsym) ,fun . ,args)
650 ; funcall is not a special form
651 ; but we treat it separately
652 ; for the needs of lambda lifting
653 (let ((fv (cdr (assq fun lmenvs))))
654 (if fv
655 (let ((args-new '())
656 (processed-fv '()))
657 ;; All args (free variables and actual arguments)
658 ;; should be processed, because they can be fvrs
659 ;; (free variables of another closure)
660 (dolist (fvr fv)
661 (push (cconv-closure-convert-rec
662 fvr (remq fvr emvrs)
663 fvrs envs lmenvs nil)
664 processed-fv))
665 (setq processed-fv (reverse processed-fv))
666 (dolist (elm args)
667 (push (cconv-closure-convert-rec
668 elm emvrs fvrs envs lmenvs nil)
669 args-new))
670 (setq args-new (append processed-fv (reverse args-new)))
671 (setq fun (cconv-closure-convert-rec
672 fun emvrs fvrs envs lmenvs nil))
673 `(,callsym ,fun . ,args-new))
674 (let ((cdr-new '()))
675 (dolist (elm (cdr form))
676 (push (cconv-closure-convert-rec
677 elm emvrs fvrs envs lmenvs nil)
678 cdr-new))
679 `(,callsym . ,(reverse cdr-new))))))
680
681 (`(,func . ,body-forms) ; first element is function or whatever
682 ; function-like forms are:
683 ; or, and, if, progn, prog1, prog2,
684 ; while, until
685 (let ((body-forms-new '()))
686 (dolist (elm body-forms)
687 (push (cconv-closure-convert-rec
688 elm emvrs fvrs envs lmenvs defs-are-legal)
689 body-forms-new))
690 (setq body-forms-new (reverse body-forms-new))
691 `(,func . ,body-forms-new)))
692
693 (_
694 (if (memq form fvrs) ;form is a free variable
695 (let* ((numero (position form envs))
696 (var '()))
697 (assert numero)
698 (if (null (cdr envs))
699 (setq var 'env)
700 ;replace form =>
701 ;(aref env #)
702 (setq var `(aref env ,numero)))
703 (if (memq form emvrs) ; form => (car (aref env #)) if mutable
704 `(car ,var)
705 var))
706 (if (memq form emvrs) ; if form is a mutable variable
707 `(car ,form) ; replace form => (car form)
708 form)))))
709
710 (defun cconv-analyse-form (form vars inclosure)
711
712 "Find mutated variables and variables captured by closure. Analyse
713 lambdas if they are suitable for lambda lifting.
714 -- FORM is a piece of Elisp code after macroexpansion.
715 -- MLCVRS is a structure that contains captured and mutated variables.
716 (first MLCVRS) is a list of mutated variables, (second MLCVRS) is a
717 list of candidates for lambda lifting and (third MLCVRS) is a list of
718 variables captured by closure. It should be (nil nil nil) initially.
719 -- VARS is a list of local variables visible in current environment
720 (initially empty).
721 -- INCLOSURE is a boolean variable, true if we are in closure.
722 Initially false"
723 (pcase form
724 ; let special form
725 (`(,(and (or `let* `let) letsym) ,varsvalues . ,body-forms)
726
727 (when (eq letsym 'let)
728 (dolist (elm varsvalues) ; analyse values
729 (when (listp elm)
730 (cconv-analyse-form (cadr elm) vars inclosure))))
731
732 (let ((v nil)
733 (var nil)
734 (value nil)
735 (varstruct nil))
736 (dolist (elm varsvalues)
737 (if (listp elm)
738 (progn
739 (setq var (car elm))
740 (setq value (cadr elm)))
741 (progn
742 (setq var elm) ; treat the form (let (x) ...) well
743 (setq value nil)))
744
745 (when (eq letsym 'let*) ; analyse value
746 (cconv-analyse-form value vars inclosure))
747
748 (let (vars-new) ; remove the old var
749 (dolist (vr vars)
750 (when (not (eq (car vr) var))
751 (push vr vars-new)))
752 (setq vars vars-new))
753
754 (setq varstruct (list var inclosure elm form))
755 (push varstruct vars) ; push a new one
756
757 (when (and (listp value)
758 (eq (car value) 'function)
759 (eq (caadr value) 'lambda))
760 ; if var is a function
761 ; push it to lambda list
762 (push varstruct cconv-lambda-candidates))))
763
764 (dolist (elm body-forms) ; analyse body forms
765 (cconv-analyse-form elm vars inclosure))
766 nil)
767 ; defun special form
768 (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
769 (let ((v nil))
770 (dolist (vr vrs)
771 (push (list vr form) vars))) ;push vrs to vars
772 (dolist (elm body-forms) ; analyse body forms
773 (cconv-analyse-form elm vars inclosure))
774 nil)
775
776 (`(function . ((lambda ,vrs . ,body-forms)))
777 (if inclosure ;we are in closure
778 (setq inclosure (+ inclosure 1))
779 (setq inclosure 1))
780 (let (vars-new) ; update vars
781 (dolist (vr vars) ; we do that in such a tricky way
782 (when (not (memq (car vr) vrs)) ; to avoid side effects
783 (push vr vars-new)))
784 (dolist (vr vrs)
785 (push (list vr inclosure form) vars-new))
786 (setq vars vars-new))
787
788 (dolist (elm body-forms)
789 (cconv-analyse-form elm vars inclosure))
790 nil)
791
792 (`(setq . ,forms) ; setq
793 ; if a local variable (member of vars)
794 ; is modified by setq
795 ; then it is a mutated variable
796 (while forms
797 (let ((v (assq (car forms) vars))) ; v = non nil if visible
798 (when v
799 (push v cconv-mutated)
800 ;; delete from candidate list for lambda lifting
801 (setq cconv-lambda-candidates (delq v cconv-lambda-candidates))
802 (when inclosure
803 ;; test if v is declared as argument for lambda
804 (let* ((thirdv (third v))
805 (isarg (if (listp thirdv)
806 (eq (car thirdv) 'function) nil)))
807 (if isarg
808 (when (> inclosure (cadr v)) ; when we are in closure
809 (push v cconv-captured)) ; push it to captured vars
810 ;; FIXME more detailed comments needed
811 (push v cconv-captured))))))
812 (cconv-analyse-form (cadr forms) vars inclosure)
813 (setq forms (cddr forms)))
814 nil)
815
816 (`((lambda . ,_) . ,_) ; first element is lambda expression
817 (dolist (exp `((function ,(car form)) . ,(cdr form)))
818 (cconv-analyse-form exp vars inclosure))
819 nil)
820
821 (`(cond . ,cond-forms) ; cond special form
822 (dolist (exp1 cond-forms)
823 (dolist (exp2 exp1)
824 (cconv-analyse-form exp2 vars inclosure)))
825 nil)
826
827 (`(quote . ,_) nil) ; quote form
828
829 (`(function . ,_) nil) ; same as quote
830
831 (`(condition-case ,var ,protected-form . ,conditions-bodies)
832 ;condition-case
833 (cconv-analyse-form protected-form vars inclosure)
834 (dolist (exp conditions-bodies)
835 (cconv-analyse-form (cadr exp) vars inclosure))
836 nil)
837
838 (`(,(or `defconst `defvar `defsubst) ,value)
839 (cconv-analyse-form value vars inclosure))
840
841 (`(,(or `funcall `apply) ,fun . ,args)
842 ;; Here we ignore fun because
843 ;; funcall and apply are the only two
844 ;; functions where we can pass a candidate
845 ;; for lambda lifting as argument.
846 ;; So, if we see fun elsewhere, we'll
847 ;; delete it from lambda candidate list.
848
849 ;; If this funcall and the definition of fun
850 ;; are in different closures - we delete fun from
851 ;; canidate list, because it is too complicated
852 ;; to manage free variables in this case.
853 (let ((lv (assq fun cconv-lambda-candidates)))
854 (when lv
855 (when (not (eq (cadr lv) inclosure))
856 (setq cconv-lambda-candidates
857 (delq lv cconv-lambda-candidates)))))
858
859 (dolist (elm args)
860 (cconv-analyse-form elm vars inclosure))
861 nil)
862
863 (`(,_ . ,body-forms) ; first element is a function or whatever
864 (dolist (exp body-forms)
865 (cconv-analyse-form exp vars inclosure))
866 nil)
867
868 (_
869 (when (and (symbolp form)
870 (not (memq form '(nil t)))
871 (not (keywordp form))
872 (not (special-variable-p form)))
873 (let ((dv (assq form vars))) ; dv = declared and visible
874 (when dv
875 (when inclosure
876 ;; test if v is declared as argument of lambda
877 (let* ((thirddv (third dv))
878 (isarg (if (listp thirddv)
879 (eq (car thirddv) 'function) nil)))
880 (if isarg
881 ;; FIXME add detailed comments
882 (when (> inclosure (cadr dv)) ; capturing condition
883 (push dv cconv-captured))
884 (push dv cconv-captured))))
885 ; delete lambda
886 (setq cconv-lambda-candidates ; if it is found here
887 (delq dv cconv-lambda-candidates)))))
888 nil)))
889
890 (provide 'cconv)
891 ;;; cconv.el ends here
Unnamed repository; edit this file 'description' to name the repository.