From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 5 Jun 2008 16:32:37 +0000 (+0000)
Subject: 1.0.17.28: fix bug in the newfangled constant dumping scheme
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=b025fdbef7236941a6389fe6fa9d9903d2a5cab7;p=sbcl.git

1.0.17.28: fix bug in the newfangled constant dumping scheme

 * When MAYBE-EMIT-MAKE-LOAD-FORMS elects to use the name to dump
   something, it better use the name to refer to the _whole_ object,
   and not just a subpart...

 * Use XSET for niceness in there as well. ...but XSET should really
   be replaced by a sane tree-based version...

 * Test-case by Kevin Reid.
---

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 869d1cd..676ed9a 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -252,43 +252,23 @@
 ;;; processed with MAKE-LOAD-FORM. We have to be careful, because
 ;;; CONSTANT might be circular. We also check that the constant (and
 ;;; any subparts) are dumpable at all.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD)
-  ;; below. -- AL 20010227
-  (def!constant list-to-hash-table-threshold 32))
 (defun maybe-emit-make-load-forms (constant &optional (name nil namep))
-  (let ((things-processed nil)
-        (count 0))
-    ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit?
-    (declare (type (or list hash-table) things-processed)
-             (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
-             (inline member))
-    (labels ((grovel (value)
+  (let ((xset (alloc-xset)))
+    (labels ((trivialp (value)
+               (typep value
+                      '(or #-sb-xc-host unboxed-array
+                        #+sb-xc-host (simple-array (unsigned-byte 8) (*))
+                        symbol
+                        number
+                        character
+                        string)))
+             (grovel (value)
                ;; Unless VALUE is an object which which obviously
                ;; can't contain other objects
-               (unless (typep value
-                              '(or #-sb-xc-host unboxed-array
-                                #+sb-xc-host (simple-array (unsigned-byte 8) (*))
-                                symbol
-                                number
-                                character
-                                string))
-                 (etypecase things-processed
-                   (list
-                    (when (member value things-processed :test #'eq)
-                      (return-from grovel nil))
-                    (push value things-processed)
-                    (incf count)
-                    (when (> count list-to-hash-table-threshold)
-                      (let ((things things-processed))
-                        (setf things-processed
-                              (make-hash-table :test 'eq))
-                        (dolist (thing things)
-                          (setf (gethash thing things-processed) t)))))
-                   (hash-table
-                    (when (gethash value things-processed)
-                      (return-from grovel nil))
-                    (setf (gethash value things-processed) t)))
+               (unless (trivialp value)
+                 (if (xset-member-p value xset)
+                     (return-from grovel nil)
+                     (add-to-xset value xset))
                  (typecase value
                    (cons
                     (grovel (car value))
@@ -313,7 +293,9 @@
                     (if namep
                         ;; We can dump arbitrary named constant references by
                         ;; using the name.
-                        (emit-make-load-form value name)
+                        (progn
+                          (emit-make-load-form constant name)
+                          (return-from maybe-emit-make-load-forms (values)))
                         ;; In the target SBCL, we can dump any instance, but
                         ;; in the cross-compilation host, %INSTANCE-FOO
                         ;; functions don't work on general instances, only on
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 89a9d83..2502ae2 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1622,13 +1622,21 @@
 (defconstant +born-to-coalesce4+ '(foo bar "zot" 123 (nested "quux") #*0101110010))
 (assert-coalescing '+born-to-coalesce4+)
 
+(defclass some-constant-thing () ())
+
+;;; correct handling of nested things loaded via SYMBOL-VALUE
+(defvar *sneaky-nested-thing* (list (make-instance 'some-constant-thing)))
+(defconstant +sneaky-nested-thing+ *sneaky-nested-thing*)
+(multiple-value-bind (file-fun core-fun) (compile2 '(lambda () +sneaky-nested-thing+))
+  (assert (eq *sneaky-nested-thing* (funcall file-fun)))
+  (assert (eq *sneaky-nested-thing* (funcall core-fun))))
+
 ;;; catch constant modifications thru undefined variables
 (defun sneak-set-dont-set-me (x)
   (ignore-errors (setq dont-set-me x)))
 (defconstant dont-set-me 42)
 (assert (not (sneak-set-dont-set-me 13)))
 (assert (= 42 dont-set-me))
-(defclass some-constant-thing () ())
 (defun sneak-set-dont-set-me2 (x)
   (ignore-errors (setq dont-set-me2 x)))
 (defconstant dont-set-me2 (make-instance 'some-constant-thing))
diff --git a/version.lisp-expr b/version.lisp-expr
index 5affd46..f365cc5 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; 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".)
-"1.0.17.27"
+"1.0.17.28"