procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/emacs-lisp/bytecomp.el (byte-compile-catch)

Browse source 
(byte-compile-unwind-protect, byte-compile-track-mouse)
(byte-compile-condition-case, byte-compile-save-window-excursion):
Provide a :fun-body alternative, so that info can be propagated from the
surrounding context, as is the case for lexical scoping.

* lisp/emacs-lisp/cconv.el (cconv-mutated, cconv-captured)
(cconv-captured+mutated, cconv-lambda-candidates): Fix up declaration.
(cconv-freevars): Minor cleanup.  Fix handling of the error var in
condition-case.
This commit is contained in:
Stefan Monnier 2011-02-10 18:37:03 -05:00
parent 94d11cb577
commit d779e73c22
3 changed files with 805 additions and 769 deletions
Download patch file Download diff file Expand all files Collapse all files

13
lisp/ChangeLog
View file

@ -1,3 +1,16 @@
2011-02-10 Stefan Monnier <monnier@iro.umontreal.ca>
* emacs-lisp/cconv.el (cconv-mutated, cconv-captured)
(cconv-captured+mutated, cconv-lambda-candidates): Fix up declaration.
(cconv-freevars): Minor cleanup. Fix handling of the error var in
condition-case.
* emacs-lisp/bytecomp.el (byte-compile-catch)
(byte-compile-unwind-protect, byte-compile-track-mouse)
(byte-compile-condition-case, byte-compile-save-window-excursion):
Provide a :fun-body alternative, so that info can be propagated from the
surrounding context, as is the case for lexical scoping.
2011-02-10 Igor Kuzmin <kuzminig@iro.umontreal.ca>
* emacs-lisp/cconv.el: New file.

95
lisp/emacs-lisp/bytecomp.el
View file

