0.9.16.6: better circularity detection in fasl dumper
authorNikodemus Siivola <nikodemus@random-state.net>
Tue, 29 Aug 2006 13:35:23 +0000 (13:35 +0000)
committerNikodemus Siivola <nikodemus@random-state.net>
Tue, 29 Aug 2006 13:35:23 +0000 (13:35 +0000)
 * We need to detect car-circularity too, which can get expensive, so
   we approximate: CYCLIC-LIST-P => MAYBE-CYCLIC-P
 * Reported by Marco Monteiro on sbcl-devel.

NEWS
package-data-list.lisp-expr
src/code/early-extensions.lisp
src/code/pred.lisp
src/compiler/dump.lisp
tests/circ-tree-test.lisp [new file with mode: 0644]
tests/compiler.impure.lisp
version.lisp-expr

diff --git a/NEWS b/NEWS
index b613ab5..033fc69 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes in sbcl-0.9.17 (0.9.99?) relative to sbcl-0.9.16:
     for a type now works.
   * bug fix: loading of default sysinit file works. (thanks to Leonid
     Slobodov)
+  * bug fix: better detection of circularities in the file-compiler.
+    (reported by Marco Monteiro)
 
 changes in sbcl-0.9.16 relative to sbcl-0.9.15:
   * feature: implemented the READER-METHOD-CLASS and
index e2dd14b..833033a 100644 (file)
@@ -869,7 +869,7 @@ retained, possibly temporariliy, because it might be used internally."
                "ADJUST-LIST"
                "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
                "SANE-PACKAGE"
-               "CYCLIC-LIST-P"
+               "MAYBE-CYCLIC-P"
                "COMPOUND-OBJECT-P"
                "SWAPPED-ARGS-FUN"
                "AND/TYPE" "NOT/TYPE"
index df396b3..5115fc0 100644 (file)
 \f
 ;;;; type-ish predicates
 
-;;; Is X a list containing a cycle?
-(defun cyclic-list-p (x)
+;;; X may contain cycles -- a conservative approximation. This
+;;; occupies a somewhat uncomfortable niche between being fast for
+;;; common cases (we don't want to allocate a hash-table), and not
+;;; falling down to exponential behaviour for large trees (so we set
+;;; an arbitrady depth limit beyond which we punt).
+(defun maybe-cyclic-p (x &optional (depth-limit 12))
   (and (listp x)
-       (labels ((safe-cddr (x) (if (listp (cdr x)) (cddr x))))
-         (do ((y x (safe-cddr y))
-              (started-p nil t)
-              (z x (cdr z)))
-             ((not (and (consp z) (consp y))) nil)
-           (when (and started-p (eq y z))
-             (return t))))))
+       (labels ((safe-cddr (cons)
+                  (let ((cdr (cdr cons)))
+                    (when (consp cdr)
+                      (cdr cdr))))
+                (check-cycle (object seen depth)
+                  (when (and (consp object)
+                             (or (> depth depth-limit)
+                                 (member object seen)
+                                 (circularp object seen depth)))
+                    (return-from maybe-cyclic-p t)))
+                (circularp (list seen depth)
+                  ;; Almost regular circular list detection, with a twist:
+                  ;; we also check each element of the list for upward
+                  ;; references using CHECK-CYCLE.
+                  (do ((fast (cons (car list) (cdr list)) (safe-cddr fast))
+                       (slow list (cdr slow)))
+                      ((not (consp fast))
+                       ;; Not CDR-circular, need to check remaining CARs yet
+                       (do ((tail slow (and (cdr tail))))
+                           ((not (consp tail))
+                            nil)
+                         (check-cycle (car tail) (cons tail seen) (1+ depth))))
+                    (check-cycle (car slow) (cons slow seen) (1+ depth))
+                    (when (eq fast slow)
+                      (return t)))))
+         (circularp x (list x) 0))))
 
 ;;; Is X a (possibly-improper) list of at least N elements?
 (declaim (ftype (function (t index)) list-of-length-at-least-p))
index 76286c4..27158cf 100644 (file)
 
 (defun equal (x y)
   #!+sb-doc
-  "Return T if X and Y are EQL or if they are structured components
-  whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
-  are the same length and have identical components. Other arrays must be
-  EQ to be EQUAL."
+  "Return T if X and Y are EQL or if they are structured components whose
+elements are EQUAL. Strings and bit-vectors are EQUAL if they are the same
+length and have identical components. Other arrays must be EQ to be EQUAL."
   ;; Non-tail self-recursion implemented with a local auxiliary function
   ;; is a lot faster than doing it the straightforward way (at least
   ;; on x86oids) due to calling convention differences. -- JES, 2005-12-30
index a5d750c..4d136f3 100644 (file)
               ;;   take a little more care while dumping these.
               ;; So if better list coalescing is needed, start here.
               ;; -- WHN 2000-11-07
-              (if (cyclic-list-p x)
+              (if (maybe-cyclic-p x)
                   (progn
                     (dump-list x file)
                     (eq-save-object x file))
diff --git a/tests/circ-tree-test.lisp b/tests/circ-tree-test.lisp
new file mode 100644 (file)
index 0000000..2189186
--- /dev/null
@@ -0,0 +1,5 @@
+;;; fasl-dumper and circular trees, reported by Marco Monteiro
+(COMPILE NIL
+         '(LAMBDA ()
+           (LIST '#5= (#5# #5# . #5#))
+           (LIST '#6= (#7= (#6#) . #7#))))
index 78d6416..ae57aa9 100644 (file)
   (assert (not res))
   (assert (typep err 'type-error)))
 
+(handler-case
+    (delete-file (compile-file "circ-tree-test.lisp"))
+  (storage-condition (e)
+    (error e)))
+
 ;;; success
index 3f1829f..d2080d2 100644 (file)
@@ -17,5 +17,5 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.16.5"
+"0.9.16.6"