diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/byte-lexbind.el | 696 | ||||
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 263 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 879 | ||||
| -rw-r--r-- | lisp/emacs-lisp/disass.el | 15 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 10 |
5 files changed, 1578 insertions, 285 deletions
diff --git a/lisp/emacs-lisp/byte-lexbind.el b/lisp/emacs-lisp/byte-lexbind.el new file mode 100644 index 00000000000..df463c17549 --- /dev/null +++ b/lisp/emacs-lisp/byte-lexbind.el @@ -0,0 +1,696 @@ +;;; byte-lexbind.el --- Lexical binding support for byte-compiler +;; +;; Copyright (C) 2001, 2002, 2010 Free Software Foundation, Inc. +;; +;; Author: Miles Bader <miles@gnu.org> +;; Keywords: lisp, compiler, lexical binding + +;; 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, 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; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; + +;;; Code: + +(require 'bytecomp-preload "bytecomp") + +;; Downward closures aren't implemented yet, so this should always be nil +(defconst byte-compile-use-downward-closures nil + "If true, use `downward closures', which are closures that don't cons.") + +(defconst byte-compile-save-window-excursion-uses-eval t + "If true, the bytecode for `save-window-excursion' uses eval. +This means that the body of the form must be put into a closure.") + +(defun byte-compile-arglist-vars (arglist) + "Return a list of the variables in the lambda argument list ARGLIST." + (remq '&rest (remq '&optional arglist))) + + +;;; Variable extent analysis. + +;; A `lforminfo' holds information about lexical bindings in a form, and some +;; other info for analysis. It is a cons-cell, where the car is a list of +;; `lvarinfo' stuctures, which form an alist indexed by variable name, and the +;; cdr is the number of closures found in the form: +;; +;; LFORMINFO : ((LVARINFO ...) . NUM-CLOSURES)" +;; +;; A `lvarinfo' holds information about a single lexical variable. It is a +;; list whose car is the variable name (so an lvarinfo is suitable as an alist +;; entry), and the rest of the of which holds information about the variable: +;; +;; LVARINFO : (VAR NUM-REFS NUM-SETS CLOSED-OVER) +;; +;; NUM-REFS is the number of times the variable's value is used +;; NUM-SETS is the number of times the variable's value is set +;; CLOSED-OVER is non-nil if the variable is referenced +;; anywhere but in its original function-level" + +;;; lvarinfo: + +;; constructor +(defsubst byte-compile-make-lvarinfo (var &optional already-set) + (list var 0 (if already-set 1 0) 0 nil)) +;; accessors +(defsubst byte-compile-lvarinfo-var (vinfo) (car vinfo)) +(defsubst byte-compile-lvarinfo-num-refs (vinfo) (cadr vinfo)) +(defsubst byte-compile-lvarinfo-num-sets (vinfo) (nth 3 vinfo)) +(defsubst byte-compile-lvarinfo-closed-over-p (vinfo) (nth 4 vinfo)) +;; setters +(defsubst byte-compile-lvarinfo-note-ref (vinfo) + (setcar (cdr vinfo) (1+ (cadr vinfo)))) +(defsubst byte-compile-lvarinfo-note-set (vinfo) + (setcar (cddr vinfo) (1+ (nth 3 vinfo)))) +(defsubst byte-compile-lvarinfo-note-closure (vinfo) + (setcar (nthcdr 4 vinfo) t)) + +;;; lforminfo: + +;; constructor +(defsubst byte-compile-make-lforminfo () + (cons nil 0)) +;; accessors +(defalias 'byte-compile-lforminfo-vars 'car) +(defalias 'byte-compile-lforminfo-num-closures 'cdr) +;; setters +(defsubst byte-compile-lforminfo-add-var (finfo var &optional already-set) + (setcar finfo (cons (byte-compile-make-lvarinfo var already-set) + (car finfo)))) + +(defun byte-compile-lforminfo-make-closure-flag () + "Return a new `closure-flag'." + (cons nil nil)) + +(defsubst byte-compile-lforminfo-note-closure (lforminfo lvarinfo closure-flag) + "If a variable reference or definition is inside a closure, record that fact. +LFORMINFO describes the form currently being analyzed, and LVARINFO +describes the variable. CLOSURE-FLAG is either nil, if currently _not_ +inside a closure, and otherwise a `closure flag' returned by +`byte-compile-lforminfo-make-closure-flag'." + (when closure-flag + (byte-compile-lvarinfo-note-closure lvarinfo) + (unless (car closure-flag) + (setcdr lforminfo (1+ (cdr lforminfo))) + (setcar closure-flag t)))) + +(defun byte-compile-compute-lforminfo (form &optional special) + "Return information about variables lexically bound by FORM. +SPECIAL is a list of variables that are special, and so shouldn't be +bound lexically (in addition to variable that are considered special +because they are declared with `defvar', et al). + +The result is an `lforminfo' data structure." + (and + (consp form) + (let ((lforminfo (byte-compile-make-lforminfo))) + (cond ((eq (car form) 'let) + ;; Find the bound variables + (dolist (clause (cadr form)) + (let ((var (if (consp clause) (car clause) clause))) + (unless (or (special-variable-p var) (memq var special)) + (byte-compile-lforminfo-add-var lforminfo var t)))) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + special nil))) + ((eq (car form) 'let*) + (dolist (clause (cadr form)) + (let ((var (if (consp clause) (car clause) clause))) + ;; Analyze each initializer based on the previously + ;; bound variables. + (when (and (consp clause) lforminfo) + (byte-compile-lforminfo-analyze lforminfo (cadr clause) + special nil)) + (unless (or (special-variable-p var) (memq var special)) + (byte-compile-lforminfo-add-var lforminfo var t)))) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + special nil))) + ((eq (car form) 'condition-case) + ;; `condition-case' currently must dynamically bind the + ;; error variable, so do nothing. + ) + ((memq (car form) '(defun defmacro)) + (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special)) + ((eq (car form) 'lambda) + (byte-compile-lforminfo-from-lambda lforminfo form special)) + ((and (consp (car form)) (eq (caar form) 'lambda)) + ;; An embedded lambda, which is basically just a `let' + (byte-compile-lforminfo-from-lambda lforminfo (cdr form) special))) + (if (byte-compile-lforminfo-vars lforminfo) + lforminfo + nil)))) + +(defun byte-compile-lforminfo-from-lambda (lforminfo lambda special) + "Initialize LFORMINFO from the lambda expression LAMBDA. +SPECIAL is a list of variables to ignore. +The first element of LAMBDA is ignored; it need not actually be `lambda'." + ;; Add the arguments + (dolist (arg (byte-compile-arglist-vars (cadr lambda))) + (byte-compile-lforminfo-add-var lforminfo arg t)) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze-forms lforminfo lambda 2 special nil))) + +(defun byte-compile-lforminfo-analyze (lforminfo form &optional ignore closure-flag) + "Update variable information in LFORMINFO by analyzing FORM. +IGNORE is a list of variables that shouldn't be analyzed (usually because +they're special, or because some inner binding shadows the version in +LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created +with `byte-compile-lforminfo-make-closure-flag'; the latter indicates that +FORM is inside a lambda expression that may close over some variable in +LFORMINFO." + (cond ((symbolp form) + ;; variable reference + (unless (member form ignore) + (let ((vinfo (assq form (byte-compile-lforminfo-vars lforminfo)))) + (when vinfo + (byte-compile-lvarinfo-note-ref vinfo) + (byte-compile-lforminfo-note-closure lforminfo vinfo + closure-flag))))) + ;; function call/special form + ((consp form) + (let ((fun (car form))) + (cond + ((eq fun 'setq) + (pop form) + (while form + (let ((var (pop form))) + (byte-compile-lforminfo-analyze lforminfo (pop form) + ignore closure-flag) + (unless (member var ignore) + (let ((vinfo + (assq var (byte-compile-lforminfo-vars lforminfo)))) + (when vinfo + (byte-compile-lvarinfo-note-set vinfo) + (byte-compile-lforminfo-note-closure lforminfo vinfo + closure-flag))))))) + ((eq fun 'catch) + ;; tag + (byte-compile-lforminfo-analyze lforminfo (cadr form) + ignore closure-flag) + ;; `catch' uses a closure for the body + (byte-compile-lforminfo-analyze-forms + lforminfo form 2 + ignore + (or closure-flag + (and (not byte-compile-use-downward-closures) + (byte-compile-lforminfo-make-closure-flag))))) + ((eq fun 'cond) + (byte-compile-lforminfo-analyze-clauses lforminfo (cdr form) 0 + ignore closure-flag)) + ((eq fun 'condition-case) + ;; `condition-case' separates its body/handlers into + ;; separate closures. + (unless (or closure-flag byte-compile-use-downward-closures) + ;; condition case is implemented by calling a function + (setq closure-flag (byte-compile-lforminfo-make-closure-flag))) + ;; value form + (byte-compile-lforminfo-analyze lforminfo (nth 2 form) + ignore closure-flag) + ;; the error variable is always bound dynamically (because + ;; of the implementation) + (when (cadr form) + (push (cadr form) ignore)) + ;; handlers + (byte-compile-lforminfo-analyze-clauses lforminfo + (nthcdr 2 form) 1 + ignore closure-flag)) + ((eq fun '(defvar defconst)) + (byte-compile-lforminfo-analyze lforminfo (nth 2 form) + ignore closure-flag)) + ((memq fun '(defun defmacro)) + (byte-compile-lforminfo-analyze-forms lforminfo form 3 + ignore closure-flag)) + ((eq fun 'function) + ;; Analyze an embedded lambda expression [note: we only recognize + ;; it within (function ...) as the (lambda ...) for is actually a + ;; macro returning (function (lambda ...))]. + (when (and (consp (cadr form)) (eq (car (cadr form)) 'lambda)) + ;; shadow bound variables + (setq ignore + (append (byte-compile-arglist-vars (cadr (cadr form))) + ignore)) + ;; analyze body of lambda + (byte-compile-lforminfo-analyze-forms + lforminfo (cadr form) 2 + ignore + (or closure-flag + (byte-compile-lforminfo-make-closure-flag))))) + ((eq fun 'let) + ;; analyze variable inits + (byte-compile-lforminfo-analyze-clauses lforminfo (cadr form) 1 + ignore closure-flag) + ;; shadow bound variables + (dolist (clause (cadr form)) + (push (if (symbolp clause) clause (car clause)) + ignore)) + ;; analyze body + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + ignore closure-flag)) + ((eq fun 'let*) + (dolist (clause (cadr form)) + (if (symbolp clause) + ;; shadow bound (to nil) variable + (push clause ignore) + ;; analyze variable init + (byte-compile-lforminfo-analyze lforminfo (cadr clause) + ignore closure-flag) + ;; shadow bound variable + (push (car clause) ignore))) + ;; analyze body + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + ignore closure-flag)) + ((eq fun 'quote) + ;; do nothing + ) + ((eq fun 'save-window-excursion) + ;; `save-window-excursion' currently uses a funny implementation + ;; that requires its body forms be put into a closure (it should + ;; be fixed to work more like `save-excursion' etc., do). + (byte-compile-lforminfo-analyze-forms + lforminfo form 2 + ignore + (or closure-flag + (and byte-compile-save-window-excursion-uses-eval + (not byte-compile-use-downward-closures) + (byte-compile-lforminfo-make-closure-flag))))) + ((and (consp fun) (eq (car fun) 'lambda)) + ;; Embedded lambda. These are inlined by the compiler, so + ;; we don't treat them like a real closure, more like `let'. + ;; analyze inits + (byte-compile-lforminfo-analyze-forms lforminfo form 2 + ignore closure-flag) + + ;; shadow bound variables + (setq ignore (nconc (byte-compile-arglist-vars (cadr fun)) + ignore)) + ;; analyze body + (byte-compile-lforminfo-analyze-forms lforminfo fun 2 + ignore closure-flag)) + (t + ;; For everything else, we just expand each argument (for + ;; setq/setq-default this works alright because the + ;; variable names are symbols). + (byte-compile-lforminfo-analyze-forms lforminfo form 1 + ignore closure-flag))))))) + +(defun byte-compile-lforminfo-analyze-forms + (lforminfo forms skip ignore closure-flag) + "Update variable information in LFORMINFO by analyzing each form in FORMS. +The first SKIP elements of FORMS are skipped without analysis. IGNORE +is a list of variables that shouldn't be analyzed (usually because +they're special, or because some inner binding shadows the version in +LFORMINFO). CLOSURE-FLAG should be either nil or a `closure flag' created with +`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is +inside a lambda expression that may close over some variable in LFORMINFO." + (when skip + (setq forms (nthcdr skip forms))) + (while forms + (byte-compile-lforminfo-analyze lforminfo (pop forms) + ignore closure-flag))) + +(defun byte-compile-lforminfo-analyze-clauses + (lforminfo clauses skip ignore closure-flag) + "Update variable information in LFORMINFO by analyzing each clause in CLAUSES. +Each clause is a list of forms; any clause that's not a list is ignored. The +first SKIP elements of each clause are skipped without analysis. IGNORE is a +list of variables that shouldn't be analyzed (usually because they're special, +or because some inner binding shadows the version in LFORMINFO). +CLOSURE-FLAG should be either nil or a `closure flag' created with +`byte-compile-lforminfo-make-closure-flag'; the latter indicates that FORM is +inside a lambda expression that may close over some variable in LFORMINFO." + (while clauses + (let ((clause (pop clauses))) + (when (consp clause) + (byte-compile-lforminfo-analyze-forms lforminfo clause skip + ignore closure-flag))))) + + +;;; Lexical environments + +;; A lexical environment is an alist, where each element is of the form +;; (VAR . (OFFSET . ENV)) where VAR is either a symbol, for normal +;; variables, or an `heapenv' descriptor for references to heap environment +;; vectors. ENV is either an atom, meaning a `stack allocated' variable +;; (the particular atom serves to indicate the particular function context +;; on whose stack it's allocated), or an `heapenv' descriptor (see above), +;; meaning a variable allocated in a heap environment vector. For the +;; later case, an anonymous `variable' holding a pointer to the environment +;; vector may be located by recursively looking up ENV in the environment +;; as if it were a variable (so the entry for that `variable' will have a +;; non-symbol VAR). + +;; We call a lexical environment a `lexenv', and an entry in it a `lexvar'. + +;; constructor +(defsubst byte-compile-make-lexvar (name offset &optional env) + (cons name (cons offset env))) +;; accessors +(defsubst byte-compile-lexvar-name (lexvar) (car lexvar)) +(defsubst byte-compile-lexvar-offset (lexvar) (cadr lexvar)) +(defsubst byte-compile-lexvar-environment (lexvar) (cddr lexvar)) +(defsubst byte-compile-lexvar-variable-p (lexvar) (symbolp (car lexvar))) +(defsubst byte-compile-lexvar-environment-p (lexvar) + (not (symbolp (car lexvar)))) +(defsubst byte-compile-lexvar-on-stack-p (lexvar) + (atom (byte-compile-lexvar-environment lexvar))) +(defsubst byte-compile-lexvar-in-heap-p (lexvar) + (not (byte-compile-lexvar-on-stack-p lexvar))) + +(defun byte-compile-make-lambda-lexenv (form closed-over-lexenv) + "Return a new lexical environment for a lambda expression FORM. +CLOSED-OVER-LEXENV is the lexical environment in which FORM occurs. +The returned lexical environment contains two sets of variables: + * Variables that were in CLOSED-OVER-LEXENV and used by FORM + (all of these will be `heap' variables) + * Arguments to FORM (all of these will be `stack' variables)." + ;; See if this is a closure or not + (let ((closure nil) + (lforminfo (byte-compile-make-lforminfo)) + (args (byte-compile-arglist-vars (cadr form)))) + ;; Add variables from surrounding lexical environment to analysis set + (dolist (lexvar closed-over-lexenv) + (when (and (byte-compile-lexvar-in-heap-p lexvar) + (not (memq (car lexvar) args))) + ;; The variable is located in a heap-allocated environment + ;; vector, so FORM may use it. Add it to the set of variables + ;; that we'll search for in FORM. + (byte-compile-lforminfo-add-var lforminfo (car lexvar)))) + ;; See how FORM uses these potentially closed-over variables. + (byte-compile-lforminfo-analyze lforminfo form args) + (let ((lexenv nil)) + (dolist (vinfo (byte-compile-lforminfo-vars lforminfo)) + (when (> (byte-compile-lvarinfo-num-refs vinfo) 0) + ;; FORM uses VINFO's variable, so it must be a closure. + (setq closure t) + ;; Make sure that the environment in which the variable is + ;; located is accessible (since we only ever pass the + ;; innermost environment to closures, if it's in some other + ;; envionment, there must be path to it from the innermost + ;; one). + (unless (byte-compile-lexvar-in-heap-p vinfo) + ;; To access the variable from FORM, it must be in the heap. + (error + "Compiler error: lexical variable `%s' should be heap-allocated but is not" + (car vinfo))) + (let ((closed-over-lexvar (assq (car vinfo) closed-over-lexenv))) + (byte-compile-heapenv-ensure-access + byte-compile-current-heap-environment + (byte-compile-lexvar-environment closed-over-lexvar)) + ;; Put this variable in the new lexical environment + (push closed-over-lexvar lexenv)))) + ;; Fill in the initial stack contents + (let ((stackpos 0)) + (when closure + ;; Add the magic first argument that holds the environment pointer + (push (byte-compile-make-lexvar byte-compile-current-heap-environment + 0) + lexenv) + (setq stackpos (1+ stackpos))) + ;; Add entries for each argument + (dolist (arg args) + (push (byte-compile-make-lexvar arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment + lexenv)))) + +(defun byte-compile-closure-initial-lexenv-p (lexenv) + "Return non-nil if LEXENV is the initial lexical environment for a closure. +This only works correctly when passed a new lexical environment as +returned by `byte-compile-make-lambda-lexenv' (it works by checking to +see whether there are any heap-allocated lexical variables in LEXENV)." + (let ((closure nil)) + (while (and lexenv (not closure)) + (when (byte-compile-lexvar-environment-p (pop lexenv)) + (setq closure t))) + closure)) + + +;;; Heap environment vectors + +;; A `heap environment vector' is heap-allocated vector used to store +;; variable that can't be put onto the stack. +;; +;; They are represented in the compiler by a list of the form +;; +;; (SIZE SIZE-CONST-ID INIT-POSITION . ENVS) +;; +;; SIZE is the current size of the vector (which may be +;; incremented if another variable or environment-reference is added to +;; the end). SIZE-CONST-ID is an `unknown constant id' (as returned by +;; `byte-compile-push-unknown-constant') representing the constant used +;; in the vector initialization code, and INIT-POSITION is a position +;; in the byte-code output (as returned by `byte-compile-delay-out') +;; at which more initialization code can be added. +;; ENVS is a list of other environment vectors accessible form this one, +;; where each element is of the form (ENV . OFFSET). + +;; constructor +(defsubst byte-compile-make-heapenv (size-const-id init-position) + (list 0 size-const-id init-position)) +;; accessors +(defsubst byte-compile-heapenv-size (heapenv) (car heapenv)) +(defsubst byte-compile-heapenv-size-const-id (heapenv) (cadr heapenv)) +(defsubst byte-compile-heapenv-init-position (heapenv) (nth 2 heapenv)) +(defsubst byte-compile-heapenv-accessible-envs (heapenv) (nthcdr 3 heapenv)) + +(defun byte-compile-heapenv-add-slot (heapenv) + "Add a slot to the heap environment HEAPENV and return its offset." + (prog1 (car heapenv) (setcar heapenv (1+ (car heapenv))))) + +(defun byte-compile-heapenv-add-accessible-env (heapenv env offset) + "Add to HEAPENV's list of accessible environments, ENV at OFFSET." + (setcdr (nthcdr 2 heapenv) + (cons (cons env offset) + (byte-compile-heapenv-accessible-envs heapenv)))) + +(defun byte-compile-push-heapenv () + "Generate byte-code to push a new heap environment vector. +Sets `byte-compile-current-heap-environment' to the compiler descriptor +for the new heap environment. +Return a `lexvar' descriptor for the new heap environment." + (let ((env-stack-pos byte-compile-depth) + size-const-id init-position) + ;; Generate code to push the vector + (byte-compile-push-constant 'make-vector) + (setq size-const-id (byte-compile-push-unknown-constant)) + (byte-compile-push-constant nil) + (byte-compile-out 'byte-call 2) + (setq init-position (byte-compile-delay-out 3)) + ;; Now make a heap-environment for the compiler to use + (setq byte-compile-current-heap-environment + (byte-compile-make-heapenv size-const-id init-position)) + (byte-compile-make-lexvar byte-compile-current-heap-environment + env-stack-pos))) + +(defun byte-compile-heapenv-ensure-access (heapenv other-heapenv) + "Make sure that HEAPENV can be used to access OTHER-HEAPENV. +If not, then add a new slot to HEAPENV pointing to OTHER-HEAPENV." + (unless (memq heapenv (byte-compile-heapenv-accessible-envs heapenv)) + (let ((offset (byte-compile-heapenv-add-slot heapenv))) + (byte-compile-heapenv-add-accessible-env heapenv other-heapenv offset)))) + + +;;; Variable binding/unbinding + +(defun byte-compile-non-stack-bindings-p (clauses lforminfo) + "Return non-nil if any lexical bindings in CLAUSES are not stack-allocated. +LFORMINFO should be information about lexical variables being bound." + (let ((vars (byte-compile-lforminfo-vars lforminfo))) + (or (not (= (length clauses) (length vars))) + (progn + (while (and vars clauses) + (when (byte-compile-lvarinfo-closed-over-p (pop vars)) + (setq clauses nil))) + (not clauses))))) + +(defun byte-compile-let-clauses-trivial-init-p (clauses) + "Return true if let binding CLAUSES all have a `trivial' init value. +Trivial means either a constant value, or a simple variable initialization." + (or (null clauses) + (and (or (atom (car clauses)) + (atom (cadr (car clauses))) + (eq (car (cadr (car clauses))) 'quote)) + (byte-compile-let-clauses-trivial-init-p (cdr clauses))))) + +(defun byte-compile-rearrange-let-clauses (clauses lforminfo) + "Return CLAUSES rearranged so non-stack variables come last if possible. +Care is taken to only do so when it's clear that the meaning is the same. +LFORMINFO should be information about lexical variables being bound." + ;; We currently do a very simple job by only exchanging clauses when + ;; one has a constant init, or one has a variable init and the other + ;; doesn't have a function call init (because that could change the + ;; value of the variable). This could be more clever and actually + ;; attempt to analyze which variables could possible be changed, etc. + (let ((unchanged nil) + (lex-non-stack nil) + (dynamic nil)) + (while clauses + (let* ((clause (pop clauses)) + (var (if (consp clause) (car clause) clause)) + (init (and (consp clause) (cadr clause))) + (vinfo (assq var (byte-compile-lforminfo-vars lforminfo)))) + (cond + ((or (and vinfo + (not (byte-compile-lvarinfo-closed-over-p vinfo))) + (not + (or (eq init nil) (eq init t) + (and (atom init) (not (symbolp init))) + (and (consp init) (eq (car init) 'quote)) + (byte-compile-let-clauses-trivial-init-p clauses)))) + (push clause unchanged)) + (vinfo + (push clause lex-non-stack)) + (t + (push clause dynamic))))) + (nconc (nreverse unchanged) (nreverse lex-non-stack) (nreverse dynamic)))) + +(defun byte-compile-maybe-push-heap-environment (&optional lforminfo) + "Push a new heap environment if necessary. +LFORMINFO should be information about lexical variables being bound. +Return a lexical environment containing only the heap vector (or +nil if nothing was pushed). +Also, `byte-compile-current-heap-environment' and +`byte-compile-current-num-closures' are updated to reflect any change (so they +should probably be bound by the caller to ensure that the new values have the +proper scope)." + ;; We decide whether a new heap environment is required by seeing if + ;; the number of closures inside the form described by LFORMINFO is + ;; the same as the number inside the binding form that created the + ;; currently active heap environment. + (let ((nclosures + (and lforminfo (byte-compile-lforminfo-num-closures lforminfo)))) + (if (or (null lforminfo) + (= nclosures byte-compile-current-num-closures)) + ;; No need to push a heap environment. + nil + ;; Have to push one. A heap environment is really just a vector, so + ;; we emit bytecodes to create a vector. However, the size is not + ;; fixed yet (the vector can grow if subforms use it to store + ;; values, and if `access points' to parent heap environments are + ;; added), so we use `byte-compile-push-unknown-constant' to push the + ;; vector size. + (setq byte-compile-current-num-closures nclosures) + (list (byte-compile-push-heapenv))))) + +(defun byte-compile-bind (var init-lexenv &optional lforminfo) + "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'. +INIT-LEXENV should be a lexical-environment alist describing the +positions of the init value that have been pushed on the stack, and +LFORMINFO should be information about lexical variables being bound. +Return non-nil if the TOS value was popped." + ;; The presence of lexical bindings mean that we may have to + ;; juggle things on the stack, either to move them to TOS for + ;; dynamic binding, or to put them in a non-stack environment + ;; vector. + (let ((vinfo (assq var (byte-compile-lforminfo-vars lforminfo)))) + (cond ((and (null vinfo) (eq var (caar init-lexenv))) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual + (byte-compile-dynamic-variable-bind var) + t) + ((null vinfo) + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set stack-pos)) + nil) + ((byte-compile-lvarinfo-closed-over-p vinfo) + ;; VAR is lexical, but needs to be in a + ;; heap-allocated environment. + (unless byte-compile-current-heap-environment + (error "No current heap-environment to allocate `%s' in!" var)) + (let ((init-stack-pos + ;; nil if the init value is on the top of the stack, + ;; otherwise the position of the init value on the stack. + (and (not (eq var (caar init-lexenv))) + (byte-compile-lexvar-offset (assq var init-lexenv)))) + (env-vec-pos + ;; Position of VAR in the environment vector + (byte-compile-lexvar-offset + (assq var byte-compile-lexical-environment))) + (env-vec-stack-pos + ;; Position of the the environment vector on the stack + ;; (the heap-environment must _always_ be available on + ;; the stack!) + (byte-compile-lexvar-offset + (assq byte-compile-current-heap-environment + byte-compile-lexical-environment)))) + (unless env-vec-stack-pos + (error "Couldn't find location of current heap environment!")) + (when init-stack-pos + ;; VAR is not on the top of the stack, so get it + (byte-compile-stack-ref init-stack-pos)) + (byte-compile-stack-ref env-vec-stack-pos) + ;; Store the variable into the vector + (byte-compile-out 'byte-vec-set env-vec-pos) + (when init-stack-pos + ;; Store nil into VAR's temporary stack + ;; position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set init-stack-pos)) + ;; Push a record of VAR's new lexical binding + (push (byte-compile-make-lexvar + var env-vec-pos byte-compile-current-heap-environment) + byte-compile-lexical-environment) + (not init-stack-pos))) + (t + ;; VAR is a simple stack-allocated lexical variable + (push (assq var init-lexenv) + byte-compile-lexical-environment) + nil)))) + +(defun byte-compile-unbind (clauses init-lexenv + &optional lforminfo preserve-body-value) + "Emit byte-codes to unbind the variables bound by CLAUSES. +CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a +lexical-environment alist describing the positions of the init value that +have been pushed on the stack, and LFORMINFO should be information about +the lexical variables that were bound. If PRESERVE-BODY-VALUE is true, +then an additional value on the top of the stack, above any lexical binding +slots, is preserved, so it will be on the top of the stack after all +binding slots have been popped." + ;; Unbind dynamic variables + (let ((num-dynamic-bindings 0)) + (if lforminfo + (dolist (clause clauses) + (unless (assq (if (consp clause) (car clause) clause) + (byte-compile-lforminfo-vars lforminfo)) + (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) + (setq num-dynamic-bindings (length clauses))) + (unless (zerop num-dynamic-bindings) + (byte-compile-out 'byte-unbind num-dynamic-bindings))) + ;; Pop lexical variables off the stack, possibly preserving the + ;; return value of the body. + (when init-lexenv + ;; INIT-LEXENV contains all init values left on the stack + (byte-compile-discard (length init-lexenv) preserve-body-value))) + + +(provide 'byte-lexbind) + +;;; arch-tag: b8f1dff6-9edb-4430-a96f-323d42a681a9 +;;; byte-lexbind.el ends here diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 1ff34fa6a81..9ce3c2eb323 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -187,8 +187,8 @@ (eval-when-compile (require 'cl)) (defun byte-compile-log-lap-1 (format &rest args) - (if (aref byte-code-vector 0) - (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) +;; (if (aref byte-code-vector 0) +;; (error "The old version of the disassembler is loaded. Reload new-bytecomp as well")) (byte-compile-log-1 (apply 'format format (let (c a) @@ -282,7 +282,8 @@ (byte-code ,string ,(aref fn 2) ,(aref fn 3))) (cdr form))) (if (eq (car-safe fn) 'lambda) - (cons fn (cdr form)) + (macroexpand-all (cons fn (cdr form)) + byte-compile-macro-environment) ;; Give up on inlining. form)))))) @@ -1333,14 +1334,15 @@ ((>= op byte-constant) (prog1 (- op byte-constant) ;offset in opcode (setq op byte-constant))) - ((and (>= op byte-constant2) - (<= op byte-goto-if-not-nil-else-pop)) + ((or (and (>= op byte-constant2) + (<= op byte-goto-if-not-nil-else-pop)) + (= op byte-stack-set2)) (setq ptr (1+ ptr)) ;offset in next 2 bytes (+ (aref bytes ptr) (progn (setq ptr (1+ ptr)) (lsh (aref bytes ptr) 8)))) ((and (>= op byte-listN) - (<= op byte-insertN)) + (<= op byte-discardN)) (setq ptr (1+ ptr)) ;offset in next byte (aref bytes ptr)))) @@ -1401,7 +1403,16 @@ (if (= ptr (1- length)) (setq op nil) (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - op 'byte-goto)))) + op 'byte-goto))) + ((eq op 'byte-stack-set2) + (setq op 'byte-stack-set)) + ((and (eq op 'byte-discardN) (>= offset #x80)) + ;; The top bit of the operand for byte-discardN is a flag, + ;; saying whether the top-of-stack is preserved. In + ;; lapcode, we represent this by using a different opcode + ;; (with the flag removed from the operand). + (setq op 'byte-discardN-preserve-tos) + (setq offset (- offset #x80)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (setq lap (cons (cons optr (cons op (or offset 0))) lap)) @@ -1457,7 +1468,7 @@ byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max byte-point-min byte-following-char byte-preceding-char byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp - byte-current-buffer byte-interactive-p)) + byte-current-buffer byte-interactive-p byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1466,7 +1477,7 @@ byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem) + byte-member byte-assq byte-quo byte-rem byte-vec-ref) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -1499,12 +1510,50 @@ ;; The variable `byte-boolean-vars' is now primitive and updated ;; automatically by DEFVAR_BOOL. +(defmacro byte-opt-update-stack-params (stack-adjust stack-depth lap0 rest lap) + "...macro used by byte-optimize-lapcode..." + `(progn + (byte-compile-log-lap "Before %s [depth = %s]" ,lap0 ,stack-depth) + (cond ((eq (car ,lap0) 'TAG) + ;; A tag can encode the expected stack depth. + (when (cddr ,lap0) + ;; First, check to see if our notion of the current stack + ;; depth agrees with this tag. We don't check at the + ;; beginning of the function, because the presence of + ;; lexical arguments means the first tag will have a + ;; non-zero offset. + (when (and (not (eq ,rest ,lap)) ; not at first insn + ,stack-depth ; not just after a goto + (not (= (cddr ,lap0) ,stack-depth))) + (error "Compiler error: optimizer is confused about %s: + %s != %s at lapcode %s" ',stack-depth (cddr ,lap0) ,stack-depth ,lap0)) + ;; Now set out current depth from this tag + (setq ,stack-depth (cddr ,lap0))) + (setq ,stack-adjust 0)) + ((memq (car ,lap0) '(byte-goto byte-return)) + ;; These insns leave us in an unknown state + (setq ,stack-adjust nil)) + ((car ,lap0) + ;; Not a no-op, set ,stack-adjust for lap0. ,stack-adjust will + ;; be added to ,stack-depth at the end of the loop, so any code + ;; that modifies the instruction sequence must adjust this too. + (setq ,stack-adjust + (byte-compile-stack-adjustment (car ,lap0) (cdr ,lap0))))) + (byte-compile-log-lap "Before %s [depth => %s, adj = %s]" ,lap0 ,stack-depth ,stack-adjust) + )) + (defun byte-optimize-lapcode (lap &optional for-effect) "Simple peephole optimizer. LAP is both modified and returned. If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (let (lap0 lap1 lap2 + stack-adjust + stack-depth + (initial-stack-depth + (if (and lap (eq (car (car lap)) 'TAG)) + (cdr (cdr (car lap))) + 0)) (keep-going 'first-time) (add-depth 0) rest tmp tmp2 tmp3 @@ -1515,12 +1564,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (or (eq keep-going 'first-time) (byte-compile-log-lap " ---- next pass")) (setq rest lap + stack-depth initial-stack-depth keep-going nil) (while rest (setq lap0 (car rest) lap1 (nth 1 rest) lap2 (nth 2 rest)) + (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap) + ;; You may notice that sequences like "dup varset discard" are ;; optimized but sequences like "dup varset TAG1: discard" are not. ;; You may be tempted to change this; resist that temptation. @@ -1534,22 +1586,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ((and (eq 'byte-discard (car lap1)) (memq (car lap0) side-effect-free)) (setq keep-going t) - (setq tmp (aref byte-stack+-info (symbol-value (car lap0)))) (setq rest (cdr rest)) - (cond ((= tmp 1) + (cond ((= stack-adjust 1) (byte-compile-log-lap " %s discard\t-->\t<deleted>" lap0) (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) + ((= stack-adjust 0) (byte-compile-log-lap " %s discard\t-->\t<deleted> discard" lap0) (setq lap (delq lap0 lap))) - ((= tmp -1) + ((= stack-adjust -1) (byte-compile-log-lap " %s discard\t-->\tdiscard discard" lap0) (setcar lap0 'byte-discard) (setcdr lap0 0)) - ((error "Optimizer error: too much on the stack")))) + ((error "Optimizer error: too much on the stack"))) + (setq stack-adjust (1- stack-adjust))) ;; ;; goto*-X X: --> X: ;; @@ -1574,10 +1626,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup ;; The latter two can enable other optimizations. ;; - ((and (eq 'byte-varref (car lap2)) - (eq (cdr lap1) (cdr lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) - (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) + ((or (and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (and (eq (car lap2) 'byte-stack-ref) + (eq (car lap1) 'byte-stack-set) + (eq (cdr lap1) (cdr lap2)))) + (if (and (eq 'byte-varref (car lap2)) + (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) @@ -1609,10 +1665,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ((and (eq 'byte-dup (car lap0)) (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) + (memq (car lap1) '(byte-varset byte-varbind byte-stack-set byte-vec-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t - rest (cdr rest)) + rest (cdr rest) + stack-adjust -1) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil @@ -1634,7 +1691,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." 'byte-goto-if-not-nil 'byte-goto-if-nil)) (setq lap (delq lap0 lap)) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: @@ -1650,7 +1708,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" lap0 lap1 lap2 (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) + (setq lap (delq lap0 lap) + stack-adjust 0) (setcar lap1 inverse) (setq keep-going t))) ;; @@ -1667,15 +1726,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq rest (cdr rest) lap (delq lap0 (delq lap1 lap)))) (t - (if (memq (car lap1) byte-goto-always-pop-ops) - (progn - (byte-compile-log-lap " %s %s\t-->\t%s" - lap0 lap1 (cons 'byte-goto (cdr lap1))) - (setq lap (delq lap0 lap))) - (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 - (cons 'byte-goto (cdr lap1)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) (setcar lap1 'byte-goto))) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; varref-X varref-X --> varref-X dup ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup @@ -1683,14 +1741,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; because that would inhibit some goto optimizations; we ;; optimize the const-X case after all other optimizations. ;; - ((and (eq 'byte-varref (car lap0)) + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn - (setq tmp (cdr rest)) + (setq tmp (cdr rest) tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) + (setq tmp (cdr tmp) tmp2 (1+ tmp2))) t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (car tmp)))) + (eq (car lap0) (car (car tmp))) + (eq (cdr lap0) (cdr (car tmp)))) (if (memq byte-optimize-log '(t byte)) (let ((str "")) (setq tmp2 (cdr rest)) @@ -1702,7 +1760,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq keep-going t) (setcar (car tmp) 'byte-dup) (setcdr (car tmp) 0) - (setq rest tmp)) + (setq rest tmp + stack-adjust (+ 2 tmp2))) ;; ;; TAG1: TAG2: --> TAG1: <deleted> ;; (and other references to TAG2 are replaced with TAG1) @@ -1769,7 +1828,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0) (setcar rest lap1) (setcar (cdr rest) lap0) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; varbind-X unbind-N --> discard unbind-(N-1) ;; save-excursion unbind-N --> unbind-(N-1) @@ -1795,6 +1855,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." "")) (setq keep-going t)) ;; + ;; stack-ref-N --> dup ; where N is TOS + ;; + ((and (eq (car lap0) 'byte-stack-ref) + (= (cdr lap0) (1- stack-depth))) + (setcar lap0 'byte-dup) + (setcdr lap0 nil) + (setq keep-going t)) + ;; ;; goto*-X ... X: goto-Y --> goto*-Y ;; goto-X ... X: return --> return ;; @@ -1871,20 +1939,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (cdr tmp)))) (setcdr lap1 (car (cdr tmp))) (setq lap (delq lap0 lap)))) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; X: varref-Y ... varset-Y goto-X --> ;; X: varref-Y Z: ... dup varset-Y goto-Z ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) ;; (This is so usual for while loops that it is worth handling). ;; - ((and (eq (car lap1) 'byte-varset) + ((and (memq (car lap1) '(byte-varset byte-stack-set)) (eq (car lap2) 'byte-goto) (not (memq (cdr lap2) rest)) ;Backwards jump (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) + (if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref)) (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) + (not (and (eq (car lap1) 'byte-varref) + (memq (car (cdr lap1)) byte-boolean-vars)))) ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) (let ((newtag (byte-compile-make-tag))) (byte-compile-log-lap @@ -1941,10 +2011,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-goto-if-not-nil byte-goto byte-goto)))) ) - (setq keep-going t)) + (setq keep-going t + stack-adjust (and (not (eq (car lap0) 'byte-goto)) -1))) ) + + (setq stack-depth + (and stack-depth stack-adjust (+ stack-depth stack-adjust))) (setq rest (cdr rest))) ) + ;; Cleanup stage: ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they @@ -1952,10 +2027,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) - (setq rest lap) + (setq rest lap + stack-depth initial-stack-depth) + (byte-compile-log-lap " ---- final pass") (while rest (setq lap0 (car rest) lap1 (nth 1 rest)) + (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap) (if (memq (car lap0) byte-constref-ops) (if (or (eq (car lap0) 'byte-constant) (eq (car lap0) 'byte-constant2)) @@ -2002,11 +2080,108 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (cons 'byte-unbind (+ (cdr lap0) (cdr lap1)))) - (setq keep-going t) (setq lap (delq lap0 lap)) (setcdr lap1 (+ (cdr lap1) (cdr lap0)))) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (- stack-depth 2 (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (if (eq (car (car tmp)) 'byte-discard) + (setq tmp3 (1+ tmp3)) + (setq tmp3 (+ tmp3 (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization + (setq lap (delq lap0 lap)) + (cond ((= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more value + ;; (to get rid of the old value) using the TOS-preserving + ;; discard operator. + (setcar lap1 'byte-discardN-preserve-tos) + (setcdr lap1 (1+ tmp3))) + (t + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + (setcar lap1 'byte-discardN) + (setcdr lap1 tmp3))) + (setcdr (cdr rest) tmp) + (setq stack-adjust 0) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard + byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setq lap (delq lap0 lap)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN) + (setq stack-adjust 0)) + + ;; + ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> + ;; discardN-preserve-tos-(X+Y) + ;; + ((and (eq (car lap0) 'byte-discardN-preserve-tos) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap0) (cdr lap1))) + (setq stack-adjust 0) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) (- stack-depth 2))))) + ;; the byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it + (setq lap (delq lap0 lap)) + (setq stack-adjust 0) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + + ;; + ;; dup stack-set-N return --> return ; where N is TOS + ;; + ((and (eq (car lap0) 'byte-dup) + (eq (car lap1) 'byte-stack-set) + (eq (car (car (cdr (cdr rest)))) 'byte-return) + (= (cdr lap1) (1- stack-depth))) + (setq lap (delq lap0 (delq lap1 lap))) + (setq rest (cdr rest)) + (setq stack-adjust 0) + (byte-compile-log-lap " dup %s return\t-->\treturn" lap1)) ) + + (setq stack-depth + (and stack-depth stack-adjust (+ stack-depth stack-adjust))) (setq rest (cdr rest))) + (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) lap) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 8b47e0421e0..e1b5b402b28 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -118,12 +118,55 @@ ;; Some versions of `file' can be customized to recognize that. (require 'backquote) +(require 'macroexp) (eval-when-compile (require 'cl)) (or (fboundp 'defsubst) ;; This really ought to be loaded already! (load "byte-run")) +;; We want to do (require 'byte-lexbind) when compiling, to avoid compilation +;; errors; however that file also wants to do (require 'bytecomp) for the +;; same reason. Since we know it's OK to load byte-lexbind.el second, we +;; have that file require a feature that's provided before at the beginning +;; of this file, to avoid an infinite require loop. +;; `eval-when-compile' is defined in byte-run.el, so it must come after the +;; preceding load expression. +(provide 'bytecomp-preload) +(eval-when-compile (require 'byte-lexbind)) + +;; The feature of compiling in a specific target Emacs version +;; has been turned off because compile time options are a bad idea. +(defmacro byte-compile-single-version () nil) +(defmacro byte-compile-version-cond (cond) cond) + +;; The crud you see scattered through this file of the form +;; (or (and (boundp 'epoch::version) epoch::version) +;; (string-lessp emacs-version "19")) +;; is because the Epoch folks couldn't be bothered to follow the +;; normal emacs version numbering convention. + +;; (if (byte-compile-version-cond +;; (or (and (boundp 'epoch::version) epoch::version) +;; (string-lessp emacs-version "19"))) +;; (progn +;; ;; emacs-18 compatibility. +;; (defvar baud-rate (baud-rate)) ;Define baud-rate if it's undefined +;; +;; (if (byte-compile-single-version) +;; (defmacro byte-code-function-p (x) "Emacs 18 doesn't have these." nil) +;; (defun byte-code-function-p (x) "Emacs 18 doesn't have these." nil)) +;; +;; (or (and (fboundp 'member) +;; ;; avoid using someone else's possibly bogus definition of this. +;; (subrp (symbol-function 'member))) +;; (defun member (elt list) +;; "like memq, but uses equal instead of eq. In v19, this is a subr." +;; (while (and list (not (equal elt (car list)))) +;; (setq list (cdr list))) +;; list)))) + + (defgroup bytecomp nil "Emacs Lisp byte-compiler." :group 'lisp) @@ -400,7 +443,17 @@ specify different fields to sort on." :type '(choice (const name) (const callers) (const calls) (const calls+callers) (const nil))) -(defvar byte-compile-debug nil) +;(defvar byte-compile-debug nil) +(defvar byte-compile-debug t) + +;; (defvar byte-compile-overwrite-file t +;; "If nil, old .elc files are deleted before the new is saved, and .elc +;; files will have the same modes as the corresponding .el file. Otherwise, +;; existing .elc files will simply be overwritten, and the existing modes +;; will not be changed. If this variable is nil, then an .elc file which +;; is a symbolic link will be turned into a normal file, instead of the file +;; which the link points to being overwritten.") + (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil @@ -420,9 +473,13 @@ This list lives partly on the stack.") ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) (eval-when-compile . (lambda (&rest body) - (list 'quote - (byte-compile-eval (byte-compile-top-level - (cons 'progn body)))))) + (list + 'quote + (byte-compile-eval + (byte-compile-top-level + (macroexpand-all + (cons 'progn body) + byte-compile-initial-macro-environment)))))) (eval-and-compile . (lambda (&rest body) (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) @@ -455,6 +512,14 @@ defined with incorrect args.") Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") +;; Variables for lexical binding +(defvar byte-compile-lexical-environment nil + "The current lexical environment.") +(defvar byte-compile-current-heap-environment nil + "If non-nil, a descriptor for the current heap-allocated lexical environment.") +(defvar byte-compile-current-num-closures 0 + "The number of lexical closures that close over `byte-compile-current-heap-environment'.") + (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil "Alist describing contents to put in byte code string. @@ -500,11 +565,10 @@ Each element is (INDEX . VALUE)") (put 'byte-stack+-info 'tmp-compile-time-value nil))) -;; unused: 0-7 - ;; These opcodes are special in that they pack their argument into the ;; opcode word. ;; +(byte-defop 0 1 byte-stack-ref "for stack reference") (byte-defop 8 1 byte-varref "for variable reference") (byte-defop 16 -1 byte-varset "for setting a variable") (byte-defop 24 -1 byte-varbind "for binding a variable") @@ -666,11 +730,28 @@ otherwise pop it") (byte-defop 168 0 byte-integerp) ;; unused: 169-174 + (byte-defop 175 nil byte-listN) (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-191 +(byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte +(byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes +(byte-defop 180 1 byte-vec-ref) ; vector offset in following one byte +(byte-defop 181 -1 byte-vec-set) ; vector offset in following one byte + +;; if (following one byte & 0x80) == 0 +;; discard (following one byte & 0x7F) stack entries +;; else +;; discard (following one byte & 0x7F) stack entries _underneath_ the top of stack +;; (that is, if the operand = 0x83, ... X Y Z T => ... T) +(byte-defop 182 nil byte-discardN) +;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into +;; `byte-discardN' with the high bit in the operand set (by +;; `byte-compile-lapcode'). +(defconst byte-discardN-preserve-tos byte-discardN) + +;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") ;; codes 193-255 are consumed by byte-constant. @@ -717,71 +798,108 @@ otherwise pop it") ;; front of the constants-vector than the constant-referencing instructions. ;; Also, this lets us notice references to free variables. +(defmacro byte-compile-push-bytecodes (&rest args) + "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. +ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. +BYTES and PC are updated after evaluating all the arguments." + (let ((byte-exprs (butlast args 2)) + (bytes-var (car (last args 2))) + (pc-var (car (last args)))) + `(setq ,bytes-var ,(if (null (cdr byte-exprs)) + `(cons ,@byte-exprs ,bytes-var) + `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) + ,pc-var (+ ,(length byte-exprs) ,pc-var)))) + +(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) + "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. +CONST2 may be evaulated multiple times." + `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) + ,bytes ,pc)) + (defun byte-compile-lapcode (lap) "Turns lapcode into bytecode. The lapcode is destroyed." ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. (let ((pc 0) ; Program counter op off ; Operation & offset + opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of tags and goto's to patch - (while lap - (setq op (car (car lap)) - off (cdr (car lap))) + (patchlist nil)) ; List of gotos to patch + (dolist (lap-entry lap) + (setq op (car lap-entry) + off (cdr lap-entry)) (cond ((not (symbolp op)) (error "Non-symbolic opcode `%s'" op)) ((eq op 'TAG) - (setcar off pc) - (setq patchlist (cons off patchlist))) - ((memq op byte-goto-ops) - (setq pc (+ pc 3)) - (setq bytes (cons (cons pc (cdr off)) - (cons nil - (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) + (setcar off pc)) + ((null op) + ;; a no-op added by `byte-compile-delay-out' + (unless (zerop off) + (error + "Placeholder added by `byte-compile-delay-out' not filled in.") + )) (t - (setq bytes - (cond ((cond ((consp off) - ;; Variable or constant reference - (setq off (cdr off)) - (eq op 'byte-constant))) - (cond ((< off byte-constant-limit) - (setq pc (1+ pc)) - (cons (+ byte-constant off) bytes)) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons byte-constant2 bytes)))))) - ((<= byte-listN (symbol-value op)) - (setq pc (+ 2 pc)) - (cons off (cons (symbol-value op) bytes))) - ((< off 6) - (setq pc (1+ pc)) - (cons (+ (symbol-value op) off) bytes)) - ((< off 256) - (setq pc (+ 2 pc)) - (cons off (cons (+ (symbol-value op) 6) bytes))) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons (+ (symbol-value op) 7) - bytes)))))))) - (setq lap (cdr lap))) + (if (eq op 'byte-discardN-preserve-tos) + ;; byte-discardN-preserve-tos is a psuedo op, which is actually + ;; the same as byte-discardN with a modified argument + (setq opcode byte-discardN) + (setq opcode (symbol-value op))) + (cond ((memq op byte-goto-ops) + ;; goto + (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) + (push bytes patchlist)) + ((and (consp off) + ;; Variable or constant reference + (progn (setq off (cdr off)) + (eq op 'byte-constant))) + ;; constant ref + (if (< off byte-constant-limit) + (byte-compile-push-bytecodes (+ byte-constant off) + bytes pc) + (byte-compile-push-bytecode-const2 byte-constant2 off + bytes pc))) + ((and (= opcode byte-stack-set) + (> off 255)) + ;; Use the two-byte version of byte-stack-set if the + ;; offset is too large for the normal version. + (byte-compile-push-bytecode-const2 byte-stack-set2 off + bytes pc)) + ((and (>= opcode byte-listN) + (< opcode byte-discardN)) + ;; These insns all put their operand into one extra byte. + (byte-compile-push-bytecodes opcode off bytes pc)) + ((= opcode byte-discardN) + ;; byte-discardN is wierd in that it encodes a flag in the + ;; top bit of its one-byte argument. If the argument is + ;; too large to fit in 7 bits, the opcode can be repeated. + (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) + (while (> off #x7f) + (byte-compile-push-bytecodes opcode (logior #x7f flag) bytes pc) + (setq off (- off #x7f))) + (byte-compile-push-bytecodes opcode (logior off flag) bytes pc))) + ((null off) + ;; opcode that doesn't use OFF + (byte-compile-push-bytecodes opcode bytes pc)) + ;; The following three cases are for the special + ;; insns that encode their operand into 0, 1, or 2 + ;; extra bytes depending on its magnitude. + ((< off 6) + (byte-compile-push-bytecodes (+ opcode off) bytes pc)) + ((< off 256) + (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) + (t + (byte-compile-push-bytecode-const2 (+ opcode 7) off + bytes pc)))))) ;;(if (not (= pc (length bytes))) ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - ;; Patch PC into jumps - (let (bytes) - (while patchlist - (setq bytes (car patchlist)) - (cond ((atom (car bytes))) ; Tag - (t ; Absolute jump - (setq pc (car (cdr (car bytes)))) ; Pick PC from tag - (setcar (cdr bytes) (logand pc 255)) - (setcar bytes (lsh pc -8)) - ;; FIXME: Replace this by some workaround. - (if (> (car bytes) 255) (error "Bytecode overflow")))) - (setq patchlist (cdr patchlist)))) + + ;; Patch tag PCs into absolute jumps + (dolist (bytes-tail patchlist) + (setq pc (caar bytes-tail)) ; Pick PC from goto's tag + (setcar (cdr bytes-tail) (logand pc 255)) + (setcar bytes-tail (lsh pc -8)) + ;; FIXME: Replace this by some workaround. + (if (> (car bytes) 255) (error "Bytecode overflow"))) + (apply 'unibyte-string (nreverse bytes)))) @@ -2086,18 +2204,16 @@ list that represents a doc string reference. (defun byte-compile-file-form (form) (let ((byte-compile-current-form nil) ; close over this for warnings. bytecomp-handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall bytecomp-handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - ((eq form (setq form (macroexpand form byte-compile-macro-environment))) - (byte-compile-keep-pending form)) - (t - (byte-compile-file-form form))))) + (setq form (macroexpand-all form byte-compile-macro-environment)) + (cond ((not (consp form)) + (byte-compile-keep-pending form)) + ((and (symbolp (car form)) + (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall bytecomp-handler form)) + (byte-compile-flush-pending) + (byte-compile-output-file-form form)))) + (t + (byte-compile-keep-pending form))))) ;; Functions and variables with doc strings must be output separately, ;; so make-docfile can recognise them. Most other things can be output @@ -2109,8 +2225,7 @@ list that represents a doc string reference. (setq byte-compile-current-form (nth 1 form)) (byte-compile-warn "defsubst `%s' was used before it was defined" (nth 1 form))) - (byte-compile-file-form - (macroexpand form byte-compile-macro-environment)) + (byte-compile-file-form form) ;; Return nil so the form is not output twice. nil) @@ -2431,6 +2546,12 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if macro (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) + ;; expand macros + (setq fun + (macroexpand-all fun + byte-compile-initial-macro-environment)) + ;; get rid of the `function' quote added by the `lambda' macro + (setq fun (cadr fun)) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) (byte-compile-lambda fun))) @@ -2518,6 +2639,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq list (cdr list))))) +(autoload 'byte-compile-make-lambda-lexenv "byte-lexbind") + ;; Byte-compile a lambda-expression and return a valid function. ;; The value is usually a compiled function but may be the original ;; lambda-expression. @@ -2574,20 +2697,43 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string bytecomp-int))))) ;; Process the body. - (let ((compiled (byte-compile-top-level - (cons 'progn bytecomp-body) nil 'lambda))) + (let* ((byte-compile-lexical-environment + ;; If doing lexical binding, push a new lexical environment + ;; containing the args and any closed-over variables. + (and lexical-binding + (byte-compile-make-lambda-lexenv + fun + byte-compile-lexical-environment))) + (is-closure + ;; This is true if we should be making a closure instead of + ;; a simple lambda (because some variables from the + ;; containing lexical environment are closed over). + (and lexical-binding + (byte-compile-closure-initial-lexenv-p + byte-compile-lexical-environment))) + (byte-compile-current-heap-environment nil) + (byte-compile-current-num-closures 0) + (compiled + (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if bytecomp-int - (list (nth 1 bytecomp-int))))) + (let ((code + (apply 'make-byte-code + (append (list bytecomp-arglist) + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (if (or bytecomp-doc bytecomp-int + lexical-binding) + (list bytecomp-doc)) + ;; optionally, the interactive spec. + (if (or bytecomp-int lexical-binding) + (list (nth 1 bytecomp-int))) + (if lexical-binding + '(t)))))) + (if is-closure + (cons 'closure code) + code)) (setq compiled (nconc (if bytecomp-int (list bytecomp-int)) (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) @@ -2598,6 +2744,26 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list nil)))) compiled)))))) +(defun byte-compile-closure-code-p (code) + (eq (car-safe code) 'closure)) + +(defun byte-compile-make-closure (code) + ;; A real closure requires that the constant be curried with an + ;; environment vector to make a closure object. + (if for-effect + (setq for-effect nil) + (byte-compile-push-constant 'curry) + (byte-compile-push-constant code) + (byte-compile-lexical-variable-ref byte-compile-current-heap-environment) + (byte-compile-out 'byte-call 2))) + +(defun byte-compile-closure (form &optional add-lambda) + (let ((code (byte-compile-lambda form add-lambda))) + (if (byte-compile-closure-code-p code) + (byte-compile-make-closure code) + ;; A simple lambda is just a constant + (byte-compile-constant code)))) + (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. ;; This modifies the constants from (const . nil) to (const . offset). @@ -2642,17 +2808,51 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-depth 0) (byte-compile-maxdepth 0) (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + (if (and (eq 'byte-code (car-safe form)) + (not (memq byte-optimize '(t byte))) + (stringp (nth 1 form)) (vectorp (nth 2 form)) + (natnump (nth 3 form))) + form + ;; Set up things for a lexically-bound function + (when (and lexical-binding (eq output-type 'lambda)) + ;; See how many arguments there are, and set the current stack depth + ;; accordingly + (dolist (var byte-compile-lexical-environment) + (when (byte-compile-lexvar-on-stack-p var) + (setq byte-compile-depth (1+ byte-compile-depth)))) + ;; If there are args, output a tag to record the initial + ;; stack-depth for the optimizer + (when (> byte-compile-depth 0) + (byte-compile-out-tag (byte-compile-make-tag))) + ;; If this is the top-level of a lexically bound lambda expression, + ;; perhaps some parameters on stack need to be copied into a heap + ;; environment, so check for them, and do so if necessary. + (let ((lforminfo (byte-compile-make-lforminfo))) + ;; Add any lexical variable that's on the stack to the analysis set. + (dolist (var byte-compile-lexical-environment) + (when (byte-compile-lexvar-on-stack-p var) + (byte-compile-lforminfo-add-var lforminfo (car var) t))) + ;; Analyze the body + (unless (null (byte-compile-lforminfo-vars lforminfo)) + (byte-compile-lforminfo-analyze lforminfo form nil nil)) + ;; If the analysis revealed some argument need to be in a heap + ;; environment (because they're closed over by an embedded + ;; lambda), put them there. + (setq byte-compile-lexical-environment + (nconc (byte-compile-maybe-push-heap-environment lforminfo) + byte-compile-lexical-environment)) + (dolist (arginfo (byte-compile-lforminfo-vars lforminfo)) + (when (byte-compile-lvarinfo-closed-over-p arginfo) + (byte-compile-bind (car arginfo) + byte-compile-lexical-environment + lforminfo))))) + ;; Now compile FORM + (byte-compile-form form for-effect) + (byte-compile-out-toplevel for-effect output-type)))) (defun byte-compile-out-toplevel (&optional for-effect output-type) (if for-effect @@ -2774,7 +2974,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (setq form (macroexpand form byte-compile-macro-environment)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) (when (symbolp form) @@ -2784,7 +2983,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp form) (byte-compile-set-symbol-position form)) (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) + (t + (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((bytecomp-fn (car form)) (bytecomp-handler (get bytecomp-fn 'byte-compile))) @@ -2835,44 +3035,98 @@ That command is designed for interactive use only" bytecomp-fn)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) -(defun byte-compile-variable-ref (base-op bytecomp-var) - (when (symbolp bytecomp-var) - (byte-compile-set-symbol-position bytecomp-var)) - (if (or (not (symbolp bytecomp-var)) - (byte-compile-const-symbol-p bytecomp-var - (not (eq base-op 'byte-varref)))) - (if (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") - ((eq base-op 'byte-varset) "variable assignment to %s `%s'") - (t "variable reference to %s `%s'")) - (if (symbolp bytecomp-var) "constant" "nonvariable") - (prin1-to-string bytecomp-var))) - (and (get bytecomp-var 'byte-obsolete-variable) - (not (memq bytecomp-var byte-compile-not-obsolete-vars)) - (byte-compile-warn-obsolete bytecomp-var)) - (if (eq base-op 'byte-varbind) - (push bytecomp-var byte-compile-bound-variables) - (or (not (byte-compile-warning-enabled-p 'free-vars)) - (boundp bytecomp-var) - (memq bytecomp-var byte-compile-bound-variables) - (if (eq base-op 'byte-varset) - (or (memq bytecomp-var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-assignments))) - (or (memq bytecomp-var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-references))))))) - (let ((tmp (assq bytecomp-var byte-compile-variables))) +(defun byte-compile-check-variable (var &optional binding) + "Do various error checks before a use of the variable VAR. +If BINDING is non-nil, VAR is being bound." + (when (symbolp var) + (byte-compile-set-symbol-position var)) + (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) + (when (byte-compile-warning-enabled-p 'constants) + (byte-compile-warn (if binding + "attempt to let-bind %s `%s`" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var)))) + ((and (get var 'byte-obsolete-variable) + (not (memq var byte-compile-not-obsolete-vars))) + (byte-compile-warn-obsolete var)))) + +(defsubst byte-compile-dynamic-variable-op (base-op var) + (let ((tmp (assq var byte-compile-variables))) (unless tmp - (setq tmp (list bytecomp-var)) + (setq tmp (list var)) (push tmp byte-compile-variables)) (byte-compile-out base-op tmp))) +(defun byte-compile-dynamic-variable-bind (var) + "Generate code to bind the lexical variable VAR to the top-of-stack value." + (byte-compile-check-variable var t) + (when (byte-compile-warning-enabled-p 'free-vars) + (push var byte-compile-bound-variables)) + (byte-compile-dynamic-variable-op 'byte-varbind var)) + +;; This is used when it's know that VAR _definitely_ has a lexical +;; binding, and no error-checking should be done. +(defun byte-compile-lexical-variable-ref (var) + "Generate code to push the value of the lexical variable VAR on the stack." + (let ((binding (assq var byte-compile-lexical-environment))) + (when (null binding) + (error "Lexical binding not found for `%s'" var)) + (if (byte-compile-lexvar-on-stack-p binding) + ;; On the stack + (byte-compile-stack-ref (byte-compile-lexvar-offset binding)) + ;; In a heap environment vector; first push the vector on the stack + (byte-compile-lexical-variable-ref + (byte-compile-lexvar-environment binding)) + ;; Now get the value from it + (byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding))))) + +(defun byte-compile-variable-ref (var) + "Generate code to push the value of the variable VAR on the stack." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (if (byte-compile-lexvar-on-stack-p lex-binding) + ;; On the stack + (byte-compile-stack-ref (byte-compile-lexvar-offset lex-binding)) + ;; In a heap environment vector + (byte-compile-lexical-variable-ref + (byte-compile-lexvar-environment lex-binding)) + (byte-compile-out 'byte-vec-ref + (byte-compile-lexvar-offset lex-binding))) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-references)) + (byte-compile-warn "reference to free variable `%s'" var) + (push var byte-compile-free-references)) + (byte-compile-dynamic-variable-op 'byte-varref var)))) + +(defun byte-compile-variable-set (var) + "Generate code to set the variable VAR from the top-of-stack value." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (if (byte-compile-lexvar-on-stack-p lex-binding) + ;; On the stack + (byte-compile-stack-set (byte-compile-lexvar-offset lex-binding)) + ;; In a heap environment vector + (byte-compile-lexical-variable-ref + (byte-compile-lexvar-environment lex-binding)) + (byte-compile-out 'byte-vec-set + (byte-compile-lexvar-offset lex-binding))) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-assignments)) + (byte-compile-warn "assignment to free variable `%s'" var) + (push var byte-compile-free-assignments)) + (byte-compile-dynamic-variable-op 'byte-varset var)))) + (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) ;; In a string constant, treat properties as significant. @@ -2899,6 +3153,25 @@ That command is designed for interactive use only" bytecomp-fn)) (let ((for-effect nil)) (inline (byte-compile-constant const)))) +(defun byte-compile-push-unknown-constant (&optional id) + "Generate code to push a `constant' who's value isn't known yet. +A tag is returned which may then later be passed to +`byte-compile-resolve-unknown-constant' to finalize the value. +The optional argument ID is a tag returned by an earlier call to +`byte-compile-push-unknown-constant', in which case the same constant is +pushed again." + (unless id + (setq id (list (make-symbol "unknown"))) + (push id byte-compile-constants)) + (byte-compile-out 'byte-constant id) + id) + +(defun byte-compile-resolve-unknown-constant (id value) + "Give an `unknown constant' a value. +ID is the tag returned by `byte-compile-push-unknown-constant'. and VALUE +is the value it should have." + (setcar id value)) + ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3102,8 +3375,39 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-noop (form) (byte-compile-constant nil)) -(defun byte-compile-discard () - (byte-compile-out 'byte-discard 0)) +(defun byte-compile-discard (&optional num preserve-tos) + "Output byte codes to discard the NUM entries at the top of the stack (NUM defaults to 1). +If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were +popped before discarding the num values, and then pushed back again after +discarding." + (if (and (null num) (not preserve-tos)) + ;; common case + (byte-compile-out 'byte-discard) + ;; general case + (unless num + (setq num 1)) + (when (and preserve-tos (> num 0)) + ;; Preserve the top-of-stack value by writing it directly to the stack + ;; location which will be at the top-of-stack after popping. + (byte-compile-stack-set (1- (- byte-compile-depth num))) + ;; Now we actually discard one less value, since we want to keep + ;; the eventual TOS + (setq num (1- num))) + (while (> num 0) + (byte-compile-out 'byte-discard) + (setq num (1- num))))) + +(defun byte-compile-stack-ref (stack-pos) + "Output byte codes to push the value at position STACK-POS in the stack, on the top of the stack." + (if (= byte-compile-depth (1+ stack-pos)) + ;; A simple optimization + (byte-compile-out 'byte-dup) + ;; normal case + (byte-compile-out 'byte-stack-ref stack-pos))) + +(defun byte-compile-stack-set (stack-pos) + "Output byte codes to store the top-of-stack value at position STACK-POS in the stack." + (byte-compile-out 'byte-stack-set stack-pos)) ;; Compile a function that accepts one or more args and is right-associative. @@ -3262,40 +3566,14 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" the syntax (function (lambda (...) ...)) instead."))))) (byte-compile-two-args form)) -(defun byte-compile-funarg (form) - ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) - ;; for cases where it's guaranteed that first arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 1 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (cons 'function (cdr fn)) - (cdr (cdr form)))) - form)))) - -(defun byte-compile-funarg-2 (form) - ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..))) - ;; for cases where it's guaranteed that second arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 2 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (nth 1 form) - (cons (cons 'function (cdr fn)) - (cdr (cdr (cdr form)))))) - form)))) - ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ((byte-compile-lambda (nth 1 form)))))) + (if (symbolp (nth 1 form)) + (byte-compile-constant (nth 1 form)) + (byte-compile-closure (nth 1 form)))) (defun byte-compile-indent-to (form) (let ((len (length form))) @@ -3339,7 +3617,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (car (cdr bytecomp-args))) (or for-effect (cdr (cdr bytecomp-args)) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) + (byte-compile-variable-set (car bytecomp-args)) (setq bytecomp-args (cdr (cdr bytecomp-args)))) ;; (setq), with no arguments. (byte-compile-form nil for-effect)) @@ -3405,16 +3683,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler-1 or) (byte-defop-compiler-1 while) (byte-defop-compiler-1 funcall) -(byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-funarg) -(byte-defop-compiler-1 mapatoms byte-compile-funarg) -(byte-defop-compiler-1 mapconcat byte-compile-funarg) -(byte-defop-compiler-1 mapc byte-compile-funarg) -(byte-defop-compiler-1 maphash byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg-2) -;; map-charset-chars should be funarg but has optional third arg -(byte-defop-compiler-1 sort byte-compile-funarg-2) (byte-defop-compiler-1 let) (byte-defop-compiler-1 let*) @@ -3596,7 +3864,14 @@ that suppresses all warnings during execution of BODY." (defun byte-compile-while (form) (let ((endtag (byte-compile-make-tag)) - (looptag (byte-compile-make-tag))) + (looptag (byte-compile-make-tag)) + ;; Heap environments can't be shared between a loop and its + ;; enclosing environment (because any lexical variables bound + ;; inside the loop should have an independent value for each + ;; iteration). Setting `byte-compile-current-num-closures' to + ;; an invalid value causes the code that tries to merge + ;; environments to not do so. + (byte-compile-current-num-closures -1)) (byte-compile-out-tag looptag) (byte-compile-form (car (cdr form))) (byte-compile-goto-if nil for-effect endtag) @@ -3609,34 +3884,116 @@ that suppresses all warnings during execution of BODY." (mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) + +;; let binding + +;; All other lexical-binding functions are guarded by a non-nil return +;; value from `byte-compile-compute-lforminfo', so they needn't be +;; autoloaded. +(autoload 'byte-compile-compute-lforminfo "byte-lexbind") + +(defun byte-compile-push-binding-init (clause init-lexenv lforminfo) + "Emit byte-codes to push the initialization value for CLAUSE on the stack. +INIT-LEXENV is the lexical environment created for initializations +already done for this form. +LFORMINFO should be information about lexical variables being bound. +Return INIT-LEXENV updated to include the newest initialization, or nil +if LFORMINFO is nil (meaning all bindings are dynamic)." + (let* ((var (if (consp clause) (car clause) clause)) + (vinfo + (and lforminfo (assq var (byte-compile-lforminfo-vars lforminfo)))) + (unused (and vinfo (zerop (cadr vinfo))))) + (unless (and unused (symbolp clause)) + (when (and lforminfo (not unused)) + ;; We record the stack position even of dynamic bindings and + ;; variables in non-stack lexical environments; we'll put + ;; them in the proper place below. + (push (byte-compile-make-lexvar var byte-compile-depth) init-lexenv)) + (if (consp clause) + (byte-compile-form (cadr clause) unused) + (byte-compile-push-constant nil)))) + init-lexenv) (defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (dolist (var varlist) - (if (consp var) - (byte-compile-form (car (cdr var))) - (byte-compile-push-constant nil)))) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (reverse (car (cdr form))))) - (dolist (var varlist) - (byte-compile-variable-ref 'byte-varbind - (if (consp var) (car var) var))) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + "Generate code for the `let' form FORM." + (let ((clauses (cadr form)) + (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) + (init-lexenv nil) + ;; bind these to restrict the scope of any changes + (byte-compile-current-heap-environment + byte-compile-current-heap-environment) + (byte-compile-current-num-closures byte-compile-current-num-closures)) + (when (and lforminfo (byte-compile-non-stack-bindings-p clauses lforminfo)) + ;; Some of the variables we're binding are lexical variables on + ;; the stack, but not all. As much as we can, rearrange the list + ;; so that non-stack lexical variables and dynamically bound + ;; variables come last, which allows slightly more optimal + ;; byte-code for binding them. + (setq clauses (byte-compile-rearrange-let-clauses clauses lforminfo))) + ;; If necessary, create a new heap environment to hold some of the + ;; variables bound here. + (when lforminfo + (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo))) + ;; First compute the binding values in the old scope. + (dolist (clause clauses) + (setq init-lexenv + (byte-compile-push-binding-init clause init-lexenv lforminfo))) + ;; Now do the bindings, execute the body, and undo the bindings + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile-lexical-environment byte-compile-lexical-environment) + (preserve-body-value (not for-effect))) + (dolist (clause (reverse clauses)) + (let ((var (if (consp clause) (car clause) clause))) + (cond ((null lforminfo) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv lforminfo) + (pop init-lexenv))))) + ;; Emit the body + (byte-compile-body-do-effect (cdr (cdr form))) + ;; Unbind the variables + (if lforminfo + ;; Unbind both lexical and dynamic variables + (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value) + ;; Unbind dynamic variables + (byte-compile-out 'byte-unbind (length clauses)))))) (defun byte-compile-let* (form) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (copy-sequence (car (cdr form))))) - (dolist (var varlist) - (if (atom var) - (byte-compile-push-constant nil) - (byte-compile-form (car (cdr var))) - (setq var (car var))) - (byte-compile-variable-ref 'byte-varbind var)) + "Generate code for the `let*' form FORM." + (let ((clauses (cadr form)) + (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form))) + (init-lexenv nil) + (preserve-body-value (not for-effect)) + ;; bind these to restrict the scope of any changes + (byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile-lexical-environment byte-compile-lexical-environment) + (byte-compile-current-heap-environment + byte-compile-current-heap-environment) + (byte-compile-current-num-closures byte-compile-current-num-closures)) + ;; If necessary, create a new heap environment to hold some of the + ;; variables bound here. + (when lforminfo + (setq init-lexenv (byte-compile-maybe-push-heap-environment lforminfo))) + ;; Bind the variables + (dolist (clause clauses) + (setq init-lexenv + (byte-compile-push-binding-init clause init-lexenv lforminfo)) + (let ((var (if (consp clause) (car clause) clause))) + (cond ((null lforminfo) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv lforminfo) + (pop init-lexenv))))) + ;; Emit the body (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + ;; Unbind the variables + (if lforminfo + ;; Unbind both lexical and dynamic variables + (byte-compile-unbind clauses init-lexenv lforminfo preserve-body-value) + ;; Unbind dynamic variables + (byte-compile-out 'byte-unbind (length clauses))))) + (byte-defop-compiler-1 /= byte-compile-negated) (byte-defop-compiler-1 atom byte-compile-negated) @@ -3659,6 +4016,7 @@ that suppresses all warnings during execution of BODY." "Compiler error: `%s' has no `byte-compile-negated-op' property" (car form))) (cdr form)))) + ;;; other tricky macro-like special-forms @@ -3779,28 +4137,28 @@ that suppresses all warnings during execution of BODY." (byte-compile-set-symbol-position (car form)) (byte-compile-set-symbol-position 'defun) (error "defun name must be a symbol, not %s" (car form))) - ;; We prefer to generate a defalias form so it will record the function - ;; definition just like interpreting a defun. - (byte-compile-form - (list 'defalias - (list 'quote (nth 1 form)) - (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t))) - t) - (byte-compile-constant (nth 1 form))) + (let ((for-effect nil)) + (byte-compile-push-constant 'defalias) + (byte-compile-push-constant (nth 1 form)) + (byte-compile-closure (cdr (cdr form)) t)) + (byte-compile-out 'byte-call 2)) (defun byte-compile-defmacro (form) ;; This is not used for file-level defmacros with doc strings. - (byte-compile-body-do-effect - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t)))) - `((defalias ',(nth 1 form) - ,(if (eq (car-safe code) 'make-byte-code) - `(cons 'macro ,code) - `'(macro . ,(eval code)))) - ,@decls - ',(nth 1 form))))) + ;; FIXME handle decls, use defalias? + (let ((decls (byte-compile-defmacro-declaration form)) + (code (byte-compile-lambda (cdr (cdr form)) t)) + (for-effect nil)) + (byte-compile-push-constant (nth 1 form)) + (if (not (byte-compile-closure-code-p code)) + ;; simple lambda + (byte-compile-push-constant (cons 'macro code)) + (byte-compile-push-constant 'macro) + (byte-compile-make-closure code) + (byte-compile-out 'byte-cons)) + (byte-compile-out 'byte-fset) + (byte-compile-discard)) + (byte-compile-constant (nth 1 form))) (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. @@ -3826,7 +4184,7 @@ that suppresses all warnings during execution of BODY." ;; Put the defined variable in this library's load-history entry ;; just as a real defvar would, but only in top-level forms. (when (and (cddr form) (null byte-compile-current-form)) - `(push ',var current-load-list)) + `(setq current-load-list (cons ',var current-load-list))) (when (> (length form) 3) (when (and string (not (stringp string))) (byte-compile-warn "third arg to `%s %s' is not a string: %s" @@ -3948,23 +4306,74 @@ that suppresses all warnings during execution of BODY." (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) (1- byte-compile-depth)))) -(defun byte-compile-out (opcode offset) - (push (cons opcode offset) byte-compile-output) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) - ) +(defun byte-compile-stack-adjustment (op operand) + "Return the amount by which an operation adjusts the stack. +OP and OPERAND are as passed to `byte-compile-out'." + (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) + ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 + ;; elements, and the push the result, for a total of -OPERAND. + ;; For discardN*, of course, we just pop OPERAND elements. + (- operand) + (or (aref byte-stack+-info (symbol-value op)) + ;; Ops with a nil entry in `byte-stack+-info' are byte-codes + ;; that take OPERAND values off the stack and push a result, for + ;; a total of 1 - OPERAND + (- 1 operand)))) + +(defun byte-compile-out (op &optional operand) + (push (cons op operand) byte-compile-output) + (if (eq op 'byte-return) + ;; This is actually an unnecessary case, because there should be no + ;; more ops behind byte-return. + (setq byte-compile-depth nil) + (setq byte-compile-depth + (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) + (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) + ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) + )) + +(defun byte-compile-delay-out (&optional stack-used stack-adjust) + "Add a placeholder to the output, which can be used to later add byte-codes. +Return a position tag that can be passed to `byte-compile-delayed-out' +to add the delayed byte-codes. STACK-USED is the maximum amount of +stack-spaced used by the delayed byte-codes (defaulting to 0), and +STACK-ADJUST is the amount by which the later-added code will adjust the +stack (defaulting to 0); the byte-codes added later _must_ adjust the +stack by this amount! If STACK-ADJUST is 0, then it's not necessary to +actually add anything later; the effect as if nothing was added at all." + ;; We just add a no-op to `byte-compile-output', and return a pointer to + ;; the tail of the list; `byte-compile-delayed-out' uses list surgery + ;; to add the byte-codes. + (when stack-used + (setq byte-compile-maxdepth + (max byte-compile-depth (+ byte-compile-depth (or stack-used 0))))) + (when stack-adjust + (setq byte-compile-depth + (+ byte-compile-depth stack-adjust))) + (push (cons nil (or stack-adjust 0)) byte-compile-output)) + +(defun byte-compile-delayed-out (position op &optional operand) + "Add at POSITION the byte-operation OP, with optional numeric arg OPERAND. +POSITION should a position returned by `byte-compile-delay-out'. +Return a new position, which can be used to add further operations." + (unless (null (caar position)) + (error "Bad POSITION arg to `byte-compile-delayed-out'")) + ;; This is kind of like `byte-compile-out', but we splice into the list + ;; where POSITION is. We don't bother updating `byte-compile-maxdepth' + ;; because that was already done by `byte-compile-delay-out', but we do + ;; update the relative operand stored in the no-op marker currently at + ;; POSITION; since we insert before that marker, this means that if the + ;; caller doesn't insert a sequence of byte-codes that matches the expected + ;; operand passed to `byte-compile-delay-out', then the nop will still have + ;; a non-zero operand when `byte-compile-lapcode' is called, which will + ;; cause an error to be signaled. + + ;; Adjust the cumulative stack-adjustment stored in the cdr of the no-op + (setcdr (car position) + (- (cdar position) (byte-compile-stack-adjustment op operand))) + ;; Add the new operation onto the list tail at POSITION + (setcdr position (cons (cons op operand) (cdr position))) + position) ;;; call tree stuff diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el index 9899e991e3f..18aa5fde0c8 100644 --- a/lisp/emacs-lisp/disass.el +++ b/lisp/emacs-lisp/disass.el @@ -73,19 +73,22 @@ redefine OBJECT if it is a symbol." (let ((macro 'nil) (name 'nil) (doc 'nil) + (lexical-binding nil) args) (while (symbolp obj) (setq name obj obj (symbol-function obj))) (if (subrp obj) (error "Can't disassemble #<subr %s>" name)) - (if (and (listp obj) (eq (car obj) 'autoload)) - (progn - (load (nth 1 obj)) - (setq obj (symbol-function name)))) + (when (and (listp obj) (eq (car obj) 'autoload)) + (load (nth 1 obj)) + (setq obj (symbol-function name))) (if (eq (car-safe obj) 'macro) ;handle macros (setq macro t obj (cdr obj))) + (when (and (listp obj) (eq (car obj) 'closure)) + (setq lexical-binding t) + (setq obj (cddr obj))) (if (and (listp obj) (eq (car obj) 'byte-code)) (setq obj (list 'lambda nil obj))) (if (and (listp obj) (not (eq (car obj) 'lambda))) @@ -216,7 +219,9 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler." (cond ((memq op byte-goto-ops) (insert (int-to-string (nth 1 arg)))) ((memq op '(byte-call byte-unbind - byte-listN byte-concatN byte-insertN)) + byte-listN byte-concatN byte-insertN + byte-stack-ref byte-stack-set byte-stack-set2 + byte-discardN byte-discardN-preserve-tos)) (insert (int-to-string arg))) ((memq op '(byte-varref byte-varset byte-varbind)) (prin1 (car arg) (current-buffer))) diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index e4330e43fc9..b4ac0eebf6d 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -702,7 +702,15 @@ If CHAR is not a character, return nil." (defun eval-last-sexp-1 (eval-last-sexp-arg-internal) "Evaluate sexp before point; print value in minibuffer. With argument, print output into current buffer." - (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t))) + (let ((standard-output (if eval-last-sexp-arg-internal (current-buffer) t)) + ;; preserve the current lexical environment + (internal-interpreter-environment internal-interpreter-environment)) + ;; Setup the lexical environment if lexical-binding is enabled. + ;; Note that `internal-interpreter-environment' _can't_ be both + ;; assigned and let-bound above -- it's treated specially (and + ;; oddly) by the interpreter! + (when lexical-binding + (setq internal-interpreter-environment '(t))) (eval-last-sexp-print-value (eval (preceding-sexp))))) |