@ -4076,76 +4076,79 @@ if LFORMINFO is nil (meaning all bindings are dynamic)."
(defun byte-compile-catch (form)
(byte-compile-form (car (cdr form)))
(pcase (cddr form)
(`(:fun-body ,f)
(byte-compile-form `(list 'funcall ,f)))
(body
(byte-compile-push-constant
(byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect))
(byte-compile-top-level (cons 'progn body) for-effect))))
(byte-compile-out 'byte-catch 0))
(defun byte-compile-unwind-protect (form)
(pcase (cddr form)
(`(:fun-body ,f)
(byte-compile-form `(list (list 'funcall ,f))))
(handlers
(byte-compile-push-constant
(byte-compile-top-level-body (cdr (cdr form)) t))
(byte-compile-top-level-body handlers t))))
(byte-compile-out 'byte-unwind-protect 0)
(byte-compile-form-do-effect (car (cdr form)))
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-track-mouse (form)
(byte-compile-form
;; Use quote rather that #' here, because we don't want to go
;; through the body again, which would lead to an infinite recursion:
;; "byte-compile-track-mouse" (0xbffc98e4)
;; "byte-compile-form" (0xbffc9c54)
;; "byte-compile-top-level" (0xbffc9fd4)
;; "byte-compile-lambda" (0xbffca364)
;; "byte-compile-closure" (0xbffca6d4)
;; "byte-compile-function-form" (0xbffcaa44)
;; "byte-compile-form" (0xbffcadc0)
;; "mapc" (0xbffcaf74)
;; "byte-compile-funcall" (0xbffcb2e4)
;; "byte-compile-form" (0xbffcb654)
;; "byte-compile-track-mouse" (0xbffcb9d4)
`(funcall '(lambda nil
(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))
(pcase form
(`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f))))
(_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form))))))))
(defun byte-compile-condition-case (form)
(let* ((var (nth 1 form))
(byte-compile-bound-variables
(if var (cons var byte-compile-bound-variables)
byte-compile-bound-variables)))
byte-compile-bound-variables))
(fun-bodies (eq var :fun-body)))
(byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
(byte-compile-warn
"`%s' is not a variable-name or nil (in condition-case)" var))
(if fun-bodies (setq var (make-symbol "err")))
(byte-compile-push-constant var)
(byte-compile-push-constant (byte-compile-top-level
(nth 2 form) for-effect))
(let ((clauses (cdr (cdr (cdr form))))
compiled-clauses)
(while clauses
(let* ((clause (car clauses))
(condition (car clause)))
(if fun-bodies
(byte-compile-form `(list 'funcall ,(nth 2 form)))
(byte-compile-push-constant
(byte-compile-top-level (nth 2 form) for-effect)))
(let ((compiled-clauses
(mapcar
(lambda (clause)
(let ((condition (car clause)))
(cond ((not (or (symbolp condition)
(and (listp condition)
(let ((syms condition) (ok t))
(while syms
(if (not (symbolp (car syms)))
(setq ok nil))
(setq syms (cdr syms)))
(let ((ok t))
(dolist (sym condition)
(if (not (symbolp sym))
(setq ok nil)))
ok))))
(byte-compile-warn
"`%s' is not a condition name or list of such (in condition-case)"
(prin1-to-string condition)))
;; ((not (or (eq condition 't)
;; (and (stringp (get condition 'error-message))
;; (consp (get condition 'error-conditions)))))
;; (byte-compile-warn
;; "`%s' is not a known condition name (in condition-case)"
;; condition))
"`%S' is not a condition name or list of such (in condition-case)"
condition))
;; (not (or (eq condition 't)
;; (and (stringp (get condition 'error-message))
;; (consp (get condition
;; 'error-conditions)))))
;; (byte-compile-warn
;; "`%s' is not a known condition name
;; (in condition-case)"
;; condition))
)
(push (cons condition
(if fun-bodies
`(list ',condition (list 'funcall ,(cadr clause) ',var))
(cons condition
(byte-compile-top-level-body
(cdr clause) for-effect))
compiled-clauses))
(setq clauses (cdr clauses)))
(byte-compile-push-constant (nreverse compiled-clauses)))
(cdr clause) for-effect)))))
(cdr (cdr (cdr form))))))
(if fun-bodies
(byte-compile-form `(list ,@compiled-clauses))
(byte-compile-push-constant compiled-clauses)))
(byte-compile-out 'byte-condition-case 0)))
@ -4168,8 +4171,12 @@ if LFORMINFO is nil (meaning all bindings are dynamic)."
(byte-compile-out 'byte-unbind 1))
(defun byte-compile-save-window-excursion (form)
(pcase (cdr form)
(`(:fun-body ,f)
(byte-compile-form `(list (list 'funcall ,f))))
(body
(byte-compile-push-constant
(byte-compile-top-level-body (cdr form) for-effect))
(byte-compile-top-level-body body for-effect))))
(byte-compile-out 'byte-save-window-excursion 0))
(defun byte-compile-with-output-to-temp-buffer (form)

82
lisp/emacs-lisp/cconv.el
View file

@ -1,14 +1,33 @@
;;; -*- lexical-binding: t -*-
;;; cconv.el --- Closure conversion for statically scoped Emacs lisp.
;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*-
;; licence stuff will be added later(I don't know yet what to write here)
;; Copyright (C) 2011 Free Software Foundation, Inc.
;; Author: Igor Kuzmin <kzuminig@iro.umontreal.ca>
;; Maintainer: FSF
;; Keywords: lisp
;; Package: emacs
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; 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).
;; All macros should be expanded.
;; 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.
@ -28,19 +47,19 @@
;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .)
;; if the function is suitable for lambda lifting (if all calls are known)
;;
;; (function (lambda (v1 ...) ... fv ...)) =>
;; (lambda (v1 ...) ... fv ...) =>
;; (curry (lambda (env v1 ...) ... env ...) env)
;; if the function has only 1 free variable
;;
;; and finally
;; (function (lambda (v1 ...) ... fv1 fv2 ...)) =>
;; (lambda (v1 ...) ... fv1 fv2 ...) =>
;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector fv1 fv2))
;; if the function has 2 or more free variables
;; if the function has 2 or more free variables.
;;
;; If the function has no free variables, we don't do anything.
;;
;; If the variable is mutable(updated by setq), and it is used in closure
;; we wrap it's definition with list: (list var) and we also replace
;; If a variable is mutated (updated by setq), and it is used in a closure
;; we wrap it's definition with list: (list val) and we also replace
;; var => (car var) wherever this variable is used, and also
;; (setq var value) => (setcar var value) where it is updated.
;;
@ -49,29 +68,23 @@
;; (defun foo (... mutable-arg ...) ...) =>
;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...))
;;
;;
;;
;;
;;
;;; Code:
(require 'pcase)
(eval-when-compile (require 'cl))
(defconst cconv-liftwhen 3
"Try to do lambda lifting if the number of arguments + free variables
is less than this number.")
(defvar cconv-mutated
(defvar cconv-mutated nil
"List of mutated variables in current form")
(defvar cconv-captured
(defvar cconv-captured nil
"List of closure captured variables in current form")
(defvar cconv-captured+mutated
(defvar cconv-captured+mutated nil
"An intersection between cconv-mutated and cconv-captured lists.")
(defvar cconv-lambda-candidates
(defvar cconv-lambda-candidates nil
"List of candidates for lambda lifting")
(defun cconv-freevars (form &optional fvrs)
"Find all free variables of given form.
Arguments:
@ -89,11 +102,11 @@ Returns a list of free variables."
;; free variables of body-forms excluding v1, v2 ...
;; and so on.
;; a list of free variables already found(FVRS) is passed in parameter
;; A list of free variables already found(FVRS) is passed in parameter
;; to try to use cons or push where possible, and to minimize the usage
;; of append
;; of append.
;; This function can contain duplicates(because we use 'append instead
;; This function can return duplicates (because we use 'append instead
;; of union of two sets - for performance reasons).
(pcase form
(`(let ,varsvalues . ,body-forms) ; let special form
@ -101,19 +114,17 @@ Returns a list of free variables."
(dolist (exp body-forms)
(setq fvrs-1 (cconv-freevars exp fvrs-1)))
(dolist (elm varsvalues)
(if (listp elm)
(setq fvrs-1 (delq (car elm) fvrs-1))
(setq fvrs-1 (delq elm fvrs-1))))
(setq fvrs (append fvrs fvrs-1))
(setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1)))
(setq fvrs (nconc fvrs-1 fvrs))
(dolist (exp varsvalues)
(when (listp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs))))
(when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs))))
fvrs))
(`(let* ,varsvalues . ,body-forms) ; let* special form
(let ((vrs '())
(fvrs-1 '()))
(dolist (exp varsvalues)
(if (listp exp)
(if (consp exp)
(progn
(setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))
(dolist (elm vrs) (setq fvrs-1 (delq elm fvrs-1)))
@ -148,10 +159,10 @@ Returns a list of free variables."
;condition-case
(`(condition-case ,var ,protected-form . ,conditions-bodies)
(let ((fvrs-1 '()))
(setq fvrs-1 (cconv-freevars protected-form '()))
(dolist (exp conditions-bodies)
(setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)))
(setq fvrs-1 (delq var fvrs-1))
(setq fvrs-1 (cconv-freevars protected-form fvrs-1))
(append fvrs fvrs-1)))
(`(,(and sym (or `defun `defconst `defvar)) . ,_)
@ -166,6 +177,11 @@ Returns a list of free variables."
(_ (if (or (not (symbolp form)) ; form is not a list
(special-variable-p form)
;; byte-compile-bound-variables normally holds both the
;; dynamic and lexical vars, but the bytecomp.el should
;; only call us at the top-level so there shouldn't be
;; any lexical vars in it here.
(memq form byte-compile-bound-variables)
(memq form '(nil t))
(keywordp form))
fvrs
@ -238,7 +254,7 @@ Returns a form where all lambdas don't have any free variables."
;; Because in envs the order of variables is important. We use this list
;; to find the number of a specific variable in the environment vector,
;; so we never touch it(unless we enter to the other closure).
;;(if (listp form) (print (car form)) form)
;;(if (listp form) (print (car form)) form)
(pcase form
(`(,(and letsym (or `let* `let)) ,varsvalues . ,body-forms)
@ -557,8 +573,8 @@ Returns a form where all lambdas don't have any free variables."
`(,sym ,definedsymbol . ,body-forms-new))
(error "Invalid form: %s inside a function" sym)))
;defun, defmacro, defsubst
(`(,(and sym (or `defun `defmacro `defsubst))
;defun, defmacro
(`(,(and sym (or `defun `defmacro))
,func ,vars . ,body-forms)
(if defs-are-legal
(let ((body-new '()) ; the whole body
@ -835,7 +851,7 @@ Initially false"
(cconv-analyse-form (cadr exp) vars inclosure))
nil)
(`(,(or `defconst `defvar `defsubst) ,value)
(`(,(or `defconst `defvar) ,value)
(cconv-analyse-form value vars inclosure))
(`(,(or `funcall `apply) ,fun . ,args)