-;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*-
+;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*-
-;; Copyright (C) 2011-2012 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: lisp
;; Package: emacs
;; All macros should be expanded beforehand.
;;
;; Here is a brief explanation how this code works.
-;; Firstly, we analyze the tree by calling cconv-analyse-form.
+;; Firstly, we analyze the tree by calling cconv-analyze-form.
;; This function finds all mutated variables, all functions that are suitable
;; for lambda lifting and all variables captured by closure. It passes the tree
;; once, returning a list of three lists.
;;
;; Then we calculate the intersection of the first and third lists returned by
-;; cconv-analyse form to find all mutated variables that are captured by
+;; cconv-analyze form to find all mutated variables that are captured by
;; closure.
;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the
;; if the function is suitable for lambda lifting (if all calls are known)
;;
;; (lambda (v0 ...) ... fv0 .. fv1 ...) =>
-;; (internal-make-closure (v0 ...) (fv1 ...)
+;; (internal-make-closure (v0 ...) (fv0 ...) <doc>
;; ... (internal-get-closed-var 0) ... (internal-get-closed-var 1) ...)
;;
;; If the function has no free variables, we don't do anything.
;;
;; If a variable is mutated (updated by setq), and it is used in a closure
;; we wrap its definition with list: (list val) and we also replace
-;; var => (car var) wherever this variable is used, and also
+;; var => (car-safe var) wherever this variable is used, and also
;; (setq var value) => (setcar var value) where it is updated.
;;
;; If defun argument is closure mutable, we letbind it and wrap it's
;;
;;; Code:
+;; PROBLEM cases found during conversion to lexical binding.
+;; We should try and detect and warn about those cases, even
+;; for lexical-binding==nil to help prepare the migration.
+;; - Uses of run-hooks, and friends.
+;; - Cases where we want to apply the same code to different vars depending on
+;; some test. These sometimes use a (let ((foo (if bar 'a 'b)))
+;; ... (symbol-value foo) ... (set foo ...)).
+
;; TODO: (not just for cconv but also for the lexbind changes in general)
;; - let (e)debug find the value of lexical variables from the stack.
;; - make eval-region do the eval-sexp-add-defvars dance.
;; command-history).
;; - canonize code in macro-expand so we don't have to handle (let (var) body)
;; and other oddities.
-;; - new byte codes for unwind-protect, catch, and condition-case so that
-;; closures aren't needed at all.
-;; - inline source code of different binding mode by first compiling it.
+;; - new byte codes for unwind-protect so that closures aren't needed at all.
;; - a reference to a var that is known statically to always hold a constant
;; should be turned into a byte-constant rather than a byte-stack-ref.
;; Hmm... right, that's called constant propagation and could be done here,
;; the bytecomp only compiles it once.
;; - Since we know here when a variable is not mutated, we could pass that
;; info to the byte-compiler, e.g. by using a new `immutable-let'.
-;; - add tail-calls to bytecode.c and the byte compiler.
;; - call known non-escaping functions with `goto' rather than `call'.
-;; - optimize mapcar to a while loop.
+;; - optimize mapc to a dolist loop.
;; (defmacro dlet (binders &rest body)
;; ;; Works in both lexical and non-lexical mode.
+;; (declare (indent 1) (debug let))
;; `(progn
;; ,@(mapcar (lambda (binder)
;; `(defvar ,(if (consp binder) (car binder) binder)))
(cconv-lambda-candidates '())
(cconv-captured+mutated '()))
;; Analyze form - fill these variables with new information.
- (cconv-analyse-form form '())
+ (cconv-analyze-form form '())
(setq cconv-freevars-alist (nreverse cconv-freevars-alist))
- (cconv-convert form nil nil))) ; Env initially empty.
+ (prog1 (cconv-convert form nil nil) ; Env initially empty.
+ (cl-assert (null cconv-freevars-alist)))))
+
+;;;###autoload
+(defun cconv-warnings-only (form)
+ "Add the warnings that closure conversion would encounter."
+ (let ((cconv-freevars-alist '())
+ (cconv-lambda-candidates '())
+ (cconv-captured+mutated '()))
+ ;; Analyze form - fill these variables with new information.
+ (cconv-analyze-form form '())
+ ;; But don't perform the closure conversion.
+ form))
(defconst cconv--dummy-var (make-symbol "ignored"))
(unless (memq (car b) s) (push b res)))
(nreverse res)))
-(defun cconv--convert-function (args body env parentform)
+(defun cconv--convert-function (args body env parentform &optional docstring)
(cl-assert (equal body (caar cconv-freevars-alist)))
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(body-new '())
;; If `fv' is a variable that's wrapped in a cons-cell,
;; we want to put the cons-cell itself in the closure,
;; rather than just a copy of its current content.
- (`(car ,iexp . ,_)
+ (`(car-safe ,iexp . ,_)
(push iexp envector)
- (push `(,fv . (car (internal-get-closed-var ,i))) new-env))
+ (push `(,fv . (car-safe (internal-get-closed-var ,i))) new-env))
(_
(push exp envector)
(push `(,fv . (internal-get-closed-var ,i)) new-env))))
(dolist (arg args)
(if (not (member (cons (list arg) parentform) cconv-captured+mutated))
(if (assq arg new-env) (push `(,arg) new-env))
- (push `(,arg . (car ,arg)) new-env)
+ (push `(,arg . (car-safe ,arg)) new-env)
(push `(,arg (list ,arg)) letbind)))
(setq body-new (mapcar (lambda (form)
`(,@(nreverse special-forms) (let ,letbind . ,body-new)))))
(cond
- ((null envector) ;if no freevars - do nothing
+ ((not (or envector docstring)) ;If no freevars - do nothing.
`(function (lambda ,args . ,body-new)))
(t
`(internal-make-closure
- ,args ,envector . ,body-new)))))
+ ,args ,envector ,docstring . ,body-new)))))
(defun cconv-convert (form env extend)
;; This function actually rewrites the tree.
used to get its value. This is used for variables that are copied into
closures, moved into cons cells, ...
ENV is a list where each entry takes the shape either:
- (VAR . (car EXP)): VAR has been moved into the car of a cons-cell, and EXP
+ (VAR . (car-safe EXP)): VAR has been moved into the car of a cons-cell, and EXP
is an expression that evaluates to this cons-cell.
(VAR . (internal-get-closed-var N)): VAR has been copied into the closure
environment's Nth slot.
(dolist (binder binders)
(let* ((value nil)
- (var (if (not (consp binder))
- (prog1 binder (setq binder (list binder)))
- (setq value (cadr binder))
- (car binder)))
- (new-val
- (cond
+ (var (if (not (consp binder))
+ (prog1 binder (setq binder (list binder)))
+ (when (cddr binder)
+ (byte-compile-log-warning
+ (format-message "Malformed `%S' binding: %S"
+ letsym binder)))
+ (setq value (cadr binder))
+ (car binder)))
+ (new-val
+ (cond
;; Check if var is a candidate for lambda lifting.
((and (member (cons binder form) cconv-lambda-candidates)
(progn
(push `(,var . (apply-partially ,var . ,fvs)) new-env)
(dolist (fv fvs)
(cl-pushnew fv new-extend)
- (if (and (eq 'car (car-safe (cdr (assq fv env))))
+ (if (and (eq 'car-safe (car-safe (cdr (assq fv env))))
(not (memq fv funargs)))
- (push `(,fv . (car ,fv)) funcbody-env)))
+ (push `(,fv . (car-safe ,fv)) funcbody-env)))
`(function (lambda ,funcvars .
,(mapcar (lambda (form)
(cconv-convert
;; Check if it needs to be turned into a "ref-cell".
((member (cons binder form) cconv-captured+mutated)
;; Declared variable is mutated and captured.
- (push `(,var . (car ,var)) new-env)
+ (push `(,var . (car-safe ,var)) new-env)
`(list ,(cconv-convert value env extend)))
;; Normal default case.
cond-forms)))
(`(function (lambda ,args . ,body) . ,_)
- (cconv--convert-function args body env form))
+ (let ((docstring (if (eq :documentation (car-safe (car body)))
+ (cconv-convert (cadr (pop body)) env extend))))
+ (cconv--convert-function args body env form docstring)))
(`(internal-make-closure . ,_)
(byte-compile-report-error
forms)))
;condition-case
- (`(condition-case ,var ,protected-form . ,handlers)
+ ((and `(condition-case ,var ,protected-form . ,handlers)
+ (guard byte-compile--use-old-handlers))
(let ((newform (cconv--convert-function
() (list protected-form) env form)))
`(condition-case :fun-body ,newform
- ,@(mapcar (lambda (handler)
+ ,@(mapcar (lambda (handler)
(list (car handler)
(cconv--convert-function
(list (or var cconv--dummy-var))
(cdr handler) env form)))
handlers))))
- (`(,(and head (or `catch `unwind-protect)) ,form . ,body)
+ ; condition-case with new byte-codes.
+ (`(condition-case ,var ,protected-form . ,handlers)
+ `(condition-case ,var
+ ,(cconv-convert protected-form env extend)
+ ,@(let* ((cm (and var (member (cons (list var) form)
+ cconv-captured+mutated)))
+ (newenv
+ (cond (cm (cons `(,var . (car-save ,var)) env))
+ ((assq var env) (cons `(,var) env))
+ (t env))))
+ (mapcar
+ (lambda (handler)
+ `(,(car handler)
+ ,@(let ((body
+ (mapcar (lambda (form)
+ (cconv-convert form newenv extend))
+ (cdr handler))))
+ (if (not cm) body
+ `((let ((,var (list ,var))) ,@body))))))
+ handlers))))
+
+ (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers))
+ `unwind-protect))
+ ,form . ,body)
`(,head ,(cconv-convert form env extend)
:fun-body ,(cconv--convert-function () body env form)))
- (`(track-mouse . ,body)
- `(track-mouse
- :fun-body ,(cconv--convert-function () body env form)))
-
(`(setq . ,forms) ; setq special form
- (let ((prognlist ()))
- (while forms
- (let* ((sym (pop forms))
- (sym-new (or (cdr (assq sym env)) sym))
- (value (cconv-convert (pop forms) env extend)))
- (push (pcase sym-new
- ((pred symbolp) `(setq ,sym-new ,value))
- (`(car ,iexp) `(setcar ,iexp ,value))
- ;; This "should never happen", but for variables which are
- ;; mutated+captured+unused, we may end up trying to `setq'
- ;; on a closed-over variable, so just drop the setq.
- (_ ;; (byte-compile-report-error
- ;; (format "Internal error in cconv of (setq %s ..)"
- ;; sym-new))
- value))
- prognlist)))
- (if (cdr prognlist)
- `(progn . ,(nreverse prognlist))
- (car prognlist))))
+ (if (= (logand (length forms) 1) 1)
+ ;; With an odd number of args, let bytecomp.el handle the error.
+ form
+ (let ((prognlist ()))
+ (while forms
+ (let* ((sym (pop forms))
+ (sym-new (or (cdr (assq sym env)) sym))
+ (value (cconv-convert (pop forms) env extend)))
+ (push (pcase sym-new
+ ((pred symbolp) `(setq ,sym-new ,value))
+ (`(car-safe ,iexp) `(setcar ,iexp ,value))
+ ;; This "should never happen", but for variables which are
+ ;; mutated+captured+unused, we may end up trying to `setq'
+ ;; on a closed-over variable, so just drop the setq.
+ (_ ;; (byte-compile-report-error
+ ;; (format "Internal error in cconv of (setq %s ..)"
+ ;; sym-new))
+ value))
+ prognlist)))
+ (if (cdr prognlist)
+ `(progn . ,(nreverse prognlist))
+ (car prognlist)))))
(`(,(and (or `funcall `apply) callsym) ,fun . ,args)
;; These are not special forms but we treat them separately for the needs
,@(mapcar (lambda (fv)
(let ((exp (or (cdr (assq fv env)) fv)))
(pcase exp
- (`(car ,iexp . ,_) iexp)
+ (`(car-safe ,iexp . ,_) iexp)
(_ exp))))
fvs)
,@(mapcar (lambda (arg)
(`(,func . ,forms)
;; First element is function or whatever function-like forms are: or, and,
- ;; if, progn, prog1, prog2, while, until
+ ;; if, catch, progn, prog1, prog2, while, until
`(,func . ,(mapcar (lambda (form)
(cconv-convert form env extend))
forms)))
(unless (fboundp 'byte-compile-not-lexical-var-p)
;; Only used to test the code in non-lexbind Emacs.
(defalias 'byte-compile-not-lexical-var-p 'boundp))
+(defvar byte-compile-lexical-variables)
-(defun cconv--analyse-use (vardata form varkind)
+(defun cconv--analyze-use (vardata form varkind)
"Analyze the use of a variable.
VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
VARKIND is the name of the kind of variable.
;; use = `(,binder ,read ,mutated ,captured ,called)
(pcase vardata
(`(,_ nil nil nil nil) nil)
- (`((,(and (pred (lambda (var) (eq ?_ (aref (symbol-name var) 0)))) var) . ,_)
+ (`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_)
,_ ,_ ,_ ,_)
(byte-compile-log-warning
- (format "%s `%S' not left unused" varkind var))))
+ (format-message "%s `%S' not left unused" varkind var))))
(pcase vardata
(`((,var . ,_) nil ,_ ,_ nil)
;; FIXME: This gives warnings in the wrong order, with imprecise line
(eq ?_ (aref (symbol-name var) 0))
;; As a special exception, ignore "ignore".
(eq var 'ignored))
- (byte-compile-log-warning (format "Unused lexical %s `%S'"
- varkind var))))
+ (byte-compile-log-warning (format-message "Unused lexical %s `%S'"
+ varkind var))))
;; If it's unused, there's no point converting it into a cons-cell, even if
;; it's captured and mutated.
(`(,binder ,_ t t ,_)
(`(,(and binder `(,_ (function (lambda . ,_)))) nil nil nil t)
(push (cons binder form) cconv-lambda-candidates))))
-(defun cconv--analyse-function (args body env parentform)
+(defun cconv--analyze-function (args body env parentform)
(let* ((newvars nil)
(freevars (list body))
;; We analyze the body within a new environment where all uses are
;; outside of it.
(envcopy
(mapcar (lambda (vdata) (list (car vdata) nil nil nil nil)) env))
+ (byte-compile-bound-variables byte-compile-bound-variables)
(newenv envcopy))
;; Push it before recursing, so cconv-freevars-alist contains entries in
;; the order they'll be used by closure-convert-rec.
(cond
((byte-compile-not-lexical-var-p arg)
(byte-compile-log-warning
- (format "Argument %S is not a lexical variable" arg)))
+ (format "Lexical argument shadows the dynamic variable %S"
+ arg)))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
(t (let ((varstruct (list arg nil nil nil nil)))
+ (cl-pushnew arg byte-compile-lexical-variables)
(push (cons (list arg) (cdr varstruct)) newvars)
(push varstruct newenv)))))
(dolist (form body) ;Analyze body forms.
- (cconv-analyse-form form newenv))
+ (cconv-analyze-form form newenv))
;; Summarize resulting data about arguments.
(dolist (vardata newvars)
- (cconv--analyse-use vardata parentform "argument"))
+ (cconv--analyze-use vardata parentform "argument"))
;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
;; and compute free variables.
(while env
(setf (nth 3 (car env)) t))
(setq env (cdr env) envcopy (cdr envcopy))))))
-(defun cconv-analyse-form (form env)
+(defun cconv-analyze-form (form env)
"Find mutated variables and variables captured by closure.
Analyze lambdas if they are suitable for lambda lifting.
- FORM is a piece of Elisp code after macroexpansion.
(let ((orig-env env)
(newvars nil)
(var nil)
+ (byte-compile-bound-variables byte-compile-bound-variables)
(value nil))
(dolist (binder binders)
(if (not (consp binder))
(setq var (car binder))
(setq value (cadr binder))
- (cconv-analyse-form value (if (eq letsym 'let*) env orig-env)))
+ (cconv-analyze-form value (if (eq letsym 'let*) env orig-env)))
(unless (byte-compile-not-lexical-var-p var)
+ (cl-pushnew var byte-compile-lexical-variables)
(let ((varstruct (list var nil nil nil nil)))
(push (cons binder (cdr varstruct)) newvars)
(push varstruct env))))
(dolist (form body-forms) ; Analyze body forms.
- (cconv-analyse-form form env))
+ (cconv-analyze-form form env))
(dolist (vardata newvars)
- (cconv--analyse-use vardata form "variable"))))
+ (cconv--analyze-use vardata form "variable"))))
(`(function (lambda ,vrs . ,body-forms))
- (cconv--analyse-function vrs body-forms env form))
+ (when (eq :documentation (car-safe (car body-forms)))
+ (cconv-analyze-form (cadr (pop body-forms)) env))
+ (cconv--analyze-function vrs body-forms env form))
(`(setq . ,forms)
;; If a local variable (member of env) is modified by setq then
(while forms
(let ((v (assq (car forms) env))) ; v = non nil if visible
(when v (setf (nth 2 v) t)))
- (cconv-analyse-form (cadr forms) env)
+ (cconv-analyze-form (cadr forms) env)
(setq forms (cddr forms))))
(`((lambda . ,_) . ,_) ; First element is lambda expression.
(byte-compile-log-warning
- "Use of deprecated ((lambda ...) ...) form" t :warning)
+ (format "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form)))
+ t :warning)
(dolist (exp `((function ,(car form)) . ,(cdr form)))
- (cconv-analyse-form exp env)))
+ (cconv-analyze-form exp env)))
(`(cond . ,cond-forms) ; cond special form
(dolist (forms cond-forms)
- (dolist (form forms) (cconv-analyse-form form env))))
+ (dolist (form forms) (cconv-analyze-form form env))))
+
+ ;; ((and `(quote ,v . ,_) (guard (assq v env)))
+ ;; (byte-compile-log-warning
+ ;; (format-message "Possible confusion variable/symbol for `%S'" v)))
(`(quote . ,_) nil) ; quote form
(`(function . ,_) nil) ; same as quote
- (`(condition-case ,var ,protected-form . ,handlers)
+ ((and `(condition-case ,var ,protected-form . ,handlers)
+ (guard byte-compile--use-old-handlers))
;; FIXME: The bytecode for condition-case forces us to wrap the
- ;; form and handlers in closures (for handlers, it's understandable
- ;; but not for the protected form).
- (cconv--analyse-function () (list protected-form) env form)
+ ;; form and handlers in closures.
+ (cconv--analyze-function () (list protected-form) env form)
(dolist (handler handlers)
- (cconv--analyse-function (if var (list var)) (cdr handler) env form)))
-
- ;; FIXME: The bytecode for catch forces us to wrap the body.
- (`(,(or `catch `unwind-protect) ,form . ,body)
- (cconv-analyse-form form env)
- (cconv--analyse-function () body env form))
-
- ;; FIXME: The lack of bytecode for track-mouse forces us to wrap the body.
- ;; `track-mouse' really should be made into a macro.
- (`(track-mouse . ,body)
- (cconv--analyse-function () body env form))
+ (cconv--analyze-function (if var (list var)) (cdr handler)
+ env form)))
+ (`(condition-case ,var ,protected-form . ,handlers)
+ (cconv-analyze-form protected-form env)
+ (when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
+ (byte-compile-log-warning
+ (format "Lexical variable shadows the dynamic variable %S" var)))
+ (let* ((varstruct (list var nil nil nil nil)))
+ (if var (push varstruct env))
+ (dolist (handler handlers)
+ (dolist (form (cdr handler))
+ (cconv-analyze-form form env)))
+ (if var (cconv--analyze-use (cons (list var) (cdr varstruct))
+ form "variable"))))
+
+ ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind.
+ (`(,(or (and `catch (guard byte-compile--use-old-handlers))
+ `unwind-protect)
+ ,form . ,body)
+ (cconv-analyze-form form env)
+ (cconv--analyze-function () body env form))
+
+ (`(defvar ,var) (push var byte-compile-bound-variables))
(`(,(or `defconst `defvar) ,var ,value . ,_)
(push var byte-compile-bound-variables)
- (cconv-analyse-form value env))
+ (cconv-analyze-form value env))
(`(,(or `funcall `apply) ,fun . ,args)
;; Here we ignore fun because funcall and apply are the only two
(let ((fdata (and (symbolp fun) (assq fun env))))
(if fdata
(setf (nth 4 fdata) t)
- (cconv-analyse-form fun env)))
- (dolist (form args) (cconv-analyse-form form env)))
+ (cconv-analyze-form fun env)))
+ (dolist (form args) (cconv-analyze-form form env)))
(`(interactive . ,forms)
;; These appear within the function body but they don't have access
;; We could extend this to allow interactive specs to refer to
;; variables in the function's enclosing environment, but it doesn't
;; seem worth the trouble.
- (dolist (form forms) (cconv-analyse-form form nil)))
+ (dolist (form forms) (cconv-analyze-form form nil)))
- (`(declare . ,_) nil) ;The args don't contain code.
+ ;; `declare' should now be macro-expanded away (and if they're not, we're
+ ;; in trouble because they *can* contain code nowadays).
+ ;; (`(declare . ,_) nil) ;The args don't contain code.
(`(,_ . ,body-forms) ; First element is a function or whatever.
- (dolist (form body-forms) (cconv-analyse-form form env)))
+ (dolist (form body-forms) (cconv-analyze-form form env)))
((pred symbolp)
(let ((dv (assq form env))) ; dv = declared and visible
(when dv
(setf (nth 1 dv) t))))))
+(define-obsolete-function-alias 'cconv-analyse-form 'cconv-analyze-form "25.1")
(provide 'cconv)
;;; cconv.el ends here