Raymond Toy pushed to branch issue-431-fix-set-floating-point-modes at cmucl / cmucl Commits: 67432557 by Raymond Toy at 2025-09-02T15:52:58-07:00 Address review comments Move new x87 constants and FP mode word printers from compiler/x86/float-sse2.lisp to code/x86-vm.lisp. Move new test from tests/float.lisp to the new file tests/float-x86.lisp. - - - - - 5002a779 by Raymond Toy at 2025-09-02T16:12:27-07:00 Address review comments Reduce scope of `unwind-protect` in tests/float-x86.lisp. Also print out the sse2 FP mode word, just like we do for the x87 FP mode word. - - - - - 6 changed files: - src/code/x86-vm.lisp - src/compiler/x86/float-sse2.lisp - src/i18n/locale/cmucl-sse2.pot - src/i18n/locale/cmucl-x86-vm.pot - + tests/float-x86.lisp - tests/float.lisp Changes: ===================================== src/code/x86-vm.lisp ===================================== @@ -733,3 +733,88 @@ (multiple-value-bind (fop dst src) (get-fp-operation scp) (values fop (list dst src)))) + +;; See src/compiler/x86/float-sse2.lisp for a description of the x87 +;; control and status words. + +(defconstant x87-float-infinity-control-byte + (byte 1 (+ 12 16)) + "The bit in the x87 FPU control word that controls the infinity mode.") + +(defconstant x87-float-rounding-mode + (byte 2 (+ 10 16)) + "The bits in the x87 FPU control word for the rounding mode.") + +(defconstant x87-float-precision-control-byte + (byte 2 (+ 8 16)) + "The bits in the x87 FPU contol word for the FP operation precision.") + +(defconstant x87-float-traps-byte + (byte 6 16) + "The bits in the x87 FPU control word indicating the exceptions that + are enabled.") + +(defconstant x87-float-precision-control-alist + `((:24-bits . 0) + (:reserved . 1) + (:53-bits . 2) + (:64-bits . 3)) + "Alist for the x87 precison control. The car is the symbolic + precision and the cdr is the value for the precision control field.") + +(defun print-fp-exceptions-enabled (enabled) + (format t "Precision enable: ~30T~A~%" (ldb (byte 1 5) enabled)) + (format t "Underflow enable: ~30T~A~%" (ldb (byte 1 4) enabled)) + (format t "Overflow enable: ~30T~A~%" (ldb (byte 1 3) enabled)) + (format t "Divide-by-zero enable: ~30T~A~%" (ldb (byte 1 2) enabled)) + (format t "Denormal op enable: ~30T~A~%" (ldb (byte 1 1) enabled)) + (format t "Invalid op enable: ~30T~A~%" (ldb (byte 1 0) enabled))) + +(defun print-fp-current-exceptions (current) + (format t "Precision flag: ~30T~A~%" (ldb (byte 1 5) current)) + (format t "Underflow flag: ~30T~A~%" (ldb (byte 1 4) current)) + (format t "Overflow flag: ~30T~A~%" (ldb (byte 1 3) current)) + (format t "Divide-by-zero flag: ~30T~A~%" (ldb (byte 1 2) current)) + (format t "Denormal op flag: ~30T~A~%" (ldb (byte 1 1) current)) + (format t "Invalid op flag: ~30T~A~%" (ldb (byte 1 0) current))) + +(defun print-sse2-fp-modes (&optional (sse-mode (sse2-floating-point-modes))) + "Print SSE2 floating modes word in a human-readable fashion." + ;; Note that Intel uses masks to disable the exception, but to match + ;; the rest of cmucl, these bits are represented as enable bits. + (format t "Flush-to-zero: ~30T~A~%" (ldb (byte 1 15) sse-mode)) + (let ((rc (ldb float-rounding-mode sse-mode))) + (format t "Rounding control: ~30T#b~2,'0b ~S~%" + rc + (car (rassoc rc rounding-mode-alist)))) + (print-fp-exceptions-enabled (ldb float-traps-byte sse-mode)) + (print-fp-current-exceptions (ldb float-exceptions-byte sse-mode))) + +(defun print-x87-fp-modes (&optional (x87-mode (x87-floating-point-modes))) + "Print X87 floating modes word in a human-readable fashion." + ;; Note that Intel uses masks to disable the exception, but to match + ;; the rest of cmucl, these bits are represented as enable bits. + (format t "Status word:~%") + (format t "FPU busy: ~30T~A~%" (ldb (byte 1 15) x87-mode)) + (format t "Condition code C3: ~30T~A~%" (ldb (byte 1 14) x87-mode)) + (format t "Top of stack: ~30T~D~%" (ldb (byte 3 11) x87-mode)) + (format t "Condition code C2: ~30T~A~%" (ldb (byte 1 10) x87-mode)) + (format t "Condition code C1: ~30T~A~%" (ldb (byte 1 9) x87-mode)) + (format t "Condition code C0: ~30T~A~%" (ldb (byte 1 8) x87-mode)) + (format t "Error summary: ~30T~A~%" (ldb (byte 1 7) x87-mode)) + (format t "Stack fault: ~30T~A~%" (ldb (byte 1 6) x87-mode)) + (print-fp-current-exceptions (ldb float-exceptions-byte x87-mode)) + (format t "~%Control word:~%") + (format t "Reserved: ~30T#b~2,'0b~%" (ldb (byte 2 (+ 13 16)) x87-mode)) + (format t "Infinity control: ~30T~A~%" (ldb x87-float-infinity-control-byte x87-mode)) + (let ((rc (ldb x87-float-rounding-mode x87-mode))) + (format t "Rounding control: ~30T#b~2,'0b ~S~%" + rc + (car (rassoc rc rounding-mode-alist)))) + (let ((pc (ldb x87-float-precision-control-byte x87-mode))) + (format t "Precision control: ~30T#b~2,'0b ~S~%" + pc + (car (rassoc pc x87-float-precision-control-alist)))) + (format t "Reserved: ~30T#b~2,'0b~%" (ldb (byte 2 (+ 6 16)) x87-mode)) + (print-fp-exceptions-enabled (ldb x87-float-traps-byte x87-mode))) + ===================================== src/compiler/x86/float-sse2.lisp ===================================== @@ -1379,83 +1379,6 @@ ;; 10 double precision (53 bits) ;; 11 double extended precision (64 bits) -(defconstant x87-float-infinity-control-byte - (byte 1 (+ 12 16)) - "The bit in the x87 FPU control word that controls the infinity mode.") -(defconstant x87-float-rounding-mode - (byte 2 (+ 10 16)) - "The bits in the x87 FPU control word for the rounding mode.") -(defconstant x87-float-precision-control-byte - (byte 2 (+ 8 16)) - "The bits in the x87 FPU contol word for the FP operation precision.") -(defconstant x87-float-traps-byte - (byte 6 16) - "The bits in the x87 FPU control word indicating the exceptions that - are enabled.") -(defconstant x87-float-precision-control-alist - `((:24-bits . 0) - (:reserved . 1) - (:53-bits . 2) - (:64-bits . 3)) - "Alist for the x87 precison control. The car is the symbolic - precision and the cdr is the value for the precision control field.") - -(defun print-fp-exceptions-enabled (enabled) - (format t "Precision enable: ~30T~A~%" (ldb (byte 1 5) enabled)) - (format t "Underflow enable: ~30T~A~%" (ldb (byte 1 4) enabled)) - (format t "Overflow enable: ~30T~A~%" (ldb (byte 1 3) enabled)) - (format t "Divide-by-zero enable: ~30T~A~%" (ldb (byte 1 2) enabled)) - (format t "Denormal op enable: ~30T~A~%" (ldb (byte 1 1) enabled)) - (format t "Invalid op enable: ~30T~A~%" (ldb (byte 1 0) enabled))) - -(defun print-fp-current-exceptions (current) - (format t "Precision flag: ~30T~A~%" (ldb (byte 1 5) current)) - (format t "Underflow flag: ~30T~A~%" (ldb (byte 1 4) current)) - (format t "Overflow flag: ~30T~A~%" (ldb (byte 1 3) current)) - (format t "Divide-by-zero flag: ~30T~A~%" (ldb (byte 1 2) current)) - (format t "Denormal op flag: ~30T~A~%" (ldb (byte 1 1) current)) - (format t "Invalid op flag: ~30T~A~%" (ldb (byte 1 0) current))) - -(defun print-sse2-fp-modes (&optional (sse-mode (sse2-floating-point-modes))) - "Print SSE2 modes word in a readable fashion." - ;; Note that Intel uses masks to disable the exception, but to match - ;; the rest of cmucl, these bits are represented as enable bits. - (format t "Flush-to-zero: ~30T~A~%" (ldb (byte 1 15) sse-mode)) - (let ((rc (ldb float-rounding-mode sse-mode))) - (format t "Rounding control: ~30T#b~2,'0b ~S~%" - rc - (car (rassoc rc rounding-mode-alist)))) - (print-fp-exceptions-enabled (ldb float-traps-byte sse-mode)) - (print-fp-current-exceptions (ldb float-exceptions-byte sse-mode))) - -(defun print-x87-fp-modes (&optional (x87-mode (x87-floating-point-modes))) - "Print X87 floating modes word in a readable fashion." - ;; Note that Intel uses masks to disable the exception, but to match - ;; the rest of cmucl, these bits are represented as enable bits. - (format t "Status word:~%") - (format t "FPU busy: ~30T~A~%" (ldb (byte 1 15) x87-mode)) - (format t "Condition code C3: ~30T~A~%" (ldb (byte 1 14) x87-mode)) - (format t "Top of stack: ~30T~D~%" (ldb (byte 3 11) x87-mode)) - (format t "Condition code C2: ~30T~A~%" (ldb (byte 1 10) x87-mode)) - (format t "Condition code C1: ~30T~A~%" (ldb (byte 1 9) x87-mode)) - (format t "Condition code C0: ~30T~A~%" (ldb (byte 1 8) x87-mode)) - (format t "Error summary: ~30T~A~%" (ldb (byte 1 7) x87-mode)) - (format t "Stack fault: ~30T~A~%" (ldb (byte 1 6) x87-mode)) - (print-fp-current-exceptions (ldb float-exceptions-byte x87-mode)) - (format t "~%Control word:~%") - (format t "Reserved: ~30T#b~2,'0b~%" (ldb (byte 2 (+ 13 16)) x87-mode)) - (format t "Infinity control: ~30T~A~%" (ldb x87-float-infinity-control-byte x87-mode)) - (let ((rc (ldb x87-float-rounding-mode x87-mode))) - (format t "Rounding control: ~30T#b~2,'0b ~S~%" - rc - (car (rassoc rc rounding-mode-alist)))) - (let ((pc (ldb x87-float-precision-control-byte x87-mode))) - (format t "Precision control: ~30T#b~2,'0b ~S~%" - pc - (car (rassoc pc x87-float-precision-control-alist)))) - (format t "Reserved: ~30T#b~2,'0b~%" (ldb (byte 2 (+ 6 16)) x87-mode)) - (print-fp-exceptions-enabled (ldb x87-float-traps-byte x87-mode))) - (defknown x87-floating-point-modes () float-modes (flushable)) (defknown ((setf x87-floating-point-modes)) (float-modes) float-modes) ===================================== src/i18n/locale/cmucl-sse2.pot ===================================== @@ -86,38 +86,6 @@ msgstr "" msgid "inline ftruncate" msgstr "" -#: src/compiler/x86/float-sse2.lisp -msgid "The bit in the x87 FPU control word that controls the infinity mode." -msgstr "" - -#: src/compiler/x86/float-sse2.lisp -msgid "The bits in the x87 FPU control word for the rounding mode." -msgstr "" - -#: src/compiler/x86/float-sse2.lisp -msgid "The bits in the x87 FPU contol word for the FP operation precision." -msgstr "" - -#: src/compiler/x86/float-sse2.lisp -msgid "" -"The bits in the x87 FPU control word indicating the exceptions that\n" -" are enabled." -msgstr "" - -#: src/compiler/x86/float-sse2.lisp -msgid "" -"Alist for the x87 precison control. The car is the symbolic\n" -" precision and the cdr is the value for the precision control field." -msgstr "" - -#: src/compiler/x86/float-sse2.lisp -msgid "Print SSE2 modes word in a readable fashion." -msgstr "" - -#: src/compiler/x86/float-sse2.lisp -msgid "Print X87 floating modes word in a readable fashion." -msgstr "" - #: src/compiler/x86/float-sse2.lisp msgid "inline complex single-float creation" msgstr "" ===================================== src/i18n/locale/cmucl-x86-vm.pot ===================================== @@ -77,6 +77,38 @@ msgstr "" msgid "Thread safe push of val onto the list in the vector element." msgstr "" +#: src/code/x86-vm.lisp +msgid "The bit in the x87 FPU control word that controls the infinity mode." +msgstr "" + +#: src/code/x86-vm.lisp +msgid "The bits in the x87 FPU control word for the rounding mode." +msgstr "" + +#: src/code/x86-vm.lisp +msgid "The bits in the x87 FPU contol word for the FP operation precision." +msgstr "" + +#: src/code/x86-vm.lisp +msgid "" +"The bits in the x87 FPU control word indicating the exceptions that\n" +" are enabled." +msgstr "" + +#: src/code/x86-vm.lisp +msgid "" +"Alist for the x87 precison control. The car is the symbolic\n" +" precision and the cdr is the value for the precision control field." +msgstr "" + +#: src/code/x86-vm.lisp +msgid "Print SSE2 floating modes word in a human-readable fashion." +msgstr "" + +#: src/code/x86-vm.lisp +msgid "Print X87 floating modes word in a human-readable fashion." +msgstr "" + #: src/code/load.lisp msgid "Top-Level Form" msgstr "" ===================================== tests/float-x86.lisp ===================================== @@ -0,0 +1,61 @@ +;; Tests of float functions + +(defpackage :float-x86-tests + (:use :cl :lisp-unit)) + +(in-package "FLOAT-X86-TESTS") + +(define-test set-floating-point-modes + (let ((old-x87-modes (x86::x87-floating-point-modes)) + (old-sse2-modes (x86::sse2-floating-point-modes)) + x87-modes sse2-modes) + (unwind-protect + (progn + ;; Set some new traps and rounding mode. + (ext:set-floating-point-modes :traps '(:underflow + :overflow + :invalid + :divide-by-zero) + :rounding-mode :zero) + ;; Save these new FP modes + (setf x87-modes (x86::x87-floating-point-modes)) + (setf sse2-modes (x86::sse2-floating-point-modes))) + + (setf (x86::x87-floating-point-modes) old-x87-modes) + (setf (x86::sse2-floating-point-modes) old-sse2-modes)) + + (let* ((x87-exceptions-enabled (ldb x86::x87-float-traps-byte x87-modes)) + (x87-rc (ldb x86::x87-float-rounding-mode x87-modes)) + (sse2-exceptions-enabled (ldb x86::float-traps-byte sse2-modes)) + (sse2-rc (ldb x86::float-rounding-mode sse2-modes))) + (format t "*X87 FP mode words:~%") + (x86::print-x87-fp-modes x87-modes) + (format t "~%*SSE2 FP mode words:~%") + (x86::print-sse2-fp-modes sse2-modes) + + ;; Verify that we set the enabled exceptions + ;; correctly. First for sse2, then for x87. + (assert-false (logbitp 5 sse2-exceptions-enabled)) ; precision + (assert-true (logbitp 4 sse2-exceptions-enabled)) ; underflow + (assert-true (logbitp 3 sse2-exceptions-enabled)) ; overflow + (assert-true (logbitp 2 sse2-exceptions-enabled)) ; divide-by-zero + (assert-false (logbitp 1 sse2-exceptions-enabled)) ; denormal + (assert-true (logbitp 0 sse2-exceptions-enabled)) ; invalid + + (assert-false (logbitp 5 x87-exceptions-enabled)) ; precision + (assert-true (logbitp 4 x87-exceptions-enabled)) ; underflow + (assert-true (logbitp 3 x87-exceptions-enabled)) ; overflow + (assert-true (logbitp 2 x87-exceptions-enabled)) ; divide-by-zero + (assert-false (logbitp 1 x87-exceptions-enabled)) ; denormal + (assert-true (logbitp 0 x87-exceptions-enabled)) ; invalid + + ;; Verify the rounding mode is set to zero + (assert-eql :zero (car (rassoc sse2-rc x86::rounding-mode-alist))) + (assert-eql :zero (car (rassoc x87-rc x86::rounding-mode-alist))) + + ;; Verify precision for x87 + (assert-eql :64-bits + (car (rassoc (ldb x86::x87-float-precision-control-byte x87-modes) + x86::x87-float-precision-control-alist)))) + ) + ) ===================================== tests/float.lisp ===================================== @@ -342,49 +342,3 @@ (x86::x87-floating-point-modes))))) (assert-true (typep new-mode 'x86::float-modes)) (assert-equal new-mode (setf (x86::x87-floating-point-modes) new-mode)))) - -(define-test set-floating-point-modes - (let ((old-x87-modes (x86::x87-floating-point-modes)) - (old-sse2-modes (x86::sse2-floating-point-modes))) - (unwind-protect - (progn - ;; Set some new traps and rounding mode - (ext:set-floating-point-modes :traps '(:underflow - :overflow - :invalid - :divide-by-zero) - :rounding-mode :zero) - (let* ((x87-modes (x86::x87-floating-point-modes)) - (x87-exceptions-enabled (ldb x86::x87-float-traps-byte x87-modes)) - (x87-rc (ldb x86::x87-float-rounding-mode x87-modes)) - (sse2-modes (x86::sse2-floating-point-modes)) - (sse2-exceptions-enabled (ldb x86::float-traps-byte sse2-modes)) - (sse2-rc (ldb x86::float-rounding-mode sse2-modes))) - (x86::print-x87-fp-modes x87-modes) - ;; Verify that we set the enabled exceptions - ;; correctly. First for sse2, then for x87. - (assert-false (logbitp 5 sse2-exceptions-enabled)) ; precision - (assert-true (logbitp 4 sse2-exceptions-enabled)) ; underflow - (assert-true (logbitp 3 sse2-exceptions-enabled)) ; overflow - (assert-true (logbitp 2 sse2-exceptions-enabled)) ; divide-by-zero - (assert-false (logbitp 1 sse2-exceptions-enabled)) ; denormal - (assert-true (logbitp 0 sse2-exceptions-enabled)) ; invalid - - (assert-false (logbitp 5 x87-exceptions-enabled)) ; precision - (assert-true (logbitp 4 x87-exceptions-enabled)) ; underflow - (assert-true (logbitp 3 x87-exceptions-enabled)) ; overflow - (assert-true (logbitp 2 x87-exceptions-enabled)) ; divide-by-zero - (assert-false (logbitp 1 x87-exceptions-enabled)) ; denormal - (assert-true (logbitp 0 x87-exceptions-enabled)) ; invalid - - ;; Verify the rounding mode is set to zero - (assert-eql :zero (car (rassoc sse2-rc x86::rounding-mode-alist))) - (assert-eql :zero (car (rassoc x87-rc x86::rounding-mode-alist))) - - ;; Verify precision for x87 - (assert-eql :64-bits - (car (rassoc (ldb x86::x87-float-precision-control-byte x87-modes) - x86::x87-float-precision-control-alist))))) - - (setf (x86::x87-floating-point-modes) old-x87-modes) - (setf (x86::sse2-floating-point-modes) old-sse2-modes)))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/12cae745fdb002782b06b40... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/12cae745fdb002782b06b40... You're receiving this email because of your account on gitlab.common-lisp.net.