Raymond Toy pushed to branch issue-431-fix-set-floating-point-modes at cmucl / cmucl

Commits:

2 changed files:

Changes:

  • src/code/float-trap.lisp
    ... ... @@ -109,37 +109,17 @@
    109 109 
     			       (ash x87-enables 7))))
    110 110
    111 111 
           final-mode))
    112 
    -  #+nil
    113 
    -  (defun (setf floating-point-modes) (new-mode)
    114 
    -    (declare (type (unsigned-byte 32) new-mode))
    115 
    -    ;; Set the floating point modes for both X87 and SSE2.  This
    116 
    -    ;; include the rounding control bits.
    117 
    -    (let* ((rc (ldb float-rounding-mode new-mode))
    118 
    -	   (new-exceptions (logand #x3f new-mode))
    119 
    -	   (new-enables (logand #x3f (ash new-mode -7)))
    120 
    -	   (x87-modes
    121 
    -	    (logior new-exceptions
    122 
    -		    (ash rc 10)
    123 
    -		    (ash new-enables 16)
    124 
    -		    ;; Set precision control to be 64-bit, always.  We
    125 
    -		    ;; don't use the x87 registers with sse2, so this
    126 
    -		    ;; is ok and would be the correct setting if we
    127 
    -		    ;; ever support long-floats.
    128 
    -		    (ash 3 (+ 8 16)))))
    129 
    -      (setf (vm::sse2-floating-point-modes) (ldb (byte 24 0) new-mode))
    130 
    -      (setf (vm::x87-floating-point-modes) (ldb (byte 24 0) x87-modes)))
    131 
    -    new-mode)
    112 
    +
    132 113 
       (defun (setf floating-point-modes) (new-mode)
    133 114 
         (declare (type (unsigned-byte 32) new-mode))
    134 115 
         ;; Set the floating point modes for both X87 and SSE2.  This
    135 116 
         ;; include the rounding control bits.
    136 
    -    #+nil
    137 
    -    (format t "new-mode = ~8,'0x~%" new-mode)
    138 117 
         (let* ((rc (ldb float-rounding-mode new-mode))
    139 118 
     	   (new-exceptions (ldb float-exceptions-byte new-mode))
    140 119 
     	   (new-enables (ldb float-traps-byte new-mode))
    141 120 
     	   (x87-modes 0))
    142 
    -      ;; From the new mode, update the x87 FPU mode with the same set of accrued exceptions, enabled exceptions, and rounding mode.
    121 
    +      ;; From the new mode, update the x87 FPU mode with the same set
    122 
    +      ;; of accrued exceptions, enabled exceptions, and rounding mode.
    143 123 
           (setf x87-modes (dpb new-exceptions float-exceptions-byte x87-modes))
    144 124 
           (setf x87-modes (dpb new-enables x87-float-traps-byte x87-modes))
    145 125 
           (setf x87-modes (dpb rc x87-float-rounding-mode x87-modes))
    ... ... @@ -152,8 +132,7 @@
    152 132
    153 133 
           (setf (vm::sse2-floating-point-modes) (ldb (byte 16 0) new-mode))
    154 134 
           (setf (vm::x87-floating-point-modes) (ldb (byte 30 0) x87-modes)))
    155 
    -    new-mode)
    156 
    -  )
    135 
    +    new-mode))
    157 136
    158 137 
     #+(and sse2 darwin)
    159 138 
     (progn

  • src/compiler/x86/float-sse2.lisp
    ... ... @@ -1422,7 +1422,7 @@
    1422 1422 
       ;; the rest of cmucl, these bits are represented as enable bits.
    1423 1423 
       (format t "Flush-to-zero:         ~30T~A~%" (ldb (byte 1 15) sse-mode))
    1424 1424 
       (let ((rc (ldb float-rounding-mode sse-mode)))
    1425 
    -    (format t "Rounding control:      ~30T~A ~A~%"
    1425 
    +    (format t "Rounding control:      ~30T#b~2,'0b ~S~%"
    1426 1426 
     	    rc
    1427 1427 
     	    (car (rassoc rc rounding-mode-alist))))
    1428 1428 
       (print-fp-exceptions-enabled (ldb float-traps-byte sse-mode))
    ... ... @@ -1432,26 +1432,28 @@
    1432 1432 
       "Print X87 floating modes word in a readable fashion."
    1433 1433 
       ;; Note that Intel uses masks to disable the exception, but to match
    1434 1434 
       ;; the rest of cmucl, these bits are represented as enable bits.
    1435 
    -  (format t "SW: FPU busy:             ~30T~A~%" (ldb (byte 1 15) x87-mode))
    1436 
    -  (format t "SW: Condition code C3:    ~30T~A~%" (ldb (byte 1 14) x87-mode))
    1437 
    -  (format t "SW: Top of stack:         ~30T~D~%" (ldb (byte 3 11) x87-mode))
    1438 
    -  (format t "SW: Condition code C2:    ~30T~A~%" (ldb (byte 1 10) x87-mode))
    1439 
    -  (format t "SW: Condition code C1:    ~30T~A~%" (ldb (byte 1 9) x87-mode))
    1440 
    -  (format t "SW: Condition code C0:    ~30T~A~%" (ldb (byte 1 8) x87-mode))
    1441 
    -  (format t "SW: Error summary:        ~30T~A~%" (ldb (byte 1 7) x87-mode))
    1442 
    -  (format t "SW: Stack fault:          ~30T~A~%" (ldb (byte 1 6) x87-mode))
    1435 
    +  (format t "Status word:~%")
    1436 
    +  (format t "FPU busy:             ~30T~A~%" (ldb (byte 1 15) x87-mode))
    1437 
    +  (format t "Condition code C3:    ~30T~A~%" (ldb (byte 1 14) x87-mode))
    1438 
    +  (format t "Top of stack:         ~30T~D~%" (ldb (byte 3 11) x87-mode))
    1439 
    +  (format t "Condition code C2:    ~30T~A~%" (ldb (byte 1 10) x87-mode))
    1440 
    +  (format t "Condition code C1:    ~30T~A~%" (ldb (byte 1 9) x87-mode))
    1441 
    +  (format t "Condition code C0:    ~30T~A~%" (ldb (byte 1 8) x87-mode))
    1442 
    +  (format t "Error summary:        ~30T~A~%" (ldb (byte 1 7) x87-mode))
    1443 
    +  (format t "Stack fault:          ~30T~A~%" (ldb (byte 1 6) x87-mode))
    1443 1444 
       (print-fp-current-exceptions (ldb float-exceptions-byte x87-mode))
    1444 
    -  (format t "CW: Reserved:             ~30T~A~%" (ldb (byte 2 (+ 13 16)) x87-mode))
    1445 
    -  (format t "CW: Infinity control:     ~30T~A~%" (ldb x87-float-infinity-control-byte x87-mode))
    1445 
    +  (format t "~%Control word:~%")
    1446 
    +  (format t "Reserved:             ~30T#b~2,'0b~%" (ldb (byte 2 (+ 13 16)) x87-mode))
    1447 
    +  (format t "Infinity control:     ~30T~A~%" (ldb x87-float-infinity-control-byte x87-mode))
    1446 1448 
       (let ((rc (ldb x87-float-rounding-mode x87-mode)))
    1447 
    -    (format t "CW: Rounding control:     ~30T~A ~A~%"
    1449 
    +    (format t "Rounding control:     ~30T#b~2,'0b ~S~%"
    1448 1450 
     	    rc
    1449 1451 
     	    (car (rassoc rc rounding-mode-alist))))
    1450 1452 
       (let ((pc (ldb x87-float-precision-control-byte x87-mode)))
    1451 
    -    (format t "CW: Precision control:    ~30T~A ~A~%"
    1453 
    +    (format t "Precision control:    ~30T#b~2,'0b ~S~%"
    1452 1454 
     	    pc
    1453 1455 
     	    (car (rassoc pc x87-float-precision-control-alist))))
    1454 
    -  (format t "CW: Reserved:             ~30T~A~%" (ldb (byte 2 (+ 6 16)) x87-mode))
    1456 
    +  (format t "Reserved:             ~30T#b~2,'0b~%" (ldb (byte 2 (+ 6 16)) x87-mode))
    1455 1457 
       (print-fp-exceptions-enabled (ldb x87-float-traps-byte x87-mode)))
    1456 1458
    1457 1459 
     (defknown x87-floating-point-modes () float-modes (flushable))

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help Notification message regarding https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/ef367c524ca6e359970c5fe34eca7696c37717b7 at 1755440141