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.
(setq add-depth 1))
t)))))
;;
;; 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
byte-stack-set)))
(setq keep-going t)
;;
;; dup varset discard(N) --> varset discard(N-1)
;; dup varbind discard(N) --> varbind discard(N-1)
;; dup stack-set(M) discard(N) --> stack-set(M-1) discard(N-1), M>1
;; (the varbind variant can emerge from other optimizations)
;;
((and (eq 'byte-dup (car lap0))
(memq (car lap2) '(byte-discard byte-discardN))
(or (memq (car lap1) '(byte-varset byte-varbind))
(and (eq (car lap1) 'byte-stack-set)
(> (cdr lap1) 1))))
(setcdr prev (cdr rest)) ; remove dup
(setcdr (cdr rest) (cdddr rest)) ; remove discard
(cond ((not (eq (car lap1) 'byte-stack-set))
(byte-compile-log-lap " %s %s %s\t-->\t%s"
lap0 lap1 lap2 lap1))
((eql (cdr lap1) 1)
(byte-compile-log-lap " %s %s %s\t-->\t<deleted>"
lap0 lap1 lap2))
(t
(let ((n (1- (cdr lap1))))
(byte-compile-log-lap " %s %s %s\t-->\t%s"
lap0 lap1 lap2
(cons (car lap1) n))
(setcdr lap1 n)))))
(let ((new1 (if (eq (car lap1) 'byte-stack-set)
(cons 'byte-stack-set (1- (cdr lap1)))
lap1))
(n (if (eq (car lap2) 'byte-discard) 1 (cdr lap2))))
(setcar (cdr rest) new1)
(cl-assert (> n 0))
(cond
((> n 1)
(let ((new2 (if (> n 2)
(cons 'byte-discardN (1- n))
(cons 'byte-discard nil))))
(byte-compile-log-lap " %s %s %s\t-->\t%s %s"
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-non-nil --> goto-X-if-nil