emacs-28 3ec8c8b3ae: Fix closure-conversion of shadowed captured lambda-lifted vars

[Mattias Engdegård]

branch: emacs-28
commit 3ec8c8b3ae2359ceb8135b672e86526969c16b7e
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Fix closure-conversion of shadowed captured lambda-lifted vars
    
    Lambda-lifted variables (ones passed explicitly to lambda-lifted
    functions) that are also captured in an outer closure and shadowed
    were renamed incorrectly (bug#51982).
    
    Reported by Paul Pogonyshev.
    
    * lisp/emacs-lisp/cconv.el (cconv--lifted-arg): New.
    (cconv-convert): Provide correct definiens for the closed-over
    variable.
    * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases):
    * test/lisp/emacs-lisp/cconv-tests.el (cconv-tests--intern-all)
    (cconv-closure-convert-remap-var): Add tests.
    
    (cherry picked from commit 45252ad8f932c98a373ef0ab7f3363a3e27ccbe4)
---
 lisp/emacs-lisp/cconv.el               |  31 +++++--
 test/lisp/emacs-lisp/bytecomp-tests.el |  43 ++++++++++
 test/lisp/emacs-lisp/cconv-tests.el    | 152 +++++++++++++++++++++++++++++++++
 3 files changed, 220 insertions(+), 6 deletions(-)

diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index ccb96d169d..fb871a9267 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -304,6 +304,25 @@ of converted forms."
             `(,@(nreverse special-forms) ,@(macroexp-unprogn body))))
       funcbody)))
 
+(defun cconv--lifted-arg (var env)
+  "The argument to use for VAR in λ-lifted calls according to ENV.
+This is used when VAR is being shadowed; we may still need its value for
+such calls."
+  (let ((mapping (cdr (assq var env))))
+    (pcase-exhaustive mapping
+      (`(internal-get-closed-var . ,_)
+       ;; The variable is captured.
+       mapping)
+      (`(car-safe (internal-get-closed-var . ,_))
+       ;; The variable is mutably captured; skip
+       ;; the indirection step because the variable is
+       ;; passed "by reference" to the λ-lifted function.
+       (cadr mapping))
+      ((or '() `(car-safe ,(pred symbolp)))
+       ;; The variable is not captured; use the (shadowed) variable value.
+       ;; (If the mapping is `(car-safe SYMBOL)', SYMBOL is always VAR.
+       var))))
+
 (defun cconv-convert (form env extend)
   ;; This function actually rewrites the tree.
   "Return FORM with all its lambdas changed so they are closed.
@@ -428,10 +447,11 @@ places where they originally did not directly appear."
                  ;; 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))))
+                 (let ((var-def (cconv--lifted-arg var env))
+                       (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)))
+                   (push `(,closedsym ,var-def) binders-new)))
 
                ;; We push the element after redefined free variables are
                ;; processed.  This is important to avoid the bug when free
