diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 47 |
1 files changed, 41 insertions, 6 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 13f885448ae..146fbcc1cb6 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,34 @@ ;; 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") + ;; We cannot use the original hash table referenced in the op, + ;; so we create a copy of it, and replace the addresses with + ;; TAGs. + (let ((orig-table last-constant)) + (cl-loop for e across constvec + when (eq e last-constant) + do (setq last-constant (copy-hash-table e)) + and return nil) + ;; Replace all addresses with TAGs. + (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) + ;; Replace the hash table referenced in the lapcode with our + ;; modified one. + (cl-loop for el in-ref lap + when (and (listp el) ;; make sure we're at the correct op + (eq (nth 1 el) 'byte-constant) + (eq (nth 2 el) orig-table)) + do (setf (nth 2 el) last-constant) and return nil)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (push (cons optr (cons bytedecomp-op (or offset 0))) lap) @@ -1728,7 +1757,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 +1768,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))) |