freepascal.compiler/rtl/ppcgen/ppcfpuex.inc

{$ifndef FPUNONE}

const
  InvalidOperationMask = %10000000;
  OverflowMask         = %01000000;
  UnderflowMask        = %00100000;
  ZeroDivideMask       = %00010000;
  InexactMask          = %00001000;

{$ifndef aix}

const
  FP_RND_RZ = 1;
  FP_RND_RN = 0;
  FP_RND_RP = 2;
  FP_RND_RM = 3;
  FP_RND_SHIFT = 28;
  FP_RND_MASK = 3;

procedure fpc_setup_fpu;
var
  cw: TNativeFPUControlWord;
begin
  asm
    { clear all "exception happened" flags we care about}
    mtfsfi 0,0
    mtfsfi 1,0
    mtfsfi 2,0
    mtfsfi 3,0
    mtfsb0 21
    mtfsb0 22
    mtfsb0 23
  end;
  cw:=GetNativeFPUControlWord;
  cw:=(cw and not(OverflowMask or UnderflowMask or InexactMask or (FP_RND_MASK shl FP_RND_SHIFT))) or InvalidOperationMask or ZeroDivideMask or (FP_RND_RN shl FP_RND_SHIFT);
  SetNativeFPUControlWord(cw);
end;


function fpc_get_ppc_fpscr: TNativeFPUControlWord;
assembler;
var
  temp: record a,b:longint; end;
asm
  mffs f0
  stfd f0,temp
{$ifdef FPC_BIG_ENDIAN}
  lwz  r3,temp.b
{$else}
  lwz  r3,temp.a
{$endif}
end;

procedure fpc_set_ppc_fpsrc(cw: TNativeFPUControlWord);
var
  cwtemp: qword;
begin
  DefaultFPUControlWord:=cw;
  cwtemp:=cw;
  asm
    lfd f0, cwtemp
    mtfsf 255, f0
  end
end;
{$else aix}
const
  FP_RND_RZ = 0;
  FP_RND_RN = 1;
  FP_RND_RP = 2;
  FP_RND_RM = 3;

  FP_TRAP_SYNC         =  1;       { precise trapping on }
  FP_TRAP_OFF          =  0;       { trapping off        }
  FP_TRAP_QUERY        =  2;       { query trapping mode }
  FP_TRAP_IMP          =  3;       { non-recoverable imprecise trapping on }
  FP_TRAP_IMP_REC      =  4;       { recoverable imprecise trapping on }
  FP_TRAP_FASTMODE     =  128;     { select fastest available mode }
  FP_TRAP_ERROR        = -1;       { error condition }
  FP_TRAP_UNIMPL       = -2;       { requested mode not available }

function fp_is_enabled(Mask: DWord): boolean;cdecl;external;
procedure fp_enable(Mask: DWord);cdecl;external;
function feclearexcept(Mask: DWord):DWord;cdecl;external;
procedure fp_disable(Mask: DWord);cdecl;external;
function fp_read_rnd: word;cdecl;external;
function fp_swap_rnd(RoundMode: word): word;cdecl;external;
function fp_trap(flag: longint): longint;cdecl; external;

procedure fpc_setup_fpu;
var
  cw: TNativeFPUControlWord;
begin
  feclearexcept(InvalidOperationMask or OverflowMask or UnderflowMask or ZeroDivideMask or InexactMask);
  if fp_trap(FP_TRAP_SYNC)<0 then
    fp_trap(FP_TRAP_IMP_REC);
  cw:=GetNativeFPUControlWord;
  cw.rndmode:=FP_RND_RN;
  cw.exceptionmask:=InvalidOperationMask or ZeroDivideMask;
  SetNativeFPUControlWord(cw);
end;


function fpc_get_ppc_fpscr: TNativeFPUControlWord;
begin
  result.rndmode:=fp_read_rnd;
  result.exceptionmask:=0;
  if fp_is_enabled(InvalidOperationMask) then
    result.exceptionmask:=result.exceptionmask or InvalidOperationMask;
  if fp_is_enabled(OverflowMask) then
    result.exceptionmask:=result.exceptionmask or OverflowMask;
  if fp_is_enabled(UnderflowMask) then
    result.exceptionmask:=result.exceptionmask or UnderflowMask;
  if fp_is_enabled(InvalidOperationMask) then
    result.exceptionmask:=result.exceptionmask or ZeroDivideMask;
  if fp_is_enabled(InexactMask) then
    result.exceptionmask:=result.exceptionmask or InexactMask;
end;


procedure fpc_set_ppc_fpsrc(cw: TNativeFPUControlWord);
var
  enablemask, disablemask: dword;
begin
  fp_swap_rnd(cw.rndmode);
  enablemask:=0;
  disablemask:=0;
  { this inverts the "mask" functionality, but that's because it's how the
    native PPC FPU control register works: the bits that are 1 enable the
    exceptions, 0 disable them. This makes sure that we can use
    SetNativeFPUControlWord in the same way regardless of what the underlying
    implementation is }
  if (cw.exceptionmask and InvalidOperationMask)<>0 then
    enablemask:=enablemask or InvalidOperationMask
  else
    disablemask:=disablemask or InvalidOperationMask;
  if (cw.exceptionmask and OverflowMask)<>0 then
    enablemask:=enablemask or OverflowMask
  else
    disablemask:=disablemask or OverflowMask;
  if (cw.exceptionmask and UnderflowMask)<>0 then
    enablemask:=enablemask or UnderflowMask
  else
    disablemask:=disablemask or UnderflowMask;
  if (cw.exceptionmask and ZeroDivideMask)<>0 then
    enablemask:=enablemask or ZeroDivideMask
  else
    disablemask:=disablemask or ZeroDivideMask;
  if (cw.exceptionmask and InexactMask)<>0 then
    enablemask:=enablemask or InexactMask
  else
    disablemask:=disablemask or InexactMask;
  fp_enable(enablemask);
  fp_disable(disablemask);
  DefaultFPUControlWord:=cw;
end;
{$endif}


function GetNativeFPUControlWord: TNativeFPUControlWord; {$if defined(SYSTEMINLINE)}inline;{$endif}
  begin
    result:=fpc_get_ppc_fpscr;
  end;


procedure SetNativeFPUControlWord(const cw: TNativeFPUControlWord); {$if defined(SYSTEMINLINE)}inline;{$endif}
  begin
    fpc_set_ppc_fpsrc(cw);
  end;


{$define FPC_SYSTEM_HAS_SYSINITFPU}
procedure SysInitFPU;{$ifdef SYSTEMINLINE}inline;{$endif}
begin
  { powerpc might use softfloat code }
  softfloat_exception_flags:=[];
  softfloat_exception_mask:=[float_flag_underflow, float_flag_overflow, float_flag_inexact, float_flag_denormal];
  fpc_setup_fpu;
end;
{$endif NOT FPU_NONE}