@@ -449,14 +469,13 @@ places where they originally did not directly appear."
          ;; before we know that the var will be in `new-extend' (bug#24171).
          (dolist (binder binders-new)
            (when (memq (car-safe binder) new-extend)
-             ;; One of the lambda-lifted vars is shadowed, so add
-             ;; a reference to the outside binding and arrange to use
-             ;; that reference.
+             ;; One of the lambda-lifted vars is shadowed.
              (let* ((var (car-safe binder))
+                    (var-def (cconv--lifted-arg var env))
                     (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)))))
+               (push `(,closedsym ,var-def) binders-new)))))
 
        `(,letsym ,(nreverse binders-new)
                  . ,(mapcar (lambda (form)
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el 
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 8a09c54591..b591474538 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -640,6 +640,49 @@ inner loops respectively."
            (f (list (lambda (x) (setq a x)))))
       (funcall (car f) 3)
       (list a b))
+
+    ;; These expressions give different results in lexbind and dynbind modes,
+    ;; but in each the compiler and interpreter should agree!
+    ;; (They look much the same but come in pairs exercising both the
+    ;; `let' and `let*' paths.)
+    (let ((f (lambda (x)
+               (lambda ()
+                 (let ((g (lambda () x)))
+                   (let ((x 'a))
+                     (list x (funcall g))))))))
+      (funcall (funcall f 'b)))
+    (let ((f (lambda (x)
+               (lambda ()
+                 (let ((g (lambda () x)))
+                   (let* ((x 'a))
+                     (list x (funcall g))))))))
+      (funcall (funcall f 'b)))
+    (let ((f (lambda (x)
+               (lambda ()
+                 (let ((g (lambda () x)))
+                   (setq x (list x x))
+                   (let ((x 'a))
+                     (list x (funcall g))))))))
+      (funcall (funcall f 'b)))
+    (let ((f (lambda (x)
+               (lambda ()
+                 (let ((g (lambda () x)))
+                   (setq x (list x x))
+                   (let* ((x 'a))
+                     (list x (funcall g))))))))
+      (funcall (funcall f 'b)))
+    (let ((f (lambda (x)
+               (let ((g (lambda () x))
+                     (h (lambda () (setq x (list x x)))))
+                 (let ((x 'a))
+                   (list x (funcall g) (funcall h)))))))
+      (funcall (funcall f 'b)))
+    (let ((f (lambda (x)
+               (let ((g (lambda () x))
+                     (h (lambda () (setq x (list x x)))))
+                 (let* ((x 'a))
+                   (list x (funcall g) (funcall h)))))))
+      (funcall (funcall f 'b)))
     )
   "List of expressions for cross-testing interpreted and compiled code.")
 
diff --git a/test/lisp/emacs-lisp/cconv-tests.el 
b/test/lisp/emacs-lisp/cconv-tests.el
index edb746cdec..a3bc690541 100644
--- a/test/lisp/emacs-lisp/cconv-tests.el
+++ b/test/lisp/emacs-lisp/cconv-tests.el
@@ -205,5 +205,157 @@
            nil 99)
           42)))
 
+(defun cconv-tests--intern-all (x)
+  "Intern all symbols in X."
+  (cond ((symbolp x) (intern (symbol-name x)))
+        ((consp x) (cons (cconv-tests--intern-all (car x))
+                         (cconv-tests--intern-all (cdr x))))
+        ;; Assume we don't need to deal with vectors etc.
+        (t x)))
+
+(ert-deftest cconv-closure-convert-remap-var ()
+  ;; Verify that we correctly remap shadowed lambda-lifted variables.
+
+  ;; We intern all symbols for ease of comparison; this works because
+  ;; the `cconv-closure-convert' result should contain no pair of
+  ;; distinct symbols having the same name.
+
+  ;; Sanity check: captured variable, no lambda-lifting or shadowing:
+  (should (equal (cconv-tests--intern-all
+           (cconv-closure-convert
+            '#'(lambda (x)
+                 #'(lambda () x))))
+           '#'(lambda (x)
+                (internal-make-closure
+                 nil (x) nil
+                 (internal-get-closed-var 0)))))
+
+  ;; Basic case:
+  (should (equal (cconv-tests--intern-all
+                  (cconv-closure-convert
+                   '#'(lambda (x)
+                        (let ((f #'(lambda () x)))
+                          (let ((x 'b))
+                            (list x (funcall f)))))))
+                 '#'(lambda (x)
+                      (let ((f #'(lambda (x) x)))
+                        (let ((x 'b)
+                              (closed-x x))
+                          (list x (funcall f closed-x)))))))
+  (should (equal (cconv-tests--intern-all
+                  (cconv-closure-convert
+                   '#'(lambda (x)
+                        (let ((f #'(lambda () x)))
+                          (let* ((x 'b))
+                            (list x (funcall f)))))))
+                 '#'(lambda (x)
+                      (let ((f #'(lambda (x) x)))
+                        (let* ((closed-x x)
+                               (x 'b))
+                          (list x (funcall f closed-x)))))))
+
+  ;; With the lambda-lifted shadowed variable also being captured:
+  (should (equal
+           (cconv-tests--intern-all
+            (cconv-closure-convert
+             '#'(lambda (x)
+                  #'(lambda ()
+                      (let ((f #'(lambda () x)))
+                        (let ((x 'a))
+                          (list x (funcall f))))))))
+           '#'(lambda (x)
+                (internal-make-closure
+                 nil (x) nil
+                 (let ((f #'(lambda (x) x)))
+                   (let ((x 'a)
+                         (closed-x (internal-get-closed-var 0)))
+                     (list x (funcall f closed-x))))))))
+  (should (equal
+           (cconv-tests--intern-all
+            (cconv-closure-convert
+             '#'(lambda (x)
+                  #'(lambda ()
+                      (let ((f #'(lambda () x)))
+                        (let* ((x 'a))
+                          (list x (funcall f))))))))
+           '#'(lambda (x)
+                (internal-make-closure
+                 nil (x) nil
+                 (let ((f #'(lambda (x) x)))
+                   (let* ((closed-x (internal-get-closed-var 0))
+                          (x 'a))
+                     (list x (funcall f closed-x))))))))
+  ;; With lambda-lifted shadowed variable also being mutably captured:
+  (should (equal
+           (cconv-tests--intern-all
+            (cconv-closure-convert
+             '#'(lambda (x)
+                  #'(lambda ()
+                      (let ((f #'(lambda () x)))
+                        (setq x x)
+                        (let ((x 'a))
+                          (list x (funcall f))))))))
+           '#'(lambda (x)
+                (let ((x (list x)))
+                  (internal-make-closure
+                   nil (x) nil
+                   (let ((f #'(lambda (x) (car-safe x))))
+                     (setcar (internal-get-closed-var 0)
+                             (car-safe (internal-get-closed-var 0)))
+                     (let ((x 'a)
+                           (closed-x (internal-get-closed-var 0)))
+                       (list x (funcall f closed-x)))))))))
+  (should (equal
+           (cconv-tests--intern-all
+            (cconv-closure-convert
+             '#'(lambda (x)
+                  #'(lambda ()
+                      (let ((f #'(lambda () x)))
+                        (setq x x)
+                        (let* ((x 'a))
+                          (list x (funcall f))))))))
+           '#'(lambda (x)
+                (let ((x (list x)))
+                  (internal-make-closure
+                   nil (x) nil
+                   (let ((f #'(lambda (x) (car-safe x))))
+                     (setcar (internal-get-closed-var 0)
+                             (car-safe (internal-get-closed-var 0)))
+                     (let* ((closed-x (internal-get-closed-var 0))
+                            (x 'a))
+                       (list x (funcall f closed-x)))))))))
+  ;; Lambda-lifted variable that isn't actually captured where it is shadowed:
+  (should (equal
+           (cconv-tests--intern-all
+            (cconv-closure-convert
+             '#'(lambda (x)
+                  (let ((g #'(lambda () x))
+                        (h #'(lambda () (setq x x))))
+                    (let ((x 'b))
+                      (list x (funcall g) (funcall h)))))))
+           '#'(lambda (x)
+                (let ((x (list x)))
+                  (let ((g #'(lambda (x) (car-safe x)))
+                        (h #'(lambda (x) (setcar x (car-safe x)))))
+                    (let ((x 'b)
+                          (closed-x x))
+                      (list x (funcall g closed-x) (funcall h closed-x))))))))
+  (should (equal
+           (cconv-tests--intern-all
+            (cconv-closure-convert
+             '#'(lambda (x)
+                  (let ((g #'(lambda () x))
+                        (h #'(lambda () (setq x x))))
+                    (let* ((x 'b))
+                      (list x (funcall g) (funcall h)))))))
+           '#'(lambda (x)
+                (let ((x (list x)))
+                  (let ((g #'(lambda (x) (car-safe x)))
+                        (h #'(lambda (x) (setcar x (car-safe x)))))
+                    (let* ((closed-x x)
+                           (x 'b))
+                      (list x (funcall g closed-x) (funcall h closed-x))))))))
+  )
+
 (provide 'cconv-tests)
 ;;; cconv-tests.el ends here