-;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler
+;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler -*- lexical-binding: t -*-
-;; Copyright (C) 1991, 1994, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994, 2000-2012 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no>
;; Maintainer: FSF
;; Keywords: internal
+;; Package: emacs
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; We'd have to notice defvars and defconsts, since those variables should
;; always be dynamic, and attempting to do a lexical binding of them
;; should simply do a dynamic binding instead.
-;; But! We need to know about variables that were not necessarily defvarred
+;; But! We need to know about variables that were not necessarily defvared
;; in the file being compiled (doing a boundp check isn't good enough.)
;; Fdefvar() would have to be modified to add something to the plist.
;;
(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"))
+ ;; Newer byte codes for stack-ref make the slot 0 non-nil again.
+ ;; But the "old disassembler" is *really* ancient by now.
+ ;; (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)
sexp)))
(cdr form))))
-
-;; Splice the given lap code into the current instruction stream.
-;; If it has any labels in it, you're responsible for making sure there
-;; are no collisions, and that byte-compile-tag-number is reasonable
-;; after this is spliced in. The provided list is destroyed.
-(defun byte-inline-lapcode (lap)
- (setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
-
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
- (fn (or (cdr (assq name byte-compile-function-environment))
- (and (fboundp name) (symbol-function name)))))
- (if (null fn)
- (progn
- (byte-compile-warn "attempt to inline `%s' before it was defined"
- name)
- form)
- ;; else
- (when (and (consp fn) (eq (car fn) 'autoload))
- (load (nth 1 fn))
- (setq fn (or (and (fboundp name) (symbol-function name))
- (cdr (assq name byte-compile-function-environment)))))
- (if (and (consp fn) (eq (car fn) 'autoload))
- (error "File `%s' didn't define `%s'" (nth 1 fn) name))
- (if (and (symbolp fn) (not (eq fn t)))
- (byte-compile-inline-expand (cons fn (cdr form)))
- (if (byte-code-function-p fn)
- (let (string)
- (fetch-bytecode fn)
- (setq string (aref fn 1))
- ;; Isn't it an error for `string' not to be unibyte?? --stef
- (if (fboundp 'string-as-unibyte)
- (setq string (string-as-unibyte string)))
- ;; `byte-compile-splice-in-already-compiled-code'
- ;; takes care of inlining the body.
- (cons `(lambda ,(aref fn 0)
- (byte-code ,string ,(aref fn 2) ,(aref fn 3)))
- (cdr form)))
- (if (eq (car-safe fn) 'lambda)
- (cons fn (cdr form))
- ;; Give up on inlining.
- form))))))
+ (localfn (cdr (assq name byte-compile-function-environment)))
+ (fn (or localfn (and (fboundp name) (symbol-function name)))))
+ (when (and (consp fn) (eq (car fn) 'autoload))
+ (load (nth 1 fn))
+ (setq fn (or (and (fboundp name) (symbol-function name))
+ (cdr (assq name byte-compile-function-environment)))))
+ (pcase fn
+ (`nil
+ (byte-compile-warn "attempt to inline `%s' before it was defined"
+ name)
+ form)
+ (`(autoload . ,_)
+ (error "File `%s' didn't define `%s'" (nth 1 fn) name))
+ ((and (pred symbolp) (guard (not (eq fn t)))) ;A function alias.
+ (byte-compile-inline-expand (cons fn (cdr form))))
+ ((pred byte-code-function-p)
+ ;; (message "Inlining byte-code for %S!" name)
+ ;; The byte-code will be really inlined in byte-compile-unfold-bcf.
+ `(,fn ,@(cdr form)))
+ ((or (and `(lambda ,args . ,body) (let env nil))
+ `(closure ,env ,args . ,body))
+ (if (not (or (eq fn localfn) ;From the same file => same mode.
+ (eq (not lexical-binding) (not env)))) ;Same mode.
+ ;; While byte-compile-unfold-bcf can inline dynbind byte-code into
+ ;; letbind byte-code (or any other combination for that matter), we
+ ;; can only inline dynbind source into dynbind source or letbind
+ ;; source into letbind source.
+ ;; FIXME: we could of course byte-compile the inlined function
+ ;; first, and then inline its byte-code.
+ form
+ (let ((renv ()))
+ ;; Turn the function's closed vars (if any) into local let bindings.
+ (dolist (binding env)
+ (cond
+ ((consp binding)
+ ;; We check shadowing by the args, so that the `let' can be
+ ;; moved within the lambda, which can then be unfolded.
+ ;; FIXME: Some of those bindings might be unused in `body'.
+ (unless (memq (car binding) args) ;Shadowed.
+ (push `(,(car binding) ',(cdr binding)) renv)))
+ ((eq binding t))
+ (t (push `(defvar ,binding) body))))
+ (let ((newfn (if (eq fn localfn)
+ ;; If `fn' is from the same file, it has already
+ ;; been preprocessed!
+ `(function ,fn)
+ (byte-compile-preprocess
+ (if (null renv)
+ `(lambda ,args ,@body)
+ `(lambda ,args (let ,(nreverse renv) ,@body)))))))
+ (if (eq (car-safe newfn) 'function)
+ (byte-compile-unfold-lambda `(,(cadr newfn) ,@(cdr form)))
+ (byte-compile-log-warning
+ (format "Inlining closure %S failed" name))
+ form)))))
+
+ (t ;; Give up on inlining.
+ form))))
;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name)
+ ;; In lexical-binding mode, let and functions don't bind vars in the same way
+ ;; (let obey special-variable-p, but functions don't). But luckily, this
+ ;; doesn't matter here, because function's behavior is underspecified so it
+ ;; can safely be turned into a `let', even though the reverse is not true.
(or name (setq name "anonymous lambda"))
(let ((lambda (car form))
(values (cdr form)))
- (if (byte-code-function-p lambda)
- (setq lambda (list 'lambda (aref lambda 0)
- (list 'byte-code (aref lambda 1)
- (aref lambda 2) (aref lambda 3)))))
(let ((arglist (nth 1 lambda))
(body (cdr (cdr lambda)))
optionalp restp
(setq body (cdr body)))
(if (and (consp (car body)) (eq 'interactive (car (car body))))
(setq body (cdr body)))
+ ;; FIXME: The checks below do not belong in an optimization phase.
(while arglist
(cond ((eq (car arglist) '&optional)
;; ok, I'll let this slide because funcall_lambda() does...
(and (nth 1 form)
(not for-effect)
form))
- ((or (byte-code-function-p fn)
- (eq 'lambda (car-safe fn)))
- (byte-compile-unfold-lambda form))
+ ((eq 'lambda (car-safe fn))
+ (let ((newform (byte-compile-unfold-lambda form)))
+ (if (eq newform form)
+ ;; Some error occurred, avoid infinite recursion
+ form
+ (byte-optimize-form-code-walker newform for-effect))))
((memq fn '(let let*))
;; recursively enter the optimizer for the bindings and body
;; of a let or let*. This for depth-firstness: forms that
(byte-optimize-form (nth 2 form) for-effect)
(byte-optimize-body (nthcdr 3 form) for-effect)))))
- ((memq fn '(and or)) ; remember, and/or are control structures.
- ;; take forms off the back until we can't any more.
+ ((memq fn '(and or)) ; Remember, and/or are control structures.
+ ;; Take forms off the back until we can't any more.
;; In the future it could conceivably be a problem that the
;; subexpressions of these forms are optimized in the reverse
;; order, but it's ok for now.
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
(and backwards
- (cons fn (nreverse (mapcar 'byte-optimize-form backwards)))))
+ (cons fn (nreverse (mapcar 'byte-optimize-form
+ backwards)))))
(cons fn (mapcar 'byte-optimize-form (cdr form)))))
((eq fn 'interactive)
(prin1-to-string form))
nil)
- ((memq fn '(defun defmacro function
- condition-case save-window-excursion))
+ ((memq fn '(function condition-case))
;; These forms are compiled as constants or by breaking out
;; all the subexpressions and compiling them separately.
form)
;; However, don't actually bother calling `ignore'.
`(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
- ;; If optimization is on, this is the only place that macros are
- ;; expanded. If optimization is off, then macroexpansion happens
- ;; in byte-compile-form. Otherwise, the macros are already expanded
- ;; by the time that is reached.
- ((not (eq form
- (setq form (macroexpand form
- byte-compile-macro-environment))))
- (byte-optimize-form form for-effect))
-
- ;; Support compiler macros as in cl.el.
- ((and (fboundp 'compiler-macroexpand)
- (symbolp (car-safe form))
- (get (car-safe form) 'cl-compiler-macro)
- (not (eq form
- (with-no-warnings
- (setq form (compiler-macroexpand form))))))
- (byte-optimize-form form for-effect))
+ ;; Needed as long as we run byte-optimize-form after cconv.
+ ((eq fn 'internal-make-closure) form)
+
+ ((byte-code-function-p fn)
+ (cons fn (mapcar #'byte-optimize-form (cdr form))))
((not (symbolp fn))
(byte-compile-warn "`%s' is a malformed function"
(defun byte-optimize-body (forms all-for-effect)
- ;; optimize the cdr of a progn or implicit progn; all forms is a list of
+ ;; Optimize the cdr of a progn or implicit progn; all forms is a list of
;; forms, all but the last of which are optimized with the assumption that
;; they are being called for effect. the last is for-effect as well if
;; all-for-effect is true. returns a new list of forms.
(defsubst byte-compile-trueconstp (form)
"Return non-nil if FORM always evaluates to a non-nil value."
+ (while (eq (car-safe form) 'progn)
+ (setq form (car (last (cdr form)))))
(cond ((consp form)
(case (car form)
(quote (cadr form))
- (progn (byte-compile-trueconstp (car (last (cdr form)))))))
+ ;; Can't use recursion in a defsubst.
+ ;; (progn (byte-compile-trueconstp (car (last (cdr form)))))
+ ))
((not (symbolp form)))
((eq form t))
((keywordp form))))
(defsubst byte-compile-nilconstp (form)
"Return non-nil if FORM always evaluates to a nil value."
+ (while (eq (car-safe form) 'progn)
+ (setq form (car (last (cdr form)))))
(cond ((consp form)
(case (car form)
(quote (null (cadr form)))
- (progn (byte-compile-nilconstp (car (last (cdr form)))))))
+ ;; Can't use recursion in a defsubst.
+ ;; (progn (byte-compile-nilconstp (car (last (cdr form)))))
+ ))
((not (symbolp form)) nil)
((null form))))
(list (apply fun (nreverse constants)))))))))
form))
+(defsubst byte-compile-butlast (form)
+ (nreverse (cdr (reverse form))))
+
(defun byte-optimize-plus (form)
- (setq form (byte-optimize-delay-constants-math form 1 '+))
+ ;; Don't call `byte-optimize-delay-constants-math' (bug#1334).
+ ;;(setq form (byte-optimize-delay-constants-math form 1 '+))
(if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
- ;;(setq form (byte-optimize-associative-two-args-math form))
- (cond ((null (cdr form))
- (condition-case ()
- (eval form)
- (error form)))
-;;; It is not safe to delete the function entirely
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker).
-;;; ((null (cdr (cdr form))) (nth 1 form))
- ((null (cddr form))
- (if (numberp (nth 1 form))
- (nth 1 form)
- form))
- ((and (null (nthcdr 3 form))
- (or (memq (nth 1 form) '(1 -1))
- (memq (nth 2 form) '(1 -1))))
- ;; Optimize (+ x 1) into (1+ x) and (+ x -1) into (1- x).
- (let ((integer
- (if (memq (nth 1 form) '(1 -1))
- (nth 1 form)
- (nth 2 form)))
- (other
- (if (memq (nth 1 form) '(1 -1))
- (nth 2 form)
- (nth 1 form))))
- (list (if (eq integer 1) '1+ '1-)
- other)))
- (t form)))
+ ;; For (+ constants...), byte-optimize-predicate does the work.
+ (when (memq nil (mapcar 'numberp (cdr form)))
+ (cond
+ ;; (+ x 1) --> (1+ x) and (+ x -1) --> (1- x).
+ ((and (= (length form) 3)
+ (or (memq (nth 1 form) '(1 -1))
+ (memq (nth 2 form) '(1 -1))))
+ (let (integer other)
+ (if (memq (nth 1 form) '(1 -1))
+ (setq integer (nth 1 form) other (nth 2 form))
+ (setq integer (nth 2 form) other (nth 1 form)))
+ (setq form
+ (list (if (eq integer 1) '1+ '1-) other))))
+ ;; Here, we could also do
+ ;; (+ x y ... 1) --> (1+ (+ x y ...))
+ ;; (+ x y ... -1) --> (1- (+ x y ...))
+ ;; The resulting bytecode is smaller, but is it faster? -- cyd
+ ))
+ (byte-optimize-predicate form))
(defun byte-optimize-minus (form)
- ;; Put constants at the end, except the last constant.
- (setq form (byte-optimize-delay-constants-math form 2 '+))
- ;; Now only first and last element can be a number.
- (let ((last (car (reverse (nthcdr 3 form)))))
- (cond ((eq 0 last)
- ;; (- x y ... 0) --> (- x y ...)
- (setq form (copy-sequence form))
- (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form))))
- ((equal (nthcdr 2 form) '(1))
- (setq form (list '1- (nth 1 form))))
- ((equal (nthcdr 2 form) '(-1))
- (setq form (list '1+ (nth 1 form))))
- ;; If form is (- CONST foo... CONST), merge first and last.
- ((and (numberp (nth 1 form))
- (numberp last))
- (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
- (delq last (copy-sequence (nthcdr 3 form))))))))
-;;; It is not safe to delete the function entirely
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker).
-;;; (if (eq (nth 2 form) 0)
-;;; (nth 1 form) ; (- x 0) --> x
- (byte-optimize-predicate
- (if (and (null (cdr (cdr (cdr form))))
- (eq (nth 1 form) 0)) ; (- 0 x) --> (- x)
- (cons (car form) (cdr (cdr form)))
- form))
-;;; )
- )
+ ;; Don't call `byte-optimize-delay-constants-math' (bug#1334).
+ ;;(setq form (byte-optimize-delay-constants-math form 2 '+))
+ ;; Remove zeros.
+ (when (and (nthcdr 3 form)
+ (memq 0 (cddr form)))
+ (setq form (nconc (list (car form) (cadr form))
+ (delq 0 (copy-sequence (cddr form)))))
+ ;; After the above, we must turn (- x) back into (- x 0)
+ (or (cddr form)
+ (setq form (nconc form (list 0)))))
+ ;; For (- constants..), byte-optimize-predicate does the work.
+ (when (memq nil (mapcar 'numberp (cdr form)))
+ (cond
+ ;; (- x 1) --> (1- x)
+ ((equal (nthcdr 2 form) '(1))
+ (setq form (list '1- (nth 1 form))))
+ ;; (- x -1) --> (1+ x)
+ ((equal (nthcdr 2 form) '(-1))
+ (setq form (list '1+ (nth 1 form))))
+ ;; (- 0 x) --> (- x)
+ ((and (eq (nth 1 form) 0)
+ (= (length form) 3))
+ (setq form (list '- (nth 2 form))))
+ ;; Here, we could also do
+ ;; (- x y ... 1) --> (1- (- x y ...))
+ ;; (- x y ... -1) --> (1+ (- x y ...))
+ ;; The resulting bytecode is smaller, but is it faster? -- cyd
+ ))
+ (byte-optimize-predicate form))
(defun byte-optimize-multiply (form)
(setq form (byte-optimize-delay-constants-math form 1 '*))
- ;; If there is a constant in FORM, it is now the last element.
- (cond ((null (cdr form)) 1)
-;;; It is not safe to delete the function entirely
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker or if it appears in other arithmetic).
-;;; ((null (cdr (cdr form))) (nth 1 form))
- ((let ((last (car (reverse form))))
- (cond ((eq 0 last) (cons 'progn (cdr form)))
- ((eq 1 last) (delq 1 (copy-sequence form)))
- ((eq -1 last) (list '- (delq -1 (copy-sequence form))))
- ((and (eq 2 last)
- (memq t (mapcar 'symbolp (cdr form))))
- (prog1 (setq form (delq 2 (copy-sequence form)))
- (while (not (symbolp (car (setq form (cdr form))))))
- (setcar form (list '+ (car form) (car form)))))
- (form))))))
-
-(defsubst byte-compile-butlast (form)
- (nreverse (cdr (reverse form))))
+ ;; For (* constants..), byte-optimize-predicate does the work.
+ (when (memq nil (mapcar 'numberp (cdr form)))
+ ;; After `byte-optimize-predicate', if there is a INTEGER constant
+ ;; in FORM, it is in the last element.
+ (let ((last (car (reverse (cdr form)))))
+ (cond
+ ;; Would handling (* ... 0) here cause floating point errors?
+ ;; See bug#1334.
+ ((eq 1 last) (setq form (byte-compile-butlast form)))
+ ((eq -1 last)
+ (setq form (list '- (if (nthcdr 3 form)
+ (byte-compile-butlast form)
+ (nth 1 form))))))))
+ (byte-optimize-predicate form))
(defun byte-optimize-divide (form)
(setq form (byte-optimize-delay-constants-math form 2 '*))
+ ;; After `byte-optimize-predicate', if there is a INTEGER constant
+ ;; in FORM, it is in the last element.
(let ((last (car (reverse (cdr (cdr form))))))
- (if (numberp last)
- (cond ((= (length form) 3)
- (if (and (numberp (nth 1 form))
- (not (zerop last))
- (condition-case nil
- (/ (nth 1 form) last)
- (error nil)))
- (setq form (list 'progn (/ (nth 1 form) last)))))
- ((= last 1)
- (setq form (byte-compile-butlast form)))
- ((numberp (nth 1 form))
- (setq form (cons (car form)
- (cons (/ (nth 1 form) last)
- (byte-compile-butlast (cdr (cdr form)))))
- last nil))))
(cond
-;;; ((null (cdr (cdr form)))
-;;; (nth 1 form))
- ((eq (nth 1 form) 0)
- (append '(progn) (cdr (cdr form)) '(0)))
- ((eq last -1)
- (list '- (if (nthcdr 3 form)
- (byte-compile-butlast form)
- (nth 1 form))))
- (form))))
+ ;; Runtime error (leave it intact).
+ ((or (null last)
+ (eq last 0)
+ (memql 0.0 (cddr form))))
+ ;; No constants in expression
+ ((not (numberp last)))
+ ;; For (* constants..), byte-optimize-predicate does the work.
+ ((null (memq nil (mapcar 'numberp (cdr form)))))
+ ;; (/ x y.. 1) --> (/ x y..)
+ ((and (eq last 1) (nthcdr 3 form))
+ (setq form (byte-compile-butlast form)))
+ ;; (/ x -1), (/ x .. -1) --> (- x), (- (/ x ..))
+ ((eq last -1)
+ (setq form (list '- (if (nthcdr 3 form)
+ (byte-compile-butlast form)
+ (nth 1 form)))))))
+ (byte-optimize-predicate form))
(defun byte-optimize-logmumble (form)
(setq form (byte-optimize-delay-constants-math form 1 (car form)))
(let ((fn (nth 1 form)))
(if (memq (car-safe fn) '(quote function))
(cons (nth 1 fn) (cdr (cdr form)))
- form)))
+ form)))
(defun byte-optimize-apply (form)
;; If the last arg is a literal constant, turn this into a funcall.
char-equal char-to-string char-width
compare-strings concat coordinates-in-window-p
copy-alist copy-sequence copy-marker cos count-lines
- decdoe-char
+ decode-char
decode-time default-boundp default-value documentation downcase
elt encode-char exp expt encode-time error-message-string
fboundp fceiling featurep ffloor
next-window nth nthcdr number-to-string
parse-colon-path plist-get plist-member
prefix-numeric-value previous-window prin1-to-string propertize
+ degrees-to-radians
radians-to-degrees rassq rassoc read-from-string regexp-quote
region-beginning region-end reverse round
sin sqrt string string< string= string-equal string-lessp string-to-char
string-to-multibyte
tan truncate
unibyte-char-to-multibyte upcase user-full-name
- user-login-name user-original-login-name user-variable-p
+ user-login-name user-original-login-name custom-variable-p
vconcat
window-buffer window-dedicated-p window-edges window-height
window-hscroll window-minibuffer-p window-width
(put (car pure-fns) 'pure t)
(setq pure-fns (cdr pure-fns)))
nil)
-
-(defun byte-compile-splice-in-already-compiled-code (form)
- ;; form is (byte-code "..." [...] n)
- (if (not (memq byte-optimize '(t lap)))
- (byte-compile-normal-call form)
- (byte-inline-lapcode
- (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
- (setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
- byte-compile-maxdepth))
- (setq byte-compile-depth (1+ byte-compile-depth))))
-
-(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
-
\f
(defconst byte-constref-ops
'(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
+;; Used and set dynamically in byte-decompile-bytecode-1.
+(defvar bytedecomp-op)
+(defvar bytedecomp-ptr)
+
;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.)
-
-(defun disassemble-offset ()
+(defun disassemble-offset (bytes)
"Don't call this!"
- ;; fetch and return the offset for the current opcode.
- ;; return nil if this opcode has no offset
- ;; OP, PTR and BYTES are used and set dynamically
- (defvar op)
- (defvar ptr)
- (defvar bytes)
- (cond ((< op byte-nth)
- (let ((tem (logand op 7)))
- (setq op (logand op 248))
+ ;; Fetch and return the offset for the current opcode.
+ ;; Return nil if this opcode has no offset.
+ (cond ((< bytedecomp-op byte-nth)
+ (let ((tem (logand bytedecomp-op 7)))
+ (setq bytedecomp-op (logand bytedecomp-op 248))
(cond ((eq tem 6)
- (setq ptr (1+ ptr)) ;offset in next byte
- (aref bytes ptr))
+ ;; Offset in next byte.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (aref bytes bytedecomp-ptr))
((eq tem 7)
- (setq ptr (1+ ptr)) ;offset in next 2 bytes
- (+ (aref bytes ptr)
- (progn (setq ptr (1+ ptr))
- (lsh (aref bytes ptr) 8))))
- (t tem)))) ;offset was in opcode
- ((>= 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))
- (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))
- (setq ptr (1+ ptr)) ;offset in next byte
- (aref bytes ptr))))
-
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytes bytedecomp-ptr) 8))))
+ (t tem)))) ;Offset was in opcode.
+ ((>= bytedecomp-op byte-constant)
+ (prog1 (- bytedecomp-op byte-constant) ;Offset in opcode.
+ (setq bytedecomp-op byte-constant)))
+ ((or (and (>= bytedecomp-op byte-constant2)
+ (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
+ (= bytedecomp-op byte-stack-set2))
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytes bytedecomp-ptr) 8))))
+ ((and (>= bytedecomp-op byte-listN)
+ (<= bytedecomp-op byte-discardN))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;Offset in next byte.
+ (aref bytes bytedecomp-ptr))))
+
+(defvar byte-compile-tag-number)
;; This de-compiler is used for inline expansion of compiled functions,
;; and by the disassembler.
;; before each insn (or its label).
(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
(let ((length (length bytes))
- (ptr 0) optr tags op offset
- lap tmp
- endtag)
- (while (not (= ptr length))
+ (bytedecomp-ptr 0) optr tags bytedecomp-op offset
+ lap tmp)
+ (while (not (= bytedecomp-ptr length))
(or make-spliceable
- (setq lap (cons ptr lap)))
- (setq op (aref bytes ptr)
- optr ptr
- offset (disassemble-offset)) ; this does dynamic-scope magic
- (setq op (aref byte-code-vector op))
- (cond ((memq op byte-goto-ops)
- ;; it's a pc
+ (push bytedecomp-ptr lap))
+ (setq bytedecomp-op (aref bytes bytedecomp-ptr)
+ optr bytedecomp-ptr
+ ;; This uses dynamic-scope magic.
+ offset (disassemble-offset bytes))
+ (let ((opcode (aref byte-code-vector bytedecomp-op)))
+ (assert opcode)
+ (setq bytedecomp-op opcode))
+ (cond ((memq bytedecomp-op byte-goto-ops)
+ ;; It's a pc.
(setq offset
(cdr (or (assq offset tags)
- (car (setq tags
- (cons (cons offset
- (byte-compile-make-tag))
- tags)))))))
- ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
- ((memq op byte-constref-ops)))
+ (let ((new (cons offset (byte-compile-make-tag))))
+ (push new tags)
+ new)))))
+ ((cond ((eq bytedecomp-op 'byte-constant2)
+ (setq bytedecomp-op 'byte-constant) t)
+ ((memq bytedecomp-op byte-constref-ops)))
(setq tmp (if (>= offset (length constvec))
(list 'out-of-range offset)
(aref constvec offset))
- offset (if (eq op 'byte-constant)
+ offset (if (eq bytedecomp-op 'byte-constant)
(byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables)
- (car (setq byte-compile-variables
- (cons (list tmp)
- byte-compile-variables)))))))
- ((and make-spliceable
- (eq op 'byte-return))
- (if (= ptr (1- length))
- (setq op nil)
- (setq offset (or endtag (setq endtag (byte-compile-make-tag)))
- op 'byte-goto))))
+ (let ((new (list tmp)))
+ (push new byte-compile-variables)
+ new)))))
+ ((eq bytedecomp-op 'byte-stack-set2)
+ (setq bytedecomp-op 'byte-stack-set))
+ ((and (eq bytedecomp-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 bytedecomp-op 'byte-discardN-preserve-tos)
+ (setq offset (- offset #x80))))
;; lap = ( [ (pc . (op . arg)) ]* )
- (setq lap (cons (cons optr (cons op (or offset 0)))
- lap))
- (setq ptr (1+ ptr)))
- ;; take off the dummy nil op that we replaced a trailing "return" with.
+ (push (cons optr (cons bytedecomp-op (or offset 0)))
+ lap)
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
(let ((rest lap))
(while rest
(cond ((numberp (car rest)))
((setq tmp (assq (car (car rest)) tags))
- ;; this addr is jumped to
+ ;; This addr is jumped to.
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
(setq tags (delq tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
- (if (null (car (cdr (car lap))))
- (setq lap (cdr lap)))
- (if endtag
- (setq lap (cons (cons nil endtag) lap)))
- ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
+ ;; Remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
(mapcar (function (lambda (elt)
(if (numberp elt)
elt
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-stack-ref))
(defconst byte-compile-side-effect-free-ops
(nconc
;; The variable `byte-boolean-vars' is now primitive and updated
;; automatically by DEFVAR_BOOL.
-(defun byte-optimize-lapcode (lap &optional for-effect)
+(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
;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
;; The latter two can enable other optimizations.
;;
+ ;; For lexical variables, we could do the same
+ ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
+ ;; but this is a very minor gain, since dup is stack-ref-0,
+ ;; i.e. it's only better if X>5, and even then it comes
+ ;; at the cost of an extra stack slot. Let's not bother.
((and (eq 'byte-varref (car lap2))
- (eq (cdr lap1) (cdr lap2))
- (memq (car lap1) '(byte-varset byte-varbind)))
+ (eq (cdr lap1) (cdr lap2))
+ (memq (car lap1) '(byte-varset byte-varbind)))
(if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
(not (eq (car lap0) 'byte-constant)))
nil
;;
;; dup varset-X discard --> varset-X
;; dup varbind-X discard --> varbind-X
+ ;; dup stack-set-X discard --> stack-set-X-1
;; (the varbind variant can emerge from other optimizations)
;;
((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-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
rest (cdr rest))
+ (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
(setq lap (delq lap0 (delq lap2 lap))))
;;
;; not goto-X-if-nil --> goto-X-if-non-nil
;; it is wrong to do the same thing for the -else-pop variants.
;;
((and (eq 'byte-not (car lap0))
- (or (eq 'byte-goto-if-nil (car lap1))
- (eq 'byte-goto-if-not-nil (car lap1))))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
(byte-compile-log-lap " not %s\t-->\t%s"
lap1
(cons
;;
;; it is wrong to do the same thing for the -else-pop variants.
;;
- ((and (or (eq 'byte-goto-if-nil (car lap0))
- (eq 'byte-goto-if-not-nil (car lap0))) ; gotoX
+ ((and (memq (car lap0)
+ '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
(eq 'byte-goto (car lap1)) ; gotoY
(eq (cdr lap0) lap2)) ; TAG X
(let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
;; const goto-if-* --> whatever
;;
((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops))
- (cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
- (eq (car lap1) 'byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
+ (memq (car lap1) byte-conditional-ops)
+ ;; If the `byte-constant's cdr is not a cons cell, it has
+ ;; to be an index into the constant pool); even though
+ ;; it'll be a constant, that constant is not known yet
+ ;; (it's typically a free variable of a closure, so will
+ ;; only be known when the closure will be built at
+ ;; run-time).
+ (consp (cdr lap0)))
+ (cond ((if (memq (car lap1) '(byte-goto-if-nil
+ byte-goto-if-nil-else-pop))
+ (car (cdr lap0))
+ (not (car (cdr lap0))))
(byte-compile-log-lap " %s %s\t-->\t<deleted>"
lap0 lap1)
(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))
;;
;; varref-X varref-X --> varref-X dup
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
;; We don't optimize the const-X variations on this here,
;; 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 tmp2 0)
(while (eq (car (car tmp)) 'byte-dup)
- (setq tmp (cdr tmp)))
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
t)
- (eq (cdr lap0) (cdr (car tmp)))
- (eq 'byte-varref (car (car tmp))))
+ (eq (if (eq 'byte-stack-ref (car lap0))
+ (+ tmp2 1 (cdr lap0))
+ (cdr lap0))
+ (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp))))
(if (memq byte-optimize-log '(t byte))
(let ((str ""))
(setq tmp2 (cdr rest))
(cons 'byte-discard byte-conditional-ops)))
(not (eq lap1 (car tmp))))
(setq tmp2 (car tmp))
- (cond ((memq (car tmp2)
- (if (null (car (cdr lap0)))
- '(byte-goto-if-nil byte-goto-if-nil-else-pop)
- '(byte-goto-if-not-nil
- byte-goto-if-not-nil-else-pop)))
+ (cond ((when (consp (cdr lap0))
+ (memq (car tmp2)
+ (if (null (car (cdr lap0)))
+ '(byte-goto-if-nil byte-goto-if-nil-else-pop)
+ '(byte-goto-if-not-nil
+ byte-goto-if-not-nil-else-pop))))
(byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
lap0 tmp2 lap0 tmp2)
(setcar lap1 (car tmp2))
(setcdr lap1 (cdr tmp2))
;; Let next step fix the (const,goto-if*) sequence.
- (setq rest (cons nil rest)))
- (t
+ (setq rest (cons nil rest))
+ (setq keep-going t))
+ ((or (consp (cdr lap0))
+ (eq (car tmp2) 'byte-discard))
;; Jump one step further
(byte-compile-log-lap
" %s goto [%s]\t-->\t<deleted> goto <skip>"
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))))
- (setq keep-going t))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))))
;;
;; 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).
+ ;;
+ ;; Here again, we could do it for stack-ref/stack-set, but
+ ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+ ;; is a very minor improvement (if any), at the cost of
+ ;; more stack use and more byte-code. Let's not do it.
;;
((and (eq (car lap1) 'byte-varset)
(eq (car lap2) 'byte-goto)
;; Rebuild byte-compile-constants / byte-compile-variables.
;; Simple optimizations that would inhibit other optimizations if they
;; were done in the optimizing loop, and optimizations which there is no
- ;; need to do more than once.
+ ;; need to do more than once.
(setq byte-compile-constants nil
byte-compile-variables nil)
(setq rest lap)
+ (byte-compile-log-lap " ---- final pass")
(while rest
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
- (if (or (eq (car lap0) 'byte-constant)
- (eq (car lap0) 'byte-constant2))
+ (if (memq (car lap0) '(byte-constant byte-constant2))
(unless (memq (cdr lap0) byte-compile-constants)
(setq byte-compile-constants (cons (cdr lap0)
byte-compile-constants)))
(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 (1- (cdr lap0)))
+ (setq tmp3 0)
+ (while (memq (car (car tmp)) '(byte-discard byte-discardN))
+ (setq tmp3
+ (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
+ 1
+ (cdr (car tmp)))))
+ (setq tmp (cdr tmp)))
+ (>= tmp3 tmp2)))
+ ;; Do the optimization.
+ (setq lap (delq lap0 lap))
+ (setcar lap1
+ (if (= 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.
+ 'byte-discardN-preserve-tos
+ ;; Otherwise, the value stored is lost, so just use a
+ ;; normal discard.
+ 'byte-discardN))
+ (setcdr lap1 (1+ tmp3))
+ (setcdr (cdr rest) tmp)
+ (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))
+
+ ;;
+ ;; 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)))
+ (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) 1))))
+ ;; The byte-code interpreter will pop the stack for us, so
+ ;; we can just leave stuff on it.
+ (setq lap (delq lap0 lap))
+ (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
+ )
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
lap)
byte-optimize-lapcode))))
nil)
-;; arch-tag: 0f14076b-737e-4bef-aae6-908826ec1ff1
;;; byte-opt.el ends here
HCoop / bpt / emacs.git / blobdiff