bug#42147: 28.0.50; pure vs side-effect-free, missing optimizations?

["Mattias Engdegård" <mattiase@acm.org>]

[-- Attachment #1: Type: text/plain, Size: 811 bytes --]

7 juli 2020 kl. 18.24 skrev Andrea Corallo <andrea_corallo@yahoo.it>:

> Sure I'm.  The native compiler does it already but I'm curious to see
> how you do it at source level and how generic it is.

Not very, but doing it at source level has some advantages since it can enable other source-level transformations.
It's mainly a proof of concept -- for simplicity, it doesn't attempt to be overly clever in the face of loops or setq.

One snag is that because Emacs inline functions (defsubst) are inlined as bytecode, they are usually not amenable to source optimisations. It is only when a defsubst is imported from a different .el file that has not yet been byte-compiled that it is integrated as source, and then the machinery in this patch will nicely propagate constant arguments into the body.


[-- Attachment #2: 0001-Constprop-of-lexical-variables.patch --]
[-- Type: application/octet-stream, Size: 20231 bytes --]

From 6ba3ec19de923250394f86fbbdb843f43f2f519a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sat, 28 Dec 2019 21:11:56 +0100
Subject: [PATCH] Constprop of lexical variables

Lexical variables bound to a constant value (symbol, number or string)
are substituted at their point of use and the variable then eliminated
if possible.  Example:

  (let ((x (+ 2 3))) (f x))  =>  (f 5)

This reduces code size, eliminates stack operations, and enables
further optimisations.  The constprop mechanism is generally afraid of
variable mutation, conditions and loops.

* lisp/emacs-lisp/byte-opt.el (byte-optimize-enable-constprop):
Master switch for constprop optimisations.
(byte-optimize--lexvars, byte-optimize--vars-outside-condition)
(byte-optimize--vars-outside-loop, byte-optimize--constprop-mode)
(byte-optimize--dynamic-vars): New dynamic variables.
(byte-optimize--substitutable-p, byte-optimize-let-form): New.
(byte-optimize-form-code-walker): Adapt several clauses for constprop,
and add clauses for 'setq' and 'defvar'.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-test-var)
(bytecomp-test-get-var, bytecomp-test-identity)
(byte-opt-testsuite-arith-data): Add constprop test cases.
---
 lisp/emacs-lisp/byte-opt.el            | 299 +++++++++++++++++++------
 test/lisp/emacs-lisp/bytecomp-tests.el |  59 +++++
 2 files changed, 290 insertions(+), 68 deletions(-)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 194ceee176..a4a14410b9 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -366,6 +366,48 @@ byte-compile-unfold-lambda
 \f
 ;;; implementing source-level optimizers
 
+(defconst byte-optimize-enable-constprop t
+  "If non-nil, enable constant propagation optimisations.")
+
+(defvar byte-optimize--lexvars nil
+  "Lexical variables in scope, in reverse order of declaration.
+Each element is on the form (NAME CHANGED [VALUE]), where:
+  NAME is the variable name,
+  CHANGED is a boolean indicating whether it's been changed (with setq),
+  VALUE, if present, is a substitutable expression.
+Earlier variables shadow later ones with the same name.
+Only lexical variables are included.")
+
+(defvar byte-optimize--vars-outside-condition nil
+  "Alist of variables lexically bound outside conditionally executed code.")
+
+(defvar byte-optimize--vars-outside-loop nil
+  "Alist of variables lexically bound outside the innermost `while' loop.")
+
+(defvar byte-optimize--constprop-mode t
+  "Constant-propagation mode: When t, constprop is always
+enabled; when nil, disabled for variables bound outside the
+innermost loop; when `loop', disabled for changed variables bound
+outside the innermost loop.")
+
+(defvar byte-optimize--dynamic-vars nil
+  "List of variables declared as dynamic during optimisation.")
+
+(defun byte-optimize--substitutable-p (expr)
+  "Whether EXPR is a constant that can be propagated."
+  ;; Only consider numbers, symbols and strings to be values for substitution
+  ;; purposes.  Numbers and symbols are immutable, and mutating string
+  ;; literals (or results from constant-evaluated string-returning functions)
+  ;; can be considered undefined.
+  ;; (What about other quoted values, like conses?)
+  (or (booleanp expr)
+      (numberp expr)
+      (stringp expr)
+      (and (consp expr)
+           (eq (car expr) 'quote)
+           (symbolp (cadr expr)))
+      (keywordp expr)))
+
 (defun byte-optimize-form-code-walker (form for-effect)
   ;;
   ;; For normal function calls, We can just mapcar the optimizer the cdr.  But
@@ -377,11 +419,22 @@ byte-optimize-form-code-walker
   (let ((fn (car-safe form))
 	tmp)
     (cond ((not (consp form))
-	   (if (not (and for-effect
-			 (or byte-compile-delete-errors
-			     (not (symbolp form))
-			     (eq form t))))
-	     form))
+           (cond
+            ((and for-effect
+		  (or byte-compile-delete-errors
+		      (not (symbolp form))
+		      (eq form t)))
+             nil)
+            ((symbolp form)
+             (let ((lexvar (assq form byte-optimize--lexvars)))
+               (if (and (cddr lexvar)      ; Value available?
+                        (or (eq byte-optimize--constprop-mode t)
+                            (not (assq form byte-optimize--vars-outside-loop))
+                            (and (eq byte-optimize--constprop-mode 'loop)
+                                 (not (cadr lexvar)))))  ; Variable unchanged?
+                   (caddr lexvar)
+                 form)))
+            (t form)))
 	  ((eq fn 'quote)
 	   (if (cdr (cdr form))
 	       (byte-compile-warn "malformed quote form: `%s'"
@@ -402,29 +455,19 @@ byte-optimize-form-code-walker
 	   ;; recursively enter the optimizer for the bindings and body
 	   ;; of a let or let*.  This for depth-firstness: forms that
 	   ;; are more deeply nested are optimized first.
-	   (cons fn
-	     (cons
-	      (mapcar (lambda (binding)
-			 (if (symbolp binding)
-			     binding
-			   (if (cdr (cdr binding))
-			       (byte-compile-warn "malformed let binding: `%s'"
-						  (prin1-to-string binding)))
-			   (list (car binding)
-				 (byte-optimize-form (nth 1 binding) nil))))
-		      (nth 1 form))
-	      (byte-optimize-body (cdr (cdr form)) for-effect))))
+           (cons fn (byte-optimize-let-form fn (cdr form) for-effect)))
 	  ((eq fn 'cond)
-	   (cons fn
-		 (mapcar (lambda (clause)
-			    (if (consp clause)
-				(cons
-				 (byte-optimize-form (car clause) nil)
-				 (byte-optimize-body (cdr clause) for-effect))
-			      (byte-compile-warn "malformed cond form: `%s'"
-						 (prin1-to-string clause))
-			      clause))
-			 (cdr form))))
+           (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars))
+	     (cons fn
+		   (mapcar (lambda (clause)
+			     (if (consp clause)
+				 (cons
+				  (byte-optimize-form (car clause) nil)
+				  (byte-optimize-body (cdr clause) for-effect))
+			       (byte-compile-warn "malformed cond form: `%s'"
+						  (prin1-to-string clause))
+			       clause))
+			   (cdr form)))))
 	  ((eq fn 'progn)
 	   ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
 	   (if (cdr (cdr form))
@@ -456,36 +499,54 @@ byte-optimize-form-code-walker
 	     (byte-compile-warn "too few arguments for `if'"))
 	   (cons fn
 	     (cons (byte-optimize-form (nth 1 form) nil)
-	       (cons
-		(byte-optimize-form (nth 2 form) for-effect)
-		(byte-optimize-body (nthcdr 3 form) for-effect)))))
+                   (let ((byte-optimize--vars-outside-condition
+                          byte-optimize--lexvars))
+	             (cons
+		      (byte-optimize-form (nth 2 form) for-effect)
+		      (byte-optimize-body (nthcdr 3 form) for-effect))))))
 
 	  ((memq fn '(and or))  ; Remember, and/or are control structures.
-	   ;; Take forms off the back until we can't any more.
-	   ;; In the future it could conceivably be a problem that the
-	   ;; subexpressions of these forms are optimized in the reverse
-	   ;; order, but it's ok for now.
-	   (if for-effect
-	       (let ((backwards (reverse (cdr form))))
-		 (while (and backwards
-			     (null (setcar backwards
-					   (byte-optimize-form (car backwards)
-							       for-effect))))
-		   (setq backwards (cdr backwards)))
-		 (if (and (cdr form) (null backwards))
-		     (byte-compile-log
-		      "  all subforms of %s called for effect; deleted" form))
-		 (and backwards
-		      (cons fn (nreverse (mapcar 'byte-optimize-form
-                                                 backwards)))))
-	     (cons fn (mapcar 'byte-optimize-form (cdr form)))))
-
-	  ((eq fn 'while)
-           (unless (consp (cdr form))
-	     (byte-compile-warn "too few arguments for `while'"))
-           (cons fn
-                 (cons (byte-optimize-form (cadr form) nil)
-                       (byte-optimize-body (cddr form) t))))
+           ;; We have to optimise in left-to-right order, but doing so
+           ;; we miss some optimisation opportunities: consider
+           ;; (and A B) in a for-effect context, where B => nil.
+           ;; Then A could be optimised in a for-effect context too.
+           (let ((tail (cdr form))
+                 (args nil))
+             (when tail
+               ;; The first argument is always unconditional.
+               (push (byte-optimize-form
+                      (car tail) (and for-effect (null (cdr tail))))
+                     args)
+               (setq tail (cdr tail))
+               ;; Remaining arguments are conditional.
+               (let ((byte-optimize--vars-outside-condition
+                      byte-optimize--lexvars))
+                 (while tail
+                   (push (byte-optimize-form
+                          (car tail) (and for-effect (null (cdr tail))))
+                         args)
+                   (setq tail (cdr tail)))))
+             (cons fn (nreverse args))))
+
+          ((eq fn 'while)
+           (let ((byte-optimize--vars-outside-condition
+                  byte-optimize--lexvars)
+                 (byte-optimize--vars-outside-loop
+                  byte-optimize--lexvars))
+             ;; Traverse the loop twice: first without any
+             ;; constprop, to detect setq forms...
+             (let ((opt
+                    (let ((byte-optimize--constprop-mode nil))
+                      (cons (byte-optimize-form (nth 1 form) nil)
+                            (byte-optimize-body (nthcdr 2 form) t)))))
+               ;; ... then in loop mode, allowing substitution of variables
+               ;; bound inside all loops or not changed anywhere.
+               ;; This is a bit slow (exponential in the number of nested
+               ;; loops).
+               (let ((byte-optimize--constprop-mode 'loop))
+                 (cons fn
+                       (cons (byte-optimize-form (car opt) nil)
+                             (byte-optimize-body (cdr opt) t)))))))
 
 	  ((eq fn 'interactive)
 	   (byte-compile-warn "misplaced interactive spec: `%s'"
@@ -498,12 +559,14 @@ byte-optimize-form-code-walker
 	   form)
 
 	  ((eq fn 'condition-case)
-           `(condition-case ,(nth 1 form) ;Not evaluated.
-                ,(byte-optimize-form (nth 2 form) for-effect)
-              ,@(mapcar (lambda (clause)
-                          `(,(car clause)
-                            ,@(byte-optimize-body (cdr clause) for-effect)))
-                        (nthcdr 3 form))))
+           (let ((byte-optimize--vars-outside-condition
+                  byte-optimize--lexvars))
+             `(condition-case ,(nth 1 form) ;Not evaluated.
+                  ,(byte-optimize-form (nth 2 form) for-effect)
+                ,@(mapcar (lambda (clause)
+                            `(,(car clause)
+                              ,@(byte-optimize-body (cdr clause) for-effect)))
+                          (nthcdr 3 form)))))
 
 	  ((eq fn 'unwind-protect)
 	   ;; the "protected" part of an unwind-protect is compiled (and thus
@@ -511,14 +574,21 @@ byte-optimize-form-code-walker
 	   ;; non-protected part has the same for-effect status as the
 	   ;; unwind-protect itself.  (The protected part is always for effect,
 	   ;; but that isn't handled properly yet.)
-	   (cons fn
-		 (cons (byte-optimize-form (nth 1 form) for-effect)
-		       (cdr (cdr form)))))
+           (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars)
+                  (bodyform (byte-optimize-form (nth 1 form) for-effect)))
+             (cons fn
+                   (cons bodyform
+                         (pcase (cddr form)
+                           (`(:fun-body ,f)
+                            (list :fun-body (byte-optimize-form f nil)))
+                           (unwindforms unwindforms))))))
 
 	  ((eq fn 'catch)
-	   (cons fn
-		 (cons (byte-optimize-form (nth 1 form) nil)
-                       (byte-optimize-body (cdr form) for-effect))))
+           (let ((byte-optimize--vars-outside-condition
+                  byte-optimize--lexvars))
+	     (cons fn
+		   (cons (byte-optimize-form (nth 1 form) nil)
+                         (byte-optimize-body (cdr form) for-effect)))))
 
 	  ((eq fn 'ignore)
 	   ;; Don't treat the args to `ignore' as being
@@ -528,7 +598,45 @@ byte-optimize-form-code-walker
 	   `(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
 
           ;; Needed as long as we run byte-optimize-form after cconv.
-          ((eq fn 'internal-make-closure) form)
+          ((eq fn 'internal-make-closure)
+           ;; Look up free vars and mark them as changed, so that they
+           ;; won't be optimised away.
+           (dolist (var (caddr form))
+             (let ((lexvar (assq var byte-optimize--lexvars)))
+               (when lexvar
+                 (setcar (cdr lexvar) t))))
+           form)
+
+          ((eq fn 'setq)
+           (let ((args (cdr form))
+                 (var-expr-list nil))
+             (while args
+               (unless (and (consp args)
+                            (symbolp (car args)) (consp (cdr args)))
+                 (byte-compile-warn "malformed setq form: %S" form))
+               (let* ((var (car args))
+                      (expr (cadr args))
+                      (lexvar (assq var byte-optimize--lexvars))
+                      (value (byte-optimize-form expr nil)))
+                 (when lexvar
+                   ;; If it's bound outside conditional, invalidate.
+                   (if (assq var byte-optimize--vars-outside-condition)
+                       ;; We are in conditional code and the variable was
+                       ;; bound outside: cancel substitutions.
+                       (setcdr (cdr lexvar) nil)
+                     (setcdr (cdr lexvar)
+                             (and (byte-optimize--substitutable-p value)
+                                  (list value))))
+                   (setcar (cdr lexvar) t))   ; Mark variable as changed.
+                 (push var var-expr-list)
+                 (push value var-expr-list))
+               (setq args (cddr args)))
+             (cons fn (nreverse var-expr-list))))
+
+          ((eq fn 'defvar)
+           (when (and (>= (length form) 2) (symbolp (cadr form)))
+             (push (cadr form) byte-optimize--dynamic-vars))
+           form)
 
           ((byte-code-function-p fn)
            (cons fn (mapcar #'byte-optimize-form (cdr form))))
@@ -563,6 +671,60 @@ byte-optimize-form-code-walker
                      (error (cons fn args))))
 	       (cons fn args)))))))
 
+(defun byte-optimize-let-form (head form for-effect)
+  (if (and lexical-binding byte-optimize-enable-constprop)
+      (let* ((byte-optimize--lexvars byte-optimize--lexvars)
+             (new-lexvars nil)
+             (let-vars nil))
+        (dolist (binding (car form))
+          (let* ((name (cond ((consp binding) (car binding))
+                             ((symbolp binding) binding)
+                             (t
+		              (byte-compile-warn "malformed let binding: `%S'"
+                                                 binding))))
+                 (expr (and (consp binding) (consp (cdr binding))
+                            (byte-optimize-form (cadr binding) nil)))
+                 (value (and (byte-optimize--substitutable-p expr)
+                             (list expr)))
+                 (lexical (not (or (special-variable-p name)
+                                   (memq name byte-compile-bound-variables)
+                                   (memq name byte-optimize--dynamic-vars))))
+                 (lexinfo (and lexical (cons name (cons nil value)))))
+            (push (cons name (cons expr (cdr lexinfo))) let-vars)
+            (when lexinfo
+              (push lexinfo (if (eq head 'let*)
+                                byte-optimize--lexvars
+                              new-lexvars)))))
+        (setq byte-optimize--lexvars
+              (append new-lexvars byte-optimize--lexvars))
+        ;; Walk the body expressions, which may mutate some of the records,
+        ;; and generate new bindings that exlude unused variables.
+        (let* ((opt-body (byte-optimize-body (cdr form) for-effect))
+               (bindings nil))
+          (dolist (var let-vars)
+            ;; VAR is (NAME EXPR [CHANGED [VALUE]])
+            (if (and (nthcdr 3 var) (not (nth 2 var))
+                     byte-optimize--constprop-mode)
+                (when nil
+                  ;; This warning makes the compiler very chatty, but
+                  ;; it does find the occasional mistake.
+                  (byte-compile-warn "eliminating local variable %S" (car var)))
+              (push (list (nth 0 var) (nth 1 var)) bindings)))
+          (cons bindings opt-body)))
+
+    ;; With dynamic binding, no substitutions are in effect.
+    (let ((byte-optimize--lexvars nil))
+      (cons
+       (mapcar (lambda (binding)
+	         (if (symbolp binding)
+		     binding
+	           (when (or (atom binding) (cddr binding))
+		     (byte-compile-warn "malformed let binding: `%S'" binding))
+	           (list (car binding)
+		         (byte-optimize-form (nth 1 binding) nil))))
+	       (car form))
+       (byte-optimize-body (cdr form) for-effect)))))
+
 (defun byte-optimize-all-constp (list)
   "Non-nil if all elements of LIST satisfy `macroexp-const-p'."
   (let ((constant t))
@@ -607,6 +769,7 @@ byte-optimize-body
   ;; all-for-effect is true.  returns a new list of forms.
   (let ((rest forms)
 	(result nil)
+        (byte-optimize--dynamic-vars byte-optimize--dynamic-vars)
 	fe new)
     (while rest
       (setq fe (or all-for-effect (cdr rest)))
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el
index c235dd43fc..07320cf921 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -31,6 +31,15 @@
 (require 'bytecomp)
 
 ;;; Code:
+(defvar bytecomp-test-var nil)
+
+(defun bytecomp-test-get-var ()
+  bytecomp-test-var)
+
+(defun bytecomp-test-identity (x)
+  "Identity, but hidden from some optimisations."
+  x)
+
 (defconst byte-opt-testsuite-arith-data
   '(
     ;; some functional tests
@@ -349,6 +358,56 @@ byte-opt-testsuite-arith-data
             '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c)
               (t c) (x "a") (x "c") (x c) (x d) (x e)))
 
+    ;; Constprop test cases
+    (let ((a 'alpha) (b (concat "be" "ta")) (c nil) (d t) (e :gamma)
+          (f '(delta epsilon)))
+      (list a b c d e f))
+
+    (let ((x 1) (y (+ 3 4)))
+      (list
+       (let (q (y x) (z y))
+         (if q x (list x y z)))))
+
+    (let* ((x 3) (y (* x 2)) (x (1+ y)))
+      x)
+
+    (let ((x 1) (bytecomp-test-var 2) (y 3))
+      (list x bytecomp-test-var (bytecomp-get-test-var) y))
+
+    (progn
+      (defvar d)
+      (let ((x 'a) (y 'b)) (list x y)))
+
+    (let ((x 2))
+      (list x (setq x 13) (setq x (* x 2)) x))
+
+    (let ((x 'a) (y 'b))
+      (setq y x
+            x (cons 'c y)
+            y x)
+      (list x y))
+
+    (let ((x 3))
+      (let ((y x) z)
+        (setq x 5)
+        (setq y (+ y 8))
+        (setq z (if (bytecomp-test-identity t)
+                    (progn
+                      (setq x (+ x 1))
+                      (list x y))
+                  (setq x (+ x 2))
+                  (list x y)))
+        (list x y z)))
+
+    (let ((i 1) (s 0) (x 13))
+      (while (< i 5)
+        (setq s (+ s i))
+        (setq i (1+ i)))
+      (list s x i))
+
+    (let ((x 2))
+      (list (or (bytecomp-identity 'a) (setq x 3)) x))
+
     ;; `substring' bytecode generation (bug#39709).
     (substring "abcdef")
     (substring "abcdef" 2)
-- 
2.21.1 (Apple Git-122.3)