mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-06 13:07:55 +02:00
495 lines
13 KiB
PHP
495 lines
13 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.
|
|
|
|
**********************************************************************}
|
|
|
|
{ for bootstrapping with 3.0.x/3.2.x }
|
|
{$if defined(darwin) or defined(FPUVFPV2) or defined(FPUVFPV3) or defined(FPUVFPV4) or defined(FPUVFPV3_d16) or defined(FPUFPV4_s16)}
|
|
{$define FPUARM_HAS_VFP_EXTENSION}
|
|
{$endif}
|
|
|
|
{$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
|
|
softfloat_rounding_mode:=RoundMode;
|
|
Result:=GetRoundMode;
|
|
c:=Ord(RoundMode) shl 16;
|
|
c:=_controlfp(c, _MCW_RC);
|
|
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
|
|
c:=c or _EM_INVALID;
|
|
if not(exDenormalized in Mask) then
|
|
c:=c or _EM_DENORMAL;
|
|
if not(exZeroDivide in Mask) then
|
|
c:=c or _EM_ZERODIVIDE;
|
|
if not(exOverflow in Mask) then
|
|
c:=c or _EM_OVERFLOW;
|
|
if not(exUnderflow in Mask) then
|
|
c:=c or _EM_UNDERFLOW;
|
|
if not(exPrecision in Mask) then
|
|
c:=c or _EM_INEXACT;
|
|
c:=_controlfp(c, _MCW_EM);
|
|
Result:=ConvertExceptionMask(c);
|
|
end;
|
|
|
|
procedure ClearExceptions(RaisePending: Boolean =true);
|
|
begin
|
|
end;
|
|
|
|
{$elseif defined(FPUARM_HAS_VFP_EXTENSION)}
|
|
|
|
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 VFPCw2RoundingMode(cw: dword): TFPURoundingMode;
|
|
begin
|
|
case (cw 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 GetRoundMode: TFPURoundingMode;
|
|
begin
|
|
result:=VFPCw2RoundingMode(VFP_GetCW);
|
|
end;
|
|
|
|
|
|
function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
|
|
var
|
|
mode: dword;
|
|
oldcw: dword;
|
|
begin
|
|
softfloat_rounding_mode:=RoundMode;
|
|
oldcw:=VFP_GetCW;
|
|
case (RoundMode) of
|
|
rmNearest : mode := 0;
|
|
rmUp : mode := 1;
|
|
rmDown : mode := 2;
|
|
rmTruncate : mode := 3;
|
|
end;
|
|
mode:=mode shl _VFP_ROUNDINGMODE_MASK_SHIFT;
|
|
VFP_SetCW((oldcw and (not _VFP_ROUNDINGMODE_MASK)) or mode);
|
|
result := VFPCw2RoundingMode(oldcw);
|
|
end;
|
|
|
|
|
|
function GetPrecisionMode: TFPUPrecisionMode;
|
|
begin
|
|
result := pmDouble;
|
|
end;
|
|
|
|
|
|
function SetPrecisionMode(const Precision: TFPUPrecisionMode): TFPUPrecisionMode;
|
|
begin
|
|
{ nothing to do, not supported }
|
|
result := pmDouble;
|
|
end;
|
|
|
|
|
|
function VFPCw2ExceptionMask(cw: dword): TFPUExceptionMask;
|
|
begin
|
|
Result:=[];
|
|
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 GetExceptionMask: TFPUExceptionMask;
|
|
begin
|
|
{ some ARM CPUs ignore writing to the hardware mask and just return 0, so we need to return
|
|
the softfloat mask which should be in sync with the hard one }
|
|
if VFP_GetCW=0 then
|
|
Result:=softfloat_exception_mask
|
|
else
|
|
Result:=VFPCw2ExceptionMask(VFP_GetCW);
|
|
end;
|
|
|
|
|
|
function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
|
|
var
|
|
cw : dword;
|
|
begin
|
|
cw:=VFP_GetCW;
|
|
Result:=VFPCw2ExceptionMask(cw);
|
|
cw:=cw 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);
|
|
softfloat_exception_mask:=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));
|
|
softfloat_exception_flags:=[];
|
|
end;
|
|
|
|
{$else FPUARM_HAS_VFP_EXTENSION}
|
|
|
|
{*****************************************************************************
|
|
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 FPUCw2ExceptionMask(cw: TNativeFPUControlWord): TFPUExceptionMask;
|
|
begin
|
|
Result:=[];
|
|
|
|
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);
|
|
end;
|
|
{$endif}
|
|
|
|
|
|
function GetRoundMode: TFPURoundingMode;
|
|
begin
|
|
GetRoundMode:=softfloat_rounding_mode;
|
|
end;
|
|
|
|
|
|
function SetRoundMode(const RoundMode: TFPURoundingMode): TFPURoundingMode;
|
|
begin
|
|
result:=softfloat_rounding_mode;
|
|
softfloat_rounding_mode:=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;
|
|
begin
|
|
{$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
|
|
Result:=FPUCw2ExceptionMask(GetNativeFPUControlWord);
|
|
{$else}
|
|
Result:=softfloat_exception_mask;
|
|
{$endif}
|
|
end;
|
|
|
|
|
|
function SetExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
|
|
{$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
|
|
var
|
|
cw : TNativeFPUControlWord;
|
|
{$endif}
|
|
begin
|
|
{$if not(defined(gba)) and not(defined(nds)) and not(defined(FPUSOFT)) and not(defined(FPULIBGCC))}
|
|
cw:=GetNativeFPUControlWord;
|
|
Result:=FPUCw2ExceptionMask(cw);
|
|
cw:=cw 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);
|
|
|
|
SetNativeFPUControlWord(cw);
|
|
{$else}
|
|
Result:=softfloat_exception_mask;
|
|
{$endif}
|
|
softfloat_exception_mask:=Mask;
|
|
end;
|
|
|
|
|
|
procedure ClearExceptions(RaisePending: Boolean =true);
|
|
begin
|
|
softfloat_exception_flags:=[];
|
|
end;
|
|
|
|
{$endif wince}
|