master 75f04848a65: Repair and speed up safe-copy-tree and make it internal (bug#61962)

[Mattias Engdegård]

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

    Repair and speed up safe-copy-tree and make it internal (bug#61962)
    
    There is no particular requirement for safe-copy-tree so let's make it
    internal for now.  The new implementation is faster and more correct.
    
    * doc/lispref/lists.texi (Building Lists):
    * etc/NEWS:  Remove doc and announcement.
    * lisp/subr.el (safe-copy-tree--seen, safe-copy-tree--1)
    (safe-copy-tree): Remove old version.
    * lisp/emacs-lisp/bytecomp.el (bytecomp--copy-tree-seen)
    (bytecomp--copy-tree-1, bytecomp--copy-tree): Add new version.
    (byte-compile-initial-macro-environment): Use it.
    * test/lisp/subr-tests.el (subr--safe-copy-tree):
    * test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp--copy-tree):
    Move and improve tests.
---
 doc/lispref/lists.texi                 | 13 --------
 etc/NEWS                               |  5 ----
 lisp/emacs-lisp/bytecomp.el            | 38 ++++++++++++++++++++++-
 lisp/subr.el                           | 55 ----------------------------------
 test/lisp/emacs-lisp/bytecomp-tests.el | 28 +++++++++++++++++
 test/lisp/subr-tests.el                | 26 ----------------
 6 files changed, 65 insertions(+), 100 deletions(-)

diff --git a/doc/lispref/lists.texi b/doc/lispref/lists.texi
index 3478049c84f..a509325854f 100644
--- a/doc/lispref/lists.texi
+++ b/doc/lispref/lists.texi
@@ -708,19 +708,6 @@ non-@code{nil}, it copies vectors too (and operates 
recursively on
 their elements).  This function cannot cope with circular lists.
 @end defun
 
-@defun safe-copy-tree tree &optional vecp
-This function returns a copy of the tree @var{tree}.  If @var{tree} is
-a cons cell, this make a new cons cell with the same @sc{car} and
-@sc{cdr}, then recursively copies the @sc{car} and @sc{cdr} in the
-same way.
-
-Normally, when @var{tree} is anything other than a cons cell,
-@code{copy-tree} simply returns @var{tree}.  However, if @var{vecp} is
-non-@code{nil}, it copies vectors and records too (and operates
-recursively on their elements).  This function handles circular lists
-and vectors, and is thus slower than @code{copy-tree} for typical cases.
-@end defun
-
 @defun flatten-tree tree
 This function returns a ``flattened'' copy of @var{tree}, that is,
 a list containing all the non-@code{nil} terminal nodes, or leaves, of
diff --git a/etc/NEWS b/etc/NEWS
index e31203689e3..3b02e85b691 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -391,11 +391,6 @@ was to catch all errors, add an explicit handler for 
'error', or use
 This warning can be suppressed using 'with-suppressed-warnings' with
 the warning name 'suspicious'.
 
-+++
-** New function 'safe-copy-tree'
-This function is a version of copy-tree which handles circular lists
-and circular vectors/records.
-
 +++
 ** New function 'file-user-uid'.
 This function is like 'user-uid', but is aware of file name handlers,
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 12850c27b88..a122e81ba3c 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -495,6 +495,42 @@ Return the compile-time value of FORM."
                     (cdr form)))
     (funcall non-toplevel-case form)))
 
