From 8aef401b4f66a64ddfa9390590fb2cae1f96d522 Mon Sep 17 00:00:00 2001 From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= Date: Sun, 12 Feb 2023 12:33:27 +0100 Subject: [PATCH] LAP optimiser: more stack reduction hoisting 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. --- lisp/emacs-lisp/byte-opt.el | 67 ++++++++++++++++++++++++------------- 1 file changed, 43 insertions(+), 24 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 833e88887f9..1fa8e8bdf8b 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -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))))) + ;; + ;; 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))) + ;; 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)) + ;; - ;; const discardN-preserve-tos ==> discardN const - ;; const stack-set(1) ==> discard const + ;; PRODUCER discardN-preserve-tos(X) --> discard(X) PRODUCER + ;; where PRODUCER pushes a result without looking at the stack: + ;; const, varref, point etc. ;; - ((and (eq (car lap0) 'byte-constant) + ((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)))) + (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)))))))) -- 2.39.2