From 61370e23f329bd3c43bf959145e125ad8392c23e Mon Sep 17 00:00:00 2001
From: Charles Zhang <charleszhang99@yahoo.com>
Date: Sun, 21 Apr 2024 00:48:52 +0200
Subject: [PATCH] Make ./build-all-cores.sh check float files.

Check the xfloat-math.lisp-expr files produced in each tree directly,
and dispense with the almost-but-not-quite stand-alone merging utility
which required loading the whole cross-compiler just to check some
lisp expressions matched what they're supposed to be on the host,
which is overkill.
---
 build-all-cores.sh        |  4 +++-
 make-target-2.sh          |  4 +++-
 src/code/cross-float.lisp | 43 +++------------------------------------
 src/cold/warm.lisp        | 43 ---------------------------------------
 validate-float.lisp       | 39 +++++++++++++++++++++++++++++++++++
 5 files changed, 48 insertions(+), 85 deletions(-)
 create mode 100644 validate-float.lisp

diff --git a/build-all-cores.sh b/build-all-cores.sh
index 4683f32c6..09f373830 100755
--- a/build-all-cores.sh
+++ b/build-all-cores.sh
@@ -132,7 +132,9 @@ obj/xbuild/{cfg}.core: obj/xbuild/{cfg}/xc.core
                :search t))
 (when (= (process-exit-code *process*) 0)
   (load "src/cold/shared" :verbose t)
-  ;; TODO: merge the xfloat-math files, unless we decide to get rid of them
+  (load "validate-float.lisp")
+  (dolist (pathname (directory "obj/xbuild/**/xfloat-math.lisp-expr"))
+    (check-float-file pathname))
   (dolist (nbits '(30 61 63))
     (let* ((filename (format nil "xperfecthash~D.lisp-expr" nbits))
            (sources (directory (format nil "obj/xbuild/*/from-xc/~A" filename))))
diff --git a/make-target-2.sh b/make-target-2.sh
index 4da0001cc..d02afc1bd 100755
--- a/make-target-2.sh
+++ b/make-target-2.sh
@@ -74,7 +74,9 @@ echo //doing warm init - load and dump phase
 EOF
 
 ./src/runtime/sbcl --noinform --core output/sbcl.core \
-  --no-sysinit --no-userinit --noprint <<EOF
+                   --no-sysinit --no-userinit --noprint <<EOF
+  (load "validate-float.lisp")
+  (check-float-file "output/xfloat-math.lisp-expr")
   (ignore-errors (delete-file "output/reorg.core"))
   ;; * Lisp won't read compressed cores, and crashes on arm64
   #+(and mark-region-gc x86-64 (not sb-core-compression))
diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp
index c060118ca..a80684e56 100644
--- a/src/code/cross-float.lisp
+++ b/src/code/cross-float.lisp
@@ -175,8 +175,7 @@
              authoritative-answer))))))
   (setf (gethash key table) (if (singleton-p values) (car values) (cons '&values values))))
 
-(defun parse-xfloat-math-file (stream table mode)
-  (declare (type (member :all :merge) mode))
+(defun parse-xfloat-math-file (stream table)
   ;; Ensure that we're reading the correct variant of the file
   ;; in case there is more than one set of floating-point formats.
   (assert (eq (read stream) :default))
@@ -201,18 +200,7 @@
                                 (rest values)
                                 values)))
                (when existsp
-                 (case mode
-                   (:merge
-                    (when (and existsp
-                               (not (equal
-                                     (if (and (listp existsp) (eq (car existsp) '&values))
-                                         (cdr existsp)
-                                         existsp)
-                                     (if (singleton-p values) (car values) values))))
-                      (error "Got different answers for ~S: ~S and ~S"
-                             key existsp values)))
-                   (:all ; should not happen
-                    (error "Line ~D of float cache: ~S is repeated" line key))))
+                 (error "Line ~D of float cache: ~S is repeated" line key))
                (float-ops-cache-insert table key values))))
       (delete-package pkg))))
 
@@ -225,7 +213,7 @@
       (with-open-file (stream (setq pathname (sb-cold::math-journal-pathname :input))
                               :if-does-not-exist nil)
         (when stream
-          (parse-xfloat-math-file stream table :all)
+          (parse-xfloat-math-file stream table)
           (setf (cdr cache) (hash-table-count table))
           (when cl:*compile-verbose*
             (format t "~&; Math journal: prefilled ~D entries from ~S~%"
@@ -1029,31 +1017,6 @@
                   (if (consp result) result (list result)))))))
   (format stream ")~%"))
 
