;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t; coding: utf-8 -*-
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: lisp
;; Package: emacs
;; This takes a piece of Elisp code, and eliminates all free variables from
;; lambda expressions. The user entry points are cconv-closure-convert and
-;; cconv-closure-convert-toplevel(for toplevel forms).
+;; cconv-closure-convert-toplevel (for toplevel forms).
;; All macros should be expanded beforehand.
;;
;; Here is a brief explanation how this code works.
-;; Firstly, we analyse the tree by calling cconv-analyse-form.
+;; Firstly, we analyze the tree by calling cconv-analyse-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 first and third lists returned by
+;; 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
;; closure.
;; Armed with this data, we call cconv-closure-convert-rec, that rewrites the
-;; tree recursivly, lifting lambdas where possible, building closures where it
+;; tree recursively, lifting lambdas where possible, building closures where it
;; is needed and eliminating mutable variables used in closure.
;;
;; We do following replacements :
;;
;; 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
;; 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 danse.
+;; - make eval-region do the eval-sexp-add-defvars dance.
;; - byte-optimize-form should be applied before cconv.
;; OTOH, the warnings emitted by cconv-analyze need to come before optimize
;; since afterwards they can because obnoxious (warnings about an "unused
;; variable" should not be emitted when the variable use has simply been
;; optimized away).
-;; - turn defun and defmacro into macros (and remove special handling of
-;; `declare' afterwards).
;; - let macros specify that some let-bindings come from the same source,
;; so the unused warning takes all uses into account.
;; - let interactive specs return a function to build the args (to stash into
;; 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,
;; (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)))
;; ,@(mapcar (lambda (binder) (if (consp binder) (cadr binder)))
;; binders)))
-(eval-when-compile (require 'cl))
+(eval-when-compile (require 'cl-lib))
(defconst cconv-liftwhen 6
"Try to do lambda lifting if the number of arguments + free variables
(let ((cconv-freevars-alist '())
(cconv-lambda-candidates '())
(cconv-captured+mutated '()))
- ;; Analyse form - fill these variables with new information.
+ ;; Analyze form - fill these variables with new information.
(cconv-analyse-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-analyse-form form '())
+ ;; But don't perform the closure conversion.
+ form))
(defconst cconv--dummy-var (make-symbol "ignored"))
;; Here we assume that X appears at most once in M.
(let* ((b (assq x m))
(res (if b (remq b m) m)))
- (assert (null (assq x res))) ;; Check the assumption was warranted.
+ (cl-assert (null (assq x res))) ;; Check the assumption was warranted.
res))
(defun cconv--map-diff-set (m s)
(nreverse res)))
(defun cconv--convert-function (args body env parentform)
- (assert (equal body (caar cconv-freevars-alist)))
+ (cl-assert (equal body (caar cconv-freevars-alist)))
(let* ((fvs (cdr (pop cconv-freevars-alist)))
(body-new '())
(letbind '())
;; 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)
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.
EXTEND is a list of variables which might need to be accessed even from places
where they are shadowed, because some part of ENV causes them to be used at
places where they originally did not directly appear."
- (assert (not (delq nil (mapcar (lambda (mapping)
- (if (eq (cadr mapping) 'apply-partially)
- (cconv--set-diff (cdr (cddr mapping))
- extend)))
- env))))
+ (cl-assert (not (delq nil (mapcar (lambda (mapping)
+ (if (eq (cadr mapping) 'apply-partially)
+ (cconv--set-diff (cdr (cddr mapping))
+ extend)))
+ env))))
;; What's the difference between fvrs and envs?
;; Suppose that we have the code
(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 "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
- (assert (and (eq (car value) 'function)
- (eq (car (cadr value)) 'lambda)))
- (assert (equal (cddr (cadr value))
- (caar cconv-freevars-alist)))
+ (cl-assert (and (eq (car value) 'function)
+ (eq (car (cadr value)) 'lambda)))
+ (cl-assert (equal (cddr (cadr value))
+ (caar cconv-freevars-alist)))
;; Peek at the freevars to decide whether to λ-lift.
(let* ((fvs (cdr (car cconv-freevars-alist)))
(fun (cadr value))
(funcbody-env ()))
(push `(,var . (apply-partially ,var . ,fvs)) new-env)
(dolist (fv fvs)
- (pushnew fv new-extend)
- (if (and (eq 'car (car-safe (cdr (assq fv env))))
+ (cl-pushnew fv new-extend)
+ (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.
(mapcar (lambda (mapping)
(if (not (eq (cadr mapping) 'apply-partially))
mapping
- (assert (eq (car mapping) (nth 2 mapping)))
- (list* (car mapping)
- 'apply-partially
- (car mapping)
- (mapcar (lambda (arg)
- (if (eq var arg)
- closedsym arg))
- (nthcdr 3 mapping)))))
+ (cl-assert (eq (car mapping) (nth 2 mapping)))
+ `(,(car mapping)
+ apply-partially
+ ,(car mapping)
+ ,@(mapcar (lambda (arg)
+ (if (eq var arg)
+ closedsym arg))
+ (nthcdr 3 mapping)))))
new-env))
(setq new-extend (remq var new-extend))
(push closedsym new-extend)
. ,(mapcar (lambda (form) (cconv-convert form env extend))
forms)))
- ;defun, defmacro
- (`(,(and sym (or `defun `defmacro))
- ,func ,args . ,body)
- (assert (equal body (caar cconv-freevars-alist)))
- (assert (null (cdar cconv-freevars-alist)))
-
- (let ((new (cconv--convert-function args body env form)))
- (pcase new
- (`(function (lambda ,newargs . ,new-body))
- (assert (equal args newargs))
- `(,sym ,func ,args . ,new-body))
- (t (byte-compile-report-error
- (format "Internal error in cconv of (%s %s ...)" sym func))))))
-
;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)))
(value (cconv-convert (pop forms) env extend)))
(push (pcase sym-new
((pred symbolp) `(setq ,sym-new ,value))
- (`(car ,iexp) `(setcar ,iexp ,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.
(let ((mapping (cdr (assq fun env))))
(pcase mapping
(`(apply-partially ,_ . ,(and fvs `(,_ . ,_)))
- (assert (eq (cadr mapping) fun))
+ (cl-assert (eq (cadr mapping) fun))
`(,callsym ,fun
,@(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)
- "Analyse the use of a variable.
+ "Analyze the use of a variable.
VARDATA should be (BINDER READ MUTATED CAPTURED CALLED).
VARKIND is the name of the kind of variable.
FORM is the parent form that binds this var."
;; 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) ;Analyse body forms.
+ (dolist (form body) ;Analyze body forms.
(cconv-analyse-form form newenv))
;; Summarize resulting data about arguments.
(dolist (vardata newvars)
;; Transfer uses collected in `envcopy' (via `newenv') back to `env';
;; and compute free variables.
(while env
- (assert (and envcopy (eq (caar env) (caar envcopy))))
+ (cl-assert (and envcopy (eq (caar env) (caar envcopy))))
(let ((free nil)
(x (cdr (car env)))
(y (cdr (car envcopy))))
(defun cconv-analyse-form (form env)
"Find mutated variables and variables captured by closure.
-Analyse lambdas if they are suitable for lambda lifting.
+Analyze lambdas if they are suitable for lambda lifting.
- FORM is a piece of Elisp code after macroexpansion.
- ENV is an alist mapping each enclosing lexical variable to its info.
I.e. each element has the form (VAR . (READ MUTATED CAPTURED CALLED)).
(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))
(cconv-analyse-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) ; Analyse body forms.
+ (dolist (form body-forms) ; Analyze body forms.
(cconv-analyse-form form env))
(dolist (vardata newvars)
(cconv--analyse-use vardata form "variable"))))
- ; defun special form
- (`(,(or `defun `defmacro) ,func ,vrs . ,body-forms)
- (when env
- (byte-compile-log-warning
- (format "Function %S will ignore its context %S"
- func (mapcar #'car env))
- t :warning))
- (cconv--analyse-function vrs body-forms nil form))
-
(`(function (lambda ,vrs . ,body-forms))
(cconv--analyse-function vrs body-forms env form))
(cconv-analyse-form (cadr forms) env)
(setq forms (cddr forms))))
- (`((lambda . ,_) . ,_) ; first element is lambda expression
+ (`((lambda . ,_) . ,_) ; First element is lambda expression.
+ (byte-compile-log-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)))
(`(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).
+ ;; form and handlers in closures.
(cconv--analyse-function () (list protected-form) env form)
(dolist (handler handlers)
- (cconv--analyse-function (if var (list var)) (cdr handler) env form)))
+ (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)
+ (`(condition-case ,var ,protected-form . ,handlers)
+ (cconv-analyse-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-analyse-form form env)))
+ (if var (cconv--analyse-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-analyse-form form env)
(cconv--analyse-function () body env form))
(`(track-mouse . ,body)
(cconv--analyse-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))
;; seem worth the trouble.
(dolist (form forms) (cconv-analyse-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)))