| 1 | ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*- |
| 2 | |
| 3 | ;; Copyright (C) 2011-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca> |
| 6 | ;; Maintainer: emacs-devel@gnu.org |
| 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 analyze 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 the 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 recursively, 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 (v0 ...) ... fv0 .. fv1 ...) => |
| 51 | ;; (internal-make-closure (v0 ...) (fv1 ...) |
| 52 | ;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...) |
| 53 | ;; |
| 54 | ;; If the function has no free variables, we don't do anything. |
| 55 | ;; |
| 56 | ;; If a variable is mutated (updated by setq), and it is used in a closure |
| 57 | ;; we wrap its definition with list: (list val) and we also replace |
| 58 | ;; var => (car-safe var) wherever this variable is used, and also |
| 59 | ;; (setq var value) => (setcar var value) where it is updated. |
| 60 | ;; |
| 61 | ;; If defun argument is closure mutable, we letbind it and wrap it's |
| 62 | ;; definition with list. |
| 63 | ;; (defun foo (... mutable-arg ...) ...) => |
| 64 | ;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) |
| 65 | ;; |
| 66 | ;;; Code: |
| 67 | |
| 68 | ;; TODO: (not just for cconv but also for the lexbind changes in general) |
| 69 | ;; - let (e)debug find the value of lexical variables from the stack. |
| 70 | ;; - make eval-region do the eval-sexp-add-defvars dance. |
| 71 | ;; - byte-optimize-form should be applied before cconv. |
| 72 | ;; OTOH, the warnings emitted by cconv-analyze need to come before optimize |
| 73 | ;; since afterwards they can because obnoxious (warnings about an "unused |
| 74 | ;; variable" should not be emitted when the variable use has simply been |
| 75 | ;; optimized away). |
| 76 | ;; - let macros specify that some let-bindings come from the same source, |
| 77 | ;; so the unused warning takes all uses into account. |
| 78 | ;; - let interactive specs return a function to build the args (to stash into |
| 79 | ;; command-history). |
| 80 | ;; - canonize code in macro-expand so we don't have to handle (let (var) body) |
| 81 | ;; and other oddities. |
| 82 | ;; - new byte codes for unwind-protect so that closures aren't needed at all. |
| 83 | ;; - a reference to a var that is known statically to always hold a constant |
| 84 | ;; should be turned into a byte-constant rather than a byte-stack-ref. |
| 85 | ;; Hmm... right, that's called constant propagation and could be done here, |
| 86 | ;; but when that constant is a function, we have to be careful to make sure |
| 87 | ;; the bytecomp only compiles it once. |
| 88 | ;; - Since we know here when a variable is not mutated, we could pass that |
| 89 | ;; info to the byte-compiler, e.g. by using a new `immutable-let'. |
| 90 | ;; - add tail-calls to bytecode.c and the byte compiler. |
| 91 | ;; - call known non-escaping functions with `goto' rather than `call'. |
| 92 | ;; - optimize mapcar to a while loop. |
| 93 | |
| 94 | ;; (defmacro dlet (binders &rest body) |
| 95 | ;; ;; Works in both lexical and non-lexical mode. |
| 96 | ;; (declare (indent 1) (debug let)) |
| 97 | ;; `(progn |
| 98 | ;; ,@(mapcar (lambda (binder) |
| 99 | ;; `(defvar ,(if (consp binder) (car binder) binder))) |
| 100 | ;; binders) |
| 101 | ;; (let ,binders ,@body))) |
| 102 | |
| 103 | ;; (defmacro llet (binders &rest body) |
| 104 | ;; ;; Only works in lexical-binding mode. |
| 105 | ;; `(funcall |
| 106 | ;; (lambda ,(mapcar (lambda (binder) (if (consp binder) (car binder) binder)) |
| 107 | ;; binders) |
| 108 | ;; ,@body) |
| 109 | ;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder))) |
| 110 | ;; binders))) |
| 111 | |
| 112 | (eval-when-compile (require 'cl-lib)) |
| 113 | |
| 114 | (defconst cconv-liftwhen 6 |
| 115 | "Try to do lambda lifting if the number of arguments + free variables |
| 116 | is less than this number.") |
| 117 | ;; List of all the variables that are both captured by a closure |
| 118 | ;; and mutated. Each entry in the list takes the form |
| 119 | ;; (BINDER . PARENTFORM) where BINDER is the (VAR VAL) that introduces the |
| 120 | ;; variable (or is just (VAR) for variables not introduced by let). |
| 121 | (defvar cconv-captured+mutated) |
| 122 | |
| 123 | ;; List of candidates for lambda lifting. |
| 124 | ;; Each candidate has the form (BINDER . PARENTFORM). A candidate |
| 125 | ;; is a variable that is only passed to `funcall' or `apply'. |
| 126 | (defvar cconv-lambda-candidates) |
| 127 | |
| 128 | ;; Alist associating to each function body the list of its free variables. |
| 129 | (defvar cconv-freevars-alist) |
| 130 | |
| 131 | ;;;###autoload |
| 132 | (defun cconv-closure-convert (form) |
| 133 | "Main entry point for closure conversion. |
| 134 | -- FORM is a piece of Elisp code after macroexpansion. |
| 135 | -- TOPLEVEL(optional) is a boolean variable, true if we are at the root of AST |
| 136 | |
| 137 | Returns a form where all lambdas don't have any free variables." |
| 138 | ;; (message "Entering cconv-closure-convert...") |
| 139 | (let ((cconv-freevars-alist '()) |
| 140 | (cconv-lambda-candidates '()) |
| 141 | (cconv-captured+mutated '())) |
| 142 | ;; Analyze form - fill these variables with new information. |
| 143 | (cconv-analyse-form form '()) |
| 144 | (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) |
| 145 | (prog1 (cconv-convert form nil nil) ; Env initially empty. |
| 146 | (cl-assert (null cconv-freevars-alist))))) |
| 147 | |
| 148 | ;;;###autoload |
| 149 | (defun cconv-warnings-only (form) |
| 150 | "Add the warnings that closure conversion would encounter." |
| 151 | (let ((cconv-freevars-alist '()) |
| 152 | (cconv-lambda-candidates '()) |
| 153 | (cconv-captured+mutated '())) |
| 154 | ;; Analyze form - fill these variables with new information. |
| 155 | (cconv-analyse-form form '()) |
| 156 | ;; But don't perform the closure conversion. |
| 157 | form)) |
| 158 | |
| 159 | (defconst cconv--dummy-var (make-symbol "ignored")) |
| 160 | |
| 161 | (defun cconv--set-diff (s1 s2) |
| 162 | "Return elements of set S1 that are not in set S2." |
| 163 | (let ((res '())) |
| 164 | (dolist (x s1) |
| 165 | (unless (memq x s2) (push x res))) |
| 166 | (nreverse res))) |
| 167 | |
| 168 | (defun cconv--set-diff-map (s m) |
| 169 | "Return elements of set S that are not in Dom(M)." |
| 170 | (let ((res '())) |
| 171 | (dolist (x s) |
| 172 | (unless (assq x m) (push x res))) |
| 173 | (nreverse res))) |
| 174 | |
| 175 | (defun cconv--map-diff (m1 m2) |
| 176 | "Return the submap of map M1 that has Dom(M2) removed." |
| 177 | (let ((res '())) |
| 178 | (dolist (x m1) |
| 179 | (unless (assq (car x) m2) (push x res))) |
| 180 | (nreverse res))) |
| 181 | |
| 182 | (defun cconv--map-diff-elem (m x) |
| 183 | "Return the map M minus any mapping for X." |
| 184 | ;; Here we assume that X appears at most once in M. |
| 185 | (let* ((b (assq x m)) |
| 186 | (res (if b (remq b m) m))) |
| 187 | (cl-assert (null (assq x res))) ;; Check the assumption was warranted. |
| 188 | res)) |
| 189 | |
| 190 | (defun cconv--map-diff-set (m s) |
| 191 | "Return the map M minus any mapping for elements of S." |
| 192 | ;; Here we assume that X appears at most once in M. |
| 193 | (let ((res '())) |
| 194 | (dolist (b m) |
| 195 | (unless (memq (car b) s) (push b res))) |
| 196 | (nreverse res))) |
| 197 | |
| 198 | (defun cconv--convert-function (args body env parentform) |
| 199 | (cl-assert (equal body (caar cconv-freevars-alist))) |
| 200 | (let* ((fvs (cdr (pop cconv-freevars-alist))) |
| 201 | (body-new '()) |
| 202 | (letbind '()) |
| 203 | (envector ()) |
| 204 | (i 0) |
| 205 | (new-env ())) |
| 206 | ;; Build the "formal and actual envs" for the closure-converted function. |
| 207 | (dolist (fv fvs) |
| 208 | (let ((exp (or (cdr (assq fv env)) fv))) |
| 209 | (pcase exp |
| 210 | ;; If `fv' is a variable that's wrapped in a cons-cell, |
| 211 | ;; we want to put the cons-cell itself in the closure, |
| 212 | ;; rather than just a copy of its current content. |
| 213 | (`(car-safe ,iexp . ,_) |
| 214 | (push iexp envector) |
| 215 | (push `(,fv . (car-safe (internal-get-closed-var ,i))) new-env)) |
| 216 | (_ |
| 217 | (push exp envector) |
| 218 | (push `(,fv . (internal-get-closed-var ,i)) new-env)))) |
| 219 | (setq i (1+ i))) |
| 220 | (setq envector (nreverse envector)) |
| 221 | (setq new-env (nreverse new-env)) |
| 222 | |
| 223 | (dolist (arg args) |
| 224 | (if (not (member (cons (list arg) parentform) cconv-captured+mutated)) |
| 225 | (if (assq arg new-env) (push `(,arg) new-env)) |
| 226 | (push `(,arg . (car-safe ,arg)) new-env) |
| 227 | (push `(,arg (list ,arg)) letbind))) |
| 228 | |
| 229 | (setq body-new (mapcar (lambda (form) |
| 230 | (cconv-convert form new-env nil)) |
| 231 | body)) |
| 232 | |
| 233 | (when letbind |
| 234 | (let ((special-forms '())) |
| 235 | ;; Keep special forms at the beginning of the body. |
| 236 | (while (or (stringp (car body-new)) ;docstring. |
| 237 | (memq (car-safe (car body-new)) '(interactive declare))) |
| 238 | (push (pop body-new) special-forms)) |
| 239 | (setq body-new |
| 240 | `(,@(nreverse special-forms) (let ,letbind . ,body-new))))) |
| 241 | |
| 242 | (cond |
| 243 | ((null envector) ;if no freevars - do nothing |
| 244 | `(function (lambda ,args . ,body-new))) |
| 245 | (t |
| 246 | `(internal-make-closure |
| 247 | ,args ,envector . ,body-new))))) |
| 248 | |
| 249 | (defun cconv-convert (form env extend) |
| 250 | ;; This function actually rewrites the tree. |
| 251 | "Return FORM with all its lambdas changed so they are closed. |
| 252 | ENV is a lexical environment mapping variables to the expression |
| 253 | used to get its value. This is used for variables that are copied into |
| 254 | closures, moved into cons cells, ... |
| 255 | ENV is a list where each entry takes the shape either: |
| 256 | (VAR . (car-safe EXP)): VAR has been moved into the car of a cons-cell, and EXP |
| 257 | is an expression that evaluates to this cons-cell. |
| 258 | (VAR . (internal-get-closed-var N)): VAR has been copied into the closure |
| 259 | environment's Nth slot. |
| 260 | (VAR . (apply-partially F ARG1 ARG2 ..)): VAR has been λ-lifted and takes |
| 261 | additional arguments ARGs. |
| 262 | EXTEND is a list of variables which might need to be accessed even from places |
| 263 | where they are shadowed, because some part of ENV causes them to be used at |
| 264 | places where they originally did not directly appear." |
| 265 | (cl-assert (not (delq nil (mapcar (lambda (mapping) |
| 266 | (if (eq (cadr mapping) 'apply-partially) |
| 267 | (cconv--set-diff (cdr (cddr mapping)) |
| 268 | extend))) |
| 269 | env)))) |
| 270 | |
| 271 | ;; What's the difference between fvrs and envs? |
| 272 | ;; Suppose that we have the code |
| 273 | ;; (lambda (..) fvr (let ((fvr 1)) (+ fvr 1))) |
| 274 | ;; only the first occurrence of fvr should be replaced by |
| 275 | ;; (aref env ...). |
| 276 | ;; So initially envs and fvrs are the same thing, but when we descend to |
| 277 | ;; the 'let, we delete fvr from fvrs. Why we don't delete fvr from envs? |
| 278 | ;; Because in envs the order of variables is important. We use this list |
| 279 | ;; to find the number of a specific variable in the environment vector, |
| 280 | ;; so we never touch it(unless we enter to the other closure). |
| 281 | ;;(if (listp form) (print (car form)) form) |
| 282 | (pcase form |
| 283 | (`(,(and letsym (or `let* `let)) ,binders . ,body) |
| 284 | |
| 285 | ; let and let* special forms |
| 286 | (let ((binders-new '()) |
| 287 | (new-env env) |
| 288 | (new-extend extend)) |
| 289 | |
| 290 | (dolist (binder binders) |
| 291 | (let* ((value nil) |
| 292 | (var (if (not (consp binder)) |
| 293 | (prog1 binder (setq binder (list binder))) |
| 294 | (when (cddr binder) |
| 295 | (byte-compile-log-warning |
| 296 | (format "Malformed `%S' binding: %S" letsym binder))) |
| 297 | (setq value (cadr binder)) |
| 298 | (car binder))) |
| 299 | (new-val |
| 300 | (cond |
| 301 | ;; Check if var is a candidate for lambda lifting. |
| 302 | ((and (member (cons binder form) cconv-lambda-candidates) |
| 303 | (progn |
| 304 | (cl-assert (and (eq (car value) 'function) |
| 305 | (eq (car (cadr value)) 'lambda))) |
| 306 | (cl-assert (equal (cddr (cadr value)) |
| 307 | (caar cconv-freevars-alist))) |
| 308 | ;; Peek at the freevars to decide whether to λ-lift. |
| 309 | (let* ((fvs (cdr (car cconv-freevars-alist))) |
| 310 | (fun (cadr value)) |
| 311 | (funargs (cadr fun)) |
| 312 | (funcvars (append fvs funargs))) |
| 313 | ; lambda lifting condition |
| 314 | (and fvs (>= cconv-liftwhen (length funcvars)))))) |
| 315 | ; Lift. |
| 316 | (let* ((fvs (cdr (pop cconv-freevars-alist))) |
| 317 | (fun (cadr value)) |
| 318 | (funargs (cadr fun)) |
| 319 | (funcvars (append fvs funargs)) |
| 320 | (funcbody (cddr fun)) |
| 321 | (funcbody-env ())) |
| 322 | (push `(,var . (apply-partially ,var . ,fvs)) new-env) |
| 323 | (dolist (fv fvs) |
| 324 | (cl-pushnew fv new-extend) |
| 325 | (if (and (eq 'car-safe (car-safe (cdr (assq fv env)))) |
| 326 | (not (memq fv funargs))) |
| 327 | (push `(,fv . (car-safe ,fv)) funcbody-env))) |
| 328 | `(function (lambda ,funcvars . |
| 329 | ,(mapcar (lambda (form) |
| 330 | (cconv-convert |
| 331 | form funcbody-env nil)) |
| 332 | funcbody))))) |
| 333 | |
| 334 | ;; Check if it needs to be turned into a "ref-cell". |
| 335 | ((member (cons binder form) cconv-captured+mutated) |
| 336 | ;; Declared variable is mutated and captured. |
| 337 | (push `(,var . (car-safe ,var)) new-env) |
| 338 | `(list ,(cconv-convert value env extend))) |
| 339 | |
| 340 | ;; Normal default case. |
| 341 | (t |
| 342 | (if (assq var new-env) (push `(,var) new-env)) |
| 343 | (cconv-convert value env extend))))) |
| 344 | |
| 345 | ;; The piece of code below letbinds free variables of a λ-lifted |
| 346 | ;; function if they are redefined in this let, example: |
| 347 | ;; (let* ((fun (lambda (x) (+ x y))) (y 1)) (funcall fun 1)) |
| 348 | ;; Here we can not pass y as parameter because it is redefined. |
| 349 | ;; So we add a (closed-y y) declaration. We do that even if the |
| 350 | ;; function is not used inside this let(*). The reason why we |
| 351 | ;; ignore this case is that we can't "look forward" to see if the |
| 352 | ;; function is called there or not. To treat this case better we'd |
| 353 | ;; need to traverse the tree one more time to collect this data, and |
| 354 | ;; I think that it's not worth it. |
| 355 | (when (memq var new-extend) |
| 356 | (let ((closedsym |
| 357 | (make-symbol (concat "closed-" (symbol-name var))))) |
| 358 | (setq new-env |
| 359 | (mapcar (lambda (mapping) |
| 360 | (if (not (eq (cadr mapping) 'apply-partially)) |
| 361 | mapping |
| 362 | (cl-assert (eq (car mapping) (nth 2 mapping))) |
| 363 | `(,(car mapping) |
| 364 | apply-partially |
| 365 | ,(car mapping) |
| 366 | ,@(mapcar (lambda (arg) |
| 367 | (if (eq var arg) |
| 368 | closedsym arg)) |
| 369 | (nthcdr 3 mapping))))) |
| 370 | new-env)) |
| 371 | (setq new-extend (remq var new-extend)) |
| 372 | (push closedsym new-extend) |
| 373 | (push `(,closedsym ,var) binders-new))) |
| 374 | |
| 375 | ;; We push the element after redefined free variables are |
| 376 | ;; processed. This is important to avoid the bug when free |
| 377 | ;; variable and the function have the same name. |
| 378 | (push (list var new-val) binders-new) |
| 379 | |
| 380 | (when (eq letsym 'let*) |
| 381 | (setq env new-env) |
| 382 | (setq extend new-extend)) |
| 383 | )) ; end of dolist over binders |
| 384 | |
| 385 | `(,letsym ,(nreverse binders-new) |
| 386 | . ,(mapcar (lambda (form) |
| 387 | (cconv-convert |
| 388 | form new-env new-extend)) |
| 389 | body)))) |
| 390 | ;end of let let* forms |
| 391 | |
| 392 | ; first element is lambda expression |
| 393 | (`(,(and `(lambda . ,_) fun) . ,args) |
| 394 | ;; FIXME: it's silly to create a closure just to call it. |
| 395 | ;; Running byte-optimize-form earlier will resolve this. |
| 396 | `(funcall |
| 397 | ,(cconv-convert `(function ,fun) env extend) |
| 398 | ,@(mapcar (lambda (form) |
| 399 | (cconv-convert form env extend)) |
| 400 | args))) |
| 401 | |
| 402 | (`(cond . ,cond-forms) ; cond special form |
| 403 | `(cond . ,(mapcar (lambda (branch) |
| 404 | (mapcar (lambda (form) |
| 405 | (cconv-convert form env extend)) |
| 406 | branch)) |
| 407 | cond-forms))) |
| 408 | |
| 409 | (`(function (lambda ,args . ,body) . ,_) |
| 410 | (cconv--convert-function args body env form)) |
| 411 | |
| 412 | (`(internal-make-closure . ,_) |
| 413 | (byte-compile-report-error |
| 414 | "Internal error in compiler: cconv called twice?")) |
| 415 | |
| 416 | (`(quote . ,_) form) |
| 417 | (`(function . ,_) form) |
| 418 | |
| 419 | ;defconst, defvar |
| 420 | (`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,forms) |
| 421 | `(,sym ,definedsymbol |
| 422 | . ,(mapcar (lambda (form) (cconv-convert form env extend)) |
| 423 | forms))) |
| 424 | |
| 425 | ;condition-case |
| 426 | ((and `(condition-case ,var ,protected-form . ,handlers) |
| 427 | (guard byte-compile--use-old-handlers)) |
| 428 | (let ((newform (cconv--convert-function |
| 429 | () (list protected-form) env form))) |
| 430 | `(condition-case :fun-body ,newform |
| 431 | ,@(mapcar (lambda (handler) |
| 432 | (list (car handler) |
| 433 | (cconv--convert-function |
| 434 | (list (or var cconv--dummy-var)) |
| 435 | (cdr handler) env form))) |
| 436 | handlers)))) |
| 437 | |
| 438 | ; condition-case with new byte-codes. |
| 439 | (`(condition-case ,var ,protected-form . ,handlers) |
| 440 | `(condition-case ,var |
| 441 | ,(cconv-convert protected-form env extend) |
| 442 | ,@(let* ((cm (and var (member (cons (list var) form) |
| 443 | cconv-captured+mutated))) |
| 444 | (newenv |
| 445 | (cond (cm (cons `(,var . (car-save ,var)) env)) |
| 446 | ((assq var env) (cons `(,var) env)) |
| 447 | (t env)))) |
| 448 | (mapcar |
| 449 | (lambda (handler) |
| 450 | `(,(car handler) |
| 451 | ,@(let ((body |
| 452 | (mapcar (lambda (form) |
| 453 | (cconv-convert form newenv extend)) |
| 454 | (cdr handler)))) |
| 455 | (if (not cm) body |
| 456 | `((let ((,var (list ,var))) ,@body)))))) |
| 457 | handlers)))) |
| 458 | |
| 459 | (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers)) |
| 460 | `unwind-protect)) |
| 461 | ,form . ,body) |
| 462 | `(,head ,(cconv-convert form env extend) |
| 463 | :fun-body ,(cconv--convert-function () body env form))) |
| 464 | |
| 465 | (`(track-mouse . ,body) |
| 466 | `(track-mouse |
| 467 | :fun-body ,(cconv--convert-function () body env form))) |
| 468 | |
| 469 | (`(setq . ,forms) ; setq special form |
| 470 | (let ((prognlist ())) |
| 471 | (while forms |
| 472 | (let* ((sym (pop forms)) |
| 473 | (sym-new (or (cdr (assq sym env)) sym)) |
| 474 | (value (cconv-convert (pop forms) env extend))) |
| 475 | (push (pcase sym-new |
| 476 | ((pred symbolp) `(setq ,sym-new ,value)) |
| 477 | (`(car-safe ,iexp) `(setcar ,iexp ,value)) |
| 478 | ;; This "should never happen", but for variables which are |
| 479 | ;; mutated+captured+unused, we may end up trying to `setq' |
| 480 | ;; on a closed-over variable, so just drop the setq. |
| 481 | (_ ;; (byte-compile-report-error |
| 482 | ;; (format "Internal error in cconv of (setq %s ..)" |
| 483 | ;; sym-new)) |
| 484 | value)) |
| 485 | prognlist))) |
| 486 | (if (cdr prognlist) |
| 487 | `(progn . ,(nreverse prognlist)) |
| 488 | (car prognlist)))) |
| 489 | |
| 490 | (`(,(and (or `funcall `apply) callsym) ,fun . ,args) |
| 491 | ;; These are not special forms but we treat them separately for the needs |
| 492 | ;; of lambda lifting. |
| 493 | (let ((mapping (cdr (assq fun env)))) |
| 494 | (pcase mapping |
| 495 | (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) |
| 496 | (cl-assert (eq (cadr mapping) fun)) |
| 497 | `(,callsym ,fun |
| 498 | ,@(mapcar (lambda (fv) |
| 499 | (let ((exp (or (cdr (assq fv env)) fv))) |
| 500 | (pcase exp |
| 501 | (`(car-safe ,iexp . ,_) iexp) |
| 502 | (_ exp)))) |
| 503 | fvs) |
| 504 | ,@(mapcar (lambda (arg) |
| 505 | (cconv-convert arg env extend)) |
| 506 | args))) |
| 507 | (_ `(,callsym ,@(mapcar (lambda (arg) |
| 508 | (cconv-convert arg env extend)) |
| 509 | (cons fun args))))))) |
| 510 | |
| 511 | (`(interactive . ,forms) |
| 512 | `(interactive . ,(mapcar (lambda (form) |
| 513 | (cconv-convert form nil nil)) |
| 514 | forms))) |
| 515 | |
| 516 | (`(declare . ,_) form) ;The args don't contain code. |
| 517 | |
| 518 | (`(,func . ,forms) |
| 519 | ;; First element is function or whatever function-like forms are: or, and, |
| 520 | ;; if, catch, progn, prog1, prog2, while, until |
| 521 | `(,func . ,(mapcar (lambda (form) |
| 522 | (cconv-convert form env extend)) |
| 523 | forms))) |
| 524 | |
| 525 | (_ (or (cdr (assq form env)) form)))) |
| 526 | |
| 527 | (unless (fboundp 'byte-compile-not-lexical-var-p) |
| 528 | ;; Only used to test the code in non-lexbind Emacs. |
| 529 | (defalias 'byte-compile-not-lexical-var-p 'boundp)) |
| 530 | (defvar byte-compile-lexical-variables) |
| 531 | |
| 532 | (defun cconv--analyse-use (vardata form varkind) |
| 533 | "Analyze the use of a variable. |
| 534 | VARDATA should be (BINDER READ MUTATED CAPTURED CALLED). |
| 535 | VARKIND is the name of the kind of variable. |
| 536 | FORM is the parent form that binds this var." |
| 537 | ;; use = `(,binder ,read ,mutated ,captured ,called) |
| 538 | (pcase vardata |
| 539 | (`(,_ nil nil nil nil) nil) |
| 540 | (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_) |
| 541 | ,_ ,_ ,_ ,_) |
| 542 | (byte-compile-log-warning |
| 543 | (format "%s `%S' not left unused" varkind var)))) |
| 544 | (pcase vardata |
| 545 | (`((,var . ,_) nil ,_ ,_ nil) |
| 546 | ;; FIXME: This gives warnings in the wrong order, with imprecise line |
| 547 | ;; numbers and without function name info. |
| 548 | (unless (or ;; Uninterned symbols typically come from macro-expansion, so |
| 549 | ;; it is often non-trivial for the programmer to avoid such |
| 550 | ;; unused vars. |
| 551 | (not (intern-soft var)) |
| 552 | (eq ?_ (aref (symbol-name var) 0)) |
| 553 | ;; As a special exception, ignore "ignore". |
| 554 | (eq var 'ignored)) |
| 555 | (byte-compile-log-warning (format "Unused lexical %s `%S'" |
| 556 | varkind var)))) |
| 557 | ;; If it's unused, there's no point converting it into a cons-cell, even if |
| 558 | ;; it's captured and mutated. |
| 559 | (`(,binder ,_ t t ,_) |
| 560 | (push (cons binder form) cconv-captured+mutated)) |
| 561 | (`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t) |
| 562 | (push (cons binder form) cconv-lambda-candidates)))) |
| 563 | |
| 564 | (defun cconv--analyse-function (args body env parentform) |
| 565 | (let* ((newvars nil) |
| 566 | (freevars (list body)) |
| 567 | ;; We analyze the body within a new environment where all uses are |
| 568 | ;; nil, so we can distinguish uses within that function from uses |
| 569 | ;; outside of it. |
| 570 | (envcopy |
| 571 | (mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env)) |
| 572 | (byte-compile-bound-variables byte-compile-bound-variables) |
| 573 | (newenv envcopy)) |
| 574 | ;; Push it before recursing, so cconv-freevars-alist contains entries in |
| 575 | ;; the order they'll be used by closure-convert-rec. |
| 576 | (push freevars cconv-freevars-alist) |
| 577 | (dolist (arg args) |
| 578 | (cond |
| 579 | ((byte-compile-not-lexical-var-p arg) |
| 580 | (byte-compile-log-warning |
| 581 | (format "Lexical argument shadows the dynamic variable %S" |
| 582 | arg))) |
| 583 | ((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ... |
| 584 | (t (let ((varstruct (list arg nil nil nil nil))) |
| 585 | (cl-pushnew arg byte-compile-lexical-variables) |
| 586 | (push (cons (list arg) (cdr varstruct)) newvars) |
| 587 | (push varstruct newenv))))) |
| 588 | (dolist (form body) ;Analyze body forms. |
| 589 | (cconv-analyse-form form newenv)) |
| 590 | ;; Summarize resulting data about arguments. |
| 591 | (dolist (vardata newvars) |
| 592 | (cconv--analyse-use vardata parentform "argument")) |
| 593 | ;; Transfer uses collected in `envcopy' (via `newenv') back to `env'; |
| 594 | ;; and compute free variables. |
| 595 | (while env |
| 596 | (cl-assert (and envcopy (eq (caar env) (caar envcopy)))) |
| 597 | (let ((free nil) |
| 598 | (x (cdr (car env))) |
| 599 | (y (cdr (car envcopy)))) |
| 600 | (while x |
| 601 | (when (car y) (setcar x t) (setq free t)) |
| 602 | (setq x (cdr x) y (cdr y))) |
| 603 | (when free |
| 604 | (push (caar env) (cdr freevars)) |
| 605 | (setf (nth 3 (car env)) t)) |
| 606 | (setq env (cdr env) envcopy (cdr envcopy)))))) |
| 607 | |
| 608 | (defun cconv-analyse-form (form env) |
| 609 | "Find mutated variables and variables captured by closure. |
| 610 | Analyze lambdas if they are suitable for lambda lifting. |
| 611 | - FORM is a piece of Elisp code after macroexpansion. |
| 612 | - ENV is an alist mapping each enclosing lexical variable to its info. |
| 613 | I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)). |
| 614 | This function does not return anything but instead fills the |
| 615 | `cconv-captured+mutated' and `cconv-lambda-candidates' variables |
| 616 | and updates the data stored in ENV." |
| 617 | (pcase form |
| 618 | ; let special form |
| 619 | (`(,(and (or `let* `let) letsym) ,binders . ,body-forms) |
| 620 | |
| 621 | (let ((orig-env env) |
| 622 | (newvars nil) |
| 623 | (var nil) |
| 624 | (byte-compile-bound-variables byte-compile-bound-variables) |
| 625 | (value nil)) |
| 626 | (dolist (binder binders) |
| 627 | (if (not (consp binder)) |
| 628 | (progn |
| 629 | (setq var binder) ; treat the form (let (x) ...) well |
| 630 | (setq binder (list binder)) |
| 631 | (setq value nil)) |
| 632 | (setq var (car binder)) |
| 633 | (setq value (cadr binder)) |
| 634 | |
| 635 | (cconv-analyse-form value (if (eq letsym 'let*) env orig-env))) |
| 636 | |
| 637 | (unless (byte-compile-not-lexical-var-p var) |
| 638 | (cl-pushnew var byte-compile-lexical-variables) |
| 639 | (let ((varstruct (list var nil nil nil nil))) |
| 640 | (push (cons binder (cdr varstruct)) newvars) |
| 641 | (push varstruct env)))) |
| 642 | |
| 643 | (dolist (form body-forms) ; Analyze body forms. |
| 644 | (cconv-analyse-form form env)) |
| 645 | |
| 646 | (dolist (vardata newvars) |
| 647 | (cconv--analyse-use vardata form "variable")))) |
| 648 | |
| 649 | (`(function (lambda ,vrs . ,body-forms)) |
| 650 | (cconv--analyse-function vrs body-forms env form)) |
| 651 | |
| 652 | (`(setq . ,forms) |
| 653 | ;; If a local variable (member of env) is modified by setq then |
| 654 | ;; it is a mutated variable. |
| 655 | (while forms |
| 656 | (let ((v (assq (car forms) env))) ; v = non nil if visible |
| 657 | (when v (setf (nth 2 v) t))) |
| 658 | (cconv-analyse-form (cadr forms) env) |
| 659 | (setq forms (cddr forms)))) |
| 660 | |
| 661 | (`((lambda . ,_) . ,_) ; First element is lambda expression. |
| 662 | (byte-compile-log-warning |
| 663 | (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) |
| 664 | t :warning) |
| 665 | (dolist (exp `((function ,(car form)) . ,(cdr form))) |
| 666 | (cconv-analyse-form exp env))) |
| 667 | |
| 668 | (`(cond . ,cond-forms) ; cond special form |
| 669 | (dolist (forms cond-forms) |
| 670 | (dolist (form forms) (cconv-analyse-form form env)))) |
| 671 | |
| 672 | (`(quote . ,_) nil) ; quote form |
| 673 | (`(function . ,_) nil) ; same as quote |
| 674 | |
| 675 | ((and `(condition-case ,var ,protected-form . ,handlers) |
| 676 | (guard byte-compile--use-old-handlers)) |
| 677 | ;; FIXME: The bytecode for condition-case forces us to wrap the |
| 678 | ;; form and handlers in closures. |
| 679 | (cconv--analyse-function () (list protected-form) env form) |
| 680 | (dolist (handler handlers) |
| 681 | (cconv--analyse-function (if var (list var)) (cdr handler) |
| 682 | env form))) |
| 683 | |
| 684 | (`(condition-case ,var ,protected-form . ,handlers) |
| 685 | (cconv-analyse-form protected-form env) |
| 686 | (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) |
| 687 | (byte-compile-log-warning |
| 688 | (format "Lexical variable shadows the dynamic variable %S" var))) |
| 689 | (let* ((varstruct (list var nil nil nil nil))) |
| 690 | (if var (push varstruct env)) |
| 691 | (dolist (handler handlers) |
| 692 | (dolist (form (cdr handler)) |
| 693 | (cconv-analyse-form form env))) |
| 694 | (if var (cconv--analyse-use (cons (list var) (cdr varstruct)) |
| 695 | form "variable")))) |
| 696 | |
| 697 | ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. |
| 698 | (`(,(or (and `catch (guard byte-compile--use-old-handlers)) |
| 699 | `unwind-protect) |
| 700 | ,form . ,body) |
| 701 | (cconv-analyse-form form env) |
| 702 | (cconv--analyse-function () body env form)) |
| 703 | |
| 704 | ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body. |
| 705 | ;; `track-mouse' really should be made into a macro. |
| 706 | (`(track-mouse . ,body) |
| 707 | (cconv--analyse-function () body env form)) |
| 708 | |
| 709 | (`(defvar ,var) (push var byte-compile-bound-variables)) |
| 710 | (`(,(or `defconst `defvar) ,var ,value . ,_) |
| 711 | (push var byte-compile-bound-variables) |
| 712 | (cconv-analyse-form value env)) |
| 713 | |
| 714 | (`(,(or `funcall `apply) ,fun . ,args) |
| 715 | ;; Here we ignore fun because funcall and apply are the only two |
| 716 | ;; functions where we can pass a candidate for lambda lifting as |
| 717 | ;; argument. So, if we see fun elsewhere, we'll delete it from |
| 718 | ;; lambda candidate list. |
| 719 | (let ((fdata (and (symbolp fun) (assq fun env)))) |
| 720 | (if fdata |
| 721 | (setf (nth 4 fdata) t) |
| 722 | (cconv-analyse-form fun env))) |
| 723 | (dolist (form args) (cconv-analyse-form form env))) |
| 724 | |
| 725 | (`(interactive . ,forms) |
| 726 | ;; These appear within the function body but they don't have access |
| 727 | ;; to the function's arguments. |
| 728 | ;; We could extend this to allow interactive specs to refer to |
| 729 | ;; variables in the function's enclosing environment, but it doesn't |
| 730 | ;; seem worth the trouble. |
| 731 | (dolist (form forms) (cconv-analyse-form form nil))) |
| 732 | |
| 733 | ;; `declare' should now be macro-expanded away (and if they're not, we're |
| 734 | ;; in trouble because they *can* contain code nowadays). |
| 735 | ;; (`(declare . ,_) nil) ;The args don't contain code. |
| 736 | |
| 737 | (`(,_ . ,body-forms) ; First element is a function or whatever. |
| 738 | (dolist (form body-forms) (cconv-analyse-form form env))) |
| 739 | |
| 740 | ((pred symbolp) |
| 741 | (let ((dv (assq form env))) ; dv = declared and visible |
| 742 | (when dv |
| 743 | (setf (nth 1 dv) t)))))) |
| 744 | |
| 745 | (provide 'cconv) |
| 746 | ;;; cconv.el ends here |