From 713b6f33e3e772edd72803446732d4cccc8a8995 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Mon, 30 Jun 2003 14:59:03 +0000
Subject: [PATCH] 	Make circular constant lists dumpable by checking for
 the list in 	the equal hash-table only if the list is definitely
 non-circular. 	Don't check for it being definitely circular because that
 slows 	down a full CMUCL build by about 16%.

	* src/compiler/dump.lisp (non-circular-list-p): New function.
	(dump-non-immediate-object): Use it.
	(circular-cons-p): Removed.
---
 compiler/dump.lisp           | 49 ++++++++++++++----------------------
 general-info/release-19a.txt |  2 ++
 2 files changed, 21 insertions(+), 30 deletions(-)

diff --git a/compiler/dump.lisp b/compiler/dump.lisp
index 58c16e764..e57253eaa 100644
--- a/compiler/dump.lisp
+++ b/compiler/dump.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.79 2003/06/10 16:52:36 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.80 2003/06/30 14:59:03 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -278,32 +278,21 @@
     (dump-fop 'lisp::fop-pop file)
     (incf (fasl-file-table-free file))))
 
-;;; circular-cons-p -- Internal
-;;;
-;;; Test for the kind of circularities that would cause equal not to
-;;; return, but allow other kinds of shared structure.
-
-(defun circular-cons-p (obj)
-  (unless (consp obj)
-    (return-from circular-cons-p nil))
-  (let ((circ-hash (make-hash-table :test #'eq)))
-    (labels ((circular-cons-p-aux (obj top-level)
-	       (do* ((sublist obj (cdr sublist)))
-		   ((not (consp sublist))
-		    nil)
-		 (let ((car-list (car sublist)))
-		   (when (gethash sublist circ-hash)
-		     (return-from circular-cons-p t))
-		   (setf (gethash sublist circ-hash) t)
-		   (when (consp car-list)
-		     (circular-cons-p-aux car-list nil))))
-	       (when (not top-level)
-		 (do ((sublist obj (cdr sublist)))
-		   ((not (consp sublist))
-		    nil)
-		 (remhash sublist circ-hash)))
-	       nil))
-      (circular-cons-p-aux obj t))))
+;;; non-circular-cons-p -- Internal
+;;;
+;;; Return true if LIST is definitely not circular.
+
+(defun non-circular-list-p (list)
+  (declare (list list))
+  (or (null list)
+      (labels ((safe-cddr (obj)
+		 (when (and (consp obj) (consp (cdr obj)))
+		   (cddr obj))))
+	(loop for tortoise = list then (cdr tortoise)
+	      for hare = (safe-cddr list) then (safe-cddr hare)
+	      when (not (consp tortoise)) return t
+	      when (consp (car tortoise)) return nil
+	      when (eq hare tortoise) return nil))))
 
 ;;; EQUAL-CHECK-TABLE  --  Internal
 ;;;
@@ -897,10 +886,10 @@
 	   (typecase x
 	     (symbol (dump-symbol x file))
 	     (list
-	      (cond (*coalesce-constants* ;(and (not (circular-cons-p x)))
+	      (cond ((and *coalesce-constants* (non-circular-list-p x))
 		     (unless (equal-check-table x file)
-			     (dump-list x file)
-			     (equal-save-object x file)))
+		       (dump-list x file)
+		       (equal-save-object x file)))
 		    (t
 		     (dump-list x file)
 		     (eq-save-object x file))))
diff --git a/general-info/release-19a.txt b/general-info/release-19a.txt
index dc94fac81..187073d7c 100644
--- a/general-info/release-19a.txt
+++ b/general-info/release-19a.txt
@@ -59,6 +59,8 @@ New in this release:
      - DISASSEMBLE disassembling closure/funcallable instance
        functions.
      - (SETF EXT:WEAK-POINTER-VALUE) has been added.
+     - CMUCL no longer entering an infinite loop when dumping
+       circular constant lists to fasl files.
 
   * Numerous ANSI compliance fixes:
      - Many bugs in CMUCL's type system detected by Paul Dietz'
-- 
GitLab