Browse Source

* reset FPU properly after an exception, resolves #12214

git-svn-id: trunk@11820 -
florian 17 years ago
parent
commit
558cf3ef87
4 changed files with 57 additions and 5 deletions
  1. 1 0
      .gitattributes
  2. 16 1
      rtl/i386/i386.inc
  3. 2 4
      rtl/i386/math.inc
  4. 38 0
      tests/webtbs/tw12214.pp

+ 1 - 0
.gitattributes

@@ -8558,6 +8558,7 @@ tests/webtbs/tw12050b.pp svneol=native#text/plain
 tests/webtbs/tw12051.pp svneol=native#text/plain
 tests/webtbs/tw12051.pp svneol=native#text/plain
 tests/webtbs/tw1207.pp svneol=native#text/plain
 tests/webtbs/tw1207.pp svneol=native#text/plain
 tests/webtbs/tw12186.pp svneol=native#text/plain
 tests/webtbs/tw12186.pp svneol=native#text/plain
+tests/webtbs/tw12214.pp svneol=native#text/plain
 tests/webtbs/tw1222.pp svneol=native#text/plain
 tests/webtbs/tw1222.pp svneol=native#text/plain
 tests/webtbs/tw1223.pp svneol=native#text/plain
 tests/webtbs/tw1223.pp svneol=native#text/plain
 tests/webtbs/tw1228.pp svneol=native#text/plain
 tests/webtbs/tw1228.pp svneol=native#text/plain

+ 16 - 1
rtl/i386/i386.inc

@@ -1378,6 +1378,7 @@ Procedure SysInitFPU;
   begin
   begin
     localfpucw:=Default8087CW;
     localfpucw:=Default8087CW;
     asm
     asm
+      fninit
       fldcw   localfpucw
       fldcw   localfpucw
       fwait
       fwait
     end;
     end;
@@ -1395,11 +1396,25 @@ Procedure SysInitFPU;
 
 
 {$define FPC_SYSTEM_HAS_SYSRESETFPU}
 {$define FPC_SYSTEM_HAS_SYSRESETFPU}
 Procedure SysResetFPU;
 Procedure SysResetFPU;
+  var
+    { these locals are so we don't have to hack pic code in the assembler }
+    localmxcsr: dword;
+    localfpucw: word;
   begin
   begin
+    localfpucw:=Default8087CW;
     asm
     asm
-      fnclex
+      fninit
       fwait
       fwait
+      fldcw   localfpucw
     end;
     end;
+    if has_sse_support then
+      begin
+        localmxcsr:=mxcsr;
+        asm
+          { setup sse exceptions }
+          ldmxcsr localmxcsr
+        end;
+      end;
     softfloat_exception_flags:=0;
     softfloat_exception_flags:=0;
   end;
   end;
 
 

+ 2 - 4
rtl/i386/math.inc

@@ -38,12 +38,10 @@
 
 
 
 
     procedure SetSSECSR(w : dword);
     procedure SetSSECSR(w : dword);
-      var
-        _w : dword;
       begin
       begin
-        _w:=w;
+        mxcsr:=w;
         asm
         asm
-          ldmxcsr _w
+          ldmxcsr w
         end;
         end;
       end;
       end;
 
 

+ 38 - 0
tests/webtbs/tw12214.pp

@@ -0,0 +1,38 @@
+{$mode objfpc}
+program test_raise;
+
+uses Math;
+
+var
+  X, Y: double;
+  I: Integer;
+  SomeFloat, SomeOtherFloat: Double;
+begin
+  X := -10.0;
+
+  SomeFloat := 1.0; { any value }
+  SomeOtherFloat := 1.0; { any value }
+
+  for I := 0 to 20 do
+  begin
+    { This line does *any* valid float operation, just to show that
+      floating-point exception (that should be raised, catched and silenced
+      by try..except below) somehow arrived here. }
+    SomeFloat := I * SomeOtherFloat;
+
+    try
+      { Any invalid fp operation. Tested on Sqrt(-10.0), Ln(-10.0).
+        I use variable X to trick FPC into calculating this at run-time,
+        otherwise "Error: Illegal constant passed to internal math function". }
+      Y := Sqrt(X);      
+      ClearExceptions(false);
+    except
+      Writeln('silenced exception');
+      { Here I silence eventual exception raised by ClearExceptions.
+        (Yes, I could just do ClearExceptions(false) do achieve the same,
+        but imagine that this is embedded in some complicated code
+        where I really want to raise exception to jump outside
+        in case of problems.) }
+    end;
+  end;
+end.