1.0.17.31: more constant cleverness

 * Make MAYBE-EMIT-MAKE-LOAD-FORM can dump _all_ references to
   non-trivial named constants using the name (well, not FP constants
   for SBCL itself.)

   This means that after (DEFCONSTANT +FOO+ "FOO") all references to
   +FOO+ are EQ, even in different files.

   ...some people are going to use this as an unportable performance
   hack, and their code will break horribly sooner or later, but more
   importantly we need to grovel less things, and more sharing means
   less memory use and better cache behaviour.

 * Tests.

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 676ed9a..91b7a69 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -256,7 +256,8 @@
   (let ((xset (alloc-xset)))
     (labels ((trivialp (value)
                (typep value
-                      '(or #-sb-xc-host unboxed-array
+                      '(or
+                        #-sb-xc-host unboxed-array
                         #+sb-xc-host (simple-array (unsigned-byte 8) (*))
                         symbol
                         number
@@ -289,31 +290,34 @@
                    ((array t)
                     (dotimes (i (array-total-size value))
                       (grovel (row-major-aref value i))))
+                   (#+sb-xc-host structure!object
+                    #-sb-xc-host instance
+                    ;; 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
+                    ;; STRUCTURE!OBJECTs.
+                    ;;
+                    ;; FIXME: What about funcallable instances with
+                    ;; user-defined MAKE-LOAD-FORM methods?
+                    (when (emit-make-load-form value)
+                      (dotimes (i (- (%instance-length value)
+                                     #+sb-xc-host 0
+                                     #-sb-xc-host (layout-n-untagged-slots
+                                                   (%instance-ref value 0))))
+                        (grovel (%instance-ref value i)))))
                    (t
-                    (if namep
-                        ;; We can dump arbitrary named constant references by
-                        ;; using the 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
-                        ;; STRUCTURE!OBJECTs.
-                        ;;
-                        ;; FIXME: What about funcallable instances with user-defined
-                        ;; MAKE-LOAD-FORM methods?
-                        (if (typep value #+sb-xc-host 'structure!object #-sb-xc-host 'instance)
-                            (when (emit-make-load-form value)
-                              (dotimes (i (- (%instance-length value)
-                                             #+sb-xc-host 0
-                                             #-sb-xc-host (layout-n-untagged-slots
-                                                           (%instance-ref value 0))))
-                                (grovel (%instance-ref value i))))
-                            (compiler-error
-                             "Objects of type ~S can't be dumped into fasl files."
-                             (type-of value)))))))))
-      (grovel constant)))
+                    (compiler-error
+                     "Objects of type ~S can't be dumped into fasl files."
+                     (type-of value)))))))
+      ;; Dump all non-trivial named constants using the name.
+      (if (and namep (not (typep constant '(or symbol character
+                                            ;; FIXME: Cold init breaks if we
+                                            ;; try to reference FP constants
+                                            ;; thru their names.
+                                            #+sb-xc-host number
+                                            #-sb-xc-host fixnum))))
+          (emit-make-load-form constant name)
+          (grovel constant))))
   (values))
 \f
 ;;;; some flow-graph hacking utilities

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 2502ae2..21b4171 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1628,8 +1628,8 @@
 (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))))
+  (assert (equal *sneaky-nested-thing* (funcall file-fun)))
+  (assert (equal *sneaky-nested-thing* (funcall core-fun))))
 
 ;;; catch constant modifications thru undefined variables
 (defun sneak-set-dont-set-me (x)
@@ -1643,4 +1643,30 @@
 (assert (not (sneak-set-dont-set-me2 13)))
 (assert (typep dont-set-me2 'some-constant-thing))
 
+;;; check that non-trivial constants are EQ across different files: this is
+;;; not something ANSI either guarantees or requires, but we want to do it
+;;; anyways.
+(defconstant +share-me-1+ 123.456d0)
+(defconstant +share-me-2+ "a string to share")
+(defconstant +share-me-3+ (vector 1 2 3))
+(defconstant +share-me-4+ (* 2 most-positive-fixnum))
+(multiple-value-bind (f1 c1) (compile2 '(lambda () (values +share-me-1+
+                                                           +share-me-2+
+                                                           +share-me-3+
+                                                           +share-me-4+
+                                                           pi)))
+  (multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+
+                                                             +share-me-2+
+                                                             +share-me-3+
+                                                             +share-me-4+
+                                                             pi)))
+    (flet ((test (fa fb)
+             (mapc (lambda (a b)
+                     (assert (eq a b)))
+                   (multiple-value-list (funcall fa))
+                   (multiple-value-list (funcall fb)))))
+      (test f1 c1)
+      (test f1 f2)
+      (test f1 c2))))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index cb0496f..e9001f9 100644 (file)
--- 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.30"
+"1.0.17.31"