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

New branch for lexbind, losing all history.

Browse source 
This initial patch is based on 2002-06-27T22:39:10Z!storm@cua.dk of the original
lexbind branch.
This commit is contained in:
Stefan Monnier 2010-06-13 16:36:17 -04:00
parent a6e8d97c14
commit b9598260f9
30 changed files with 3032 additions and 416 deletions
Download patch file Download diff file Expand all files Collapse all files

696
lisp/emacs-lisp/byte-lexbind.el Normal file
View file

@ -0,0 +1,696 @@
;;; byte-lexbind.el --- Lexical binding support for byte-compiler
;;
;; Copyright (C) 2001, 2002 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 2, 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 (specialp 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 (specialp 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

263
lisp/emacs-lisp/byte-opt.el
View file

@ -186,8 +186,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)
@ -281,7 +281,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))))))
@ -1332,14 +1333,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))))
@ -1400,7 +1402,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))
@ -1456,7 +1467,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
@ -1465,7 +1476,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.
@ -1498,12 +1509,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
@ -1514,12 +1563,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.
@ -1533,22 +1585,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:
;;
@ -1573,10 +1625,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)
@ -1608,10 +1664,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
@ -1633,7 +1690,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:
@ -1649,7 +1707,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)))
;;
@ -1666,15 +1725,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
@ -1682,14 +1740,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))
@ -1701,7 +1759,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)
@ -1768,7 +1827,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)
@ -1794,6 +1854,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
;;
@ -1870,20 +1938,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
@ -1940,10 +2010,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
@ -1951,10 +2026,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))
@ -2001,11 +2079,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)

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

File diff suppressed because it is too large Load diff

15
lisp/emacs-lisp/disass.el
View file

@ -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)))

10
lisp/emacs-lisp/lisp-mode.el
View file

@ -701,7 +701,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)))))