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> 2011-02-10 Igor Kuzmin <kuzminig@iro.umontreal.ca>
* emacs-lisp/cconv.el: New file. * emacs-lisp/cconv.el: New file.

89
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) (defun byte-compile-catch (form)
(byte-compile-form (car (cdr 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-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)) (byte-compile-out 'byte-catch 0))
(defun byte-compile-unwind-protect (form) (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-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-out 'byte-unwind-protect 0)
(byte-compile-form-do-effect (car (cdr form))) (byte-compile-form-do-effect (car (cdr form)))
(byte-compile-out 'byte-unbind 1)) (byte-compile-out 'byte-unbind 1))
(defun byte-compile-track-mouse (form) (defun byte-compile-track-mouse (form)
(byte-compile-form (byte-compile-form
;; Use quote rather that #' here, because we don't want to go (pcase form
;; through the body again, which would lead to an infinite recursion: (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f))))
;; "byte-compile-track-mouse" (0xbffc98e4) (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form))))))))
;; "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)))))))
(defun byte-compile-condition-case (form) (defun byte-compile-condition-case (form)
(let* ((var (nth 1 form)) (let* ((var (nth 1 form))
(byte-compile-bound-variables (byte-compile-bound-variables
(if var (cons var 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) (byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var) (unless (symbolp var)
(byte-compile-warn (byte-compile-warn
"`%s' is not a variable-name or nil (in condition-case)" var)) "`%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 var)
(byte-compile-push-constant (byte-compile-top-level (if fun-bodies
(nth 2 form) for-effect)) (byte-compile-form `(list 'funcall ,(nth 2 form)))
(let ((clauses (cdr (cdr (cdr form)))) (byte-compile-push-constant
compiled-clauses) (byte-compile-top-level (nth 2 form) for-effect)))
(while clauses (let ((compiled-clauses
(let* ((clause (car clauses)) (mapcar
(condition (car clause))) (lambda (clause)
(let ((condition (car clause)))
(cond ((not (or (symbolp condition) (cond ((not (or (symbolp condition)
(and (listp condition) (and (listp condition)
(let ((syms condition) (ok t)) (let ((ok t))
(while syms (dolist (sym condition)
(if (not (symbolp (car syms))) (if (not (symbolp sym))
(setq ok nil)) (setq ok nil)))
(setq syms (cdr syms)))
ok)))) ok))))
(byte-compile-warn (byte-compile-warn
"`%s' is not a condition name or list of such (in condition-case)" "`%S' is not a condition name or list of such (in condition-case)"
(prin1-to-string condition))) condition))
;; ((not (or (eq condition 't) ;; (not (or (eq condition 't)
;; (and (stringp (get condition 'error-message)) ;; (and (stringp (get condition 'error-message))
;; (consp (get condition 'error-conditions))))) ;; (consp (get condition
;; 'error-conditions)))))
;; (byte-compile-warn ;; (byte-compile-warn
;; "`%s' is not a known condition name (in condition-case)" ;; "`%s' is not a known condition name
;; (in condition-case)"
;; condition)) ;; condition))
) )
(push (cons condition (if fun-bodies
`(list ',condition (list 'funcall ,(cadr clause) ',var))
(cons condition
(byte-compile-top-level-body (byte-compile-top-level-body
(cdr clause) for-effect)) (cdr clause) for-effect)))))
compiled-clauses)) (cdr (cdr (cdr form))))))
(setq clauses (cdr clauses))) (if fun-bodies
(byte-compile-push-constant (nreverse compiled-clauses))) (byte-compile-form `(list ,@compiled-clauses))
(byte-compile-push-constant compiled-clauses)))
(byte-compile-out 'byte-condition-case 0))) (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)) (byte-compile-out 'byte-unbind 1))
(defun byte-compile-save-window-excursion (form) (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-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)) (byte-compile-out 'byte-save-window-excursion 0))
(defun byte-compile-with-output-to-temp-buffer (form) (defun byte-compile-with-output-to-temp-buffer (form)

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

@ -1,14 +1,33 @@
;;; -*- lexical-binding: t -*- ;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*-
;;; cconv.el --- Closure conversion for statically scoped Emacs lisp.
;; 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: ;;; Commentary:
;; This takes a piece of Elisp code, and eliminates all free variables from ;; This takes a piece of Elisp code, and eliminates all free variables from
;; lambda expressions. The user entry points are cconv-closure-convert and ;; 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. ;; All macros should be expanded beforehand.
;; ;;
;; Here is a brief explanation how this code works. ;; Here is a brief explanation how this code works.
;; Firstly, we analyse the tree by calling cconv-analyse-form. ;; Firstly, we analyse the tree by calling cconv-analyse-form.
@ -28,19 +47,19 @@
;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .) ;; (lambda (v1 ...) ... fv1 fv2 ...) => (lambda (v1 ... fv1 fv2 ) ... fv1 fv2 .)
;; if the function is suitable for lambda lifting (if all calls are known) ;; 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) ;; (curry (lambda (env v1 ...) ... env ...) env)
;; if the function has only 1 free variable ;; if the function has only 1 free variable
;; ;;
;; and finally ;; and finally
;; (function (lambda (v1 ...) ... fv1 fv2 ...)) => ;; (lambda (v1 ...) ... fv1 fv2 ...) =>
;; (curry (lambda (env v1 ..) .. (aref env 0) (aref env 1) ..) (vector 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 function has no free variables, we don't do anything.
;; ;;
;; If the variable is mutable(updated by setq), and it is used in closure ;; If a variable is mutated (updated by setq), and it is used in a closure
;; we wrap it's definition with list: (list var) and we also replace ;; we wrap it's definition with list: (list val) and we also replace
;; var => (car var) wherever this variable is used, and also ;; var => (car var) wherever this variable is used, and also
;; (setq var value) => (setcar var value) where it is updated. ;; (setq var value) => (setcar var value) where it is updated.
;; ;;
@ -49,29 +68,23 @@
;; (defun foo (... mutable-arg ...) ...) => ;; (defun foo (... mutable-arg ...) ...) =>
;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...)) ;; (defun foo (... m-arg ...) (let ((m-arg (list m-arg))) ...))
;; ;;
;;
;;
;;
;;
;;; Code: ;;; Code:
(require 'pcase)
(eval-when-compile (require 'cl)) (eval-when-compile (require 'cl))
(defconst cconv-liftwhen 3 (defconst cconv-liftwhen 3
"Try to do lambda lifting if the number of arguments + free variables "Try to do lambda lifting if the number of arguments + free variables
is less than this number.") is less than this number.")
(defvar cconv-mutated (defvar cconv-mutated nil
"List of mutated variables in current form") "List of mutated variables in current form")
(defvar cconv-captured (defvar cconv-captured nil
"List of closure captured variables in current form") "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.") "An intersection between cconv-mutated and cconv-captured lists.")
(defvar cconv-lambda-candidates (defvar cconv-lambda-candidates nil
"List of candidates for lambda lifting") "List of candidates for lambda lifting")
(defun cconv-freevars (form &optional fvrs) (defun cconv-freevars (form &optional fvrs)
"Find all free variables of given form. "Find all free variables of given form.
Arguments: Arguments:
@ -89,11 +102,11 @@ Returns a list of free variables."
;; free variables of body-forms excluding v1, v2 ... ;; free variables of body-forms excluding v1, v2 ...
;; and so on. ;; 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 ;; 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). ;; of union of two sets - for performance reasons).
(pcase form (pcase form
(`(let ,varsvalues . ,body-forms) ; let special form (`(let ,varsvalues . ,body-forms) ; let special form
@ -101,19 +114,17 @@ Returns a list of free variables."
(dolist (exp body-forms) (dolist (exp body-forms)
(setq fvrs-1 (cconv-freevars exp fvrs-1))) (setq fvrs-1 (cconv-freevars exp fvrs-1)))
(dolist (elm varsvalues) (dolist (elm varsvalues)
(if (listp elm) (setq fvrs-1 (delq (if (consp elm) (car elm) elm) fvrs-1)))
(setq fvrs-1 (delq (car elm) fvrs-1)) (setq fvrs (nconc fvrs-1 fvrs))
(setq fvrs-1 (delq elm fvrs-1))))
(setq fvrs (append fvrs fvrs-1))
(dolist (exp varsvalues) (dolist (exp varsvalues)
(when (listp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs)))) (when (consp exp) (setq fvrs (cconv-freevars (cadr exp) fvrs))))
fvrs)) fvrs))
(`(let* ,varsvalues . ,body-forms) ; let* special form (`(let* ,varsvalues . ,body-forms) ; let* special form
(let ((vrs '()) (let ((vrs '())
(fvrs-1 '())) (fvrs-1 '()))
(dolist (exp varsvalues) (dolist (exp varsvalues)
(if (listp exp) (if (consp exp)
(progn (progn
(setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)) (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))
(dolist (elm vrs) (setq fvrs-1 (delq elm 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
(`(condition-case ,var ,protected-form . ,conditions-bodies) (`(condition-case ,var ,protected-form . ,conditions-bodies)
(let ((fvrs-1 '())) (let ((fvrs-1 '()))
(setq fvrs-1 (cconv-freevars protected-form '()))
(dolist (exp conditions-bodies) (dolist (exp conditions-bodies)
(setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1))) (setq fvrs-1 (cconv-freevars (cadr exp) fvrs-1)))
(setq fvrs-1 (delq var fvrs-1)) (setq fvrs-1 (delq var fvrs-1))
(setq fvrs-1 (cconv-freevars protected-form fvrs-1))
(append fvrs fvrs-1))) (append fvrs fvrs-1)))
(`(,(and sym (or `defun `defconst `defvar)) . ,_) (`(,(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 (_ (if (or (not (symbolp form)) ; form is not a list
(special-variable-p form) (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)) (memq form '(nil t))
(keywordp form)) (keywordp form))
fvrs fvrs
@ -557,8 +573,8 @@ Returns a form where all lambdas don't have any free variables."
`(,sym ,definedsymbol . ,body-forms-new)) `(,sym ,definedsymbol . ,body-forms-new))
(error "Invalid form: %s inside a function" sym))) (error "Invalid form: %s inside a function" sym)))
;defun, defmacro, defsubst ;defun, defmacro
(`(,(and sym (or `defun `defmacro `defsubst)) (`(,(and sym (or `defun `defmacro))
,func ,vars . ,body-forms) ,func ,vars . ,body-forms)
(if defs-are-legal (if defs-are-legal
(let ((body-new '()) ; the whole body (let ((body-new '()) ; the whole body
@ -835,7 +851,7 @@ Initially false"
(cconv-analyse-form (cadr exp) vars inclosure)) (cconv-analyse-form (cadr exp) vars inclosure))
nil) nil)
(`(,(or `defconst `defvar `defsubst) ,value) (`(,(or `defconst `defvar) ,value)
(cconv-analyse-form value vars inclosure)) (cconv-analyse-form value vars inclosure))
(`(,(or `funcall `apply) ,fun . ,args) (`(,(or `funcall `apply) ,fun . ,args)