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
 
 ;;; 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)

