procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

* lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode): Add 2 new opts

Browse source 
This introduces two new optimizations.  They're designed for code like

    (while
        (let (...)
          (if ... (progn blabla t) (progn blabla nil)))
      ...)

and they allow the elimination of the test internal to `while` since
we can immediately know when we return `t` or `nil` what the result
of the test will be.

`cl-labels` tends to generate this kind of code when it applies the
tail-call optimization.
This commit is contained in:
Stefan Monnier 2021-01-20 14:08:35 -05:00
parent 4dfebf25c7
commit 66439d31ad
1 changed files with 31 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

31
lisp/emacs-lisp/byte-opt.el
View file

@ -2056,6 +2056,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setcdr (cdr rest) tmp)
(byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
lap0 lap1))
;;
;; discardN-preserve-tos return --> return
;; dup return --> return
@ -2071,6 +2072,36 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setq lap (delq lap0 lap))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
;;
;; goto-X ... X: discard ==> discard goto-Y ... X: discard Y:
;;
((and (eq (car lap0) 'byte-goto)
(setq tmp (cdr (memq (cdr lap0) lap)))
(memq (caar tmp) '(byte-discard byte-discardN
byte-discardN-preserve-tos)))
(byte-compile-log-lap
" goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
(car tmp) (car tmp))
(setq keep-going t)
(let* ((newtag (byte-compile-make-tag))
;; Make a copy, since we sometimes modify insts in-place!
(newdiscard (cons (caar tmp) (cdar tmp)))
(newjmp (cons (car lap0) newtag)))
(push newtag (cdr tmp)) ;Push new tag after the discard.
(setcar rest newdiscard)
(push newjmp (cdr rest))))
;;
;; const discardN-preserve-tos ==> discardN const
;;
((and (eq (car lap0) 'byte-constant)
(eq (car lap1) 'byte-discardN-preserve-tos))
(setq keep-going t)
(let ((newdiscard (cons 'byte-discardN (cdr lap1))))
(byte-compile-log-lap
" %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
(setf (car rest) newdiscard)
(setf (cadr rest) lap0)))
)
(setq rest (cdr rest)))
)