From 83983b6b7a115474572973b62eb5e42251713e63 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Mattias=20Engdeg=C3=A5rd?= <mattiase@acm.org>
Date: Sat, 6 Feb 2021 18:34:45 +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 implementation is conservative, and is
strongly curtailed by the presence of variable mutation, conditions
and loops.

* lisp/emacs-lisp/byte-opt.el
(byte-optimize-enable-variable-constprop)
(byte-optimize-warn-eliminated-variable): New constants.
(byte-optimize--lexvars, byte-optimize--vars-outside-condition)
(byte-optimize--vars-outside-loop, byte-optimize--dynamic-vars):
New dynamic variables.
(byte-optimize--substitutable-p, byte-optimize-let-form):
New functions.
(byte-optimize-form-code-walker): Adapt clauses for variable
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 test cases.
---
 lisp/emacs-lisp/byte-opt.el            | 314 +++++++++++++++++++------
 test/lisp/emacs-lisp/bytecomp-tests.el |  61 ++++-
 2 files changed, 304 insertions(+), 71 deletions(-)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 66a117fccc8..017cad900d8 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -368,6 +368,53 @@
 
 ;;; implementing source-level optimizers
 
+(defconst byte-optimize-enable-variable-constprop t
+  "If non-nil, enable constant propagation through local variables.")
+
+(defconst byte-optimize-warn-eliminated-variable nil
+  "Whether to warn when a variable is optimised away entirely.
+This does usually not indicate a problem and makes the compiler
+very chatty, but can be useful for debugging.")
+
+(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.")
+
+(defvar byte-optimize--vars-outside-condition nil
+  "Alist of variables lexically bound outside conditionally executed code.
+Variables here are sensitive to mutation inside the condition, since such
+changes may not be effective for all code paths.
+Same format as `byte-optimize--lexvars', with shared structure and contents.")
+
+(defvar byte-optimize--vars-outside-loop nil
+  "Alist of variables lexically bound outside the innermost `while' loop.
+Variables here are sensitive to mutation inside the loop, since this can
+occur an indeterminate number of times and thus have effect on code
+sequentially preceding the mutation itself.
+Same format as `byte-optimize--lexvars', with shared structure and contents.")
+
+(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
@@ -382,11 +429,24 @@
   (let ((fn (car-safe form)))
     (pcase form
       ((pred (not consp))
-       (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 (cddr lexvar)      ; Value available?
+               (if (assq form byte-optimize--vars-outside-loop)
+                   ;; Cannot substitute; mark as changed to avoid the
+                   ;; variable being eliminated.
+                   (progn
+                     (setcar (cdr lexvar) t)
+                     form)
+                 (caddr lexvar))        ; variable value to use
+             form)))
+        (t form)))
       (`(quote . ,v)
        (if (cdr v)
 	   (byte-compile-warn "malformed quote form: `%s'"
@@ -396,33 +456,22 @@
        (and (car v)
 	    (not for-effect)
 	    form))
-      (`(,(or 'let 'let*) . ,(or `(,bindings . ,exps) pcase--dontcare))
-       ;; 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))))
-		      bindings)
-	      (byte-optimize-body exps for-effect))))
+      (`(,(or 'let 'let*) . ,rest)
+        (cons fn (byte-optimize-let-form fn rest for-effect)))
       (`(cond . ,clauses)
-       (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))
-		     clauses)))
+       ;; The condition in the first clause is always executed, but
+       ;; right now we treat all of them as conditional for simplicity.
+       (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))
+                   clauses))))
       (`(progn . ,exps)
        ;; As an extra added bonus, this simplifies (progn <x>) --> <x>.
        (if (cdr exps)
@@ -442,35 +491,54 @@
        (cons fn (byte-optimize-body exps for-effect)))
 
       (`(if ,test ,then . ,else)
-       `(if ,(byte-optimize-form test nil)
-	    ,(byte-optimize-form then for-effect)
-	  . ,(byte-optimize-body else for-effect)))
+       ;; The test is always executed.
+       (let* ((test-opt (byte-optimize-form test nil))
+              ;; The THEN and ELSE branches are executed conditionally.
+              ;;
+              ;; FIXME: We are conservative here: any variable changed in the
+              ;; THEN branch will be barred from substitution in the ELSE
+              ;; branch, despite the branches being  mutually exclusive.
+              (byte-optimize--vars-outside-condition byte-optimize--lexvars)
+              (then-opt (byte-optimize-form then for-effect))
+              (else-opt (byte-optimize-body else for-effect)))
+         `(if ,test-opt ,then-opt . ,else-opt)))
       (`(if . ,_)
        (byte-compile-warn "too few arguments for `if'"))
 
       (`(,(or 'and 'or) . ,exps) ; 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 exps)))
-	     (while (and backwards
-			 (null (setcar backwards
-				       (byte-optimize-form (car backwards)
-							   for-effect))))
-	       (setq backwards (cdr backwards)))
-	     (if (and exps (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 exps))))
+       ;; FIXME: We have to traverse the expressions 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 exps)
+             (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))))
 
       (`(while ,exp . ,exps)
-       `(while ,(byte-optimize-form exp nil)
-          . ,(byte-optimize-body exps t)))
+       ;; FIXME: We conservatively prevent the substitution of any variable
+       ;; bound outside the loop in case it is mutated later in the loop,
+       ;; but this misses many opportunities: variables not mutated in the
+       ;; loop at all, and variables affecting the initial condition (which
+       ;; is always executed unconditionally).
+       (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars)
+              (byte-optimize--vars-outside-loop byte-optimize--lexvars)
+              (condition (byte-optimize-form exp nil))
+              (body (byte-optimize-body exps t)))
+         `(while ,condition . ,body)))
+
       (`(while . ,_)
        (byte-compile-warn "too few arguments for `while'"))
 
@@ -485,24 +553,35 @@
        form)
 
       (`(condition-case . ,(or `(,var ,exp . ,clauses) pcase--dontcare))
