;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler
-;; Copyright (C) 1991, 1994, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1991, 1994, 2000-2011 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:
(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)
;; 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)))
+ ;; "Replay" the operations: we used to just do
+ ;; (setq byte-compile-output (nconc (nreverse lap) byte-compile-output))
+ ;; but that fails to update byte-compile-depth, so we had to assume
+ ;; that `lap' ends up adding exactly 1 element to the stack. This
+ ;; happens to be true for byte-code generated by bytecomp.el without
+ ;; lexical-binding, but it's not true in general, and it's not true for
+ ;; code output by bytecomp.el with lexical-binding.
+ (dolist (op lap)
+ (cond
+ ((eq (car op) 'TAG) (byte-compile-out-tag op))
+ ((memq (car op) byte-goto-ops) (byte-compile-goto (car op) (cdr op)))
+ (t (byte-compile-out (car op) (cdr op))))))
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
(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))))))
+ (cond
+ ((and (symbolp fn) (not (eq fn t))) ;A function alias.
+ (byte-compile-inline-expand (cons fn (cdr form))))
+ ((and (byte-code-function-p fn)
+ ;; FIXME: This works to inline old-style-byte-codes into
+ ;; old-style-byte-codes, but not mixed cases (not sure
+ ;; about new-style into new-style).
+ (not lexical-binding)
+ (not (and (>= (length fn) 7)
+ (aref fn 6)))) ;6 = COMPILED_PUSH_ARGS
+ ;; (message "Inlining %S byte-code" name)
+ (fetch-bytecode fn)
+ (let ((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))))
+ ((eq (car-safe fn) 'lambda)
+ (macroexpand-all (cons fn (cdr form))
+ byte-compile-macro-environment))
+ (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). 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)))
form))
((or (byte-code-function-p fn)
(eq 'lambda (car-safe fn)))
- (byte-optimize-form-code-walker
- (byte-compile-unfold-lambda form)
- for-effect))
+ (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
(prin1-to-string form))
nil)
- ((memq fn '(defun defmacro function
- condition-case save-window-excursion))
+ ((memq fn '(defun defmacro 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))
-
+ ((eq fn 'internal-make-closure)
+ form)
+
((not (symbolp fn))
+ (debug)
(byte-compile-warn "`%s' is a malformed function"
(prin1-to-string fn))
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)))
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
(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))))
+ (byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))))
(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
(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)
+(defvar bytedecomp-bytes)
+
;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.)
-
(defun disassemble-offset ()
"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))
+ (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 bytedecomp-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))))
+ ;; Offset in next 2 bytes.
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (+ (aref bytedecomp-bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytedecomp-bytes bytedecomp-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))))
+ ((>= 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 bytedecomp-bytes bytedecomp-ptr)
+ (progn (setq bytedecomp-ptr (1+ bytedecomp-ptr))
+ (lsh (aref bytedecomp-bytes bytedecomp-ptr) 8))))
+ ((and (>= bytedecomp-op byte-listN)
+ (<= bytedecomp-op byte-discardN))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)) ;offset in next byte
+ (aref bytedecomp-bytes bytedecomp-ptr))))
;; This de-compiler is used for inline expansion of compiled functions,
;; If MAKE-SPLICEABLE is nil, we are being called for the disassembler.
;; In that case, we put a pc value into the list
;; 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
+(defun byte-decompile-bytecode-1 (bytedecomp-bytes constvec
+ &optional make-spliceable)
+ (let ((length (length bytedecomp-bytes))
+ (bytedecomp-ptr 0) optr tags bytedecomp-op offset
lap tmp
endtag)
- (while (not (= ptr length))
+ (while (not (= bytedecomp-ptr length))
(or make-spliceable
- (setq lap (cons ptr lap)))
- (setq op (aref bytes ptr)
- optr ptr
+ (setq lap (cons bytedecomp-ptr lap)))
+ (setq bytedecomp-op (aref bytedecomp-bytes bytedecomp-ptr)
+ optr bytedecomp-ptr
offset (disassemble-offset)) ; this does dynamic-scope magic
- (setq op (aref byte-code-vector op))
- (cond ((memq op byte-goto-ops)
+ (setq bytedecomp-op (aref byte-code-vector bytedecomp-op))
+ (cond ((memq bytedecomp-op byte-goto-ops)
;; it's a pc
(setq offset
(cdr (or (assq offset tags)
(cons (cons offset
(byte-compile-make-tag))
tags)))))))
- ((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
- ((memq op byte-constref-ops)))
+ ((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)
+ (eq bytedecomp-op 'byte-return))
+ (if (= bytedecomp-ptr (1- length))
+ (setq bytedecomp-op nil)
(setq offset (or endtag (setq endtag (byte-compile-make-tag)))
- op 'byte-goto))))
+ bytedecomp-op 'byte-goto)))
+ ((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)))
+ (setq lap (cons (cons optr (cons bytedecomp-op (or offset 0)))
lap))
- (setq ptr (1+ ptr)))
+ (setq bytedecomp-ptr (1+ bytedecomp-ptr)))
;; take off the dummy nil op that we replaced a trailing "return" with.
(let ((rest lap))
(while rest
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 ;; byte-closed-var
+ ))
(defconst byte-compile-side-effect-free-ops
(nconc
;; 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 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
;; const goto-if-* --> whatever
;;
((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops))
+ (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 (or (eq (car lap1) 'byte-goto-if-nil)
- (eq (car lap1) 'byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
+ (eq (car lap1) '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