+ Implemented IEEE 754-compliant checking for unordered results of floating-point compares on x86 targets. Mantis #9362.

git-svn-id: trunk@27581 -

.gitattributes

@@ -12316,6 +12316,7 @@ tests/test/units/fpwidestring/twide2fpwidestring.pp svneol=native#text/pascal
 tests/test/units/fpwidestring/twide6fpwidestring.pp svneol=native#text/pascal
 tests/test/units/fpwidestring/twide7fpwidestring.pp svneol=native#text/pascal
 tests/test/units/lineinfo/tlininfo.pp svneol=native#text/plain
+tests/test/units/math/tcmpnan.pp svneol=native#text/plain
 tests/test/units/math/tdivmod.pp svneol=native#text/plain
 tests/test/units/math/tmask.inc svneol=native#text/plain
 tests/test/units/math/tmask.pp svneol=native#text/plain

compiler/x86/cgx86.pas

@@ -2116,23 +2116,75 @@ unit cgx86;
      procedure tcgx86.a_jmp_flags(list : TAsmList;const f : TResFlags;l: tasmlabel);
        var
          ai : taicpu;
+         hl : tasmlabel;
+         f2 : tresflags;
        begin
+         hl:=nil;
+         f2:=f;
+         case f of
+           F_FNE:
+             begin
+               ai:=Taicpu.op_sym(A_Jcc,S_NO,l);
+               ai.SetCondition(C_P);
+               ai.is_jmp:=true;
+               list.concat(ai);
+               f2:=F_NE;
+             end;
+           F_FE,F_FA,F_FAE,F_FB,F_FBE:
+             begin
+               { JP before JA/JAE is redundant, but it must be generated here
+                 and left for peephole optimizer to remove. }
+               current_asmdata.getjumplabel(hl);
+               ai:=Taicpu.op_sym(A_Jcc,S_NO,hl);
+               ai.SetCondition(C_P);
+               ai.is_jmp:=true;
+               list.concat(ai);
+               f2:=FPUFlags2Flags[f];
+             end;
+         end;
          ai := Taicpu.op_sym(A_Jcc,S_NO,l);
-         ai.SetCondition(flags_to_cond(f));
+         ai.SetCondition(flags_to_cond(f2));
          ai.is_jmp := true;
          list.concat(ai);
+         if assigned(hl) then
+           a_label(list,hl);
        end;
 
 
     procedure tcgx86.g_flags2reg(list: TAsmList; size: TCgSize; const f: tresflags; reg: TRegister);
       var
         ai : taicpu;
-        hreg : tregister;
+        f2 : tresflags;
+        hreg,hreg2 : tregister;
+        op: tasmop;
       begin
+        hreg2:=NR_NO;
+        op:=A_AND;
+        f2:=f;
+        case f of
+          F_FE,F_FNE,F_FB,F_FBE:
+            begin
+              hreg2:=getintregister(list,OS_8);
+              ai:=Taicpu.op_reg(A_SETcc,S_B,hreg2);
+              if (f=F_FNE) then       { F_FNE means "PF or (not ZF)" }
+                begin
+                  ai.setcondition(C_P);
+                  op:=A_OR;
+                end
+              else
+                ai.setcondition(C_NP);
+              list.concat(ai);
+              f2:=FPUFlags2Flags[f];
+            end;
+          F_FA,F_FAE:                 { These do not need PF check }
+            f2:=FPUFlags2Flags[f];
+        end;
         hreg:=makeregsize(list,reg,OS_8);
         ai:=Taicpu.op_reg(A_SETcc,S_B,hreg);
-        ai.setcondition(flags_to_cond(f));
+        ai.setcondition(flags_to_cond(f2));
         list.concat(ai);
+        if (hreg2<>NR_NO) then
+          list.concat(taicpu.op_reg_reg(op,S_B,hreg2,hreg));
         if reg<>hreg then
           a_load_reg_reg(list,OS_8,size,hreg,reg);
       end;
@@ -2142,13 +2194,24 @@ unit cgx86;
       var
         ai : taicpu;
         tmpref  : treference;
+        f2 : tresflags;
       begin
+        f2:=f;
+        case f of
+          F_FE,F_FNE,F_FB,F_FBE:
+            begin
+              inherited g_flags2ref(list,size,f,ref);
+              exit;
+            end;
+          F_FA,F_FAE:
+            f2:=FPUFlags2Flags[f];
+        end;
          tmpref:=ref;
          make_simple_ref(list,tmpref);
          if not(size in [OS_8,OS_S8]) then
            a_load_const_ref(list,size,0,tmpref);
          ai:=Taicpu.op_ref(A_SETcc,S_B,tmpref);
-         ai.setcondition(flags_to_cond(f));
+         ai.setcondition(flags_to_cond(f2));
          list.concat(ai);
 {$ifndef cpu64bitalu}
          if size in [OS_S64,OS_64] then

compiler/x86/cpubase.pas

@@ -247,8 +247,16 @@ uses
     type
       TResFlags = (F_E,F_NE,F_G,F_L,F_GE,F_LE,F_C,F_NC,
                    F_A,F_AE,F_B,F_BE,
-                   F_S,F_NS,F_O,F_NO);
+                   F_S,F_NS,F_O,F_NO,
+                   { For IEEE-compliant floating-point compares,
+                     same as normal counterparts but additionally check PF }
+                   F_FE,F_FNE,F_FA,F_FAE,F_FB,F_FBE);
 
