master f472dd8: Simplify lexical let-optimisations

[Mattias Engdegård]

branch: master
commit f472dd8ea5d94f0231bb7bf23552895c3ab19689
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Simplify lexical let-optimisations
    
    Ensure in cconv that let-bindings have the normal form (VAR EXPR)
    where VAR is a valid variable name, so that we don't need to keep
    re-checking this all the time in the optimiser.
    
    * lisp/emacs-lisp/byte-opt.el
    (byte-optimize-enable-variable-constprop)
    (byte-optimize-warn-eliminated-variable): Remove; these were mainly
    used for debugging.
    * lisp/emacs-lisp/byte-opt.el (byte-optimize-let-form):
    Assume normalised let-bindings (with lexical-binding).
    Stop using the variables removed above.
    * lisp/emacs-lisp/cconv.el (cconv-convert): Ensure normalised
    let-bindings.  Malformed bindings are dropped after warning.
    
    remove byte-optimize-warn-eliminated-variable
---
 lisp/emacs-lisp/byte-opt.el |  46 +++++--------
 lisp/emacs-lisp/cconv.el    | 163 ++++++++++++++++++++++----------------------
 2 files changed, 99 insertions(+), 110 deletions(-)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index d444d70..142f206 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -310,14 +310,6 @@ Earlier variables shadow later ones with the same name.")
 
 ;;; 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--vars-outside-condition nil
   "Alist of variables lexically bound outside conditionally executed code.
 Variables here are sensitive to mutation inside the conditional code,
@@ -691,28 +683,24 @@ Same format as `byte-optimize--lexvars', with shared 
structure and contents.")
   ;; 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)
+  (if lexical-binding
       (let* ((byte-optimize--lexvars byte-optimize--lexvars)
              (new-lexvars nil)
              (let-vars nil))
         (dolist (binding (car form))
-          (let (name expr)
-            (if (atom binding)
-                (setq name binding)
-              (setq name (car binding))
-              (setq expr (byte-optimize-form (cadr binding) nil)))
-            (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))))))
+          (let* ((name (car binding))
+                 (expr (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,
@@ -722,10 +710,8 @@ Same format as `byte-optimize--lexvars', with shared 
structure and contents.")
                (bindings nil))
           (dolist (var let-vars)
             ;; VAR is (NAME EXPR [KEEP [VALUE]])
-            (if (and (nthcdr 3 var) (not (nth 2 var)))
-                ;; Value present and not marked to be kept: eliminate.
-                (when byte-optimize-warn-eliminated-variable
-                  (byte-compile-warn "eliminating local variable %S" (car 
var)))
+            (when (or (not (nthcdr 3 var)) (nth 2 var))
+              ;; Value not present, or variable marked to be kept.
               (push (list (nth 0 var) (nth 1 var)) bindings)))
           (cons bindings opt-body)))
 
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index e079597..3abbf71 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -357,88 +357,91 @@ places where they originally did not directly appear."
                           "Malformed `%S' binding: %S"
                           letsym binder))
                       (setq value (cadr binder))
