diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-lexbind.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-lexbind.el | 696 |
1 files changed, 696 insertions, 0 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 |