File : a-numaux.adb
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
5 -- A D A . N U M E R I C S . A U X --
-- --
-- B o d y --
-- (Machine Version for x86) --
-- --
10 -- $Revision: 1.16 $
-- --
-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
15 -- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
20 -- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
25 -- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
30 -- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
35 ------------------------------------------------------------------------------
-- File a-numaux.adb <- 86numaux.adb
-- This version of Numerics.Aux is for the IEEE Double Extended floating
40 -- point format on x86.
with System.Machine_Code; use System.Machine_Code;
package body Ada.Numerics.Aux is
45
NL : constant String := ASCII.LF & ASCII.HT;
type FPU_Stack_Pointer is range 0 .. 7;
for FPU_Stack_Pointer'Size use 3;
50
type FPU_Status_Word is record
B : Boolean; -- FPU Busy (for 8087 compatibility only)
ES : Boolean; -- Error Summary Status
SF : Boolean; -- Stack Fault
55
Top : FPU_Stack_Pointer;
-- Condition Code Flags
60 -- C2 is set by FPREM and FPREM1 to indicate incomplete reduction.
-- In case of successfull recorction, C0, C3 and C1 are set to the
-- three least significant bits of the result (resp. Q2, Q1 and Q0).
-- C2 is used by FPTAN, FSIN, FCOS, and FSINCOS to indicate that
65 -- that source operand is beyond the allowable range of
-- -2.0**63 .. 2.0**63.
C3 : Boolean;
C2 : Boolean;
70 C1 : Boolean;
C0 : Boolean;
-- Exception Flags
75 PE : Boolean; -- Precision
UE : Boolean; -- Underflow
OE : Boolean; -- Overflow
ZE : Boolean; -- Zero Divide
DE : Boolean; -- Denormalized Operand
80 IE : Boolean; -- Invalid Operation
end record;
for FPU_Status_Word use record
B at 0 range 15 .. 15;
85 C3 at 0 range 14 .. 14;
Top at 0 range 11 .. 13;
C2 at 0 range 10 .. 10;
C1 at 0 range 9 .. 9;
C0 at 0 range 8 .. 8;
90 ES at 0 range 7 .. 7;
SF at 0 range 6 .. 6;
PE at 0 range 5 .. 5;
UE at 0 range 4 .. 4;
OE at 0 range 3 .. 3;
95 ZE at 0 range 2 .. 2;
DE at 0 range 1 .. 1;
IE at 0 range 0 .. 0;
end record;
100 for FPU_Status_Word'Size use 16;
-----------------------
-- Local subprograms --
-----------------------
105
function Is_Nan (X : Double) return Boolean;
-- Return True iff X is a IEEE NaN value
function Logarithmic_Pow (X, Y : Double) return Double;
110 -- Implementation of X**Y using Exp and Log functions (binary base)
-- to calculate the exponentiation. This is used by Pow for values
-- for values of Y in the open interval (-0.25, 0.25)
function Reduce (X : Double) return Double;
115 -- Implement partial reduction of X by Pi in the x86.
-- Note that for the Sin, Cos and Tan functions completely accurate
-- reduction of the argument is done for arguments in the range of
-- -2.0**63 .. 2.0**63, using a 66-bit approximation of Pi.
120
pragma Inline (Is_Nan);
pragma Inline (Reduce);
---------------------------------
125 -- Basic Elementary Functions --
---------------------------------
-- This section implements a few elementary functions that are
-- used to build the more complex ones. This ordering enables
130 -- better inlining.
----------
-- Atan --
----------
135
function Atan (X : Double) return Double is
Result : Double;
begin
140 Asm (Template =>
"fld1" & NL
& "fpatan",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
145
-- The result value is NaN iff input was invalid
if not (Result = Result) then
raise Argument_Error;
150 end if;
return Result;
end Atan;
155 ---------
-- Exp --
---------
function Exp (X : Double) return Double is
160 Result : Double;
begin
Asm (Template =>
"fldl2e " & NL
& "fmulp %%st, %%st(1)" & NL -- X * log2 (E)
165 & "fld %%st(0) " & NL
& "frndint " & NL -- Integer (X * Log2 (E))
& "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E))
& "fxch " & NL
& "f2xm1 " & NL -- 2**(...) - 1
170 & "fld1 " & NL
& "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E)))
& "fscale " & NL -- E ** X
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
175 Inputs => Double'Asm_Input ("0", X));
return Result;
end Exp;
------------
180 -- Is_Nan --
------------
function Is_Nan (X : Double) return Boolean is
begin
185 -- The IEEE NaN values are the only ones that do not equal themselves
return not (X = X);
end Is_Nan;
190 ---------
-- Log --
---------
function Log (X : Double) return Double is
195 Result : Double;
begin
Asm (Template =>
"fldln2 " & NL
200 & "fxch " & NL
& "fyl2x " & NL,
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
205 end Log;
------------
-- Reduce --
------------
210
function Reduce (X : Double) return Double is
Result : Double;
begin
Asm
215 (Template =>
-- Partial argument reduction
"fldpi " & NL
& "fadd %%st(0), %%st" & NL
& "fxch %%st(1) " & NL
220 & "fprem1 " & NL
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
225 end Reduce;
----------
-- Sqrt --
----------
230
function Sqrt (X : Double) return Double is
Result : Double;
begin
235 if X < 0.0 then
raise Argument_Error;
end if;
Asm (Template => "fsqrt",
240 Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Sqrt;
245
---------------------------------
-- Other Elementary Functions --
---------------------------------
250 -- These are built using the previously implemented basic functions
----------
-- Acos --
----------
255
function Acos (X : Double) return Double is
Result : Double;
begin
Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
260
-- The result value is NaN iff input was invalid
if Is_Nan (Result) then
raise Argument_Error;
265 end if;
return Result;
end Acos;
270 ----------
-- Asin --
----------
function Asin (X : Double) return Double is
275 Result : Double;
begin
Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
280 -- The result value is NaN iff input was invalid
if Is_Nan (Result) then
raise Argument_Error;
end if;
285
return Result;
end Asin;
---------
290 -- Cos --
---------
function Cos (X : Double) return Double is
Reduced_X : Double := X;
295 Result : Double;
Status : FPU_Status_Word;
begin
300 loop
Asm
(Template =>
"fcos " & NL
& "xorl %%eax, %%eax " & NL
305 & "fnstsw %%ax ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
Inputs => Double'Asm_Input ("0", Reduced_X));
310 exit when not Status.C2;
-- Original argument was not in range and the result
-- is the unmodified argument.
315 Reduced_X := Reduce (Result);
end loop;
return Result;
end Cos;
320
---------------------
-- Logarithmic_Pow --
---------------------
325 function Logarithmic_Pow (X, Y : Double) return Double is
Result : Double;
begin
Asm (Template => "" -- X : Y
330 & "fyl2x " & NL -- Y * Log2 (X)
& "fst %%st(1) " & NL -- Y * Log2 (X) : Y * Log2 (X)
& "frndint " & NL -- Int (...) : Y * Log2 (X)
& "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...)
& "fxch " & NL -- Fract (...) : Int (...)
335 & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...)
& "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...)
& "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...)
& "fscale " & NL -- 2**(Fract (...) + Int (...))
& "fstp %%st(1) ",
340 Outputs => Double'Asm_Output ("=t", Result),
Inputs =>
(Double'Asm_Input ("0", X),
Double'Asm_Input ("u", Y)));
345 return Result;
end Logarithmic_Pow;
---------
-- Pow --
350 ---------
function Pow (X, Y : Double) return Double is
type Mantissa_Type is mod 2**Double'Machine_Mantissa;
-- Modular type that can hold all bits of the mantissa of Double
355
-- For negative exponents, a division is done
-- at the end of the processing.
Negative_Y : constant Boolean := Y < 0.0;
360 Abs_Y : constant Double := abs Y;
-- During this function the following invariant is kept:
-- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor
365 Base : Double := X;
Exp_High : Double := Double'Floor (Abs_Y);
Exp_Mid : Double;
Exp_Low : Double;
370 Exp_Int : Mantissa_Type;
Factor : Double := 1.0;
begin
375 -- Select algorithm for calculating Pow:
-- integer cases fall through
if Exp_High >= 2.0**Double'Machine_Mantissa then
380 -- In case of Y that is IEEE infinity, just raise constraint error
if Exp_High > Double'Safe_Last then
raise Constraint_Error;
end if;
385
-- Large values of Y are even integers and will stay integer
-- after division by two.
loop
390 -- Exp_Mid and Exp_Low are zero, so
-- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2)
Exp_High := Exp_High / 2.0;
Base := Base * Base;
395 exit when Exp_High < 2.0**Double'Machine_Mantissa;
end loop;
elsif Exp_High /= Abs_Y then
Exp_Low := Abs_Y - Exp_High;
400
Factor := 1.0;
if Exp_Low /= 0.0 then
405 -- Exp_Low now is in interval (0.0, 1.0)
-- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0;
Exp_Mid := 0.0;
Exp_Low := Exp_Low - Exp_Mid;
410
if Exp_Low >= 0.5 then
Factor := Sqrt (X);
Exp_Low := Exp_Low - 0.5; -- exact
415 if Exp_Low >= 0.25 then
Factor := Factor * Sqrt (Factor);
Exp_Low := Exp_Low - 0.25; -- exact
end if;
420 elsif Exp_Low >= 0.25 then
Factor := Sqrt (Sqrt (X));
Exp_Low := Exp_Low - 0.25; -- exact
end if;
425 -- Exp_Low now is in interval (0.0, 0.25)
-- This means it is safe to call Logarithmic_Pow
-- for the remaining part.
430 Factor := Factor * Logarithmic_Pow (X, Exp_Low);
end if;
elsif X = 0.0 then
return 0.0;
435 end if;
-- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa
Exp_Int := Mantissa_Type (Exp_High);
440
-- Standard way for processing integer powers > 0
while Exp_Int > 1 loop
if (Exp_Int and 1) = 1 then
445
-- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0
Factor := Factor * Base;
end if;
450
-- Exp_Int is even and Exp_Int > 0, so
-- Base**Y = (Base**2)**(Exp_Int / 2)
Base := Base * Base;
455 Exp_Int := Exp_Int / 2;
end loop;
-- Exp_Int = 1 or Exp_Int = 0
460 if Exp_Int = 1 then
Factor := Base * Factor;
end if;
if Negative_Y then
465 Factor := 1.0 / Factor;
end if;
return Factor;
end Pow;
470
---------
-- Sin --
---------
475 function Sin (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
Status : FPU_Status_Word;
480 begin
loop
Asm
(Template =>
485 "fsin " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
490 Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
495 -- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
500 return Result;
end Sin;
---------
-- Tan --
505 ---------
function Tan (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
510 Status : FPU_Status_Word;
begin
loop
515 Asm
(Template =>
"fptan " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax " & NL
520 & "ffree %%st(0) " & NL
& "fincstp ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
525 Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
530 -- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
535 return Result;
end Tan;
----------
-- Sinh --
540 ----------
function Sinh (X : Double) return Double is
begin
-- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0
545
if abs X < 25.0 then
return (Exp (X) - Exp (-X)) / 2.0;
else
550 return Exp (X) / 2.0;
end if;
end Sinh;
555 ----------
-- Cosh --
----------
function Cosh (X : Double) return Double is
560 begin
-- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0
if abs X < 22.0 then
return (Exp (X) + Exp (-X)) / 2.0;
565
else
return Exp (X) / 2.0;
end if;
570 end Cosh;
----------
-- Tanh --
----------
575
function Tanh (X : Double) return Double is
begin
-- Return the Hyperbolic Tangent of x
--
580 -- x -x
-- e - e Sinh (X)
-- Tanh (X) is defined to be ----------- = --------
-- x -x Cosh (X)
-- e + e
585
if abs X > 23.0 then
return Double'Copy_Sign (1.0, X);
end if;
590 return 1.0 / (1.0 + Exp (-2.0 * X)) - 1.0 / (1.0 + Exp (2.0 * X));
end Tanh;
end Ada.Numerics.Aux;