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

LAP peephole optimisation improvements

Browse source 
- Since discardN-preserve-tos(1) and stack-set(1) have the same
  effect, treat them as equivalent in all transformations.

- Move the rule

        discardN-preserve-tos(X) discardN-preserve-tos(Y)
    --> discardN-preserve-tos(X+Y)

  from the final pass to the main iteration since it may enable
  further optimisations.

- Don't apply the rule

    goto(X) ... X: DISCARD --> DISCARD goto(Y) ... X: DISCARD Y:

  when DISCARD could be merged or deleted instead, which is even better.

- Add the rule

    OP const return -> <deleted> const return

  where OP is effect-free.

- Generalise the push-pop annihilation rule to

    PUSH(K) discard(N) -> discard(N-K), N>K
    PUSH(K) discard(N) -> <deleted>,    N=K

  to any N, not just N=1.

- Add the rule

    OP goto(X) Y: OP X: -> <deleted> Y: OP X:

  for any operation OP.

* lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode):
Make the changes described above.
This commit is contained in:
Mattias Engdegård 2023-01-18 18:36:29 +01:00
parent f6955482c2
commit bfd338aad9
1 changed files with 90 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -2042,31 +2042,29 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; optimized but sequences like "dup varset TAG1: discard" are not.
;; You may be tempted to change this; resist that temptation.
(cond
;; <side-effect-free> pop --> <deleted>
;; ...including:
;; const-X pop --> <deleted>
;; varref-X pop --> <deleted>
;; dup pop --> <deleted>
;;
((and (eq 'byte-discard (car lap1))
;;
;; PUSH(K) discard(N) --> <deleted> discard(N-K), N>K
;; PUSH(K) discard(N) --> <deleted>, N=K
;; where PUSH(K) is a side-effect-free op such as const, varref, dup
;;
((and (memq (car lap1) '(byte-discard byte-discardN))
(memq (car lap0) side-effect-free))
(setq keep-going t)
(setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
(setq rest (cdr rest))
(cond ((eql tmp 1)
(byte-compile-log-lap
" %s discard\t-->\t<deleted>" lap0)
(setq lap (delq lap0 (delq lap1 lap))))
((eql tmp 0)
(byte-compile-log-lap
" %s discard\t-->\t<deleted> discard" lap0)
(setq lap (delq lap0 lap)))
((eql tmp -1)
(byte-compile-log-lap
" %s discard\t-->\tdiscard discard" lap0)
(setcar lap0 'byte-discard)
(setcdr lap0 0))
(t (error "Optimizer error: too much on the stack"))))
(let* ((pushes (aref byte-stack+-info (symbol-value (car lap0))))
(pops (if (eq (car lap1) 'byte-discardN) (cdr lap1) 1))
(net-pops (- pops pushes)))
(cond ((= net-pops 0)
(byte-compile-log-lap " %s %s\t-->\t<deleted>" lap0 lap1)
(setcdr rest (cddr rest))
(setq lap (delq lap0 lap)))
((> net-pops 0)
(byte-compile-log-lap
" %s %s\t-->\t<deleted> discard(%d)" lap0 lap1 net-pops)
(setcar rest (if (eql net-pops 1)
(cons 'byte-discard nil)
(cons 'byte-discardN net-pops)))
(setcdr rest (cddr rest)))
(t (error "Optimizer error: too much on the stack")))))
;;
;; goto*-X X: --> X:
;;
@ -2353,6 +2351,40 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setcar lap0 'byte-return))
(setcdr lap0 (cdr tmp))
(setq keep-going t))))
;;
;; OP goto(X) Y: OP X: -> Y: OP X:
;;
((and (eq (car lap1) 'byte-goto)
(eq (car lap2) 'TAG)
(let ((lap3 (nth 3 rest)))
(and (eq (car lap0) (car lap3))
(eq (cdr lap0) (cdr lap3))
(eq (cdr lap1) (nth 4 rest)))))
(byte-compile-log-lap " %s %s %s %s %s\t-->\t%s %s %s"
lap0 lap1 lap2
(nth 3 rest) (nth 4 rest)
lap2 (nth 3 rest) (nth 4 rest))
(setcdr rest (cddr rest))
(setq lap (delq lap0 lap))
(setq keep-going t))
;;
;; OP const return --> const return
;; where OP is side-effect-free (or mere stack manipulation).
;;
((and (eq (car lap1) 'byte-constant)
(eq (car (nth 2 rest)) 'byte-return)
(or (memq (car lap0) '( byte-discard byte-discardN
byte-discardN-preserve-tos
byte-stack-set))
(memq (car lap0) side-effect-free)))
(setq keep-going t)
(setq add-depth 1) ; in case we get rid of too much stack reduction
(setq lap (delq lap0 lap))
(byte-compile-log-lap " %s %s %s\t-->\t%s %s"
lap0 lap1 (nth 2 rest) lap1 (nth 2 rest)))
;;
;; goto-*-else-pop X ... X: goto-if-* --> whatever
;; goto-*-else-pop X ... X: discard --> whatever
@ -2491,6 +2523,24 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
)
(setq keep-going t))
;;
;; discardN-preserve-tos(X) discardN-preserve-tos(Y)
;; --> discardN-preserve-tos(X+Y)
;; where stack-set(1) is accepted as discardN-preserve-tos(1)
;;
((and (or (eq (car lap0) 'byte-discardN-preserve-tos)
(and (eq (car lap0) 'byte-stack-set) (eql (cdr lap0) 1)))
(or (eq (car lap1) 'byte-discardN-preserve-tos)
(and (eq (car lap1) 'byte-stack-set) (eql (cdr lap1) 1))))
(setq keep-going t)
(let ((new-op (cons 'byte-discardN-preserve-tos
;; This happens to work even when either
;; op is stack-set(1).
(+ (cdr lap0) (cdr lap1)))))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 new-op)
(setcar rest new-op)
(setcdr rest (cddr rest))))
;;
;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
;; stack-set-M [discard/discardN ...] --> discardN
@ -2529,7 +2579,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; discardN-preserve-tos return --> return
;; dup return --> return
;; stack-set-N return --> return ; where N is TOS-1
;; stack-set(1) return --> return
;;
((and (eq (car lap1) 'byte-return)
(or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
@ -2546,8 +2596,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
((and (eq (car lap0) 'byte-goto)
(setq tmp (cdr (memq (cdr lap0) lap)))
(memq (caar tmp) '(byte-discard byte-discardN
byte-discardN-preserve-tos)))
(or (memq (caar tmp) '(byte-discard byte-discardN))
;; Make sure we don't hoist a discardN-preserve-tos
;; that really should be merged or deleted instead.
(and (eq (caar tmp) 'byte-discardN-preserve-tos)
(let ((next (cadr tmp)))
(not (or (memq (car next) '(byte-discardN-preserve-tos
byte-return))
(and (eq (car next) 'byte-stack-set)
(eql (cdr next) 1))))))))
(byte-compile-log-lap
" goto-X .. X: \t-->\t%s goto-X.. X: %s Y:"
(car tmp) (car tmp))
@ -2562,11 +2619,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; const discardN-preserve-tos ==> discardN const
;; const stack-set(1) ==> discard const
;;
((and (eq (car lap0) 'byte-constant)
(eq (car lap1) 'byte-discardN-preserve-tos))
(or (eq (car lap1) 'byte-discardN-preserve-tos)
(and (eq (car lap1) 'byte-stack-set)
(eql (cdr lap1) 1))))
(setq keep-going t)
(let ((newdiscard (cons 'byte-discardN (cdr lap1))))
(let ((newdiscard (if (eql (cdr lap1) 1)
(cons 'byte-discard nil)
(cons 'byte-discardN (cdr lap1)))))
(byte-compile-log-lap
" %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
(setf (car rest) newdiscard)
@ -2651,16 +2713,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0))
(if (eq (car lap1) 'byte-discard) 1 (cdr lap1))))
(setcar lap1 'byte-discardN))
;;
;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
;; discardN-preserve-tos-(X+Y)
;;
((and (eq (car lap0) 'byte-discardN-preserve-tos)
(eq (car lap1) 'byte-discardN-preserve-tos))
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap0) (cdr lap1)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest)))
)
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))