+

+;; 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/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 ""

+

+;; 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))))

+    )

+    )