-       `(condition-case ,var            ;Not evaluated.
-            ,(byte-optimize-form exp for-effect)
-          ,@(mapcar (lambda (clause)
-                      `(,(car clause)
-                        ,@(byte-optimize-body (cdr clause) for-effect)))
-                    clauses)))
-
-      (`(unwind-protect . ,(or `(,exp . ,exps) pcase--dontcare))
-       ;; The "protected" part of an unwind-protect is compiled (and thus
-       ;; optimized) as a top-level form, so don't do it here.  But the
-       ;; non-protected part has the same for-effect status as the
-       ;; unwind-protect itself.  (The protected part is always for effect,
+       (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars))
+         `(condition-case ,var            ;Not evaluated.
+              ,(byte-optimize-form exp for-effect)
+            ,@(mapcar (lambda (clause)
+                        `(,(car clause)
+                          ,@(byte-optimize-body (cdr clause) for-effect)))
+                      clauses))))
+
+      (`(unwind-protect ,exp . ,exps)
+       ;; The unwinding part of an unwind-protect is compiled (and thus
+       ;; optimized) as a top-level form, but run the optimizer for it here
+       ;; anyway for lexical variable usage and substitution.  But the
+       ;; protected part has the same for-effect status as the
+       ;; unwind-protect itself.  (The unwinding part is always for effect,
        ;; but that isn't handled properly yet.)
-       `(unwind-protect ,(byte-optimize-form exp for-effect) . ,exps))
+       (let* ((byte-optimize--vars-outside-condition byte-optimize--lexvars)
+              (bodyform (byte-optimize-form exp for-effect)))
+         (pcase exps
+           (`(:fun-body ,f)
+            `(unwind-protect ,bodyform
+               :fun-body ,(byte-optimize-form f nil)))
+           (_
+            `(unwind-protect ,bodyform
+               . ,(byte-optimize-body exps t))))))
 
       (`(catch . ,(or `(,tag . ,exps) pcase--dontcare))
-       `(catch ,(byte-optimize-form tag nil)
-          . ,(byte-optimize-body exps for-effect)))
+       (let ((byte-optimize--vars-outside-condition byte-optimize--lexvars))
+         `(catch ,(byte-optimize-form tag nil)
+            . ,(byte-optimize-body exps for-effect))))
 
       (`(ignore . ,exps)
        ;; Don't treat the args to `ignore' as being
@@ -512,7 +591,14 @@
        `(prog1 nil . ,(mapcar #'byte-optimize-form exps)))
 
       ;; Needed as long as we run byte-optimize-form after cconv.
-      (`(internal-make-closure . ,_) form)
+      (`(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)
 
       (`((lambda . ,_) . ,_)
        (let ((newform (byte-compile-unfold-lambda form)))
@@ -525,6 +611,35 @@
       ;; is a *value* and shouldn't appear in the car.
       (`((closure . ,_) . ,_) form)
 
+      (`(setq . ,args)
+       (let ((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))))
+
+      (`(defvar ,(and (pred symbolp) name) . ,_)
+       (push name byte-optimize--dynamic-vars)
+       form)
+
       (`(,(pred byte-code-function-p) . ,exps)
        (cons fn (mapcar #'byte-optimize-form exps)))
 
@@ -582,6 +697,64 @@
 	  new)
       form)))
 
+(defun byte-optimize-let-form (head form for-effect)
+  ;; 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.
+  (if (and lexical-binding byte-optimize-enable-variable-constprop)
+      (let* ((byte-optimize--lexvars byte-optimize--lexvars)
+             (new-lexvars nil)
+             (let-vars nil))
+        (dolist (binding (car form))
+          (let (name expr)
+            (cond ((consp binding)
+                   (setq name (car binding))
+                   (unless (symbolp name)
+                     (byte-compile-warn "let-bind nonvariable: `%S'" name))
+                   (setq expr (byte-optimize-form (cadr binding) nil)))
+                  ((symbolp binding)
+                   (setq name binding))
+                  (t (byte-compile-warn "malformed let binding: `%S'" binding)))
+            (let* (
+                   (value (and (byte-optimize--substitutable-p expr)
+                               (list expr)))
+                   (lexical (not (or (and (symbolp name)
+                                          (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 exclude 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)))
+                (when byte-optimize-warn-eliminated-variable
+                  (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-body (forms all-for-effect)
   ;; Optimize the cdr of a progn or implicit progn; all forms is a list of
@@ -590,6 +763,7 @@
   ;; 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 980b402ca2d..bc623d3efca 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -32,6 +32,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
@@ -371,7 +380,57 @@
     (assoc 'b '((a 1) (b 2) (c 3)))
     (assoc "b" '(("a" 1) ("b" 2) ("c" 3)))
     (let ((x '((a 1) (b 2) (c 3)))) (assoc 'c x))
-    (assoc 'a '((a 1) (b 2) (c 3)) (lambda (u v) (not (equal u v)))))
+    (assoc 'a '((a 1) (b 2) (c 3)) (lambda (u v) (not (equal u v))))
+
+    ;; 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)))
   "List of expression for test.
 Each element will be executed by interpreter and with
 bytecompiled code, and their results compared.")
-- 
2.39.2