+
+(defvar bytecomp--copy-tree-seen)
+
+(defun bytecomp--copy-tree-1 (tree)
+  ;; TREE must be a cons.
+  (or (gethash tree bytecomp--copy-tree-seen)
+      (let* ((next (cdr tree))
+             (result (cons nil next))
+             (copy result))
+        (while (progn
+                 (puthash tree copy bytecomp--copy-tree-seen)
+                 (let ((a (car tree)))
+                   (setcar copy (if (consp a)
+                                    (bytecomp--copy-tree-1 a)
+                                  a)))
+                 (and (consp next)
+                      (let ((tail (gethash next bytecomp--copy-tree-seen)))
+                        (if tail
+                            (progn (setcdr copy tail)
+                                   nil)
+                          (setq tree next)
+                          (setq next (cdr next))
+                          (let ((prev copy))
+                            (setq copy (cons nil next))
+                            (setcdr prev copy)
+                            t))))))
+        result)))
+
+(defun bytecomp--copy-tree (tree)
+  "Make a copy of TREE, preserving any circular structure therein.
+Only conses are traversed and duplicated, not arrays or any other structure."
+  (if (consp tree)
+      (let ((bytecomp--copy-tree-seen (make-hash-table :test #'eq)))
+        (bytecomp--copy-tree-1 tree))
+    tree))
+
 (defconst byte-compile-initial-macro-environment
   `(
     ;; (byte-compiler-options . (lambda (&rest forms)
@@ -534,7 +570,7 @@ Return the compile-time value of FORM."
                                        form
                                        macroexpand-all-environment)))
                                 (eval (byte-run-strip-symbol-positions
-                                       (safe-copy-tree expanded))
+                                       (bytecomp--copy-tree expanded))
                                       lexical-binding)
                                 expanded)))))
     (with-suppressed-warnings
diff --git a/lisp/subr.el b/lisp/subr.el
index 40bec544b73..8aedce934d1 100644
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -846,61 +846,6 @@ argument VECP, this copies vectors as well as conses."
          tree)
       tree)))
 
-(defvar safe-copy-tree--seen nil
-  "A hash table for conses/vectors/records already seen by safe-copy-tree-1.
-Its key is a cons or vector/record seen by the algorithm, and its
-value is the corresponding cons/vector/record in the copy.")
-
-(defun safe-copy-tree--1 (tree &optional vecp)
-  "Make a copy of TREE, taking circular structure into account.
-If TREE is a cons cell, this recursively copies both its car and its cdr.
-Contrast to `copy-sequence', which copies only along the cdrs.  With second
-argument VECP, this copies vectors and records as well as conses."
-  (cond
-   ((gethash tree safe-copy-tree--seen))
-   ((consp tree)
-    (let* ((result (cons (car tree) (cdr tree)))
-          (newcons result)
-          hash)
-      (while (and (not hash) (consp tree))
-       (if (setq hash (gethash tree safe-copy-tree--seen))
-            (setq newcons hash)
-         (puthash tree newcons safe-copy-tree--seen))
-        (setq tree newcons)
-        (unless hash
-         (if (or (consp (car tree))
-                  (and vecp (or (vectorp (car tree)) (recordp (car tree)))))
-             (let ((newcar (safe-copy-tree--1 (car tree) vecp)))
-               (setcar tree newcar)))
-          (setq newcons (if (consp (cdr tree))
-                            (cons (cadr tree) (cddr tree))
-                          (cdr tree)))
-          (setcdr tree newcons)
-          (setq tree (cdr tree))))
-      (nconc result
-             (if (and vecp (or (vectorp tree) (recordp tree)))
-                (safe-copy-tree--1 tree vecp) tree))))
-   ((and vecp (or (vectorp tree) (recordp tree)))
-    (let* ((newvec (copy-sequence tree))
-           (i (length newvec)))
-      (puthash tree newvec safe-copy-tree--seen)
-      (setq tree newvec)
-      (while (>= (setq i (1- i)) 0)
-       (aset tree i (safe-copy-tree--1 (aref tree i) vecp)))
-      tree))
-   (t tree)))
-
-(defun safe-copy-tree (tree &optional vecp)
-  "Make a copy of TREE, taking circular structure into account.
-If TREE is a cons cell, this recursively copies both its car and its cdr.
-Contrast to `copy-sequence', which copies only along the cdrs.  With second
-argument VECP, this copies vectors and records as well as conses."
-  (setq safe-copy-tree--seen (make-hash-table :test #'eq))
-  (unwind-protect
-      (safe-copy-tree--1 tree vecp)
-    (clrhash safe-copy-tree--seen)
-    (setq safe-copy-tree--seen nil)))
-
 
 ;;;; Various list-search functions.
 
diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el 
b/test/lisp/emacs-lisp/bytecomp-tests.el
index 10b009a261c..2cd4dd75742 100644
--- a/test/lisp/emacs-lisp/bytecomp-tests.el
+++ b/test/lisp/emacs-lisp/bytecomp-tests.el
@@ -1850,6 +1850,34 @@ EXPECTED-POINT BINDINGS (MODES \\='\\='(ruby-mode 
js-mode python-mode)) \
     (should (eq (byte-compile-file src-file) 'no-byte-compile))
     (should-not (file-exists-p dest-file))))
 
+(ert-deftest bytecomp--copy-tree ()
+  (should (null (bytecomp--copy-tree nil)))
+  (let ((print-circle t))
+    (let* ((x '(1 2 (3 4)))
+           (y (bytecomp--copy-tree x)))
+      (should (equal (prin1-to-string (list x y))
+                     "((1 2 (3 4)) (1 2 (3 4)))")))
+    (let* ((x '#1=(a #1#))
+           (y (bytecomp--copy-tree x)))
+      (should (equal (prin1-to-string (list x y))
+                     "(#1=(a #1#) #2=(a #2#))")))
+    (let* ((x '#1=(#1# a))
+           (y (bytecomp--copy-tree x)))
+      (should (equal (prin1-to-string (list x y))
+                     "(#1=(#1# a) #2=(#2# a))")))
+    (let* ((x '((a . #1=(b)) #1#))
+           (y (bytecomp--copy-tree x)))
+      (should (equal (prin1-to-string (list x y))
+                     "(((a . #1=(b)) #1#) ((a . #2=(b)) #2#))")))
+    (let* ((x '#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d)))
+           (y (bytecomp--copy-tree x)))
+      (should (equal (prin1-to-string (list x y))
+                     (concat
+                      "("
+                      "#1=(a #2=(#1# b . #3=(#2# c . #1#)) (#3# d))"
+                      " "
+                      "#4=(a #5=(#4# b . #6=(#5# c . #4#)) (#6# d))"
+                      ")"))))))
 
 ;; Local Variables:
 ;; no-byte-compile: t
diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el
index 37fe09c1716..050ee22ac18 100644
--- a/test/lisp/subr-tests.el
+++ b/test/lisp/subr-tests.el
@@ -1205,31 +1205,5 @@ final or penultimate step during initialization."))
     (should (equal a-dedup '("a" "b" "a" "b" "c")))
     (should (eq a a-dedup))))
 
-(ert-deftest subr--safe-copy-tree ()
-  (should (null (safe-copy-tree nil)))
-  (let* ((foo '(1 2 (3 4))) (bar (safe-copy-tree foo)))
-    (should (equal bar foo))
-    (should-not (eq bar foo))
-    (should-not (eq (caddr bar) (caddr foo))))
-  (let* ((foo '#1=(a #1#)) (bar (safe-copy-tree foo)))
-    (should (eq (car bar) (car foo)))
-;    (should-not (proper-list-p bar))
-    (should (eq (caadr bar) (caadr foo)))
-    (should (eq (caadr bar) 'a)))
-  (let* ((foo [1 2 3 4]) (bar (safe-copy-tree foo)))
-    (should (eq bar foo)))
-  (let* ((foo [1 (2 3) 4]) (bar (safe-copy-tree foo t)))
-    (should-not (eq bar foo))
-    (should (equal bar foo))
-    (should-not (eq (aref bar 1) (aref foo 1))))
-  (let* ((foo [1 [2 3] 4]) (bar (safe-copy-tree foo t)))
-    (should (equal bar foo))
-    (should-not (eq bar foo))
-    (should-not (eq (aref bar 1) (aref foo 1))))
-  (let* ((foo (record 'foo 1 "two" 3)) (bar (safe-copy-tree foo t)))
-    (should (equal bar foo))
-    (should-not (eq bar foo))
-    (should (eq (aref bar 2) (aref foo 2)))))
-
 (provide 'subr-tests)
 ;;; subr-tests.el ends here