mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-11 15:48:11 +02:00
386738a7c3
This corrects the handling of exception masks and ARM VFP implementations. The old code enable the exception when it was present in the mask. So in fact it did the contrary of what it was supposed to do. VFP-Support is currently broken, this patch at least allows to build a working VFP-native compiler. But the full build still breaks because of some compiler options not properly beeing passed down to packages/ which results in: "Trying to use a unit which was compiled with a different FPU mode" because somehow OPT="-Cfvfpv2" did not get passed down. git-svn-id: trunk@21952 -
564 lines
15 KiB
PHP
564 lines
15 KiB
PHP
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 2004 by Florian Klaempfl
|
|
member of the Free Pascal development team
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
function FPUExceptionMaskToSoftFloatMask(const Mask: TFPUExceptionMask): byte;
|
|
begin
|
|
result:=0;
|
|
if exInvalidOp in Mask then
|
|
result:=result or (1 shl ord(exInvalidOp));
|
|
if exDenormalized in Mask then
|
|
result:=result or (1 shl ord(exDenormalized));
|
|
if exZeroDivide in Mask then
|
|
result:=result or (1 shl ord(exZeroDivide));
|
|
if exOverflow in Mask then
|
|
result:=result or (1 shl ord(exOverflow));
|
|
if exUnderflow in Mask then
|
|
result:=result or (1 shl ord(exUnderflow));
|
|
if exPrecision in Mask then
|
|
result:=result or (1 shl ord(exPrecision));
|
|
end;
|
|
|
|
function SoftFloatMaskToFPUExceptionMask(const Mask: byte): TFPUExceptionMask;
|
|
begin
|
|
result:=[];
|
|
if (mask and (1 shl ord(exInvalidOp)) <> 0) then
|
|
include(result,exInvalidOp);
|
|
if (mask and (1 shl ord(exDenormalized)) <> 0) then
|
|
include(result,exDenormalized);
|
|
if (mask and (1 shl ord(exZeroDivide)) <> 0) then
|
|
include(result,exZeroDivide);
|
|
if (mask and (1 shl ord(exOverflow)) <> 0) then
|
|
include(result,exOverflow);
|
|
if (mask and (1 shl ord(exUnderflow)) <> 0) then
|
|
include(result,exUnderflow);
|
|
if (mask and (1 shl ord(exPrecision)) <> 0) then
|
|
include(result,exPrecision);
|
|
end;
|
|
|
|
{$if defined(wince)}
|
|
|
|
const
|
|
_DN_SAVE = $00000000;
|
|
_DN_FLUSH = $01000000;
|
|
|
|
_EM_INVALID = $00000010;
|
|
_EM_DENORMAL = $00080000;
|
|
_EM_ZERODIVIDE = $00000008;
|
|
_EM_OVERFLOW = $00000004;
|
|
_EM_UNDERFLOW = $00000002;
|
|
_EM_INEXACT = $00000001;
|
|
|
|
_IC_AFFINE = $00040000;
|
|
_IC_PROJECTIVE = $00000000;
|
|
|
|
_RC_CHOP = $00000300;
|
|
_RC_UP = $00000200;
|
|
_RC_DOWN = $00000100;
|
|
_RC_NEAR = $00000000;
|
|
|
|
_PC_24 = $00020000;
|
|
_PC_53 = $00010000;
|
|
_PC_64 = $00000000;
|
|
|
|
_MCW_DN = $03000000;
|
|
_MCW_EM = $0008001F;
|
|
_MCW_IC = $00040000;
|
|
_MCW_RC = $00000300;
|
|
_MCW_PC = $00030000;
|
|
|
|
function _controlfp(new: DWORD; mask: DWORD): DWORD; cdecl; external 'coredll';
|
|
|
|
function GetRoundMode: TFPURoundingMode;
|
|
var
|
|
c: dword;
|
|
begin
|
|
c:=_controlfp(0, 0);
|
|
Result:=TFPURoundingMode((c shr 16) and 3);
|
|
end;
|
|
|
|
function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
|
|
var
|
|
c: dword;
|
|
begin
|
|
case (RoundMode) of
|
|
rmNearest :
|
|
softfloat_rounding_mode := float_round_nearest_even;
|
|
rmTruncate :
|
|
softfloat_rounding_mode := float_round_to_zero;
|
|
rmUp :
|
|
softfloat_rounding_mode := float_round_up;
|
|
rmDown :
|
|
softfloat_rounding_mode := float_round_down;
|
|
end;
|
|
c:=Ord(RoundMode) shl 16;
|
|
c:=_controlfp(c, _MCW_RC);
|
|
Result:=TFPURoundingMode((c shr 16) and 3);
|
|
end;
|
|
|
|
function GetPrecisionMode: TFPUPrecisionMode;
|
|
var
|
|
c: dword;
|
|
begin
|
|
c:=_controlfp(0, 0);
|
|
if c and _MCW_PC = _PC_64 then
|
|
Result:=pmDouble
|
|
else
|
|
Result:=pmSingle;
|
|
end;
|
|
|
|
function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
|
|
var
|
|
c: dword;
|
|
begin
|
|
Result:=GetPrecisionMode;
|
|
if Precision = pmSingle then
|
|
c:=_PC_24
|
|
else
|
|
c:=_PC_64;
|
|
_controlfp(c, _MCW_PC);
|
|
end;
|
|
|
|
function ConvertExceptionMask(em: dword): TFPUExceptionMask;
|
|
begin
|
|
Result:=[];
|
|
if em and _EM_INVALID = 0 then
|
|
Result:=Result + [exInvalidOp];
|
|
if em and _EM_DENORMAL = 0 then
|
|
Result:=Result + [exDenormalized];
|
|
if em and _EM_ZERODIVIDE = 0 then
|
|
Result:=Result + [exZeroDivide];
|
|
if em and _EM_OVERFLOW = 0 then
|
|
Result:=Result + [exOverflow];
|
|
if em and _EM_UNDERFLOW = 0 then
|
|
Result:=Result + [exUnderflow];
|
|
if em and _EM_INEXACT = 0 then
|
|
Result:=Result + [exPrecision];
|
|
end;
|
|
|
|
function GetExceptionMask: TFPUExceptionMask;
|
|
begin
|
|
Result:=ConvertExceptionMask(_controlfp(0, 0));
|
|
end;
|
|
|
|
function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
|
|
var
|
|
c: dword;
|
|
begin
|
|
c:=0;
|
|
if not(exInvalidOp in Mask) then
|
|
cw:=cw or _VFP_ENABLE_IM;
|
|
if not(exDenormalized in Mask) then
|
|
cw:=cw or _VFP_ENABLE_DM;
|
|
if not(exZeroDivide in Mask) then
|
|
cw:=cw or _VFP_ENABLE_ZM;
|
|
if not(exOverflow in Mask) then
|
|
cw:=cw or _VFP_ENABLE_OM;
|
|
if not(exUnderflow in Mask) then
|
|
cw:=cw or _VFP_ENABLE_UM;
|
|
if not(exPrecision in Mask) then
|
|
cw:=cw or _VFP_ENABLE_PM;
|
|
c:=_controlfp(c, _MCW_EM);
|
|
Result:=ConvertExceptionMask(c);
|
|
softfloat_exception_mask:=FPUExceptionMaskToSoftFloatMask(mask);
|
|
end;
|
|
|
|
procedure ClearExceptions(RaisePending: Boolean =true);
|
|
begin
|
|
end;
|
|
|
|
{$elseif defined(darwin) or defined(FPUVFPV2) or defined(FPUVFPV3) or defined(FPUVFPV3_d16)}
|
|
|
|
const
|
|
_VFP_ENABLE_IM = 1 shl 8; { invalid operation }
|
|
_VFP_ENABLE_ZM = 1 shl 9; { divide by zero }
|
|
_VFP_ENABLE_OM = 1 shl 10; { overflow }
|
|
_VFP_ENABLE_UM = 1 shl 11; { underflow }
|
|
_VFP_ENABLE_PM = 1 shl 12; { inexact }
|
|
_VFP_ENABLE_DM = 1 shl 15; { denormalized operation }
|
|
_VFP_ENABLE_ALL = _VFP_ENABLE_IM or
|
|
_VFP_ENABLE_ZM or
|
|
_VFP_ENABLE_OM or
|
|
_VFP_ENABLE_UM or
|
|
_VFP_ENABLE_PM or
|
|
_VFP_ENABLE_DM; { mask for all flags }
|
|
|
|
_VFP_ROUNDINGMODE_MASK_SHIFT = 22;
|
|
_VFP_ROUNDINGMODE_MASK = 3 shl _VFP_ROUNDINGMODE_MASK_SHIFT;
|
|
|
|
_VFP_EXCEPTIONS_PENDING_MASK =
|
|
(1 shl 0) or
|
|
(1 shl 1) or
|
|
(1 shl 2) or
|
|
(1 shl 3) or
|
|
(1 shl 4) or
|
|
(1 shl 7);
|
|
|
|
function VFP_GetCW : dword; nostackframe; assembler;
|
|
asm
|
|
fmrx r0,fpscr
|
|
end;
|
|
|
|
|
|
procedure VFP_SetCW(cw : dword); nostackframe; assembler;
|
|
asm
|
|
fmxr fpscr,r0
|
|
end;
|
|
|
|
|
|
function GetRoundMode: TFPURoundingMode;
|
|
var
|
|
rm: byte;
|
|
begin
|
|
case (VFP_GetCW and _VFP_ROUNDINGMODE_MASK) shr _VFP_ROUNDINGMODE_MASK_SHIFT of
|
|
0 : result := rmNearest;
|
|
1 : result := rmUp;
|
|
2 : result := rmDown;
|
|
3 : result := rmTruncate;
|
|
end;
|
|
end;
|
|
|
|
|
|
function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
|
|
var
|
|
mode: dword;
|
|
begin
|
|
case (RoundMode) of
|
|
rmNearest :
|
|
begin
|
|
mode := 0;
|
|
softfloat_rounding_mode := float_round_nearest_even;
|
|
end;
|
|
rmUp :
|
|
begin
|
|
mode := 1;
|
|
softfloat_rounding_mode := float_round_up;
|
|
end;
|
|
rmDown :
|
|
begin
|
|
mode := 2;
|
|
softfloat_rounding_mode := float_round_down;
|
|
end;
|
|
rmTruncate :
|
|
begin
|
|
mode := 3;
|
|
softfloat_rounding_mode := float_round_to_zero;
|
|
end;
|
|
end;
|
|
mode:=mode shl _VFP_ROUNDINGMODE_MASK_SHIFT;
|
|
VFP_SetCW((VFP_GetCW and (not _VFP_ROUNDINGMODE_MASK)) or mode);
|
|
result := RoundMode;
|
|
end;
|
|
|
|
|
|
function GetPrecisionMode: TFPUPrecisionMode;
|
|
begin
|
|
result := pmDouble;
|
|
end;
|
|
|
|
|
|
function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
|
|
begin
|
|
{ nothing to do, not supported }
|
|
result := pmDouble;
|
|
end;
|
|
|
|
|
|
function GetExceptionMask: TFPUExceptionMask;
|
|
var
|
|
cw : dword;
|
|
begin
|
|
Result:=[];
|
|
cw:=VFP_GetCW;
|
|
|
|
if (cw and _VFP_ENABLE_IM)=0 then
|
|
include(Result,exInvalidOp);
|
|
|
|
if (cw and _VFP_ENABLE_DM)=0 then
|
|
include(Result,exDenormalized);
|
|
|
|
if (cw and _VFP_ENABLE_ZM)=0 then
|
|
include(Result,exZeroDivide);
|
|
|
|
if (cw and _VFP_ENABLE_OM)=0 then
|
|
include(Result,exOverflow);
|
|
|
|
if (cw and _VFP_ENABLE_UM)=0 then
|
|
include(Result,exUnderflow);
|
|
|
|
if (cw and _VFP_ENABLE_PM)=0 then
|
|
include(Result,exPrecision);
|
|
end;
|
|
|
|
|
|
function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
|
|
var
|
|
cw : dword;
|
|
begin
|
|
cw:=VFP_GetCW and not(_VFP_ENABLE_ALL);
|
|
|
|
{$ifndef darwin}
|
|
if not(exInvalidOp in Mask) then
|
|
cw:=cw or _VFP_ENABLE_IM;
|
|
|
|
if not(exDenormalized in Mask) then
|
|
cw:=cw or _VFP_ENABLE_DM;
|
|
|
|
if not(exZeroDivide in Mask) then
|
|
cw:=cw or _VFP_ENABLE_ZM;
|
|
|
|
if not(exOverflow in Mask) then
|
|
cw:=cw or _VFP_ENABLE_OM;
|
|
|
|
if not(exUnderflow in Mask) then
|
|
cw:=cw or _VFP_ENABLE_UM;
|
|
|
|
if not(exPrecision in Mask) then
|
|
cw:=cw or _VFP_ENABLE_PM;
|
|
{$endif}
|
|
VFP_SetCW(cw);
|
|
result:=Mask;
|
|
|
|
softfloat_exception_mask:=FPUExceptionMaskToSoftFloatMask(Mask);
|
|
end;
|
|
|
|
|
|
procedure ClearExceptions(RaisePending: Boolean =true);
|
|
begin
|
|
{ RaisePending has no effect on ARM, it always raises them at the correct location }
|
|
VFP_SetCW(VFP_GetCW and (not _VFP_EXCEPTIONS_PENDING_MASK));
|
|
end;
|
|
|
|
{$else wince/darwin/vfpv2/vfpv3}
|
|
|
|
{*****************************************************************************
|
|
FPA code
|
|
*****************************************************************************}
|
|
{
|
|
Docs from uclib
|
|
|
|
* We have a slight terminology confusion here. On the ARM, the register
|
|
* we're interested in is actually the FPU status word - the FPU control
|
|
* word is something different (which is implementation-defined and only
|
|
* accessible from supervisor mode.)
|
|
*
|
|
* The FPSR looks like this:
|
|
*
|
|
* 31-24 23-16 15-8 7-0
|
|
* | system ID | trap enable | system control | exception flags |
|
|
*
|
|
* We ignore the system ID bits; for interest's sake they are:
|
|
*
|
|
* 0000 "old" FPE
|
|
* 1000 FPPC hardware
|
|
* 0001 FPE 400
|
|
* 1001 FPA hardware
|
|
*
|
|
* The trap enable and exception flags are both structured like this:
|
|
*
|
|
* 7 - 5 4 3 2 1 0
|
|
* | reserved | INX | UFL | OFL | DVZ | IVO |
|
|
*
|
|
* where a `1' bit in the enable byte means that the trap can occur, and
|
|
* a `1' bit in the flags byte means the exception has occurred.
|
|
*
|
|
* The exceptions are:
|
|
*
|
|
* IVO - invalid operation
|
|
* DVZ - divide by zero
|
|
* OFL - overflow
|
|
* UFL - underflow
|
|
* INX - inexact (do not use; implementations differ)
|
|
*
|
|
* The system control byte looks like this:
|
|
*
|
|
* 7-5 4 3 2 1 0
|
|
* | reserved | AC | EP | SO | NE | ND |
|
|
*
|
|
* where the bits mean
|
|
*
|
|
* ND - no denormalised numbers (force them all to zero)
|
|
* NE - enable NaN exceptions
|
|
* SO - synchronous operation
|
|
* EP - use expanded packed-decimal format
|
|
* AC - use alternate definition for C flag on compare operations
|
|
*/
|
|
|
|
/* masking of interrupts */
|
|
#define _FPU_MASK_IM 0x00010000 /* invalid operation */
|
|
#define _FPU_MASK_ZM 0x00020000 /* divide by zero */
|
|
#define _FPU_MASK_OM 0x00040000 /* overflow */
|
|
#define _FPU_MASK_UM 0x00080000 /* underflow */
|
|
#define _FPU_MASK_PM 0x00100000 /* inexact */
|
|
#define _FPU_MASK_DM 0x00000000 /* denormalized operation */
|
|
|
|
/* The system id bytes cannot be changed.
|
|
Only the bottom 5 bits in the trap enable byte can be changed.
|
|
Only the bottom 5 bits in the system control byte can be changed.
|
|
Only the bottom 5 bits in the exception flags are used.
|
|
The exception flags are set by the fpu, but can be zeroed by the user. */
|
|
#define _FPU_RESERVED 0xffe0e0e0 /* These bits are reserved. */
|
|
|
|
/* The fdlibm code requires strict IEEE double precision arithmetic,
|
|
no interrupts for exceptions, rounding to nearest. Changing the
|
|
rounding mode will break long double I/O. Turn on the AC bit,
|
|
the compiler generates code that assumes it is on. */
|
|
#define _FPU_DEFAULT 0x00001000 /* Default value. */
|
|
#define _FPU_IEEE 0x001f1000 /* Default + exceptions enabled. */
|
|
}
|
|
|
|
|
|
{$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
|
|
const
|
|
_FPU_MASK_IM = $00010000; { invalid operation }
|
|
_FPU_MASK_ZM = $00020000; { divide by zero }
|
|
_FPU_MASK_OM = $00040000; { overflow }
|
|
_FPU_MASK_UM = $00080000; { underflow }
|
|
_FPU_MASK_PM = $00100000; { inexact }
|
|
_FPU_MASK_DM = $00000000; { denormalized operation }
|
|
_FPU_MASK_ALL = $001f0000; { mask for all flags }
|
|
|
|
function FPU_GetCW : dword; nostackframe; assembler;
|
|
asm
|
|
rfs r0
|
|
end;
|
|
|
|
|
|
procedure FPU_SetCW(cw : dword); nostackframe; assembler;
|
|
asm
|
|
wfs r0
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
function GetRoundMode: TFPURoundingMode;
|
|
begin
|
|
case softfloat_rounding_mode of
|
|
float_round_nearest_even:
|
|
GetRoundMode:=rmNearest;
|
|
float_round_up:
|
|
GetRoundMode:=rmUp;
|
|
float_round_down:
|
|
GetRoundMode:=rmDown;
|
|
float_round_to_zero:
|
|
GetRoundMode:=rmTruncate;
|
|
end;
|
|
end;
|
|
|
|
|
|
function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
|
|
begin
|
|
case (RoundMode) of
|
|
rmNearest :
|
|
begin
|
|
softfloat_rounding_mode := float_round_nearest_even;
|
|
end;
|
|
rmUp :
|
|
begin
|
|
softfloat_rounding_mode := float_round_up;
|
|
end;
|
|
rmDown :
|
|
begin
|
|
softfloat_rounding_mode := float_round_down;
|
|
end;
|
|
rmTruncate :
|
|
begin
|
|
softfloat_rounding_mode := float_round_to_zero;
|
|
end;
|
|
end;
|
|
SetRoundMode:=RoundMode;
|
|
end;
|
|
|
|
|
|
function GetPrecisionMode: TFPUPrecisionMode;
|
|
begin
|
|
result := pmDouble;
|
|
end;
|
|
|
|
|
|
function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
|
|
begin
|
|
{ does not apply }
|
|
result := pmDouble;
|
|
end;
|
|
|
|
|
|
function GetExceptionMask: TFPUExceptionMask;
|
|
var
|
|
cw : dword;
|
|
begin
|
|
{$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
|
|
Result:=[];
|
|
cw:=FPU_GetCW;
|
|
|
|
if (cw and _FPU_MASK_IM)=0 then
|
|
include(Result,exInvalidOp);
|
|
|
|
if (cw and _FPU_MASK_DM)=0 then
|
|
include(Result,exDenormalized);
|
|
|
|
if (cw and _FPU_MASK_ZM)=0 then
|
|
include(Result,exZeroDivide);
|
|
|
|
if (cw and _FPU_MASK_OM)=0 then
|
|
include(Result,exOverflow);
|
|
|
|
if (cw and _FPU_MASK_UM)=0 then
|
|
include(Result,exUnderflow);
|
|
|
|
if (cw and _FPU_MASK_PM)=0 then
|
|
include(Result,exPrecision);
|
|
{$else}
|
|
Result:=SoftFloatMaskToFPUExceptionMask(softfloat_exception_mask);
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
|
|
var
|
|
cw : dword;
|
|
begin
|
|
{$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
|
|
cw:=FPU_GetCW or _FPU_MASK_ALL;
|
|
|
|
if exInvalidOp in Mask then
|
|
cw:=cw and not(_FPU_MASK_IM);
|
|
|
|
if exDenormalized in Mask then
|
|
cw:=cw and not(_FPU_MASK_DM);
|
|
|
|
if exZeroDivide in Mask then
|
|
cw:=cw and not(_FPU_MASK_ZM);
|
|
|
|
if exOverflow in Mask then
|
|
cw:=cw and not(_FPU_MASK_OM);
|
|
|
|
if exUnderflow in Mask then
|
|
cw:=cw and not(_FPU_MASK_UM);
|
|
|
|
if exPrecision in Mask then
|
|
cw:=cw and not(_FPU_MASK_PM);
|
|
|
|
FPU_SetCW(cw);
|
|
{$endif}
|
|
softfloat_exception_mask:=FPUExceptionMaskToSoftFloatMask(Mask);
|
|
Result:=Mask;
|
|
end;
|
|
|
|
|
|
procedure ClearExceptions(RaisePending: Boolean =true);
|
|
begin
|
|
end;
|
|
|
|
{$endif wince}
|