| 1 | ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: nil -*- |
| 2 | |
| 3 | ;; Copyright (C) 2011 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> |
| 6 | ;; Maintainer: FSF |
| 7 | ;; Keywords: lisp |
| 8 | ;; Package: emacs |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 13 | ;; it under the terms of the GNU General Public License as published by |
| 14 | ;; the Free Software Foundation, either version 3 of the License, or |
| 15 | ;; (at your option) any later version. |
| 16 | |
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;; GNU General Public License for more details. |
| 21 | |
| 22 | ;; You should have received a copy of the GNU General Public License |
| 23 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;; This takes a piece of Elisp code, and eliminates all free variables from |
| 28 | ;; lambda expressions. The user entry points are cconv-closure-convert and |
| 29 | ;; cconv-closure-convert-toplevel(for toplevel forms). |
| 30 | ;; All macros should be expanded beforehand. |
| 31 | ;; |
| 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. |
| 37 | ;; |
| 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 |
| 40 | ;; closure. |
| 41 | |
| 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. |
| 45 | ;; |
| 46 | ;; We do following replacements : |
| 47 | ;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) |
| 48 | ;; if the function is suitable for lambda lifting (if all calls are known) |
| 49 | ;; |
| 50 | ;; (lambda (v1 ...) ... fv ...) => |
| 51 | ;; (curry (lambda (env v1 ...) ... env ...) env) |
| 52 | ;; if the function has only 1 free variable |
| 53 | ;; |
| 54 | ;; and finally |
| 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. |
| 58 | ;; |
| 59 | ;; If the function has no free variables, we don't do anything. |
| 60 | ;; |
| 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. |
| 65 | ;; |
| 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))) ...)) |
| 70 | ;; |
| 71 | ;;; Code: |
| 72 | |
| 73 | (eval-when-compile (require 'cl)) |
| 74 | |
| 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).") |
| 87 | |
| 88 | (defun cconv-freevars (form &optional fvrs) |
| 89 | "Find all free variables of given form. |
| 90 | Arguments: |
| 91 | -- FORM is a piece of Elisp code after macroexpansion. |
| 92 | -- FVRS(optional) is a list of variables already found. Used for recursive tree |
| 93 | traversal |
| 94 | |
| 95 | Returns a list of free variables." |
| 96 | ;; If a leaf in the tree is a symbol, but it is not a global variable, not a |
| 97 | ;; keyword, not 'nil or 't we consider this leaf as a variable. |
| 98 | ;; Free variables are the variables that are not declared above in this tree. |
| 99 | ;; For example free variables of (lambda (a1 a2 ..) body-forms) are |
| 100 | ;; free variables of body-forms excluding a1, a2 .. |
| 101 | ;; Free variables of (let ((v1 ..) (v2) ..)) body-forms) are |
| 102 | ;; free variables of body-forms excluding v1, v2 ... |
| 103 | ;; and so on. |
| 104 | |
| 105 | ;; A list of free variables already found(FVRS) is passed in parameter |
| 106 | ;; to try to use cons or push where possible, and to minimize the usage |
| 107 | ;; of append. |
| 108 | |
| 109 | ;; This function can return duplicates (because we use 'append instead |
| 110 | ;; of union of two sets - for performance reasons). |
| 111 | (pcase form |
| 112 | (`(let ,varsvalues . ,body-forms) ; let special form |
| 113 | (let ((fvrs-1 '())) |
| 114 | (dolist (exp body-forms) |
| 115 | (setq fvrs-1 (cconv-freevars exp fvrs-1))) |
| 116 | (dolist (elm varsvalues) |
| 117 | (setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1))) |
| 118 | (setq fvrs (nconc fvrs-1 fvrs)) |
| 119 | (dolist (exp varsvalues) |
| 120 | (when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs)))) |
| 121 | fvrs)) |
| 122 | |
| 123 | (`(let* ,varsvalues . ,body-forms) ; let* special form |
| 124 | (let ((vrs '()) |
| 125 | (fvrs-1 '())) |
| 126 | (dolist (exp varsvalues) |
| 127 | (if (consp exp) |
| 128 | (progn |
| 129 | (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)) |
| 130 | (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) |
| 131 | (push (car exp) vrs)) |
| 132 | (progn |
| 133 | (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) |
| 134 | (push exp vrs)))) |
| 135 | (dolist (exp body-forms) |
| 136 | (setq fvrs-1 (cconv-freevars exp fvrs-1))) |
| 137 | (dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1))) |
| 138 | (append fvrs fvrs-1))) |
| 139 | |
| 140 | (`((lambda . ,_) . ,_) ; first element is lambda expression |
| 141 | (dolist (exp `((function ,(car form)) . ,(cdr form))) |
| 142 | (setq fvrs (cconv-freevars exp fvrs))) fvrs) |
| 143 | |
| 144 | (`(cond . ,cond-forms) ; cond special form |
| 145 | (dolist (exp1 cond-forms) |
| 146 | (dolist (exp2 exp1) |
| 147 | (setq fvrs (cconv-freevars exp2 fvrs)))) fvrs) |
| 148 | |
| 149 | (`(quote . ,_) fvrs) ; quote form |
| 150 | |
| 151 | (`(function . ((lambda ,vars . ,body-forms))) |
| 152 | (let ((functionform (cadr form)) (fvrs-1 '())) |
| 153 | (dolist (exp body-forms) |
| 154 | (setq fvrs-1 (cconv-freevars exp fvrs-1))) |
| 155 | (dolist (elm vars) (setq fvrs-1 (delq elm fvrs-1))) |
| 156 | (append fvrs fvrs-1))) ; function form |
| 157 | |
| 158 | (`(function . ,_) fvrs) ; same as quote |
| 159 | ;condition-case |
| 160 | (`(condition-case ,var ,protected-form . ,conditions-bodies) |
| 161 | (let ((fvrs-1 '())) |
| 162 | (dolist (exp conditions-bodies) |
| 163 | (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))) |
| 164 | (setq fvrs-1 (delq var fvrs-1)) |
| 165 | (setq fvrs-1 (cconv-freevars protected-form fvrs-1)) |
| 166 | (append fvrs fvrs-1))) |
| 167 | |
| 168 | (`(,(and sym (or `defun `defconst `defvar)) . ,_) |
| 169 | ;; We call cconv-freevars only for functions(lambdas) |
| 170 | ;; defun, defconst, defvar are not allowed to be inside |
| 171 | ;; a function (lambda). |
| 172 | ;; FIXME: should be a byte-compile-report-error! |
| 173 | (error "Invalid form: %s inside a function" sym)) |
| 174 | |
| 175 | (`(,_ . ,body-forms) ; First element is (like) a function. |
| 176 | (dolist (exp body-forms) |
| 177 | (setq fvrs (cconv-freevars exp fvrs))) fvrs) |
| 178 | |
| 179 | (_ (if (byte-compile-not-lexical-var-p form) |
| 180 | fvrs |
| 181 | (cons form fvrs))))) |
| 182 | |
| 183 | ;;;###autoload |
| 184 | (defun cconv-closure-convert (form) |
| 185 | "Main entry point for closure conversion. |
| 186 | -- FORM is a piece of Elisp code after macroexpansion. |
| 187 | -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST |
| 188 | |
| 189 | Returns a form where all lambdas don't have any free variables." |
| 190 | (message "Entering cconv-closure-convert...") |
| 191 | (let ((cconv-mutated '()) |
| 192 | (cconv-lambda-candidates '()) |
| 193 | (cconv-captured '()) |
| 194 | (cconv-captured+mutated '())) |
| 195 | ;; Analyse form - fill these variables with new information |
| 196 | (cconv-analyse-form form '() 0) |
| 197 | ;; Calculate an intersection of cconv-mutated and cconv-captured |
| 198 | (dolist (mvr cconv-mutated) |
| 199 | (when (memq mvr cconv-captured) ; |
| 200 | (push mvr cconv-captured+mutated))) |
| 201 | (cconv-closure-convert-rec |
| 202 | form ; the tree |
| 203 | '() ; |
| 204 | '() ; fvrs initially empty |
| 205 | '() ; envs initially empty |
| 206 | '() |
| 207 | ))) |
| 208 | |
| 209 | (defun cconv-lookup-let (table var binder form) |
| 210 | (let ((res nil)) |
| 211 | (dolist (elem table) |
| 212 | (when (and (eq (nth 2 elem) binder) |
| 213 | (eq (nth 3 elem) form)) |
| 214 | (assert (eq (car elem) var)) |
| 215 | (setq res elem))) |
| 216 | res)) |
| 217 | |
| 218 | (defconst cconv--dummy-var (make-symbol "ignored")) |
| 219 | |
| 220 | (defun cconv-closure-convert-rec |
| 221 | (form emvrs fvrs envs lmenvs) |
| 222 | ;; This function actually rewrites the tree. |
| 223 | "Eliminates all free variables of all lambdas in given forms. |
| 224 | Arguments: |
| 225 | -- FORM is a piece of Elisp code after macroexpansion. |
| 226 | -- LMENVS is a list of environments used for lambda-lifting. Initially empty. |
| 227 | -- EMVRS is a list that contains mutated variables that are visible |
| 228 | within current environment. |
| 229 | -- ENVS is an environment(list of free variables) of current closure. |
| 230 | Initially empty. |
| 231 | -- FVRS is a list of variables to substitute in each context. |
| 232 | Initially empty. |
| 233 | |
| 234 | Returns a form where all lambdas don't have any free variables." |
| 235 | ;; What's the difference between fvrs and envs? |
| 236 | ;; Suppose that we have the code |
| 237 | ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) |
| 238 | ;; only the first occurrence of fvr should be replaced by |
| 239 | ;; (aref env ...). |
| 240 | ;; So initially envs and fvrs are the same thing, but when we descend to |
| 241 | ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? |
| 242 | ;; Because in envs the order of variables is important. We use this list |
| 243 | ;; to find the number of a specific variable in the environment vector, |
| 244 | ;; so we never touch it(unless we enter to the other closure). |
| 245 | ;;(if (listp form) (print (car form)) form) |
| 246 | (pcase form |
| 247 | (`(,(and letsym (or `let* `let)) ,binders . ,body-forms) |
| 248 | |
| 249 | ; let and let* special forms |
| 250 | (let ((body-forms-new '()) |
| 251 | (binders-new '()) |
| 252 | ;; next for variables needed for delayed push |
| 253 | ;; because we should process <value(s)> |
| 254 | ;; before we change any arguments |
| 255 | (lmenvs-new '()) ;needed only in case of let |
| 256 | (emvrs-new '()) ;needed only in case of let |
| 257 | (emvr-push) ;needed only in case of let* |
| 258 | (lmenv-push)) ;needed only in case of let* |
| 259 | |
| 260 | (dolist (binder binders) |
| 261 | (let* ((value nil) |
| 262 | (var (if (not (consp binder)) |
| 263 | binder |
| 264 | (setq value (cadr binder)) |
| 265 | (car binder))) |
| 266 | (new-val |
| 267 | (cond |
| 268 | ;; Check if var is a candidate for lambda lifting. |
| 269 | ((cconv-lookup-let cconv-lambda-candidates var binder form) |
| 270 | |
| 271 | (let* ((fv (delete-dups (cconv-freevars value '()))) |
| 272 | (funargs (cadr (cadr value))) |
| 273 | (funcvars (append fv funargs)) |
| 274 | (funcbodies (cddadr value)) ; function bodies |
| 275 | (funcbodies-new '())) |
| 276 | ; lambda lifting condition |
| 277 | (if (or (not fv) (< cconv-liftwhen (length funcvars))) |
| 278 | ; do not lift |
| 279 | (cconv-closure-convert-rec |
| 280 | value emvrs fvrs envs lmenvs) |
| 281 | ; lift |
| 282 | (progn |
| 283 | (dolist (elm2 funcbodies) |
| 284 | (push ; convert function bodies |
| 285 | (cconv-closure-convert-rec |
| 286 | elm2 emvrs nil envs lmenvs) |
| 287 | funcbodies-new)) |
| 288 | (if (eq letsym 'let*) |
| 289 | (setq lmenv-push (cons var fv)) |
| 290 | (push (cons var fv) lmenvs-new)) |
| 291 | ; push lifted function |
| 292 | |
| 293 | `(function . |
| 294 | ((lambda ,funcvars . |
| 295 | ,(reverse funcbodies-new)))))))) |
| 296 | |
| 297 | ;; Check if it needs to be turned into a "ref-cell". |
| 298 | ((cconv-lookup-let cconv-captured+mutated var binder form) |
| 299 | ;; Declared variable is mutated and captured. |
| 300 | (prog1 |
| 301 | `(list ,(cconv-closure-convert-rec |
| 302 | value emvrs |
| 303 | fvrs envs lmenvs)) |
| 304 | (if (eq letsym 'let*) |
| 305 | (setq emvr-push var) |
| 306 | (push var emvrs-new)))) |
| 307 | |
| 308 | ;; Normal default case. |
| 309 | (t |
| 310 | (cconv-closure-convert-rec |
| 311 | value emvrs fvrs envs lmenvs))))) |
| 312 | |
| 313 | ;; this piece of code below letbinds free |
| 314 | ;; variables of a lambda lifted function |
| 315 | ;; if they are redefined in this let |
| 316 | ;; example: |
| 317 | ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) |
| 318 | ;; Here we can not pass y as parameter because it is |
| 319 | ;; redefined. We add a (closed-y y) declaration. |
| 320 | ;; We do that even if the function is not used inside |
| 321 | ;; this let(*). The reason why we ignore this case is |
| 322 | ;; that we can't "look forward" to see if the function |
| 323 | ;; is called there or not. To treat well this case we |
| 324 | ;; need to traverse the tree one more time to collect this |
| 325 | ;; data, and I think that it's not worth it. |
| 326 | |
| 327 | (when (eq letsym 'let*) |
| 328 | (let ((closedsym '()) |
| 329 | (new-lmenv '()) |
| 330 | (old-lmenv '())) |
| 331 | (dolist (lmenv lmenvs) |
| 332 | (when (memq var (cdr lmenv)) |
| 333 | (setq closedsym |
| 334 | (make-symbol |
| 335 | (concat "closed-" (symbol-name var)))) |
| 336 | (setq new-lmenv (list (car lmenv))) |
| 337 | (dolist (frv (cdr lmenv)) (if (eq frv var) |
| 338 | (push closedsym new-lmenv) |
| 339 | (push frv new-lmenv))) |
| 340 | (setq new-lmenv (reverse new-lmenv)) |
| 341 | (setq old-lmenv lmenv))) |
| 342 | (when new-lmenv |
| 343 | (setq lmenvs (remq old-lmenv lmenvs)) |
| 344 | (push new-lmenv lmenvs) |
| 345 | (push `(,closedsym ,var) binders-new)))) |
| 346 | ;; we push the element after redefined free variables |
| 347 | ;; are processes. this is important to avoid the bug |
| 348 | ;; when free variable and the function have the same |
| 349 | ;; name |
| 350 | (push (list var new-val) binders-new) |
| 351 | |
| 352 | (when (eq letsym 'let*) ; update fvrs |
| 353 | (setq fvrs (remq var fvrs)) |
| 354 | (setq emvrs (remq var emvrs)) ; remove if redefined |
| 355 | (when emvr-push |
| 356 | (push emvr-push emvrs) |
| 357 | (setq emvr-push nil)) |
| 358 | (let (lmenvs-1) ; remove var from lmenvs if redefined |
| 359 | (dolist (iter lmenvs) |
| 360 | (when (not (assq var lmenvs)) |
| 361 | (push iter lmenvs-1))) |
| 362 | (setq lmenvs lmenvs-1)) |
| 363 | (when lmenv-push |
| 364 | (push lmenv-push lmenvs) |
| 365 | (setq lmenv-push nil))) |
| 366 | )) ; end of dolist over binders |
| 367 | (when (eq letsym 'let) |
| 368 | |
| 369 | (let (var fvrs-1 emvrs-1 lmenvs-1) |
| 370 | ;; Here we update emvrs, fvrs and lmenvs lists |
| 371 | (dolist (vr fvrs) |
| 372 | ; safely remove |
| 373 | (when (not (assq vr binders-new)) (push vr fvrs-1))) |
| 374 | (setq fvrs fvrs-1) |
| 375 | (dolist (vr emvrs) |
| 376 | ; safely remove |
| 377 | (when (not (assq vr binders-new)) (push vr emvrs-1))) |
| 378 | (setq emvrs emvrs-1) |
| 379 | ; push new |
| 380 | (setq emvrs (append emvrs emvrs-new)) |
| 381 | (dolist (vr lmenvs) |
| 382 | (when (not (assq (car vr) binders-new)) |
| 383 | (push vr lmenvs-1))) |
| 384 | (setq lmenvs (append lmenvs lmenvs-new))) |
| 385 | |
| 386 | ;; Here we do the same letbinding as for let* above |
| 387 | ;; to avoid situation when a free variable of a lambda lifted |
| 388 | ;; function got redefined. |
| 389 | |
| 390 | (let ((new-lmenv) |
| 391 | (var nil) |
| 392 | (closedsym nil) |
| 393 | (letbinds '())) |
| 394 | (dolist (binder binders) |
| 395 | (setq var (if (consp binder) (car binder) binder)) |
| 396 | |
| 397 | (let ((lmenvs-1 lmenvs)) ; just to avoid manipulating |
| 398 | (dolist (lmenv lmenvs-1) ; the counter inside the loop |
| 399 | (when (memq var (cdr lmenv)) |
| 400 | (setq closedsym (make-symbol |
| 401 | (concat "closed-" |
| 402 | (symbol-name var)))) |
| 403 | |
| 404 | (setq new-lmenv (list (car lmenv))) |
| 405 | (dolist (frv (cdr lmenv)) (if (eq frv var) |
| 406 | (push closedsym new-lmenv) |
| 407 | (push frv new-lmenv))) |
| 408 | (setq new-lmenv (reverse new-lmenv)) |
| 409 | (setq lmenvs (remq lmenv lmenvs)) |
| 410 | (push new-lmenv lmenvs) |
| 411 | (push `(,closedsym ,var) letbinds) |
| 412 | )))) |
| 413 | (setq binders-new (append binders-new letbinds)))) |
| 414 | |
| 415 | (dolist (elm body-forms) ; convert body forms |
| 416 | (push (cconv-closure-convert-rec |
| 417 | elm emvrs fvrs envs lmenvs) |
| 418 | body-forms-new)) |
| 419 | `(,letsym ,(reverse binders-new) . ,(reverse body-forms-new)))) |
| 420 | ;end of let let* forms |
| 421 | |
| 422 | ; first element is lambda expression |
| 423 | (`(,(and `(lambda . ,_) fun) . ,other-body-forms) |
| 424 | |
| 425 | (let ((other-body-forms-new '())) |
| 426 | (dolist (elm other-body-forms) |
| 427 | (push (cconv-closure-convert-rec |
| 428 | elm emvrs fvrs envs lmenvs) |
| 429 | other-body-forms-new)) |
| 430 | `(funcall |
| 431 | ,(cconv-closure-convert-rec |
| 432 | (list 'function fun) emvrs fvrs envs lmenvs) |
| 433 | ,@(nreverse other-body-forms-new)))) |
| 434 | |
| 435 | (`(cond . ,cond-forms) ; cond special form |
| 436 | (let ((cond-forms-new '())) |
| 437 | (dolist (elm cond-forms) |
| 438 | (push (let ((elm-new '())) |
| 439 | (dolist (elm-2 elm) |
| 440 | (push |
| 441 | (cconv-closure-convert-rec |
| 442 | elm-2 emvrs fvrs envs lmenvs) |
| 443 | elm-new)) |
| 444 | (reverse elm-new)) |
| 445 | cond-forms-new)) |
| 446 | (cons 'cond |
| 447 | (reverse cond-forms-new)))) |
| 448 | |
| 449 | (`(quote . ,_) form) ; quote form |
| 450 | |
| 451 | (`(function . ((lambda ,vars . ,body-forms))) ; function form |
| 452 | (let (fvrs-new) ; we remove vars from fvrs |
| 453 | (dolist (elm fvrs) ;i use such a tricky way to avoid side effects |
| 454 | (when (not (memq elm vars)) |
| 455 | (push elm fvrs-new))) |
| 456 | (setq fvrs fvrs-new)) |
| 457 | (let* ((fv (delete-dups (cconv-freevars form '()))) |
| 458 | (leave fvrs) ; leave = non nil if we should leave env unchanged |
| 459 | (body-forms-new '()) |
| 460 | (letbind '()) |
| 461 | (mv nil) |
| 462 | (envector nil)) |
| 463 | (when fv |
| 464 | ;; Here we form our environment vector. |
| 465 | ;; If outer closure contains all |
| 466 | ;; free variables of this function(and nothing else) |
| 467 | ;; then we use the same environment vector as for outer closure, |
| 468 | ;; i.e. we leave the environment vector unchanged |
| 469 | ;; otherwise we build a new environmet vector |
| 470 | (if (eq (length envs) (length fv)) |
| 471 | (let ((fv-temp fv)) |
| 472 | (while (and fv-temp leave) |
| 473 | (when (not (memq (car fv-temp) fvrs)) (setq leave nil)) |
| 474 | (setq fv-temp (cdr fv-temp)))) |
| 475 | (setq leave nil)) |
| 476 | |
| 477 | (if (not leave) |
| 478 | (progn |
| 479 | (dolist (elm fv) |
| 480 | (push |
| 481 | (cconv-closure-convert-rec |
| 482 | elm (remq elm emvrs) fvrs envs lmenvs) |
| 483 | envector)) ; process vars for closure vector |
| 484 | (setq envector (reverse envector)) |
| 485 | (setq envs fv)) |
| 486 | (setq envector `(env))) ; leave unchanged |
| 487 | (setq fvrs fv)) ; update substitution list |
| 488 | |
| 489 | ;; the difference between envs and fvrs is explained |
| 490 | ;; in comment in the beginning of the function |
| 491 | (dolist (elm cconv-captured+mutated) ; find mutated arguments |
| 492 | (setq mv (car elm)) ; used in inner closures |
| 493 | (when (and (memq mv vars) (eq form (caddr elm))) |
| 494 | (progn (push mv emvrs) |
| 495 | (push `(,mv (list ,mv)) letbind)))) |
| 496 | (dolist (elm body-forms) ; convert function body |
| 497 | (push (cconv-closure-convert-rec |
| 498 | elm emvrs fvrs envs lmenvs) |
| 499 | body-forms-new)) |
| 500 | |
| 501 | (setq body-forms-new |
| 502 | (if letbind `((let ,letbind . ,(reverse body-forms-new))) |
| 503 | (reverse body-forms-new))) |
| 504 | |
| 505 | (cond |
| 506 | ;if no freevars - do nothing |
| 507 | ((null envector) |
| 508 | `(function (lambda ,vars . ,body-forms-new))) |
| 509 | ; 1 free variable - do not build vector |
| 510 | ((null (cdr envector)) |
| 511 | `(curry |
| 512 | (function (lambda (env . ,vars) . ,body-forms-new)) |
| 513 | ,(car envector))) |
| 514 | ; >=2 free variables - build vector |
| 515 | (t |
| 516 | `(curry |
| 517 | (function (lambda (env . ,vars) . ,body-forms-new)) |
| 518 | (vector . ,envector)))))) |
| 519 | |
| 520 | (`(function . ,_) form) ; same as quote |
| 521 | |
| 522 | ;defconst, defvar |
| 523 | (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms) |
| 524 | |
| 525 | (let ((body-forms-new '())) |
| 526 | (dolist (elm body-forms) |
| 527 | (push (cconv-closure-convert-rec |
| 528 | elm emvrs fvrs envs lmenvs) |
| 529 | body-forms-new)) |
| 530 | (setq body-forms-new (reverse body-forms-new)) |
| 531 | `(,sym ,definedsymbol . ,body-forms-new))) |
| 532 | |
| 533 | ;defun, defmacro |
| 534 | (`(,(and sym (or `defun `defmacro)) |
| 535 | ,func ,vars . ,body-forms) |
| 536 | (let ((body-new '()) ; the whole body |
| 537 | (body-forms-new '()) ; body w\o docstring and interactive |
| 538 | (letbind '())) |
| 539 | ; find mutable arguments |
| 540 | (let ((lmutated cconv-captured+mutated) ismutated) |
| 541 | (dolist (elm vars) |
| 542 | (setq ismutated nil) |
| 543 | (while (and lmutated (not ismutated)) |
| 544 | (when (and (eq (caar lmutated) elm) |
| 545 | (eq (cadar lmutated) form)) |
| 546 | (setq ismutated t)) |
| 547 | (setq lmutated (cdr lmutated))) |
| 548 | (when ismutated |
| 549 | (push elm letbind) |
| 550 | (push elm emvrs)))) |
| 551 | ;transform body-forms |
| 552 | (when (stringp (car body-forms)) ; treat docstring well |
| 553 | (push (car body-forms) body-new) |
| 554 | (setq body-forms (cdr body-forms))) |
| 555 | (when (eq (car-safe (car body-forms)) 'interactive) |
| 556 | (push (cconv-closure-convert-rec |
| 557 | (car body-forms) |
| 558 | emvrs fvrs envs lmenvs) |
| 559 | body-new) |
| 560 | (setq body-forms (cdr body-forms))) |
| 561 | |
| 562 | (dolist (elm body-forms) |
| 563 | (push (cconv-closure-convert-rec |
| 564 | elm emvrs fvrs envs lmenvs) |
| 565 | body-forms-new)) |
| 566 | (setq body-forms-new (reverse body-forms-new)) |
| 567 | |
| 568 | (if letbind |
| 569 | ; letbind mutable arguments |
| 570 | (let ((binders-new '())) |
| 571 | (dolist (elm letbind) (push `(,elm (list ,elm)) |
| 572 | binders-new)) |
| 573 | (push `(let ,(reverse binders-new) . |
| 574 | ,body-forms-new) body-new) |
| 575 | (setq body-new (reverse body-new))) |
| 576 | (setq body-new (append (reverse body-new) body-forms-new))) |
| 577 | |
| 578 | `(,sym ,func ,vars . ,body-new))) |
| 579 | |
| 580 | ;condition-case |
| 581 | (`(condition-case ,var ,protected-form . ,handlers) |
| 582 | (let ((handlers-new '()) |
| 583 | (newform (cconv-closure-convert-rec |
| 584 | `(function (lambda () ,protected-form)) |
| 585 | emvrs fvrs envs lmenvs))) |
| 586 | (setq fvrs (remq var fvrs)) |
| 587 | (dolist (handler handlers) |
| 588 | (push (list (car handler) |
| 589 | (cconv-closure-convert-rec |
| 590 | `(function (lambda (,(or var cconv--dummy-var)) |
| 591 | ,@(cdr handler))) |
| 592 | emvrs fvrs envs lmenvs)) |
| 593 | handlers-new)) |
| 594 | `(condition-case :fun-body ,newform |
| 595 | ,@(nreverse handlers-new)))) |
| 596 | |
| 597 | (`(,(and head (or `catch `unwind-protect)) ,form . ,body) |
| 598 | `(,head ,(cconv-closure-convert-rec form emvrs fvrs envs lmenvs) |
| 599 | :fun-body |
| 600 | ,(cconv-closure-convert-rec `(function (lambda () ,@body)) |
| 601 | emvrs fvrs envs lmenvs))) |
| 602 | |
| 603 | (`(,(and head (or `save-window-excursion `track-mouse)) . ,body) |
| 604 | `(,head |
| 605 | :fun-body |
| 606 | ,(cconv-closure-convert-rec `(function (lambda () ,@body)) |
| 607 | emvrs fvrs envs lmenvs))) |
| 608 | |
| 609 | (`(setq . ,forms) ; setq special form |
| 610 | (let (prognlist sym sym-new value) |
| 611 | (while forms |
| 612 | (setq sym (car forms)) |
| 613 | (setq sym-new (cconv-closure-convert-rec |
| 614 | sym |
| 615 | (remq sym emvrs) fvrs envs lmenvs)) |
| 616 | (setq value |
| 617 | (cconv-closure-convert-rec |
| 618 | (cadr forms) emvrs fvrs envs lmenvs)) |
| 619 | (if (memq sym emvrs) |
| 620 | (push `(setcar ,sym-new ,value) prognlist) |
| 621 | (if (symbolp sym-new) |
| 622 | (push `(setq ,sym-new ,value) prognlist) |
| 623 | (push `(set ,sym-new ,value) prognlist))) |
| 624 | (setq forms (cddr forms))) |
| 625 | (if (cdr prognlist) |
| 626 | `(progn . ,(reverse prognlist)) |
| 627 | (car prognlist)))) |
| 628 | |
| 629 | (`(,(and (or `funcall `apply) callsym) ,fun . ,args) |
| 630 | ; funcall is not a special form |
| 631 | ; but we treat it separately |
| 632 | ; for the needs of lambda lifting |
| 633 | (let ((fv (cdr (assq fun lmenvs)))) |
| 634 | (if fv |
| 635 | (let ((args-new '()) |
| 636 | (processed-fv '())) |
| 637 | ;; All args (free variables and actual arguments) |
| 638 | ;; should be processed, because they can be fvrs |
| 639 | ;; (free variables of another closure) |
| 640 | (dolist (fvr fv) |
| 641 | (push (cconv-closure-convert-rec |
| 642 | fvr (remq fvr emvrs) |
| 643 | fvrs envs lmenvs) |
| 644 | processed-fv)) |
| 645 | (setq processed-fv (reverse processed-fv)) |
| 646 | (dolist (elm args) |
| 647 | (push (cconv-closure-convert-rec |
| 648 | elm emvrs fvrs envs lmenvs) |
| 649 | args-new)) |
| 650 | (setq args-new (append processed-fv (reverse args-new))) |
| 651 | (setq fun (cconv-closure-convert-rec |
| 652 | fun emvrs fvrs envs lmenvs)) |
| 653 | `(,callsym ,fun . ,args-new)) |
| 654 | (let ((cdr-new '())) |
| 655 | (dolist (elm (cdr form)) |
| 656 | (push (cconv-closure-convert-rec |
| 657 | elm emvrs fvrs envs lmenvs) |
| 658 | cdr-new)) |
| 659 | `(,callsym . ,(reverse cdr-new)))))) |
| 660 | |
| 661 | (`(,func . ,body-forms) ; first element is function or whatever |
| 662 | ; function-like forms are: |
| 663 | ; or, and, if, progn, prog1, prog2, |
| 664 | ; while, until |
| 665 | (let ((body-forms-new '())) |
| 666 | (dolist (elm body-forms) |
| 667 | (push (cconv-closure-convert-rec |
| 668 | elm emvrs fvrs envs lmenvs) |
| 669 | body-forms-new)) |
| 670 | (setq body-forms-new (reverse body-forms-new)) |
| 671 | `(,func . ,body-forms-new))) |
| 672 | |
| 673 | (_ |
| 674 | (let ((free (memq form fvrs))) |
| 675 | (if free ;form is a free variable |
| 676 | (let* ((numero (- (length fvrs) (length free))) |
| 677 | (var '())) |
| 678 | (assert numero) |
| 679 | (if (null (cdr envs)) |
| 680 | (setq var 'env) |
| 681 | ;replace form => |
| 682 | ;(aref env #) |
| 683 | (setq var `(aref env ,numero))) |
| 684 | (if (memq form emvrs) ; form => (car (aref env #)) if mutable |
| 685 | `(car ,var) |
| 686 | var)) |
| 687 | (if (memq form emvrs) ; if form is a mutable variable |
| 688 | `(car ,form) ; replace form => (car form) |
| 689 | form)))))) |
| 690 | |
| 691 | (defun cconv-analyse-function (args body env parentform inclosure) |
| 692 | (dolist (arg args) |
| 693 | (cond |
| 694 | ((byte-compile-not-lexical-var-p arg) |
| 695 | (byte-compile-report-error |
| 696 | (format "Argument %S is not a lexical variable" arg))) |
| 697 | ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... |
| 698 | (t (push (list arg inclosure parentform) env)))) ;Push vrs to vars. |
| 699 | (dolist (form body) ;Analyse body forms. |
| 700 | (cconv-analyse-form form env inclosure))) |
| 701 | |
| 702 | (defun cconv-analyse-form (form env inclosure) |
| 703 | "Find mutated variables and variables captured by closure. Analyse |
| 704 | lambdas if they are suitable for lambda lifting. |
| 705 | -- FORM is a piece of Elisp code after macroexpansion. |
| 706 | -- ENV is a list of variables visible in current lexical environment. |
| 707 | Each entry has the form (VAR INCLOSURE BINDER PARENTFORM) |
| 708 | for let-bound vars and (VAR INCLOSURE PARENTFORM) for function arguments. |
| 709 | -- INCLOSURE is the nesting level within lambdas." |
| 710 | (pcase form |
| 711 | ; let special form |
| 712 | (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) |
| 713 | |
| 714 | (let ((orig-env env) |
| 715 | (var nil) |
| 716 | (value nil)) |
| 717 | (dolist (binder binders) |
| 718 | (if (not (consp binder)) |
| 719 | (progn |
| 720 | (setq var binder) ; treat the form (let (x) ...) well |
| 721 | (setq value nil)) |
| 722 | (setq var (car binder)) |
| 723 | (setq value (cadr binder)) |
| 724 | |
| 725 | (cconv-analyse-form value (if (eq letsym 'let*) env orig-env) |
| 726 | inclosure)) |
| 727 | |
| 728 | (unless (byte-compile-not-lexical-var-p var) |
| 729 | (let ((varstruct (list var inclosure binder form))) |
| 730 | (push varstruct env) ; Push a new one. |
| 731 | |
| 732 | (pcase value |
| 733 | (`(function (lambda . ,_)) |
| 734 | ;; If var is a function push it to lambda list. |
| 735 | (push varstruct cconv-lambda-candidates))))))) |
| 736 | |
| 737 | (dolist (form body-forms) ; Analyse body forms. |
| 738 | (cconv-analyse-form form env inclosure))) |
| 739 | |
| 740 | ; defun special form |
| 741 | (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms) |
| 742 | (when env |
| 743 | (byte-compile-log-warning |
| 744 | (format "Function %S will ignore its context %S" |
| 745 | func (mapcar #'car env)) |
| 746 | t :warning)) |
| 747 | (cconv-analyse-function vrs body-forms nil form 0)) |
| 748 | |
| 749 | (`(function (lambda ,vrs . ,body-forms)) |
| 750 | (cconv-analyse-function vrs body-forms env form (1+ inclosure))) |
| 751 | |
| 752 | (`(setq . ,forms) |
| 753 | ;; If a local variable (member of env) is modified by setq then |
| 754 | ;; it is a mutated variable. |
| 755 | (while forms |
| 756 | (let ((v (assq (car forms) env))) ; v = non nil if visible |
| 757 | (when v |
| 758 | (push v cconv-mutated) |
| 759 | ;; Delete from candidate list for lambda lifting. |
| 760 | (setq cconv-lambda-candidates (delq v cconv-lambda-candidates)) |
| 761 | (unless (eq inclosure (cadr v)) ;Bound in a different closure level. |
| 762 | (push v cconv-captured)))) |
| 763 | (cconv-analyse-form (cadr forms) env inclosure) |
| 764 | (setq forms (cddr forms)))) |
| 765 | |
| 766 | (`((lambda . ,_) . ,_) ; first element is lambda expression |
| 767 | (dolist (exp `((function ,(car form)) . ,(cdr form))) |
| 768 | (cconv-analyse-form exp env inclosure))) |
| 769 | |
| 770 | (`(cond . ,cond-forms) ; cond special form |
| 771 | (dolist (forms cond-forms) |
| 772 | (dolist (form forms) |
| 773 | (cconv-analyse-form form env inclosure)))) |
| 774 | |
| 775 | (`(quote . ,_) nil) ; quote form |
| 776 | (`(function . ,_) nil) ; same as quote |
| 777 | |
| 778 | (`(condition-case ,var ,protected-form . ,handlers) |
| 779 | ;; FIXME: The bytecode for condition-case forces us to wrap the |
| 780 | ;; form and handlers in closures (for handlers, it's probably |
| 781 | ;; unavoidable, but not for the protected form). |
| 782 | (setq inclosure (1+ inclosure)) |
| 783 | (cconv-analyse-form protected-form env inclosure) |
| 784 | (push (list var inclosure form) env) |
| 785 | (dolist (handler handlers) |
| 786 | (dolist (form (cdr handler)) |
| 787 | (cconv-analyse-form form env inclosure)))) |
| 788 | |
| 789 | ;; FIXME: The bytecode for catch forces us to wrap the body. |
| 790 | (`(,(or `catch `unwind-protect) ,form . ,body) |
| 791 | (cconv-analyse-form form env inclosure) |
| 792 | (setq inclosure (1+ inclosure)) |
| 793 | (dolist (form body) |
| 794 | (cconv-analyse-form form env inclosure))) |
| 795 | |
| 796 | ;; FIXME: The bytecode for save-window-excursion and the lack of |
| 797 | ;; bytecode for track-mouse forces us to wrap the body. |
| 798 | (`(,(or `save-window-excursion `track-mouse) . ,body) |
| 799 | (setq inclosure (1+ inclosure)) |
| 800 | (dolist (form body) |
| 801 | (cconv-analyse-form form env inclosure))) |
| 802 | |
| 803 | (`(,(or `defconst `defvar) ,var ,value . ,_) |
| 804 | (push var byte-compile-bound-variables) |
| 805 | (cconv-analyse-form value env inclosure)) |
| 806 | |
| 807 | (`(,(or `funcall `apply) ,fun . ,args) |
| 808 | ;; Here we ignore fun because funcall and apply are the only two |
| 809 | ;; functions where we can pass a candidate for lambda lifting as |
| 810 | ;; argument. So, if we see fun elsewhere, we'll delete it from |
| 811 | ;; lambda candidate list. |
| 812 | (if (symbolp fun) |
| 813 | (let ((lv (assq fun cconv-lambda-candidates))) |
| 814 | (when lv |
| 815 | (unless (eq (cadr lv) inclosure) |
| 816 | (push lv cconv-captured) |
| 817 | ;; If this funcall and the definition of fun are in |
| 818 | ;; different closures - we delete fun from candidate |
| 819 | ;; list, because it is too complicated to manage free |
| 820 | ;; variables in this case. |
| 821 | (setq cconv-lambda-candidates |
| 822 | (delq lv cconv-lambda-candidates))))) |
| 823 | (cconv-analyse-form fun env inclosure)) |
| 824 | (dolist (form args) |
| 825 | (cconv-analyse-form form env inclosure))) |
| 826 | |
| 827 | (`(,_ . ,body-forms) ; First element is a function or whatever. |
| 828 | (dolist (form body-forms) |
| 829 | (cconv-analyse-form form env inclosure))) |
| 830 | |
| 831 | ((pred symbolp) |
| 832 | (let ((dv (assq form env))) ; dv = declared and visible |
| 833 | (when dv |
| 834 | (unless (eq inclosure (cadr dv)) ; capturing condition |
| 835 | (push dv cconv-captured)) |
| 836 | ;; Delete lambda if it is found here, since it escapes. |
| 837 | (setq cconv-lambda-candidates |
| 838 | (delq dv cconv-lambda-candidates))))))) |
| 839 | |
| 840 | (provide 'cconv) |
| 841 | ;;; cconv.el ends here |