diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 40 |
1 files changed, 34 insertions, 6 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 13f885448ae..b775976efb2 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -185,6 +185,7 @@ (require 'bytecomp) (eval-when-compile (require 'cl-lib)) (require 'macroexp) +(require 'subr-x) (defun byte-compile-log-lap-1 (format &rest args) ;; Newer byte codes for stack-ref make the slot 0 non-nil again. @@ -1356,7 +1357,7 @@ (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (let ((length (length bytes)) (bytedecomp-ptr 0) optr tags bytedecomp-op offset - lap tmp) + lap tmp last-constant) (while (not (= bytedecomp-ptr length)) (or make-spliceable (push bytedecomp-ptr lap)) @@ -1385,7 +1386,8 @@ (or (assq tmp byte-compile-variables) (let ((new (list tmp))) (push new byte-compile-variables) - new))))) + new))) + last-constant tmp)) ((eq bytedecomp-op 'byte-stack-set2) (setq bytedecomp-op 'byte-stack-set)) ((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80)) @@ -1394,7 +1396,27 @@ ;; 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)))) + (setq offset (- offset #x80))) + ((eq bytedecomp-op 'byte-switch) + (cl-assert (hash-table-p last-constant) nil + "byte-switch used without preceeding hash table") + ;; make a copy of constvec to avoid making changes to the + ;; original jump table for the compiled function. + (setq constvec (cl-map 'vector + #'(lambda (e) + (if (eq last-constant e) + (setq last-constant (copy-hash-table e)) + e)) + constvec)) + (maphash #'(lambda (value tag) + (let (newtag) + (cl-assert (consp tag) + nil "Invalid address for byte-switch") + (setq newtag (byte-compile-make-tag)) + (push (cons (+ (car tag) (lsh (cdr tag) 8)) newtag) tags) + (puthash value newtag last-constant))) + last-constant) + (setf (nth 2 (cadr lap)) last-constant))) ;; lap = ( [ (pc . (op . arg)) ]* ) (push (cons optr (cons bytedecomp-op (or offset 0))) lap) @@ -1728,7 +1750,10 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; unused-TAG: --> <deleted> ;; ((and (eq 'TAG (car lap0)) - (not (rassq lap0 lap))) + (not (rassq lap0 lap)) + (cl-loop for table in byte-compile-jump-tables + when (member lap0 (hash-table-values table)) + return nil finally return t)) (and (memq byte-optimize-log '(t byte)) (byte-compile-log " unused tag %d removed" (nth 1 lap0))) (setq lap (delq lap0 lap) @@ -1736,9 +1761,12 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ;; goto ... --> goto <delete until TAG or end> ;; return ... --> return <delete until TAG or end> - ;; + ;; (unless a jump-table is being used, where deleting may affect + ;; other valid case bodies) + ;; ((and (memq (car lap0) '(byte-goto byte-return)) - (not (memq (car lap1) '(TAG nil)))) + (not (memq (car lap1) '(TAG nil))) + (not byte-compile-jump-tables)) (setq tmp rest) (let ((i 0) (opt-p (memq byte-optimize-log '(t lap))) |