-;;; Recipe:
-;;; $ ./build-all-cores.sh
-;;; $ /path/to/host/sbcl
-;;; * (load "load-xc")
-;;; * (sb-impl:merge-all-xfloat-files)
-;;; Check:
-;;; $ ./make-target-2.sh
-(export 'merge-all-xfloat-files)
-(defun merge-all-xfloat-files ()
-  (let ((ht sb-cold::*math-ops-memoization*)
-        (total-delta 0))
-    (dolist (pathname (directory "obj/xbuild/**/xfloat-math.lisp-expr"))
-      (let ((old-count (hash-table-count ht)))
-        (with-open-file (stream pathname)
-          (parse-xfloat-math-file stream ht :merge)
-          (let ((delta (- (hash-table-count ht) old-count)))
-            (incf total-delta delta)
-            (when (plusp delta)
-              (format t "~D new entr~@:P from ~S~%" delta pathname))))))
-    (if (zerop total-delta)
-        (format t "~&Nothing new~%")
-        (with-open-file (stream "output/xfloat-math.lisp-expr"
-                                :direction :output :if-exists :supersede)
-          (dump-math-memoization-table ht stream)))))
-
 (defun show-interned-numbers (stream)
   (flet ((to-native (x)
             (declare (ignorable x))
diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp
index ffb6e279b..446d19472 100644
--- a/src/cold/warm.lisp
+++ b/src/cold/warm.lisp
@@ -85,49 +85,6 @@ sb-kernel::
 
 ;;; Verify that compile-time floating-point math matches load-time.
 (defvar *compile-files-p*)
-(when (or (not (boundp '*compile-files-p*)) *compile-files-p*)
-  (with-open-file (stream "output/xfloat-math.lisp-expr" :if-does-not-exist nil)
-    (when stream
-      (format t "; Checking ~S~%" (pathname stream))
-      ;; Ensure that we're reading the correct variant of the file
-      ;; in case there is more than one set of floating-point formats.
-      (assert (eq (read stream) :default))
-      (sb-kernel::with-float-traps-masked (:overflow :divide-by-zero)
-        (let ((*readtable* (copy-readtable))
-              (*package* (find-package "SB-KERNEL")))
-          ;; The reasoning behind this limited-use variant of read-time-eval is that
-          ;; since it is too early to actually use EVAL in the interpreted fashion,
-          ;; EVAL would call COMPILE which is just ridiculous because it would mean
-          ;; compiling however many #. expression there are in this file
-          (set-dispatch-macro-character
-           #\# #\. (lambda (stream subchar arg)
-                     (declare (ignore subchar arg))
-                     (let ((expr (read stream t nil t)))
-                       (ecase (car expr)
-                         (sb-kernel::s (sb-kernel:make-single-float (second expr)))
-                         (sb-kernel::d
-                          (sb-kernel:make-double-float (second expr) (third expr)))))))
-          (dolist (expr (read stream))
-            (destructuring-bind (fun args . result) expr
-              (let ((result (if (eq (first result) 'sb-kernel::&values)
-                                (rest result)
-                                result))
-                    (actual (if (eql fun 'read-from-string)
-                                (let ((*read-default-float-format* (car args)))
-                                  (multiple-value-list (apply fun (sb-int:ensure-list (cdr args)))))
-                                (multiple-value-list (apply fun (sb-int:ensure-list args))))))
-                (labels ((eqal (x y) ; non-ideal name, but other names are also non-ideal
-                           (etypecase x
-                             (cons (and (consp y) (eqal (car x) (car y)) (eqal (cdr x) (cdr y))))
-                             (symbol (eql x y))
-                             (rational (eql x y))
-                             (float (eql x y))
-                             (string (string= x y)))))
-                  (unless (eqal actual result)
-                    (cerror "Continue"
-                     "FLOAT CACHE LINE ~S vs COMPUTED ~S~%"
-                     expr actual)))))))))))
-
 (when (if (boundp '*compile-files-p*) *compile-files-p* t)
   (with-open-file (output "output/cold-vop-usage.txt" :if-does-not-exist nil)
     (when output
diff --git a/validate-float.lisp b/validate-float.lisp
new file mode 100644
index 000000000..88301e50e
--- /dev/null
+++ b/validate-float.lisp
@@ -0,0 +1,39 @@
+(defun check-float-file (name)
+  (with-open-file (stream name :if-does-not-exist nil)
+    (when stream
+      (format t "; Checking ~S~%" (pathname stream))
+      ;; Ensure that we're reading the correct variant of the file
+      ;; in case there is more than one set of floating-point formats.
+      (assert (eq (read stream) :default))
+      (sb-kernel::with-float-traps-masked (:overflow :divide-by-zero)
+        (let ((*readtable* (copy-readtable)))
+          ;; No need to do a full-blown read-time-eval.
+          (set-dispatch-macro-character
+              #\# #\. (lambda (stream subchar arg)
+                        (declare (ignore subchar arg))
+                        (let ((expr (read stream t nil t)))
+                          (ecase (car expr)
+                            (s (sb-kernel:make-single-float (second expr)))
+                            (d (sb-kernel:make-double-float (second expr) (third expr)))))))
+          (dolist (expr (read stream))
+            (destructuring-bind (fun args . result) expr
+              (let ((result (if (eq (first result) 'sb-kernel::&values)
+                                (rest result)
+                                result))
+                    (actual (if (eql fun 'read-from-string)
+                                (let ((*read-default-float-format* (car args)))
+                                  (multiple-value-list (apply fun (sb-int:ensure-list (cdr args)))))
+                                (multiple-value-list (apply fun (sb-int:ensure-list args))))))
+                (labels ((eqal (x y) ; non-ideal name, but other names are also non-ideal
+                           (etypecase x
+                             (cons (and (consp y) (eqal (car x) (car y)) (eqal (cdr x) (cdr y))))
+                             (symbol (eql x y))
+                             (rational (eql x y))
+                             (float (eql x y))
+                             (string (string= x y)))))
+                  (unless (eqal actual result)
+                    (cerror "Continue"
+                            "FLOAT CACHE LINE ~S vs COMPUTED ~S~%"
+                            expr actual)))))))))))
+
+(compile 'check-float-file)