From d88bcbc71aa7cd980f39b9965b240a00306b4fce Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 4 Oct 2007 19:58:20 +0000
Subject: [PATCH] The floating point precision was always getting reset to
 :53-bit, even if the user set a different value.  Fix this so the correct
 precision is restored.

compiler/x86/parms.lisp:
o Add new static-symbol *FPU-PRECISION* to hold the precision bits
  that are given in (setf floating-point-modes).

compiler/x86/float.lisp:
o Whenever (setf floating-point-modes) is called, save the precision
  bits to *FPU-PRECISION* so that get restored correctly in
  DEALLOC-NUMBER-STACK-SPACE.

compiler/x86/c-call.lisp:
o Update DEALLOC-NUMBER-STACK-SPACE VOP so that when float-accuracy
  policy says so, we restore the precision from *fpu-precision*,
  instead of always making it :53-bit.

code/lispinit.lisp:
o Initialize the default precision to :53-bit on startup.
---
 code/lispinit.lisp       |  5 +++--
 compiler/x86/c-call.lisp | 31 ++++++++++++++++++++++++++++++-
 compiler/x86/float.lisp  | 11 ++++++++++-
 compiler/x86/parms.lisp  |  6 +++---
 4 files changed, 46 insertions(+), 7 deletions(-)

diff --git a/code/lispinit.lisp b/code/lispinit.lisp
index 4cd582c65..9c96c0de3 100644
--- a/code/lispinit.lisp
+++ b/code/lispinit.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.76 2006/06/30 18:41:22 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.77 2007/10/04 19:58:19 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -400,7 +400,8 @@
   (print-and-call kernel::signal-init)
   (setf (alien:extern-alien "internal_errors_enabled" boolean) t)
 
-  (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero))
+  (set-floating-point-modes :traps '(:overflow :invalid :divide-by-zero)
+			    #+x86 :precision-control #+x86 :53-bit)
   ;; This is necessary because some of the initial top level forms might
   ;; have changed the compilation policy in strange ways.
   (print-and-call c::proclaim-init)
diff --git a/compiler/x86/c-call.lisp b/compiler/x86/c-call.lisp
index c3916b0b8..e2338f17a 100644
--- a/compiler/x86/c-call.lisp
+++ b/compiler/x86/c-call.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.17 2007/07/06 08:04:39 cshapiro Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/c-call.lisp,v 1.18 2007/10/04 19:58:20 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -276,6 +276,7 @@
     #+darwin (inst and esp-tn #xfffffff0)
     (move result esp-tn)))
 
+#+nil
 (define-vop (dealloc-number-stack-space)
   (:info amount)
   (:node-var node)
@@ -292,6 +293,34 @@
       (inst wait)
       (inst add esp-tn 4))))
 
+(define-vop (dealloc-number-stack-space)
+  (:info amount)
+  (:node-var node)
+  (:temporary (:sc unsigned-reg) precision)
+  (:temporary (:sc word-reg) cw)
+  (:generator 0
+    (unless (zerop amount)
+      (let ((delta (logandc2 (+ amount 3) 3)))
+	(inst add esp-tn delta)))
+    ;; Reset the rounding precision to 53-bits
+    (when (policy node (= float-accuracy 3))
+      (inst fnstcw (make-ea :word :base esp-tn))
+      (load-symbol-value precision *fpu-precision*)
+      (inst sar precision 2)		; Remove fixnum tag bits
+      (inst wait)
+      ;; Clear the precision bits so we can fill them in with our
+      ;; desired precision value.
+      (inst mov cw (make-ea :word :base esp-tn))
+      (inst and cw #xfcff)
+      (inst or cw
+	    (make-random-tn :kind :normal
+			    :sc (sc-or-lose 'word-reg *backend*)
+			    :offset (tn-offset precision)))
+      (inst mov (make-ea :word :base esp-tn) cw)
+      (inst fldcw (make-ea :word :base esp-tn))
+      (inst wait)
+      (inst add esp-tn 4))))
+
 (define-vop (alloc-alien-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index e8d33b888..511453b64 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.49 2007/04/14 14:10:08 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.50 2007/10/04 19:58:20 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2276,6 +2276,9 @@
 (defconstant npx-cw-offset 0)
 (defconstant npx-sw-offset 4)
 
+(defvar *fpu-precision*
+  (dpb float-precision-53-bit float-precision-control 0))
+
 (define-vop (floating-point-modes)
   (:results (res :scs (unsigned-reg)))
   (:result-types unsigned-num)
@@ -2310,6 +2313,12 @@
    (inst wait)                          ; Catch any pending FPE exceptions
    (inst fstenv (make-ea :dword :base esp-tn))
    (inst mov eax new)
+   ;; Save precision bits so we can restore them properly
+   (inst and eax #x300)
+   (inst shl eax 2)			; Convert to fixnum
+   (store-symbol-value eax *fpu-precision*)
+   ;; Now set the desired mode
+   (inst mov eax new)
    (inst xor eax #x3f)	    ; turn trap enable bits into exception mask
    (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
    (inst shr eax 16)			; position status word
diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp
index 4d0e51e9e..27448d413 100644
--- a/compiler/x86/parms.lisp
+++ b/compiler/x86/parms.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.32 2007/07/06 08:04:39 cshapiro Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/parms.lisp,v 1.33 2007/10/04 19:58:20 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -332,10 +332,10 @@
       :value
       :key-and-value
       :key-or-value
-      
+
+      *fpu-precision*
       ;; Spare symbols.  Rename these when you need to add some static
       ;; symbols and don't want to do a cross-compile.
-      spare-9
       spare-8
       spare-7
       spare-6
-- 
GitLab