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

LAP optimiser: more stack reduction hoisting

Browse source 
Hoisting stack reduction ops allows them to coalesce and/or cancel out
pushing ops, and for useful operations to sink and combine, such as
not + goto-if-[not-]nil.

* lisp/emacs-lisp/byte-opt.el (byte-optimize-lapcode):
Add the rule

  UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY

where UNARY pops and pushes one value.

Generalise the rule

  const discardN-preserve-tos --> discardN const

to any 0-ary op, not just const: varref, point, etc.
This commit is contained in:
Mattias Engdegård 2023-02-12 12:33:27 +01:00
parent a3edacd3f5
commit 8aef401b4f
1 changed files with 45 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -2042,6 +2042,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(let ((side-effect-free (if byte-compile-delete-errors
byte-compile-side-effect-free-ops
byte-compile-side-effect-and-error-free-ops))
;; Ops taking and produce a single value on the stack.
(unary-ops '( byte-not byte-length byte-list1 byte-nreverse
byte-car byte-cdr byte-car-safe byte-cdr-safe
byte-symbolp byte-consp byte-stringp
byte-listp byte-integerp byte-numberp
byte-add1 byte-sub1 byte-negate
;; There are more of these but the list is
;; getting long and the gain is typically small.
))
;; Ops producing a single result without looking at the stack.
(producer-ops '( byte-constant byte-varref
byte-point byte-point-max byte-point-min
byte-following-char byte-preceding-char
byte-current-column
byte-eolp byte-eobp byte-bolp byte-bobp
byte-current-buffer byte-widen))
(add-depth 0)
(keep-going 'first-time)
;; Create a cons cell as head of the list so that removing the first
@ -2421,12 +2437,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; const, varref, point etc.
;;
((and (eq (car (nth 2 rest)) 'byte-return)
(memq (car lap1) '( byte-constant byte-varref
byte-point byte-point-max byte-point-min
byte-following-char byte-preceding-char
byte-current-column
byte-eolp byte-eobp byte-bolp byte-bobp
byte-current-buffer byte-widen))
(memq (car lap1) producer-ops)
(or (memq (car lap0) '( byte-discard byte-discardN
byte-discardN-preserve-tos
byte-stack-set))
@ -2438,26 +2449,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
lap0 lap1 (nth 2 rest) lap1 (nth 2 rest)))
;;
;; discardN-preserve-tos OP return --> OP return
;; dup OP return --> OP return
;; where OP is 1->1 in stack use, like `not'.
;; (discardN-preserve-tos|dup) UNARY return --> UNARY return
;; where UNARY takes and produces a single value on the stack
;;
;; FIXME: ideally we should run this backwards, so that we could do
;; discardN-preserve-tos OP1...OPn return -> OP1..OPn return
;; but that would require a different approach.
;;
((and (eq (car (nth 2 rest)) 'byte-return)
(memq (car lap1)
'( byte-not
byte-symbolp byte-consp byte-stringp
byte-listp byte-integerp byte-numberp
byte-list1
byte-car byte-cdr byte-car-safe byte-cdr-safe
byte-length
byte-add1 byte-sub1 byte-negate byte-nreverse
;; There are more of these but the list is
;; getting long and the gain is small.
))
(memq (car lap1) unary-ops)
(or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
(and (eq (car lap0) 'byte-stack-set)
(eql (cdr lap0) 1))))
@ -2785,14 +2785,32 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(push newjmp (cdr rest)))
t)))))
;;
;; const discardN-preserve-tos ==> discardN const
;; const stack-set(1) ==> discard const
;;
((and (eq (car lap0) 'byte-constant)
;;
;; UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY
;; where UNARY takes and produces a single value on the stack
;;
((and (memq (car lap0) unary-ops)
(or (eq (car lap1) 'byte-discardN-preserve-tos)
(and (eq (car lap1) 'byte-stack-set)
(eql (cdr lap1) 1))))
(eql (cdr lap1) 1)))
;; unless followed by return (which will eat the discard)
(not (eq (car lap2) 'byte-return)))
(setq keep-going t)
(byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
(setcar rest lap1)
(setcar (cdr rest) lap0))
;;
;; PRODUCER discardN-preserve-tos(X) --> discard(X) PRODUCER
;; where PRODUCER pushes a result without looking at the stack:
;; const, varref, point etc.
;;
((and (memq (car lap0) producer-ops)
(or (eq (car lap1) 'byte-discardN-preserve-tos)
(and (eq (car lap1) 'byte-stack-set)
(eql (cdr lap1) 1)))
;; unless followed by return (which will eat the discard)
(not (eq (car lap2) 'byte-return)))
(setq keep-going t)
(let ((newdiscard (if (eql (cdr lap1) 1)
(cons 'byte-discard nil)
@ -2801,6 +2819,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
" %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
(setf (car rest) newdiscard)
(setf (cadr rest) lap0)))
(t
;; If no rule matched, advance and try again.
(setq prev (cdr prev))))))))