mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-30 08:09:04 +00:00
Revert "Fix closure-conversion of shadowed captured lambda-lifted vars"
This reverts commit 3ec8c8b3ae.
It was committed to a stable branch without prior discussion;
see bug#53071.
This commit is contained in:
Mattias Engdegård
parent
a1ac6bd47e
commit
22ddd2ba13
@ -304,25 +304,6 @@ 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.
|
||||
@ -447,11 +428,10 @@ 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 ((var-def (cconv--lifted-arg var env))
|
||||
(closedsym (make-symbol (format "closed-%s" var))))
|
||||
(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-def) binders-new)))
|
||||
(push `(,closedsym ,var) binders-new)))
|
||||
|
||||
;; We push the element after redefined free variables are
|
||||
;; processed. This is important to avoid the bug when free
|
||||
@ -469,13 +449,14 @@ 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.
|
||||
;; One of the lambda-lifted vars is shadowed, so add
|
||||
;; a reference to the outside binding and arrange to use
|
||||
;; that reference.
|
||||
(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-def) binders-new)))))
|
||||
(push `(,closedsym ,var) binders-new)))))
|
||||
|
||||
`(,letsym ,(nreverse binders-new)
|
||||
. ,(mapcar (lambda (form)
|
||||
|
||||
@ -640,49 +640,6 @@ 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.")
|
||||
|
||||
|
||||
@ -205,157 +205,5 @@
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user