diff options
Diffstat (limited to 'gcc-4.4.0/gcc/ada/s-fatgen.adb')
-rw-r--r-- | gcc-4.4.0/gcc/ada/s-fatgen.adb | 921 |
1 files changed, 0 insertions, 921 deletions
diff --git a/gcc-4.4.0/gcc/ada/s-fatgen.adb b/gcc-4.4.0/gcc/ada/s-fatgen.adb deleted file mode 100644 index 0db154db4..000000000 --- a/gcc-4.4.0/gcc/ada/s-fatgen.adb +++ /dev/null @@ -1,921 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ G E N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The implementation here is portable to any IEEE implementation. It does --- not handle non-binary radix, and also assumes that model numbers and --- machine numbers are basically identical, which is not true of all possible --- floating-point implementations. On a non-IEEE machine, this body must be --- specialized appropriately, or better still, its generic instantiations --- should be replaced by efficient machine-specific code. - -with Ada.Unchecked_Conversion; -with System; -package body System.Fat_Gen is - - Float_Radix : constant T := T (T'Machine_Radix); - Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1); - - pragma Assert (T'Machine_Radix = 2); - -- This version does not handle radix 16 - - -- Constants for Decompose and Scaling - - Rad : constant T := T (T'Machine_Radix); - Invrad : constant T := 1.0 / Rad; - - subtype Expbits is Integer range 0 .. 6; - -- 2 ** (2 ** 7) might overflow. How big can radix-16 exponents get? - - Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64); - - R_Power : constant array (Expbits) of T := - (Rad ** 1, - Rad ** 2, - Rad ** 4, - Rad ** 8, - Rad ** 16, - Rad ** 32, - Rad ** 64); - - R_Neg_Power : constant array (Expbits) of T := - (Invrad ** 1, - Invrad ** 2, - Invrad ** 4, - Invrad ** 8, - Invrad ** 16, - Invrad ** 32, - Invrad ** 64); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Decompose (XX : T; Frac : out T; Expo : out UI); - -- Decomposes a floating-point number into fraction and exponent parts. - -- Both results are signed, with Frac having the sign of XX, and UI has - -- the sign of the exponent. The absolute value of Frac is in the range - -- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero. - - function Gradual_Scaling (Adjustment : UI) return T; - -- Like Scaling with a first argument of 1.0, but returns the smallest - -- denormal rather than zero when the adjustment is smaller than - -- Machine_Emin. Used for Succ and Pred. - - -------------- - -- Adjacent -- - -------------- - - function Adjacent (X, Towards : T) return T is - begin - if Towards = X then - return X; - elsif Towards > X then - return Succ (X); - else - return Pred (X); - end if; - end Adjacent; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (X : T) return T is - XT : constant T := Truncation (X); - begin - if X <= 0.0 then - return XT; - elsif X = XT then - return X; - else - return XT + 1.0; - end if; - end Ceiling; - - ------------- - -- Compose -- - ------------- - - function Compose (Fraction : T; Exponent : UI) return T is - Arg_Frac : T; - Arg_Exp : UI; - pragma Unreferenced (Arg_Exp); - begin - Decompose (Fraction, Arg_Frac, Arg_Exp); - return Scaling (Arg_Frac, Exponent); - end Compose; - - --------------- - -- Copy_Sign -- - --------------- - - function Copy_Sign (Value, Sign : T) return T is - Result : T; - - function Is_Negative (V : T) return Boolean; - pragma Import (Intrinsic, Is_Negative); - - begin - Result := abs Value; - - if Is_Negative (Sign) then - return -Result; - else - return Result; - end if; - end Copy_Sign; - - --------------- - -- Decompose -- - --------------- - - procedure Decompose (XX : T; Frac : out T; Expo : out UI) is - X : constant T := T'Machine (XX); - - begin - if X = 0.0 then - Frac := X; - Expo := 0; - - -- More useful would be defining Expo to be T'Machine_Emin - 1 or - -- T'Machine_Emin - T'Machine_Mantissa, which would preserve - -- monotonicity of the exponent function ??? - - -- Check for infinities, transfinites, whatnot - - elsif X > T'Safe_Last then - Frac := Invrad; - Expo := T'Machine_Emax + 1; - - elsif X < T'Safe_First then - Frac := -Invrad; - Expo := T'Machine_Emax + 2; -- how many extra negative values? - - else - -- Case of nonzero finite x. Essentially, we just multiply - -- by Rad ** (+-2**N) to reduce the range. - - declare - Ax : T := abs X; - Ex : UI := 0; - - -- Ax * Rad ** Ex is invariant - - begin - if Ax >= 1.0 then - while Ax >= R_Power (Expbits'Last) loop - Ax := Ax * R_Neg_Power (Expbits'Last); - Ex := Ex + Log_Power (Expbits'Last); - end loop; - - -- Ax < Rad ** 64 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ax >= R_Power (N) then - Ax := Ax * R_Neg_Power (N); - Ex := Ex + Log_Power (N); - end if; - - -- Ax < R_Power (N) - end loop; - - -- 1 <= Ax < Rad - - Ax := Ax * Invrad; - Ex := Ex + 1; - - else - -- 0 < ax < 1 - - while Ax < R_Neg_Power (Expbits'Last) loop - Ax := Ax * R_Power (Expbits'Last); - Ex := Ex - Log_Power (Expbits'Last); - end loop; - - -- Rad ** -64 <= Ax < 1 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ax < R_Neg_Power (N) then - Ax := Ax * R_Power (N); - Ex := Ex - Log_Power (N); - end if; - - -- R_Neg_Power (N) <= Ax < 1 - end loop; - end if; - - if X > 0.0 then - Frac := Ax; - else - Frac := -Ax; - end if; - - Expo := Ex; - end; - end if; - end Decompose; - - -------------- - -- Exponent -- - -------------- - - function Exponent (X : T) return UI is - X_Frac : T; - X_Exp : UI; - pragma Unreferenced (X_Frac); - begin - Decompose (X, X_Frac, X_Exp); - return X_Exp; - end Exponent; - - ----------- - -- Floor -- - ----------- - - function Floor (X : T) return T is - XT : constant T := Truncation (X); - begin - if X >= 0.0 then - return XT; - elsif XT = X then - return X; - else - return XT - 1.0; - end if; - end Floor; - - -------------- - -- Fraction -- - -------------- - - function Fraction (X : T) return T is - X_Frac : T; - X_Exp : UI; - pragma Unreferenced (X_Exp); - begin - Decompose (X, X_Frac, X_Exp); - return X_Frac; - end Fraction; - - --------------------- - -- Gradual_Scaling -- - --------------------- - - function Gradual_Scaling (Adjustment : UI) return T is - Y : T; - Y1 : T; - Ex : UI := Adjustment; - - begin - if Adjustment < T'Machine_Emin - 1 then - Y := 2.0 ** T'Machine_Emin; - Y1 := Y; - Ex := Ex - T'Machine_Emin; - while Ex < 0 loop - Y := T'Machine (Y / 2.0); - - if Y = 0.0 then - return Y1; - end if; - - Ex := Ex + 1; - Y1 := Y; - end loop; - - return Y1; - - else - return Scaling (1.0, Adjustment); - end if; - end Gradual_Scaling; - - ------------------ - -- Leading_Part -- - ------------------ - - function Leading_Part (X : T; Radix_Digits : UI) return T is - L : UI; - Y, Z : T; - - begin - if Radix_Digits >= T'Machine_Mantissa then - return X; - - elsif Radix_Digits <= 0 then - raise Constraint_Error; - - else - L := Exponent (X) - Radix_Digits; - Y := Truncation (Scaling (X, -L)); - Z := Scaling (Y, L); - return Z; - end if; - end Leading_Part; - - ------------- - -- Machine -- - ------------- - - -- The trick with Machine is to force the compiler to store the result - -- in memory so that we do not have extra precision used. The compiler - -- is clever, so we have to outwit its possible optimizations! We do - -- this by using an intermediate pragma Volatile location. - - function Machine (X : T) return T is - Temp : T; - pragma Volatile (Temp); - begin - Temp := X; - return Temp; - end Machine; - - ---------------------- - -- Machine_Rounding -- - ---------------------- - - -- For now, the implementation is identical to that of Rounding, which is - -- a permissible behavior, but is not the most efficient possible approach. - - function Machine_Rounding (X : T) return T is - Result : T; - Tail : T; - - begin - Result := Truncation (abs X); - Tail := abs X - Result; - - if Tail >= 0.5 then - Result := Result + 1.0; - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end Machine_Rounding; - - ----------- - -- Model -- - ----------- - - -- We treat Model as identical to Machine. This is true of IEEE and other - -- nice floating-point systems, but not necessarily true of all systems. - - function Model (X : T) return T is - begin - return Machine (X); - end Model; - - ---------- - -- Pred -- - ---------- - - -- Subtract from the given number a number equivalent to the value of its - -- least significant bit. Given that the most significant bit represents - -- a value of 1.0 * radix ** (exp - 1), the value we want is obtained by - -- shifting this by (mantissa-1) bits to the right, i.e. decreasing the - -- exponent by that amount. - - -- Zero has to be treated specially, since its exponent is zero - - function Pred (X : T) return T is - X_Frac : T; - X_Exp : UI; - - begin - if X = 0.0 then - return -Succ (X); - - else - Decompose (X, X_Frac, X_Exp); - - -- A special case, if the number we had was a positive power of - -- two, then we want to subtract half of what we would otherwise - -- subtract, since the exponent is going to be reduced. - - -- Note that X_Frac has the same sign as X, so if X_Frac is 0.5, - -- then we know that we have a positive number (and hence a - -- positive power of 2). - - if X_Frac = 0.5 then - return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); - - -- Otherwise the exponent is unchanged - - else - return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa); - end if; - end if; - end Pred; - - --------------- - -- Remainder -- - --------------- - - function Remainder (X, Y : T) return T is - A : T; - B : T; - Arg : T; - P : T; - P_Frac : T; - Sign_X : T; - IEEE_Rem : T; - Arg_Exp : UI; - P_Exp : UI; - K : UI; - P_Even : Boolean; - - Arg_Frac : T; - pragma Unreferenced (Arg_Frac); - - begin - if Y = 0.0 then - raise Constraint_Error; - end if; - - if X > 0.0 then - Sign_X := 1.0; - Arg := X; - else - Sign_X := -1.0; - Arg := -X; - end if; - - P := abs Y; - - if Arg < P then - P_Even := True; - IEEE_Rem := Arg; - P_Exp := Exponent (P); - - else - Decompose (Arg, Arg_Frac, Arg_Exp); - Decompose (P, P_Frac, P_Exp); - - P := Compose (P_Frac, Arg_Exp); - K := Arg_Exp - P_Exp; - P_Even := True; - IEEE_Rem := Arg; - - for Cnt in reverse 0 .. K loop - if IEEE_Rem >= P then - P_Even := False; - IEEE_Rem := IEEE_Rem - P; - else - P_Even := True; - end if; - - P := P * 0.5; - end loop; - end if; - - -- That completes the calculation of modulus remainder. The final - -- step is get the IEEE remainder. Here we need to compare Rem with - -- (abs Y) / 2. We must be careful of unrepresentable Y/2 value - -- caused by subnormal numbers - - if P_Exp >= 0 then - A := IEEE_Rem; - B := abs Y * 0.5; - - else - A := IEEE_Rem * 2.0; - B := abs Y; - end if; - - if A > B or else (A = B and then not P_Even) then - IEEE_Rem := IEEE_Rem - abs Y; - end if; - - return Sign_X * IEEE_Rem; - end Remainder; - - -------------- - -- Rounding -- - -------------- - - function Rounding (X : T) return T is - Result : T; - Tail : T; - - begin - Result := Truncation (abs X); - Tail := abs X - Result; - - if Tail >= 0.5 then - Result := Result + 1.0; - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end Rounding; - - ------------- - -- Scaling -- - ------------- - - -- Return x * rad ** adjustment quickly, - -- or quietly underflow to zero, or overflow naturally. - - function Scaling (X : T; Adjustment : UI) return T is - begin - if X = 0.0 or else Adjustment = 0 then - return X; - end if; - - -- Nonzero x essentially, just multiply repeatedly by Rad ** (+-2**n) - - declare - Y : T := X; - Ex : UI := Adjustment; - - -- Y * Rad ** Ex is invariant - - begin - if Ex < 0 then - while Ex <= -Log_Power (Expbits'Last) loop - Y := Y * R_Neg_Power (Expbits'Last); - Ex := Ex + Log_Power (Expbits'Last); - end loop; - - -- -64 < Ex <= 0 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ex <= -Log_Power (N) then - Y := Y * R_Neg_Power (N); - Ex := Ex + Log_Power (N); - end if; - - -- -Log_Power (N) < Ex <= 0 - end loop; - - -- Ex = 0 - - else - -- Ex >= 0 - - while Ex >= Log_Power (Expbits'Last) loop - Y := Y * R_Power (Expbits'Last); - Ex := Ex - Log_Power (Expbits'Last); - end loop; - - -- 0 <= Ex < 64 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ex >= Log_Power (N) then - Y := Y * R_Power (N); - Ex := Ex - Log_Power (N); - end if; - - -- 0 <= Ex < Log_Power (N) - - end loop; - - -- Ex = 0 - end if; - - return Y; - end; - end Scaling; - - ---------- - -- Succ -- - ---------- - - -- Similar computation to that of Pred: find value of least significant - -- bit of given number, and add. Zero has to be treated specially since - -- the exponent can be zero, and also we want the smallest denormal if - -- denormals are supported. - - function Succ (X : T) return T is - X_Frac : T; - X_Exp : UI; - X1, X2 : T; - - begin - if X = 0.0 then - X1 := 2.0 ** T'Machine_Emin; - - -- Following loop generates smallest denormal - - loop - X2 := T'Machine (X1 / 2.0); - exit when X2 = 0.0; - X1 := X2; - end loop; - - return X1; - - else - Decompose (X, X_Frac, X_Exp); - - -- A special case, if the number we had was a negative power of - -- two, then we want to add half of what we would otherwise add, - -- since the exponent is going to be reduced. - - -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, - -- then we know that we have a negative number (and hence a - -- negative power of 2). - - if X_Frac = -0.5 then - return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); - - -- Otherwise the exponent is unchanged - - else - return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa); - end if; - end if; - end Succ; - - ---------------- - -- Truncation -- - ---------------- - - -- The basic approach is to compute - - -- T'Machine (RM1 + N) - RM1 - - -- where N >= 0.0 and RM1 = radix ** (mantissa - 1) - - -- This works provided that the intermediate result (RM1 + N) does not - -- have extra precision (which is why we call Machine). When we compute - -- RM1 + N, the exponent of N will be normalized and the mantissa shifted - -- shifted appropriately so the lower order bits, which cannot contribute - -- to the integer part of N, fall off on the right. When we subtract RM1 - -- again, the significant bits of N are shifted to the left, and what we - -- have is an integer, because only the first e bits are different from - -- zero (assuming binary radix here). - - function Truncation (X : T) return T is - Result : T; - - begin - Result := abs X; - - if Result >= Radix_To_M_Minus_1 then - return Machine (X); - - else - Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1; - - if Result > abs X then - Result := Result - 1.0; - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end if; - end Truncation; - - ----------------------- - -- Unbiased_Rounding -- - ----------------------- - - function Unbiased_Rounding (X : T) return T is - Abs_X : constant T := abs X; - Result : T; - Tail : T; - - begin - Result := Truncation (Abs_X); - Tail := Abs_X - Result; - - if Tail > 0.5 then - Result := Result + 1.0; - - elsif Tail = 0.5 then - Result := 2.0 * Truncation ((Result / 2.0) + 0.5); - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end Unbiased_Rounding; - - ----------- - -- Valid -- - ----------- - - -- Note: this routine does not work for VAX float. We compensate for this - -- in Exp_Attr by using the Valid functions in Vax_Float_Operations rather - -- than the corresponding instantiation of this function. - - function Valid (X : not null access T) return Boolean is - - IEEE_Emin : constant Integer := T'Machine_Emin - 1; - IEEE_Emax : constant Integer := T'Machine_Emax - 1; - - IEEE_Bias : constant Integer := -(IEEE_Emin - 1); - - subtype IEEE_Exponent_Range is - Integer range IEEE_Emin - 1 .. IEEE_Emax + 1; - - -- The implementation of this floating point attribute uses a - -- representation type Float_Rep that allows direct access to the - -- exponent and mantissa parts of a floating point number. - - -- The Float_Rep type is an array of Float_Word elements. This - -- representation is chosen to make it possible to size the type based - -- on a generic parameter. Since the array size is known at compile - -- time, efficient code can still be generated. The size of Float_Word - -- elements should be large enough to allow accessing the exponent in - -- one read, but small enough so that all floating point object sizes - -- are a multiple of the Float_Word'Size. - - -- The following conditions must be met for all possible - -- instantiations of the attributes package: - - -- - T'Size is an integral multiple of Float_Word'Size - - -- - The exponent and sign are completely contained in a single - -- component of Float_Rep, named Most_Significant_Word (MSW). - - -- - The sign occupies the most significant bit of the MSW and the - -- exponent is in the following bits. Unused bits (if any) are in - -- the least significant part. - - type Float_Word is mod 2**Positive'Min (System.Word_Size, 32); - type Rep_Index is range 0 .. 7; - - Rep_Words : constant Positive := - (T'Size + Float_Word'Size - 1) / Float_Word'Size; - Rep_Last : constant Rep_Index := Rep_Index'Min - (Rep_Index (Rep_Words - 1), (T'Mantissa + 16) / Float_Word'Size); - -- Determine the number of Float_Words needed for representing the - -- entire floating-point value. Do not take into account excessive - -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 - -- bits. In general, the exponent field cannot be larger than 15 bits, - -- even for 128-bit floating-point types, so the final format size - -- won't be larger than T'Mantissa + 16. - - type Float_Rep is - array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word; - - pragma Suppress_Initialization (Float_Rep); - -- This pragma suppresses the generation of an initialization procedure - -- for type Float_Rep when operating in Initialize/Normalize_Scalars - -- mode. This is not just a matter of efficiency, but of functionality, - -- since Valid has a pragma Inline_Always, which is not permitted if - -- there are nested subprograms present. - - Most_Significant_Word : constant Rep_Index := - Rep_Last * Standard'Default_Bit_Order; - -- Finding the location of the Exponent_Word is a bit tricky. In general - -- we assume Word_Order = Bit_Order. This expression needs to be refined - -- for VMS. - - Exponent_Factor : constant Float_Word := - 2**(Float_Word'Size - 1) / - Float_Word (IEEE_Emax - IEEE_Emin + 3) * - Boolean'Pos (Most_Significant_Word /= 2) + - Boolean'Pos (Most_Significant_Word = 2); - -- Factor that the extracted exponent needs to be divided by to be in - -- range 0 .. IEEE_Emax - IEEE_Emin + 2. Special kludge: Exponent_Factor - -- is 1 for x86/IA64 double extended as GCC adds unused bits to the - -- type. - - Exponent_Mask : constant Float_Word := - Float_Word (IEEE_Emax - IEEE_Emin + 2) * - Exponent_Factor; - -- Value needed to mask out the exponent field. This assumes that the - -- range IEEE_Emin - 1 .. IEEE_Emax + contains 2**N values, for some N - -- in Natural. - - function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T); - - type Float_Access is access all T; - function To_Address is - new Ada.Unchecked_Conversion (Float_Access, System.Address); - - XA : constant System.Address := To_Address (Float_Access (X)); - - R : Float_Rep; - pragma Import (Ada, R); - for R'Address use XA; - -- R is a view of the input floating-point parameter. Note that we - -- must avoid copying the actual bits of this parameter in float - -- form (since it may be a signalling NaN. - - E : constant IEEE_Exponent_Range := - Integer ((R (Most_Significant_Word) and Exponent_Mask) / - Exponent_Factor) - - IEEE_Bias; - -- Mask/Shift T to only get bits from the exponent. Then convert biased - -- value to integer value. - - SR : Float_Rep; - -- Float_Rep representation of significant of X.all - - begin - if T'Denorm then - - -- All denormalized numbers are valid, so the only invalid numbers - -- are overflows and NaNs, both with exponent = Emax + 1. - - return E /= IEEE_Emax + 1; - - end if; - - -- All denormalized numbers except 0.0 are invalid - - -- Set exponent of X to zero, so we end up with the significand, which - -- definitely is a valid number and can be converted back to a float. - - SR := R; - SR (Most_Significant_Word) := - (SR (Most_Significant_Word) - and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor; - - return (E in IEEE_Emin .. IEEE_Emax) or else - ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0); - end Valid; - - --------------------- - -- Unaligned_Valid -- - --------------------- - - function Unaligned_Valid (A : System.Address) return Boolean is - subtype FS is String (1 .. T'Size / Character'Size); - type FSP is access FS; - - function To_FSP is new Ada.Unchecked_Conversion (Address, FSP); - - Local_T : aliased T; - - begin - -- Note that we have to be sure that we do not load the value into a - -- floating-point register, since a signalling NaN may cause a trap. - -- The following assignment is what does the actual alignment, since - -- we know that the target Local_T is aligned. - - To_FSP (Local_T'Address).all := To_FSP (A).all; - - -- Now that we have an aligned value, we can use the normal aligned - -- version of Valid to obtain the required result. - - return Valid (Local_T'Access); - end Unaligned_Valid; - -end System.Fat_Gen; |