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