mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-12 11:49:28 +02:00
* move exception mask initialization to procedure compile
* reset exception mask at compiler exit * use math routines for exception masking git-svn-id: trunk@5841 -
This commit is contained in:
florian
parent
2b540fd851
commit
fa493c7898
compiler
@ -34,7 +34,7 @@ uses
|
||||
emu387,
|
||||
{$endif WATCOM}
|
||||
{$IFNDEF USE_FAKE_SYSUTILS}
|
||||
sysutils,
|
||||
sysutils,math,
|
||||
{$ELSE}
|
||||
fksysutl,
|
||||
{$ENDIF}
|
||||
@ -219,9 +219,13 @@ var
|
||||
{$ifdef SHOWUSEDMEM}
|
||||
hstatus : TFPCHeapStatus;
|
||||
{$endif SHOWUSEDMEM}
|
||||
ExceptionMask : TFPUExceptionMask;
|
||||
begin
|
||||
try
|
||||
try
|
||||
ExceptionMask:=GetExceptionMask;
|
||||
SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide,
|
||||
exOverflow, exUnderflow, exPrecision]);
|
||||
{ Initialize the compiler }
|
||||
InitCompiler(cmd);
|
||||
|
||||
@ -270,6 +274,8 @@ begin
|
||||
finally
|
||||
{ no message possible after this !! }
|
||||
DoneCompiler;
|
||||
|
||||
SetExceptionMask(ExceptionMask);
|
||||
end;
|
||||
DoneVerbose;
|
||||
except
|
||||
|
||||
@ -100,10 +100,6 @@ interface
|
||||
{$endif}
|
||||
|
||||
type
|
||||
TFPUException = (exInvalidOp, exDenormalized, exZeroDivide,
|
||||
exOverflow, exUnderflow, exPrecision);
|
||||
TFPUExceptionMask = set of TFPUException;
|
||||
|
||||
pfileposinfo = ^tfileposinfo;
|
||||
tfileposinfo = record
|
||||
line : longint;
|
||||
@ -328,7 +324,6 @@ interface
|
||||
function GetEnvPChar(const envname:string):pchar;
|
||||
procedure FreeEnvPChar(p:pchar);
|
||||
|
||||
procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
|
||||
function is_number_float(d : double) : boolean;
|
||||
{ discern +0.0 and -0.0 }
|
||||
function get_real_sign(r: bestreal): longint;
|
||||
@ -693,251 +688,6 @@ implementation
|
||||
{$endif hasunix}
|
||||
|
||||
{$UNDEF AMIGASHELL}
|
||||
|
||||
{$ifdef CPUI386}
|
||||
{$asmmode att}
|
||||
|
||||
{$define HASSETFPUEXCEPTIONMASK}
|
||||
{ later, this should be replaced by the math unit }
|
||||
const
|
||||
Default8087CW : word = $1332;
|
||||
|
||||
procedure Set8087CW(cw:word);assembler;
|
||||
asm
|
||||
movw cw,%ax
|
||||
movw %ax,default8087cw
|
||||
fnclex
|
||||
fldcw default8087cw
|
||||
end;
|
||||
|
||||
|
||||
function Get8087CW:word;assembler;
|
||||
asm
|
||||
pushl $0
|
||||
fnstcw (%esp)
|
||||
popl %eax
|
||||
end;
|
||||
|
||||
|
||||
procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
|
||||
var
|
||||
CtlWord: Word;
|
||||
begin
|
||||
CtlWord:=Get8087CW;
|
||||
Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
|
||||
end;
|
||||
{$endif CPUI386}
|
||||
|
||||
{$ifdef CPUX86_64}
|
||||
{$define HASSETFPUEXCEPTIONMASK}
|
||||
{ later, this should be replaced by the math unit }
|
||||
const
|
||||
Default8087CW : word = $1332;
|
||||
|
||||
procedure Set8087CW(cw:word);assembler;
|
||||
asm
|
||||
movw cw,%ax
|
||||
movw %ax,default8087cw
|
||||
fnclex
|
||||
fldcw default8087cw
|
||||
end;
|
||||
|
||||
|
||||
function Get8087CW:word;assembler;
|
||||
asm
|
||||
pushq $0
|
||||
fnstcw (%rsp)
|
||||
popq %rax
|
||||
end;
|
||||
|
||||
|
||||
procedure SetSSECSR(w : dword);
|
||||
var
|
||||
_w : dword;
|
||||
begin
|
||||
_w:=w;
|
||||
asm
|
||||
ldmxcsr _w
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
function GetSSECSR : dword;
|
||||
var
|
||||
_w : dword;
|
||||
begin
|
||||
asm
|
||||
stmxcsr _w
|
||||
end;
|
||||
result:=_w;
|
||||
end;
|
||||
|
||||
|
||||
procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
|
||||
var
|
||||
CtlWord: Word;
|
||||
newmask : dword;
|
||||
const
|
||||
MM_MaskInvalidOp = %0000000010000000;
|
||||
MM_MaskDenorm = %0000000100000000;
|
||||
MM_MaskDivZero = %0000001000000000;
|
||||
MM_MaskOverflow = %0000010000000000;
|
||||
MM_MaskUnderflow = %0000100000000000;
|
||||
MM_MaskPrecision = %0001000000000000;
|
||||
begin
|
||||
{ classic FPU }
|
||||
CtlWord:=Get8087CW;
|
||||
Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
|
||||
|
||||
{ SSE }
|
||||
|
||||
newmask:=GetSSECSR;
|
||||
|
||||
{ invalid operation }
|
||||
if (exInvalidOp in mask) then
|
||||
newmask:=newmask or MM_MaskInvalidOp
|
||||
else
|
||||
newmask:=newmask and not(MM_MaskInvalidOp);
|
||||
|
||||
{ denormals }
|
||||
if (exDenormalized in mask) then
|
||||
newmask:=newmask or MM_MaskDenorm
|
||||
else
|
||||
newmask:=newmask and not(MM_MaskDenorm);
|
||||
|
||||
{ zero divide }
|
||||
if (exZeroDivide in mask) then
|
||||
newmask:=newmask or MM_MaskDivZero
|
||||
else
|
||||
newmask:=newmask and not(MM_MaskDivZero);
|
||||
|
||||
{ overflow }
|
||||
if (exOverflow in mask) then
|
||||
newmask:=newmask or MM_MaskOverflow
|
||||
else
|
||||
newmask:=newmask and not(MM_MaskOverflow);
|
||||
|
||||
{ underflow }
|
||||
if (exUnderflow in mask) then
|
||||
newmask:=newmask or MM_MaskUnderflow
|
||||
else
|
||||
newmask:=newmask and not(MM_MaskUnderflow);
|
||||
|
||||
{ Precision (inexact result) }
|
||||
if (exPrecision in mask) then
|
||||
newmask:=newmask or MM_MaskPrecision
|
||||
else
|
||||
newmask:=newmask and not(MM_MaskPrecision);
|
||||
SetSSECSR(newmask);
|
||||
end;
|
||||
{$endif CPUX86_64}
|
||||
|
||||
{$ifdef CPUPOWERPC}
|
||||
{$define HASSETFPUEXCEPTIONMASK}
|
||||
procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
|
||||
var
|
||||
newmask: record
|
||||
case byte of
|
||||
1: (d: double);
|
||||
2: (a,b: cardinal);
|
||||
end;
|
||||
begin
|
||||
{ load current control register contents }
|
||||
asm
|
||||
mffs f0
|
||||
stfd f0,newmask.d
|
||||
end;
|
||||
{ invalid operation: bit 24 (big endian, bit 0 = left-most bit) }
|
||||
if (exInvalidOp in mask) then
|
||||
newmask.b := newmask.b and not(1 shl (31-24))
|
||||
else
|
||||
newmask.b := newmask.b or (1 shl (31-24));
|
||||
|
||||
{ denormals can not cause exceptions on the PPC }
|
||||
|
||||
{ zero divide: bit 27 }
|
||||
if (exZeroDivide in mask) then
|
||||
newmask.b := newmask.b and not(1 shl (31-27))
|
||||
else
|
||||
newmask.b := newmask.b or (1 shl (31-27));
|
||||
|
||||
{ overflow: bit 25 }
|
||||
if (exOverflow in mask) then
|
||||
newmask.b := newmask.b and not(1 shl (31-25))
|
||||
else
|
||||
newmask.b := newmask.b or (1 shl (31-25));
|
||||
|
||||
{ underflow: bit 26 }
|
||||
if (exUnderflow in mask) then
|
||||
newmask.b := newmask.b and not(1 shl (31-26))
|
||||
else
|
||||
newmask.b := newmask.b or (1 shl (31-26));
|
||||
|
||||
{ Precision (inexact result): bit 28 }
|
||||
if (exPrecision in mask) then
|
||||
newmask.b := newmask.b and not(1 shl (31-28))
|
||||
else
|
||||
newmask.b := newmask.b or (1 shl (31-28));
|
||||
{ update control register contents }
|
||||
asm
|
||||
lfd f0, newmask.d
|
||||
mtfsf 255,f0
|
||||
end;
|
||||
end;
|
||||
{$endif CPUPOWERPC}
|
||||
|
||||
{$ifdef CPUSPARC}
|
||||
{$define HASSETFPUEXCEPTIONMASK}
|
||||
procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
|
||||
var
|
||||
fsr : cardinal;
|
||||
begin
|
||||
{ load current control register contents }
|
||||
asm
|
||||
st %fsr,fsr
|
||||
end;
|
||||
{ invalid operation: bit 27 }
|
||||
if (exInvalidOp in mask) then
|
||||
fsr:=fsr and not(1 shl 27)
|
||||
else
|
||||
fsr:=fsr or (1 shl 27);
|
||||
|
||||
{ zero divide: bit 24 }
|
||||
if (exZeroDivide in mask) then
|
||||
fsr:=fsr and not(1 shl 24)
|
||||
else
|
||||
fsr:=fsr or (1 shl 24);
|
||||
|
||||
{ overflow: bit 26 }
|
||||
if (exOverflow in mask) then
|
||||
fsr:=fsr and not(1 shl 26)
|
||||
else
|
||||
fsr:=fsr or (1 shl 26);
|
||||
|
||||
{ underflow: bit 25 }
|
||||
if (exUnderflow in mask) then
|
||||
fsr:=fsr and not(1 shl 25)
|
||||
else
|
||||
fsr:=fsr or (1 shl 25);
|
||||
|
||||
{ Precision (inexact result): bit 23 }
|
||||
if (exPrecision in mask) then
|
||||
fsr:=fsr and not(1 shl 23)
|
||||
else
|
||||
fsr:=fsr or (1 shl 23);
|
||||
{ update control register contents }
|
||||
asm
|
||||
ld fsr,%fsr
|
||||
end;
|
||||
end;
|
||||
{$endif CPUSPARC}
|
||||
|
||||
{$ifndef HASSETFPUEXCEPTIONMASK}
|
||||
procedure SetFPUExceptionMask(const Mask: TFPUExceptionMask);
|
||||
begin
|
||||
end;
|
||||
{$endif HASSETFPUEXCEPTIONMASK}
|
||||
|
||||
function is_number_float(d : double) : boolean;
|
||||
var
|
||||
bytearray : array[0..7] of byte;
|
||||
|
||||
@ -203,8 +203,6 @@ begin
|
||||
{$ifdef extheaptrc}
|
||||
keepreleased:=true;
|
||||
{$endif extheaptrc}
|
||||
SetFPUExceptionMask([exInvalidOp, exDenormalized, exZeroDivide,
|
||||
exOverflow, exUnderflow, exPrecision]);
|
||||
{ Call the compiler with empty command, so it will take the parameters }
|
||||
Halt(compiler.Compile(''));
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user