Re: master: Speed up and improve genheaders test

When building with round-float, aka adding :sse4 into backend-subfeatures:

Diffing sbcl.h against genesis and checking that it can stand alone
55a56
> #define LISP_FEATURE_ROUND_FLOAT

On Fri, Feb 6, 2026 at 7:02 PM snuglas via Sbcl-commits
<[email protected]> wrote:
>
> The branch "master" has been updated in SBCL:
>        via  e79b67d46852a510ed6f4a0918ca7c8de67b805c (commit)
>       from  4df46c49aa3edab29c3e29fdad05ea2db1ecbe93 (commit)
>
> - Log -----------------------------------------------------------------
> commit e79b67d46852a510ed6f4a0918ca7c8de67b805c
> Author: Douglas Katzman <[email protected]>
> Date:   Fri Feb 6 10:52:20 2026 -0500
>
>     Speed up and improve genheaders test
>
>     On my workstation it's down to 15 sec. with sb-eval or 2 sec. with fasteval
> ---
>  src/code/cross-float.lisp      | 11 ++++++++++
>  src/code/float-from-bits.lisp  | 50 ++++++++++++++++++++++++++++++++++++++++++
>  src/code/float.lisp            | 41 ----------------------------------
>  src/code/hash-table.lisp       | 10 +++++++--
>  src/cold/build-order.lisp-expr |  5 +++--
>  tests/genheaders.test.sh       |  3 +++
>  6 files changed, 75 insertions(+), 45 deletions(-)
>
> diff --git a/src/code/cross-float.lisp b/src/code/cross-float.lisp
> index ef24c7fa1..eb61fbaf3 100644
> --- a/src/code/cross-float.lisp
> +++ b/src/code/cross-float.lisp
> @@ -344,6 +344,7 @@
>                 (setf current (cl:/ (cl:+ current (cl:/ rational current)) 2))))))
>      (%%sqrt rational (cl:/ (isqrt (numerator rational)) (isqrt (denominator rational))))))
>
> +#-c-headers-only
>  (defun sb-xc:sqrt (arg)
>    (cond ((eql arg 0)
>           0.0)
> @@ -364,6 +365,7 @@
>    `(progn ,@body))
>
>  (defun realpart (x) (if (realp x) x (complexnum-real x)))
> +#-c-headers-only
>  (defun imagpart (x)
>    (cond ((rationalp x) 0)
>          ((single-float-p x) 0f0)
> @@ -375,6 +377,7 @@
>
>  ;;; PI is needed in order to build the cross-compiler mainly so that vm-fndb
>  ;;; can define bounds on irrational functions.
> +#-c-headers-only
>  (defconstant pi 3.14159265358979323846264338327950288419716939937511L0)
>
>  (macrolet ((def (name lambda-list)
> @@ -392,6 +395,7 @@
>    (def tan (number))
>    (def tanh (number)))
>
> +#-c-headers-only
>  (defun asin (number)
>    (case number
>      (-1d0 -1.5707963267948966d0)
> @@ -401,6 +405,7 @@
>      (t
>       (error "Unimplemented."))))
>
> +#-c-headers-only
>  (defun acos (number)
>    (case number
>      (-1d0 pi)
> @@ -410,6 +415,7 @@
>      (t
>       (error "Unimplemented."))))
>
> +#-c-headers-only
>  (defun acosh (number)
>    (with-memoized-math-op (acosh number)
>      (case number
> @@ -418,6 +424,7 @@
>        (t
>         (error "Unimplemented.")))))
>
> +#-c-headers-only
>  (defun atanh (number)
>    (with-memoized-math-op (atanh number)
>      (case number
> @@ -428,6 +435,7 @@
>        (t
>         (error "Unimplemented.")))))
>
> +#-c-headers-only
>  (defun atan (number1 &optional (number2 nil number2p))
>    (if number2p
>        (with-memoized-math-op (atan (list number1 number2))
> @@ -437,6 +445,7 @@
>              number1
>              (error "Unimplemented.")))))
>
> +#-c-headers-only
>  (defun cosh (number)
>    (with-memoized-math-op (cosh number)
>      (case number
> @@ -551,6 +560,7 @@
>                   table)))))
>
>  ;;; Perform some simple checks
> +#-c-headers-only (progn
>  (assert (not (eq -0.0f0 -0.0d0)))
>  (assert (not (eq single-float-negative-infinity 0f0)))
>  (dolist (format '(single-float double-float))
> @@ -615,3 +625,4 @@
>      (assert-not-number single-float-positive-infinity)
>      (assert-not-number double-float-negative-infinity)
>      (assert-not-number double-float-positive-infinity))))
> +)
> diff --git a/src/code/float-from-bits.lisp b/src/code/float-from-bits.lisp
> new file mode 100644
> index 000000000..9b6fb6e47
> --- /dev/null
> +++ b/src/code/float-from-bits.lisp
> @@ -0,0 +1,50 @@
> +;;;; 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-KERNEL")
> +
> +;;;; utilities
> +;;; Don't need to define it in the host in both passes
> +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
> +;;; These functions let us create floats from bits with the
> +;;; significand uniformly represented as an integer. This is less
> +;;; efficient for double floats, but is more convenient when making
> +;;; special values, etc.
> +(declaim (inline single-from-bits double-from-bits))
> +
> +(defun single-from-bits (sign exp sig)
> +  (declare (type bit sign) (type (unsigned-byte 24) sig)
> +           (type (unsigned-byte 8) exp))
> +  (make-single-float
> +   (dpb exp sb-vm:single-float-exponent-byte
> +        (dpb sig sb-vm:single-float-significand-byte
> +             (if (zerop sign) 0 -1)))))
> +(defun double-from-bits (sign exp sig)
> +  (declare (type bit sign) (type (unsigned-byte 53) sig)
> +           (type (unsigned-byte 11) exp))
> +  #-64-bit
> +  (make-double-float (dpb exp sb-vm:double-float-hi-exponent-byte
> +                          (dpb (ash sig -32)
> +                               sb-vm:double-float-hi-significand-byte
> +                               (if (zerop sign) 0 -1)))
> +                     (ldb (byte 32 0) sig))
> +  #+64-bit
> +  (%make-double-float
> +   (dpb exp sb-vm:double-float-exponent-byte
> +        (dpb sig sb-vm:double-float-significand-byte
> +             (if (zerop sign) 0 -1)))))
> +#+(and long-float x86)
> +(defun long-from-bits (sign exp sig)
> +  (declare (type bit sign) (type (unsigned-byte 64) sig)
> +           (type (unsigned-byte 15) exp))
> +  (make-long-float (logior (ash sign 15) exp)
> +                   (ldb (byte 32 32) sig)
> +                   (ldb (byte 32 0) sig)))
> +
> +) ; EVAL-WHEN
> diff --git a/src/code/float.lisp b/src/code/float.lisp
> index 7e59c017c..35bf3895c 100644
> --- a/src/code/float.lisp
> +++ b/src/code/float.lisp
> @@ -14,47 +14,6 @@
>  ;;;; files for more information.
>
>  (in-package "SB-KERNEL")
> -
> -;;;; utilities
> -;;; Don't need to define it in the host in both passes
> -(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
> -;;; These functions let us create floats from bits with the
> -;;; significand uniformly represented as an integer. This is less
> -;;; efficient for double floats, but is more convenient when making
> -;;; special values, etc.
> -(declaim (inline single-from-bits double-from-bits))
> -
> -(defun single-from-bits (sign exp sig)
> -  (declare (type bit sign) (type (unsigned-byte 24) sig)
> -           (type (unsigned-byte 8) exp))
> -  (make-single-float
> -   (dpb exp sb-vm:single-float-exponent-byte
> -        (dpb sig sb-vm:single-float-significand-byte
> -             (if (zerop sign) 0 -1)))))
> -(defun double-from-bits (sign exp sig)
> -  (declare (type bit sign) (type (unsigned-byte 53) sig)
> -           (type (unsigned-byte 11) exp))
> -  #-64-bit
> -  (make-double-float (dpb exp sb-vm:double-float-hi-exponent-byte
> -                          (dpb (ash sig -32)
> -                               sb-vm:double-float-hi-significand-byte
> -                               (if (zerop sign) 0 -1)))
> -                     (ldb (byte 32 0) sig))
> -  #+64-bit
> -  (%make-double-float
> -   (dpb exp sb-vm:double-float-exponent-byte
> -        (dpb sig sb-vm:double-float-significand-byte
> -             (if (zerop sign) 0 -1)))))
> -#+(and long-float x86)
> -(defun long-from-bits (sign exp sig)
> -  (declare (type bit sign) (type (unsigned-byte 64) sig)
> -           (type (unsigned-byte 15) exp))
> -  (make-long-float (logior (ash sign 15) exp)
> -                   (ldb (byte 32 32) sig)
> -                   (ldb (byte 32 0) sig)))
> -
> -) ; EVAL-WHEN
> -
>
>  ;;;; float parameters
>
> diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp
> index f98fd691b..12b8a0d28 100644
> --- a/src/code/hash-table.lisp
> +++ b/src/code/hash-table.lisp
> @@ -152,7 +152,8 @@
>    ;; How much to grow the hash table by when it fills up. If an index,
>    ;; then add that amount. If a floating point number, then multiply
>    ;; it by that.
> -  (rehash-size nil :type (or index (single-float (1.0)))
> +  (rehash-size nil :type #+c-headers-only real
> +                         #-c-headers-only (or index (single-float (1.0)))
>                 :read-only t)
>    ;; How full the hash table has to get before we rehash
>    ;; but only for the initial determination of how many buckets to make.
> @@ -161,7 +162,12 @@
>    ;; table to be X amount larger *and* that you care at about what load factor the
>    ;; new table gets rehashed, but no, you don't get to pick both every time.
>    ;; (CLHS says that these are all just "hints" and we're free to ignore)
> -  (rehash-threshold nil :type (single-float (0.0) 1.0) :read-only t)
> +  ;; If #+c-headers-only, the type is weakened to one which generates the right
> +  ;; C type without parsing a float. (NUMBER or T would result in the type being
> +  ;; lispobj, while WORD would give the struct field an incorrect name)
> +  (rehash-threshold nil :type #+c-headers-only single-float
> +                              #-c-headers-only (single-float (0.0) 1.0)
> +                        :read-only t)
>    ;; The current number of entries in the table.
>    (%count 0 :type index)
>    ;; Index into the Next vector chaining together free slots in the KV
> diff --git a/src/cold/build-order.lisp-expr b/src/cold/build-order.lisp-expr
> index 5fa8ba81a..bbfb9d609 100644
> --- a/src/cold/build-order.lisp-expr
> +++ b/src/cold/build-order.lisp-expr
> @@ -71,7 +71,7 @@
>   ;; whereas if it's (BACKQUOTE (FOO (UNQUOTE A) (UNQUOTE B))) then it's
>   ;; flat out wrong. At any rate, judicious avoidance of EVAL-WHEN and nested
>   ;; quasiquotation in 'primordial-extensions' prevents any such issues.
> - ("src/code/backq" :c-headers)
> + ("src/code/backq")
>
>   ;; It's difficult to be too early with a DECLAIM SPECIAL (or DEFVAR
>   ;; or whatever) thanks to the sullenly-do-the-wrong-thing semantics
> @@ -163,7 +163,8 @@
>
>   ("src/code/number-dispatch" :c-headers)
>   ("src/code/cross-float-reader" :c-headers :not-target)
> - ("src/code/float" :c-headers)
> + ("src/code/float-from-bits" :c-headers)
> + ("src/code/float")
>   ("src/code/cross-float" :c-headers :not-target)
>
>   ;; 32-bit implementation of GET-INTERNAL-REAL-TIME needs some thread slots
> diff --git a/tests/genheaders.test.sh b/tests/genheaders.test.sh
> index ccd3e1845..ea52ce97c 100755
> --- a/tests/genheaders.test.sh
> +++ b/tests/genheaders.test.sh
> @@ -39,6 +39,9 @@ if [ -r $TEST_DIRECTORY/cons.h ]
>  then
>      for i in $TEST_DIRECTORY/*.h
>      do
> +          name=`basename $i`
> +          echo Diffing $name against genesis and checking that it can stand alone
> +          diff $i ../src/runtime/genesis/$name
>            echo "#include \"$i\"" > ${src}
>            ./run-compiler.sh -I../src/runtime -c -o ${obj} ${src}
>      done
>
> -----------------------------------------------------------------------
>
>
> hooks/post-receive
> --
> SBCL
>
>
> _______________________________________________
> Sbcl-commits mailing list
> [email protected]
> https://lists.sourceforge.net/lists/listinfo/sbcl-commits


_______________________________________________
Sbcl-commits mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/sbcl-commits