mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-11-23 07:19:15 +00:00
Code Issues Releases Activity

Fix recent LAP optimiser error

Browse Source 
* lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode):
Fix a flaw in the

  dup (varset|varbind|stack-set) discard -> (varset|varbind|stack-set)

rule: don't match stack-set(1) which is dealt with elsewhere, and
generalise to discard(N).
This commit is contained in:
Mattias Engdegård 2023-02-14 17:06:49 +01:00
parent 0960ce4b57
commit 864bf5dda4
1 changed files with 32 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
lisp/emacs-lisp/byte-opt.el
View File

@ -2167,31 +2167,39 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; be larger than necessary. ;; be larger than necessary.
(setq add-depth 1)) (setq add-depth 1))
t))))) t)))))
;; ;;
;; dup varset-X discard --> varset-X ;; dup varset discard(N) --> varset discard(N-1)
;; dup varbind-X discard --> varbind-X ;; dup varbind discard(N) --> varbind discard(N-1)
;; dup stack-set-X discard --> stack-set-X-1 ;; dup stack-set(M) discard(N) --> stack-set(M-1) discard(N-1), M>1
;; (the varbind variant can emerge from other optimizations) ;; (the varbind variant can emerge from other optimizations)
;; ;;
((and (eq 'byte-dup (car lap0)) ((and (eq 'byte-dup (car lap0))
(eq 'byte-discard (car lap2)) (memq (car lap2) '(byte-discard byte-discardN))
(memq (car lap1) '(byte-varset byte-varbind (or (memq (car lap1) '(byte-varset byte-varbind))
byte-stack-set))) (and (eq (car lap1) 'byte-stack-set)
(setq keep-going t) (> (cdr lap1) 1))))
(setcdr prev (cdr rest)) ; remove dup (setcdr prev (cdr rest)) ; remove dup
(setcdr (cdr rest) (cdddr rest)) ; remove discard (let ((new1 (if (eq (car lap1) 'byte-stack-set)
(cond ((not (eq (car lap1) 'byte-stack-set)) (cons 'byte-stack-set (1- (cdr lap1)))
(byte-compile-log-lap " %s %s %s\t-->\t%s" lap1))
lap0 lap1 lap2 lap1)) (n (if (eq (car lap2) 'byte-discard) 1 (cdr lap2))))
((eql (cdr lap1) 1) (setcar (cdr rest) new1)
(byte-compile-log-lap " %s %s %s\t-->\t<deleted>" (cl-assert (> n 0))
lap0 lap1 lap2)) (cond
(t ((> n 1)
(let ((n (1- (cdr lap1)))) (let ((new2 (if (> n 2)
(byte-compile-log-lap " %s %s %s\t-->\t%s" (cons 'byte-discardN (1- n))
lap0 lap1 lap2 (cons 'byte-discard nil))))
(cons (car lap1) n)) (byte-compile-log-lap " %s %s %s\t-->\t%s %s"
(setcdr lap1 n))))) lap0 lap1 lap2 new1 new2)
(setcar (cddr rest) new2)))
(t
(byte-compile-log-lap " %s %s %s\t-->\t%s"
lap0 lap1 lap2 new1)
;; discard(0) = nop, remove
(setcdr (cdr rest) (cdddr rest)))))
(setq keep-going t))
;; ;;
;; not goto-X-if-nil --> goto-X-if-non-nil ;; not goto-X-if-nil --> goto-X-if-non-nil
;; not goto-X-if-non-nil --> goto-X-if-nil ;; not goto-X-if-non-nil --> goto-X-if-nil