+    const
+      FPUFlags = [F_FE,F_FNE,F_FA,F_FAE,F_FB,F_FBE];
+      FPUFlags2Flags: array[F_FE..F_FBE] of TResFlags = (
+        F_E,F_NE,F_A,F_AE,F_B,F_BE
+      );
 
 {*****************************************************************************
                                  Constants
@@ -478,7 +486,8 @@ implementation
         inv_flags: array[TResFlags] of TResFlags =
           (F_NE,F_E,F_LE,F_GE,F_L,F_G,F_NC,F_C,
            F_BE,F_B,F_AE,F_A,
-           F_NS,F_S,F_NO,F_O);
+           F_NS,F_S,F_NO,F_O,
+           F_FNE,F_FE,F_FBE,F_FB,F_FAE,F_FA);
       begin
         f:=inv_flags[f];
       end;
@@ -487,9 +496,12 @@ implementation
     function flags_to_cond(const f: TResFlags) : TAsmCond;
       const
         flags_2_cond : array[TResFlags] of TAsmCond =
-          (C_E,C_NE,C_G,C_L,C_GE,C_LE,C_C,C_NC,C_A,C_AE,C_B,C_BE,C_S,C_NS,C_O,C_NO);
+          (C_E,C_NE,C_G,C_L,C_GE,C_LE,C_C,C_NC,C_A,C_AE,C_B,C_BE,C_S,C_NS,C_O,C_NO,
+           C_None,C_None,C_None,C_None,C_None,C_None);
       begin
         result := flags_2_cond[f];
+        if (result=C_None) then
+          InternalError(2014041301);
       end;
 
 

compiler/x86/nx86add.pas

@@ -35,6 +35,7 @@ unit nx86add;
       tx86addnode = class(tcgaddnode)
       protected
         function  getresflags(unsigned : boolean) : tresflags;
+        function  getfpuresflags : tresflags;
         procedure left_must_be_reg(opdef: tdef; opsize:TCGSize;noswap:boolean);
         procedure force_left_and_right_fpureg;
         procedure prepare_x87_locations(out refnode: tnode);
@@ -400,6 +401,32 @@ unit nx86add;
       end;
 
 
+    function tx86addnode.getfpuresflags : tresflags;
+      begin
+        if (nodetype=equaln) then
+          result:=F_FE
+        else if (nodetype=unequaln) then
+          result:=F_FNE
+        else if (nf_swapped in flags) then
+          case nodetype of
+            ltn : result:=F_FA;
+            lten : result:=F_FAE;
+            gtn : result:=F_FB;
+            gten : result:=F_FBE;
+          else
+            internalerror(2014031402);
+          end
+        else
+          case nodetype of
+            ltn : result:=F_FB;
+            lten : result:=F_FBE;
+            gtn : result:=F_FA;
+            gten : result:=F_FAE;
+          else
+            internalerror(2014031403);
+          end;
+      end;
+
 {*****************************************************************************
                                 AddSmallSet
 *****************************************************************************}
@@ -1093,7 +1120,7 @@ unit nx86add;
                 internalerror(200402223);
             end;
           end;
-        location.resflags:=getresflags(true);
+        location.resflags:=getfpuresflags;
         location_freetemp(current_asmdata.CurrAsmList,left.location);
         location_freetemp(current_asmdata.CurrAsmList,right.location);
       end;
@@ -1259,7 +1286,7 @@ unit nx86add;
           end;
 
         location_reset(location,LOC_FLAGS,OS_NO);
-        location.resflags:=getresflags(true);
+        location.resflags:=getfpuresflags;
       end;
 
 

tests/test/units/math/tcmpnan.pp

@@ -0,0 +1,62 @@
+{ Tests unordered comparison results. This is a basic codegeneration test, but it needs
+  Math unit to silence exceptions. }
+uses math;
+ 
+const
+  kNan = Sqrt(-1);
+  kX = 5.8E-7;
+var
+  vNan, vX: real;
+  code: longint;
+  b: boolean;
+begin
+  code:=0;
+  SetExceptionMask( [exInvalidOp, exDenormalized, exZeroDivide, exOverflow, exUnderflow, exPrecision]);
+  if kNan = kX  then code:=1;
+  if kNan < kX  then code:=code or 2;
+  if kNan <= kX then code:=code or 4;
+  if kNan > kX  then code:=code or 8;
+  if kNan >= kX then code:=code or 16;
+  code:=code or 32;
+  if kX <> kNan then code:=code and (not 32);
+  
+  vNan:= kNan;
+  vX:= kX;
+  
+  { Test g_flag2reg/ref }
+  b:=(vNan = vX);
+  if b then code:=code or 64;
+  b:=(vNan < vX);
+  if b then code:=code or 128;
+  b:=(vNan <= vX);
+  if b then code:=code or 256;
+  b:=(vNan > vX);
+  if b then code:=code or 512;
+  b:=(vNan >= vX);
+  if b then code:=code or 1024;
+  b:=(vNan <> vX);
+  if (not b) then code:=code or 2048;
+  
+  { Test a_jmp_flags }
+  if vNan = vX then
+    code:=code or 4096;
+  if vNan < vX then
+    code:=code or 8192;
+  if vNan <= vX then
+    code:=code or 16384;
+  if vNan > vX then
+    code:=code or 32768;
+  if vNan >= vX then
+    code:=code or 65536;  
+ 
+  code:=code or 131072;
+  if vNan <> vX then
+    code:=code and (not 131072);
+    
+  if code=0 then
+    writeln('ok') 
+  else
+    writeln('error: ',hexstr(code,8));
+  Halt(code);
+end.
+