-                      (car binder)))
-                (_ (cond
-                    ((not (symbolp var))
-                     (byte-compile-warn "attempt to let-bind nonvariable `%S'"
-                                        var))
-                    ((or (booleanp var) (keywordp var))
-                     (byte-compile-warn "attempt to let-bind constant `%S'"
-                                        var))))
-               (new-val
-                (pcase (cconv--var-classification binder form)
-                   ;; Check if var is a candidate for lambda lifting.
-                   ((and :lambda-candidate
-                         (guard
-                          (progn
-                            (cl-assert (and (eq (car value) 'function)
-                                            (eq (car (cadr value)) 'lambda)))
-                            (cl-assert (equal (cddr (cadr value))
-                                              (caar cconv-freevars-alist)))
-                            ;; Peek at the freevars to decide whether to 
λ-lift.
-                            (let* ((fvs (cdr (car cconv-freevars-alist)))
-                                   (fun (cadr value))
-                                   (funargs (cadr fun))
-                                   (funcvars (append fvs funargs)))
+                      (car binder))))
+           (cond
+            ;; Ignore bindings without a valid name.
+            ((not (symbolp var))
+             (byte-compile-warn "attempt to let-bind nonvariable `%S'" var))
+            ((or (booleanp var) (keywordp var))
+             (byte-compile-warn "attempt to let-bind constant `%S'" var))
+            (t
+             (let ((new-val
+                   (pcase (cconv--var-classification binder form)
+                      ;; Check if var is a candidate for lambda lifting.
+                      ((and :lambda-candidate
+                            (guard
+                             (progn
+                               (cl-assert (and (eq (car value) 'function)
+                                               (eq (car (cadr value)) 
'lambda)))
+                               (cl-assert (equal (cddr (cadr value))
+                                                 (caar cconv-freevars-alist)))
+                               ;; Peek at the freevars to decide whether
+                               ;; to λ-lift.
+                               (let* ((fvs (cdr (car cconv-freevars-alist)))
+                                      (fun (cadr value))
+                                      (funargs (cadr fun))
+                                      (funcvars (append fvs funargs)))
                                        ; lambda lifting condition
-                              (and fvs (>= cconv-liftwhen
-                                          (length funcvars)))))))
+                                 (and fvs (>= cconv-liftwhen
+                                             (length funcvars)))))))
                                        ; Lift.
-                    (let* ((fvs (cdr (pop cconv-freevars-alist)))
-                           (fun (cadr value))
-                           (funargs (cadr fun))
-                           (funcvars (append fvs funargs))
-                           (funcbody (cddr fun))
-                           (funcbody-env ()))
-                      (push `(,var . (apply-partially ,var . ,fvs)) new-env)
-                      (dolist (fv fvs)
-                        (cl-pushnew fv new-extend)
-                        (if (and (eq 'car-safe (car-safe (cdr (assq fv env))))
-                                 (not (memq fv funargs)))
-                            (push `(,fv . (car-safe ,fv)) funcbody-env)))
-                      `(function (lambda ,funcvars .
-                                   ,(cconv--convert-funcbody
-                                     funargs funcbody funcbody-env value)))))
-
-                  ;; Check if it needs to be turned into a "ref-cell".
-                  (:captured+mutated
-                   ;; Declared variable is mutated and captured.
-                   (push `(,var . (car-safe ,var)) new-env)
-                   `(list ,(cconv-convert value env extend)))
-
-                  ;; Check if it needs to be turned into a "ref-cell".
-                  (:unused
-                   ;; Declared variable is unused.
-                   (if (assq var new-env) (push `(,var) new-env)) 
;FIXME:Needed?
-                   (let ((newval
-                          `(ignore ,(cconv-convert value env extend)))
-                         (msg (cconv--warn-unused-msg var "variable")))
-                     (if (null msg) newval
-                       (macroexp--warn-wrap msg newval 'lexical))))
-
-                  ;; Normal default case.
-                  (_
-                   (if (assq var new-env) (push `(,var) new-env))
-                   (cconv-convert value env extend)))))
-
-           (when (and (eq letsym 'let*) (memq var new-extend))
-             ;; One of the lambda-lifted vars is shadowed, so add
-             ;; a reference to the outside binding and arrange to use
-             ;; that reference.
-             (let ((closedsym (make-symbol (format "closed-%s" var))))
-               (setq new-env (cconv--remap-llv new-env var closedsym))
-               (setq new-extend (cons closedsym (remq var new-extend)))
-               (push `(,closedsym ,var) binders-new)))
-
-           ;; We push the element after redefined free variables are
-           ;; processed.  This is important to avoid the bug when free
-           ;; variable and the function have the same name.
-           (push (list var new-val) binders-new)
-
-           (when (eq letsym 'let*)
-             (setq env new-env)
-             (setq extend new-extend))
-           ))                           ; end of dolist over binders
+                       (let* ((fvs (cdr (pop cconv-freevars-alist)))
+                              (fun (cadr value))
+                              (funargs (cadr fun))
+                              (funcvars (append fvs funargs))
+                              (funcbody (cddr fun))
+                              (funcbody-env ()))
+                         (push `(,var . (apply-partially ,var . ,fvs)) new-env)
+                         (dolist (fv fvs)
+                           (cl-pushnew fv new-extend)
+                           (if (and (eq 'car-safe (car-safe
+                                                   (cdr (assq fv env))))
+                                    (not (memq fv funargs)))
+                               (push `(,fv . (car-safe ,fv)) funcbody-env)))
+                         `(function (lambda ,funcvars .
+                                      ,(cconv--convert-funcbody
+                                        funargs funcbody funcbody-env 
value)))))
+
+                      ;; Check if it needs to be turned into a "ref-cell".
+                      (:captured+mutated
+                       ;; Declared variable is mutated and captured.
+                       (push `(,var . (car-safe ,var)) new-env)
+                       `(list ,(cconv-convert value env extend)))
+
+                      ;; Check if it needs to be turned into a "ref-cell".
+                      (:unused
+                       ;; Declared variable is unused.
+                       (if (assq var new-env)
+                           (push `(,var) new-env)) ;FIXME:Needed?
+                       (let ((newval
+                              `(ignore ,(cconv-convert value env extend)))
+                             (msg (cconv--warn-unused-msg var "variable")))
+                         (if (null msg) newval
+                           (macroexp--warn-wrap msg newval 'lexical))))
+
+                      ;; Normal default case.
+                      (_
+                       (if (assq var new-env) (push `(,var) new-env))
+                       (cconv-convert value env extend)))))
+
+               (when (and (eq letsym 'let*) (memq var new-extend))
+                 ;; One of the lambda-lifted vars is shadowed, so add
+                 ;; a reference to the outside binding and arrange to use
+                 ;; that reference.
+                 (let ((closedsym (make-symbol (format "closed-%s" var))))
+                   (setq new-env (cconv--remap-llv new-env var closedsym))
+                   (setq new-extend (cons closedsym (remq var new-extend)))
+                   (push `(,closedsym ,var) binders-new)))
+
+               ;; We push the element after redefined free variables are
+               ;; processed.  This is important to avoid the bug when free
+               ;; variable and the function have the same name.
+               (push (list var new-val) binders-new)
+
+               (when (eq letsym 'let*)
+                 (setq env new-env)
+                 (setq extend new-extend))))))
+         )                           ; end of dolist over binders
 
        (when (not (eq letsym 'let*))
          ;; We can't do the cconv--remap-llv at the same place for let and