+ Win32/Win64 SEH: STATUS_FLOAT_MULTIPLE_(FAULTS|TRAPS) need additional handling. Makes floating-point exceptions consistent between x87 and SSE.

git-svn-id: trunk@27177 -

rtl/win/syswin.inc

@@ -157,13 +157,24 @@ begin
     STATUS_ACCESS_VIOLATION:            result := 216;    { reAccessViolation }
     STATUS_CONTROL_C_EXIT:              result := 217;    { reControlBreak }
     STATUS_PRIVILEGED_INSTRUCTION:      result := 218;    { rePrivilegedInstruction }
+    STATUS_FLOAT_MULTIPLE_TRAPS,
+    STATUS_FLOAT_MULTIPLE_FAULTS:       result := -255;   { indicate FPU reset }
   else
     result := 255;                                        { reExternalException }
   end;
 end;
 
+procedure TranslateMxcsr(mxcsr: longword; var code: longint);
+begin
+  case (mxcsr and $3f) of
+    1,32:  code:=-207;  { InvalidOp, Precision }
+    2,16:  code:=-206;  { Denormal, Underflow }
+    4:     code:=-208;  { !!reZeroDivide }
+    8:     code:=-205;  { reOverflow }
+  end;
+end;
 
-function FilterException(var rec:TExceptionRecord; imagebase: PtrUInt; filterRva: DWord): Pointer;
+function FilterException(var rec:TExceptionRecord; imagebase: PtrUInt; filterRva: DWord; errcode: Longint): Pointer;
 var
   ExClass: TClass;
   i: Longint;
@@ -174,7 +185,7 @@ begin
   if rec.ExceptionCode=FPC_EXCEPTION_CODE then
     ExClass:=TObject(rec.ExceptionInformation[1]).ClassType
   else if Assigned(ExceptClsProc) then
-    ExClass:=TClass(TExceptClsProc(ExceptClsProc)(abs(RunErrorCode(rec))))
+    ExClass:=TClass(TExceptClsProc(ExceptClsProc)(errcode))
   else
     Exit; { if we cannot determine type of exception, don't handle it }
   Filter:=Pointer(imagebase+filterRva);

rtl/win32/seh32.inc

@@ -70,6 +70,15 @@ begin
 end;
 
 
+function RunErrorCode386(const rec: TExceptionRecord; const context: TContext): Longint;
+begin
+  result:=RunErrorCode(rec);
+  { deal with SSE exceptions }
+  if (result=-255) and ((context.ContextFlags and CONTEXT_EXTENDED_REGISTERS)<>0) then
+    TranslateMxcsr(PLongword(@context.ExtendedRegisters[24])^,result);
+end;
+
+
 procedure fpc_RaiseException(Obj: TObject; AnAddr,AFrame: Pointer); [public,alias: 'FPC_RAISEEXCEPTION']; compilerproc;
 var
   ctx: TContext;
@@ -186,7 +195,7 @@ begin
 
     if rec.ExceptionCode<>FPC_EXCEPTION_CODE then
     begin
-      code:=RunErrorCode(rec);
+      code:=RunErrorCode386(rec,context);
       if code<0 then
         SysResetFPU;
       code:=abs(code);
@@ -265,7 +274,7 @@ begin
   if rec.ExceptionCode<>FPC_EXCEPTION_CODE then
   begin
     Exc.FObject:=nil;
-    code:=RunErrorCode(rec);
+    code:=RunErrorCode386(rec,context);
     if Assigned(ExceptObjProc) then
       Exc.FObject:=TObject(TExceptObjProc(ExceptObjProc)(abs(code),rec));
     if (Exc.FObject=nil) and (frame.Addr<>Pointer(@__FPC_except_safecall)) then
@@ -356,7 +365,7 @@ begin
       exit;
     end;
     { Are we going to catch it? }
-    TargetAddr:=FilterException(rec,0,PtrUInt(frame.HandlerArg));
+    TargetAddr:=FilterException(rec,0,PtrUInt(frame.HandlerArg),abs(RunErrorCode386(rec,context)));
     if assigned(TargetAddr) then
       CommonHandler(rec,frame,context,TargetAddr);
   end;

rtl/win64/seh64.inc

@@ -264,6 +264,15 @@ begin
   Result:=FrameCount;
 end;
 
+
+function RunErrorCodex64(const rec: TExceptionRecord; const context: TContext): Longint;
+begin
+  result:=RunErrorCode(rec);
+  if (result=-255) then
+    TranslateMxcsr(context.MxCsr,result);
+end;
+
+
 {$push}
 {$codealign localmin=16}          { TContext record requires this }
 procedure fpc_RaiseException(Obj: TObject; AnAddr,AFrame: Pointer); [public,alias: 'FPC_RAISEEXCEPTION']; compilerproc;
@@ -332,7 +341,7 @@ begin
   begin
     Obj:=nil;
     Result:=False;
-    code:=RunErrorCode(rec);
+    code:=RunErrorCodex64(rec,context);
     if Assigned(ExceptObjProc) then
       Obj:=TObject(TExceptObjProc(ExceptObjProc)(abs(code),rec));
     if (Obj=nil) and (not AcceptNull) then
@@ -382,7 +391,7 @@ begin
   begin
     Exc:=ExceptObjectStack;
     if Exc^.FObject=nil then
-      RunError(abs(RunErrorCode(rec)))  // !!prints wrong backtrace
+      RunError(abs(RunErrorCodex64(rec,context)))  // !!prints wrong backtrace
     else
     begin
       { if ExceptObjProc=nil, ExceptProc is typically also nil,
@@ -453,7 +462,7 @@ begin
 
         if scope^.Typ>SCOPE_IMPLICIT then  // filtering needed
         begin
-          TargetAddr:=FilterException(rec,dispatch.ImageBase,scope^.Typ);
+          TargetAddr:=FilterException(rec,dispatch.ImageBase,scope^.Typ,abs(RunErrorCodex64(rec,context)));
           if TargetAddr=nil then
           begin
             Inc(ScopeIdx);