Enable fancy (CASE SYMBOL ...) expander in cross-compiler

* Put %sxhash-simple-substring where make-host-2 can call it

* Fix a bug in dumping of fixnum-specialized vectors

* Move the post-XC audit of SXHASH results even later in build-order

* Use sb-xc:char-code

build-order.lisp-expr

@@ -210,6 +210,7 @@
  ("src/code/pred" :not-host)
  ("src/compiler/generic/pinned-objects" :not-host)
 
+ ("src/code/string-hash")
  ("src/code/target-sxhash" :not-host) ; needs most-fooative-foo-float constants
 
  ("src/code/list"   :not-host)
@@ -718,7 +719,12 @@
 
  ("src/code/late-globaldb" :not-host)
  ("src/code/redblack" :not-host)
- )
+ ;; This file, which must be last, contains sanity-checks of the cross-compile.
+ ;; The inputs and outputs of certain functions (currently just SXHASH) are stored
+ ;; in global symbols. Relying on the fact that data are easily dumped as constants
+ ;; (assuming we don't have a genesis bug), the forms in this file can audit
+ ;; whether things came out right.
+ ("src/code/last-file" :not-host))
 
 ;;; make-target-2 build steps
 (("src/code/early-ntrace" ; lets PCL hook into tracing

src/code/last-file.lisp

@@ -0,0 +1,25 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-IMPL")
+
+;;; Verify on startup that some constants were dumped reflecting the correct
+;;; action of our vanilla-host-compatible functions.
+;;; For now, just SXHASH is checked.
+
+;;; Parallelized build doesn't get the full set of data because the side effect
+;;; of data recording when invoking compile-time functions aren't propagated
+;;; back to process that forked the children doing the grunt work.
+(defvar sb-c::*sxhash-crosscheck* '#.sb-c::*sxhash-crosscheck*)
+(defun check-compile-time-sxhashes ()
+  (loop for (object . hash) in sb-c::*sxhash-crosscheck*
+        unless (= (sxhash object) hash)
+        do (error "SB-XC:SXHASH computed wrong answer for ~S. Got ~x should be ~x"
+                  object hash (sxhash object))))
+(check-compile-time-sxhashes)

src/code/late-globaldb.lisp

@@ -44,10 +44,3 @@
   ;; to detect possible inlining failures
   (def :compile-toplevel)
   (def :load-toplevel :execute))
-
-;;; This check is most effective when placed in the final cross-compiled file.
-;;; Parallelized build effectively skips this, but oh well.
-(loop for (object . hash) in '#.sb-c::*sxhash-crosscheck*
-      unless (= (sxhash object) hash)
-      do (error "SB-XC:SXHASH computed wrong answer for ~S. Got ~x should be ~x"
-                object hash (sxhash object)))

src/code/macros.lisp

@@ -402,12 +402,6 @@ symbol-case giving up: case=((V U) (F))
 ;;; looked as if the COND might return NIL.
 (defun expand-symbol-case (keyform clauses keys errorp hash-fun)
   (declare (ignorable keyform clauses keys errorp))
-  ;; I'm not sure how I want to handle the cross-compiler's dependence
-  ;; on SXHASH here. The path of least resistance is to avoid this macro.
-  ;; Nonetheless I'd like to see how often this expander would run if it could
-  ;; during cross-compilation.
-  ;; (we could emulate SBCL's SXHASH of strings/symbols in the host, it's not hard)
-  #+sb-xc-host (return-from expand-symbol-case nil)
   ;; for few keys, the clever algorithm  probably gives no better performance
   ;; - and potentially worse - than the CPU's branch predictor.
   (unless (>= (length keys) 6)

src/code/string-hash.lisp

@@ -0,0 +1,65 @@
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-IMPL")
+
+;;;; hashing strings
+;;;;
+;;;; Note that this operation is used in compiler symbol table
+;;;; lookups, so we'd like it to be fast.
+;;;;
+;;;; As of 2004-03-10, we implement the one-at-a-time algorithm
+;;;; designed by Bob Jenkins (see
+;;;; <http://burtleburtle.net/bob/hash/doobs.html> for some more
+;;;; information).
+
+#-sb-xc-host (declaim (inline %sxhash-simple-substring))
+(defun %sxhash-simple-substring (string start end)
+  ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
+  ;; cross-compiler were smarter about ASH, but we need it for
+  ;; sbcl-0.5.0m.  (probably no longer true?  We might need SAFETY 0
+  ;; to elide some type checks, but then again if this is inlined in
+  ;; all the critical places, we might not -- CSR, 2004-03-10)
+
+  ;; Never decrease safety in the cross-compiler. It's not worth the headache
+  ;; of tracking down insidious host/target compatibility bugs.
+  #-sb-xc-host (declare (optimize (speed 3) (safety 0)))
+  (macrolet ((guts ()
+               `(loop for i of-type index from start below end do
+                  (set-result (+ result (char-code (aref string i))))
+                  (set-result (+ result (ash result 10)))
+                  (set-result (logxor result (ash result -6)))))
+             (set-result (form)
+               `(setf result (ldb (byte #.sb-vm:n-word-bits 0) ,form))))
+    (let ((result 238625159)) ; (logandc2 most-positive-fixnum (sxhash #\S)) on 32 bits
+      (declare (type word result))
+      ;; Avoid accessing elements of a (simple-array nil (*)).
+      ;; The expansion of STRING-DISPATCH involves ETYPECASE,
+      ;; so we can't simply omit one case. Therefore that macro
+      ;; is unusable here.
+      #-sb-xc-host (typecase string
+                     (simple-base-string (guts))
+                     ((simple-array character (*)) (guts)))
+
+      #+sb-xc-host (guts) ; just do it, don't care about loop unswitching
+
+      (set-result (+ result (ash result 3)))
+      (set-result (logxor result (ash result -11)))
+      (set-result (logxor result (ash result 15)))
+      (logand result sb-xc:most-positive-fixnum))))
+;;; test:
+;;;   (let ((ht (make-hash-table :test 'equal)))
+;;;     (do-all-symbols (symbol)
+;;;       (let* ((string (symbol-name symbol))
+;;;           (hash (%sxhash-substring string)))
+;;;      (if (gethash hash ht)
+;;;          (unless (string= (gethash hash ht) string)
+;;;            (format t "collision: ~S ~S~%" string (gethash hash ht)))
+;;;          (setf (gethash hash ht) string))))
+;;;     (format t "final count=~W~%" (hash-table-count ht)))

src/code/target-sxhash.lisp

@@ -110,55 +110,6 @@
           mask))
 
 
-;;;; hashing strings
-;;;;
-;;;; Note that this operation is used in compiler symbol table
-;;;; lookups, so we'd like it to be fast.
-;;;;
-;;;; As of 2004-03-10, we implement the one-at-a-time algorithm
-;;;; designed by Bob Jenkins (see
-;;;; <http://burtleburtle.net/bob/hash/doobs.html> for some more
-;;;; information).
-
-(declaim (inline %sxhash-simple-substring))
-(defun %sxhash-simple-substring (string start end)
-  ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
-  ;; cross-compiler were smarter about ASH, but we need it for
-  ;; sbcl-0.5.0m.  (probably no longer true?  We might need SAFETY 0
-  ;; to elide some type checks, but then again if this is inlined in
-  ;; all the critical places, we might not -- CSR, 2004-03-10)
-  (declare (optimize (speed 3) (safety 0)))
-  (macrolet ((guts ()
-               `(loop for i of-type index from start below end do
-                  (set-result (+ result (char-code (aref string i))))
-                  (set-result (+ result (ash result 10)))
-                  (set-result (logxor result (ash result -6)))))
-             (set-result (form)
-               `(setf result (ldb (byte #.sb-vm:n-word-bits 0) ,form))))
-    (let ((result 238625159)) ; (logandc2 most-positive-fixnum (sxhash #\S)) on 32 bits
-      (declare (type word result))
-      ;; Avoid accessing elements of a (simple-array nil (*)).
-      ;; The expansion of STRING-DISPATCH involves ETYPECASE,
-      ;; so we can't simply omit one case. Therefore that macro
-      ;; is unusable here.
-      (typecase string
-        (simple-base-string (guts))
-        ((simple-array character (*)) (guts)))
-      (set-result (+ result (ash result 3)))
-      (set-result (logxor result (ash result -11)))
-      (set-result (logxor result (ash result 15)))
-      (logand result sb-xc:most-positive-fixnum))))
-;;; test:
-;;;   (let ((ht (make-hash-table :test 'equal)))
-;;;     (do-all-symbols (symbol)
-;;;       (let* ((string (symbol-name symbol))
-;;;           (hash (%sxhash-substring string)))
-;;;      (if (gethash hash ht)
-;;;          (unless (string= (gethash hash ht) string)
-;;;            (format t "collision: ~S ~S~%" string (gethash hash ht)))
-;;;          (setf (gethash hash ht) string))))
-;;;     (format t "final count=~W~%" (hash-table-count ht)))
-
 (defun %sxhash-simple-string (x)
   (declare (optimize speed))
   (declare (type simple-string x))

src/compiler/dump.lisp

@@ -774,6 +774,14 @@
     (unless data-only
       (dump-fop 'fop-spec-vector file length)
       (dump-byte widetag file))
+
+    #+sb-xc-host
+    (when (or (= widetag sb-vm:simple-array-fixnum-widetag)
+              (= widetag sb-vm:simple-array-unsigned-fixnum-widetag))
+      ;; Fixnum vector contents are tagged numbers. Make a copy.
+      (setq vector (map 'vector (lambda (x) (ash x sb-vm:n-fixnum-tag-bits))
+                        vector)))
+
     ;; cross-io doesn't know about fasl streams, so use actual stream.
     (sb-impl::buffer-output (fasl-output-stream file)
                             vector

src/compiler/ir2opt.lisp

@@ -639,7 +639,7 @@
     (let ((values (mapcar #'car choices)))
       (cond ((every #'fixnump values)) ; ok
             ((every #'characterp values)
-             (setq values (mapcar #'char-code values)))
+             (setq values (mapcar #'sb-xc:char-code values)))
             (t
              (return-from should-use-jump-table-p nil)))
       (let* ((min (reduce #'min values))

src/compiler/sxhash.lisp

@@ -223,10 +223,19 @@
 (progn
   (defvar *sxhash-crosscheck* nil)
   (defun sxhash (x)
-    (let ((answer (etypecase x ; croak on anything but these
-                    (null         (ash sb-vm:nil-value (- sb-vm:n-fixnum-tag-bits)))
-                    (sb-xc:fixnum #.+sxhash-fixnum-expr+)
-                    (single-float #.+sxhash-single-float-expr+)
-                    (double-float #.+sxhash-double-float-expr+))))
+    (let ((answer
+           (etypecase x ; croak on anything but these
+            (null (ash sb-vm:nil-value (- sb-vm:n-fixnum-tag-bits)))
+            (symbol
+             ;; There had better not be homographs of NIL.
+             ;; See the comment in COMPUTE-SYMBOL-HASH for explanation.
+             (aver (string/= x "NIL"))
+             (let* ((string (coerce (string x) 'simple-string))
+                    (length (length string))
+                    (string-hash (sb-impl::%sxhash-simple-substring string 0 length)))
+               (logand (lognot string-hash) sb-xc:most-positive-fixnum)))
+            (sb-xc:fixnum #.+sxhash-fixnum-expr+)
+            (single-float #.+sxhash-single-float-expr+)
+            (double-float #.+sxhash-double-float-expr+))))
       (push (cons x answer) *sxhash-crosscheck*)
       answer)))

src/compiler/x86-64/pred.lisp

@@ -94,11 +94,11 @@
          (inst lea table (register-inline-constant :jump-table (coerce vector 'list)))
          (inst jmp (ea table temp-reg-tn 4))))
       (character
-       (let* ((min (reduce #'min values :key #'char-code))
-              (max (reduce #'max values :key #'char-code))
+       (let* ((min (reduce #'min values :key #'sb-xc:char-code))
+              (max (reduce #'max values :key #'sb-xc:char-code))
               (vector (make-array (1+ (- max min)) :initial-element otherwise)))
          (mapc (lambda (value label)
-                 (setf (aref vector (- (char-code value) min)) label))
+                 (setf (aref vector (- (sb-xc:char-code value) min)) label))
                values labels)
          ;; Same as above, but test the widetag before shifting it out.
          (unless (member test-vop-name '(fast-char=/character/c

src/compiler/x86/pred.lisp

@@ -71,11 +71,11 @@
            (inst jmp (make-ea :dword :disp (ea-disp table)
                               :index index :scale 1)))))
       (character
-       (let* ((min (reduce #'min values :key #'char-code))
-              (max (reduce #'max values :key #'char-code))
+       (let* ((min (reduce #'min values :key #'sb-xc:char-code))
+              (max (reduce #'max values :key #'sb-xc:char-code))
               (vector (make-array (1+ (- max min)) :initial-element otherwise)))
          (mapc (lambda (value label)
-                 (setf (aref vector (- (char-code value) min)) label))
+                 (setf (aref vector (- (sb-xc:char-code value) min)) label))
                values labels)
          (inst mov index x)
          (inst and index widetag-mask)