------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ V F P T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1997-2012, 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Atree; use Atree; with Einfo; use Einfo; with Nlists; use Nlists; with Nmake; use Nmake; with Rtsfind; use Rtsfind; with Sem_Res; use Sem_Res; with Sinfo; use Sinfo; with Stand; use Stand; with Tbuild; use Tbuild; with Urealp; use Urealp; with Eval_Fat; use Eval_Fat; package body Exp_VFpt is -- Vax floating point format (from Vax Architecture Reference Manual -- version 6): -- Float F: -- -------- -- 1 1 -- 5 4 7 6 0 -- +-+---------------+--------------+ -- |S| exp | fraction | A -- +-+---------------+--------------+ -- | fraction | A + 2 -- +--------------------------------+ -- bit 15 is the sign bit, -- bits 14:7 is the excess 128 binary exponent, -- bits 6:0 and 31:16 the normalized 24-bit fraction with the redundant -- most significant fraction bit not represented. -- An exponent value of 0 together with a sign bit of 0, is taken to -- indicate that the datum has a value of 0. Exponent values of 1 through -- 255 indicate true binary exponents of -127 to +127. An exponent value -- of 0, together with a sign bit of 1, is taken as reserved. -- Note that fraction bits are not continuous in memory, VAX is little -- endian (LSB first). -- Float D: -- -------- -- 1 1 -- 5 4 7 6 0 -- +-+---------------+--------------+ -- |S| exp | fraction | A -- +-+---------------+--------------+ -- | fraction | A + 2 -- +--------------------------------+ -- | fraction | A + 4 -- +--------------------------------+ -- | fraction (low) | A + 6 -- +--------------------------------+ -- Note that the fraction bits are not continuous in memory. Bytes in a -- words are stored in little endian format, but words are stored using -- big endian format (PDP endian). -- Like Float F but with 55 bits for the fraction. -- Float G: -- -------- -- 1 1 -- 5 4 4 3 0 -- +-+---------------------+--------+ -- |S| exp | fract | A -- +-+---------------------+--------+ -- | fraction | A + 2 -- +--------------------------------+ -- | fraction | A + 4 -- +--------------------------------+ -- | fraction (low) | A + 6 -- +--------------------------------+ -- Exponent values of 1 through 2047 indicate true binary exponents of -- -1023 to +1023. -- Main differences compared to IEEE 754: -- * No denormalized numbers -- * No infinity -- * No NaN -- * No -0.0 -- * Reserved values (exp = 0, sign = 1) -- * Vax mantissa represent values [0.5, 1) -- * Bias is shifted by 1 (for single float: 128 on Vax, 127 on IEEE) VAXFF_Digits : constant := 6; VAXDF_Digits : constant := 9; VAXGF_Digits : constant := 15; ---------------------- -- Expand_Vax_Arith -- ---------------------- procedure Expand_Vax_Arith (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Base_Type (Etype (N)); Typc : Character; Atyp : Entity_Id; Func : RE_Id; Args : List_Id; begin -- Get arithmetic type, note that we do D stuff in G if Digits_Value (Typ) = VAXFF_Digits then Typc := 'F'; Atyp := RTE (RE_F); else Typc := 'G'; Atyp := RTE (RE_G); end if; case Nkind (N) is when N_Op_Abs => if Typc = 'F' then Func := RE_Abs_F; else Func := RE_Abs_G; end if; when N_Op_Add => if Typc = 'F' then Func := RE_Add_F; else Func := RE_Add_G; end if; when N_Op_Divide => if Typc = 'F' then Func := RE_Div_F; else Func := RE_Div_G; end if; when N_Op_Multiply => if Typc = 'F' then Func := RE_Mul_F; else Func := RE_Mul_G; end if; when N_Op_Minus => if Typc = 'F' then Func := RE_Neg_F; else Func := RE_Neg_G; end if; when N_Op_Subtract => if Typc = 'F' then Func := RE_Sub_F; else Func := RE_Sub_G; end if; when others => Func := RE_Null; raise Program_Error; end case; Args := New_List; if Nkind (N) in N_Binary_Op then Append_To (Args, Convert_To (Atyp, Left_Opnd (N))); end if; Append_To (Args, Convert_To (Atyp, Right_Opnd (N))); Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (Func), Loc), Parameter_Associations => Args))); Analyze_And_Resolve (N, Typ, Suppress => All_Checks); end Expand_Vax_Arith; --------------------------- -- Expand_Vax_Comparison -- --------------------------- procedure Expand_Vax_Comparison (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N))); Typc : Character; Func : RE_Id; Atyp : Entity_Id; Revrs : Boolean := False; Args : List_Id; begin -- Get arithmetic type, note that we do D stuff in G if Digits_Value (Typ) = VAXFF_Digits then Typc := 'F'; Atyp := RTE (RE_F); else Typc := 'G'; Atyp := RTE (RE_G); end if; case Nkind (N) is when N_Op_Eq => if Typc = 'F' then Func := RE_Eq_F; else Func := RE_Eq_G; end if; when N_Op_Ge => if Typc = 'F' then Func := RE_Le_F; else Func := RE_Le_G; end if; Revrs := True; when N_Op_Gt => if Typc = 'F' then Func := RE_Lt_F; else Func := RE_Lt_G; end if; Revrs := True; when N_Op_Le => if Typc = 'F' then Func := RE_Le_F; else Func := RE_Le_G; end if; when N_Op_Lt => if Typc = 'F' then Func := RE_Lt_F; else Func := RE_Lt_G; end if; when N_Op_Ne => if Typc = 'F' then Func := RE_Ne_F; else Func := RE_Ne_G; end if; when others => Func := RE_Null; raise Program_Error; end case; if not Revrs then Args := New_List ( Convert_To (Atyp, Left_Opnd (N)), Convert_To (Atyp, Right_Opnd (N))); else Args := New_List ( Convert_To (Atyp, Right_Opnd (N)), Convert_To (Atyp, Left_Opnd (N))); end if; Rewrite (N, Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (Func), Loc), Parameter_Associations => Args)); Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end Expand_Vax_Comparison; --------------------------- -- Expand_Vax_Conversion -- --------------------------- procedure Expand_Vax_Conversion (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Expr : constant Node_Id := Expression (N); S_Typ : constant Entity_Id := Base_Type (Etype (Expr)); T_Typ : constant Entity_Id := Base_Type (Etype (N)); CallS : RE_Id; CallT : RE_Id; Func : RE_Id; function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; -- Given one of the two types T, determines the corresponding call -- type, i.e. the type to be used for the call (or the result of -- the call). The actual operand is converted to (or from) this type. -- Otyp is the other type, which is useful in figuring out the result. -- The result returned is the RE_Id value for the type entity. function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id; -- Find the predefined integer type that has the same size as the -- fixed-point type T, for use in fixed/float conversions. --------------- -- Call_Type -- --------------- function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is begin -- Vax float formats if Vax_Float (T) then if Digits_Value (T) = VAXFF_Digits then return RE_F; elsif Digits_Value (T) = VAXGF_Digits then return RE_G; -- For D_Float, leave it as D float if the other operand is -- G_Float, since this is the one conversion that is properly -- supported for D_Float, but otherwise, use G_Float. else pragma Assert (Digits_Value (T) = VAXDF_Digits); if Vax_Float (Otyp) and then Digits_Value (Otyp) = VAXGF_Digits then return RE_D; else return RE_G; end if; end if; -- For all discrete types, use 64-bit integer elsif Is_Discrete_Type (T) then return RE_Q; -- For all real types (other than Vax float format), we use the -- IEEE float-type which corresponds in length to the other type -- (which is Vax Float). else pragma Assert (Is_Real_Type (T)); if Digits_Value (Otyp) = VAXFF_Digits then return RE_S; else return RE_T; end if; end if; end Call_Type; ------------------------------------------------- -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- ------------------------------------------------- function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is begin if Esize (T) = Esize (Standard_Long_Long_Integer) then return Standard_Long_Long_Integer; elsif Esize (T) = Esize (Standard_Long_Integer) then return Standard_Long_Integer; else return Standard_Integer; end if; end Equivalent_Integer_Type; -- Start of processing for Expand_Vax_Conversion; begin -- If input and output are the same Vax type, we change the -- conversion to be an unchecked conversion and that's it. if Vax_Float (S_Typ) and then Vax_Float (T_Typ) and then Digits_Value (S_Typ) = Digits_Value (T_Typ) then Rewrite (N, Unchecked_Convert_To (T_Typ, Expr)); -- Case of conversion of fixed-point type to Vax_Float type elsif Is_Fixed_Point_Type (S_Typ) then -- If Conversion_OK set, then we introduce an intermediate IEEE -- target type since we are expecting the code generator to handle -- the case of integer to IEEE float. if Conversion_OK (N) then Rewrite (N, Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr))); -- Otherwise, convert the scaled integer value to the target type, -- and multiply by 'Small of type. else Rewrite (N, Make_Op_Multiply (Loc, Left_Opnd => Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (T_Typ, Loc), Expression => Unchecked_Convert_To ( Equivalent_Integer_Type (S_Typ), Expr)), Right_Opnd => Make_Real_Literal (Loc, Realval => Small_Value (S_Typ)))); end if; -- Case of conversion of Vax_Float type to fixed-point type elsif Is_Fixed_Point_Type (T_Typ) then -- If Conversion_OK set, then we introduce an intermediate IEEE -- target type, since we are expecting the code generator to handle -- the case of IEEE float to integer. if Conversion_OK (N) then Rewrite (N, OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr))); -- Otherwise, multiply value by 'small of type, and convert to the -- corresponding integer type. else Rewrite (N, Unchecked_Convert_To (T_Typ, Make_Type_Conversion (Loc, Subtype_Mark => New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc), Expression => Make_Op_Multiply (Loc, Left_Opnd => Expr, Right_Opnd => Make_Real_Literal (Loc, Realval => Ureal_1 / Small_Value (T_Typ)))))); end if; -- All other cases else -- Compute types for call CallS := Call_Type (S_Typ, T_Typ); CallT := Call_Type (T_Typ, S_Typ); -- Get function and its types if CallS = RE_D and then CallT = RE_G then Func := RE_D_To_G; elsif CallS = RE_G and then CallT = RE_D then Func := RE_G_To_D; elsif CallS = RE_G and then CallT = RE_F then Func := RE_G_To_F; elsif CallS = RE_F and then CallT = RE_G then Func := RE_F_To_G; elsif CallS = RE_F and then CallT = RE_S then Func := RE_F_To_S; elsif CallS = RE_S and then CallT = RE_F then Func := RE_S_To_F; elsif CallS = RE_G and then CallT = RE_T then Func := RE_G_To_T; elsif CallS = RE_T and then CallT = RE_G then Func := RE_T_To_G; elsif CallS = RE_F and then CallT = RE_Q then Func := RE_F_To_Q; elsif CallS = RE_Q and then CallT = RE_F then Func := RE_Q_To_F; elsif CallS = RE_G and then CallT = RE_Q then Func := RE_G_To_Q; else pragma Assert (CallS = RE_Q and then CallT = RE_G); Func := RE_Q_To_G; end if; Rewrite (N, Convert_To (T_Typ, Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (Func), Loc), Parameter_Associations => New_List ( Convert_To (RTE (CallS), Expr))))); end if; Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); end Expand_Vax_Conversion; ------------------------------- -- Expand_Vax_Foreign_Return -- ------------------------------- procedure Expand_Vax_Foreign_Return (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Base_Type (Etype (N)); Func : RE_Id; Args : List_Id; Atyp : Entity_Id; Rtyp : constant Entity_Id := Etype (N); begin if Digits_Value (Typ) = VAXFF_Digits then Func := RE_Return_F; Atyp := RTE (RE_F); elsif Digits_Value (Typ) = VAXDF_Digits then Func := RE_Return_D; Atyp := RTE (RE_D); else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); Func := RE_Return_G; Atyp := RTE (RE_G); end if; Args := New_List (Convert_To (Atyp, N)); Rewrite (N, Convert_To (Rtyp, Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (Func), Loc), Parameter_Associations => Args))); Analyze_And_Resolve (N, Typ, Suppress => All_Checks); end Expand_Vax_Foreign_Return; -------------------------------- -- Vax_Real_Literal_As_Signed -- -------------------------------- function Get_Vax_Real_Literal_As_Signed (N : Node_Id) return Uint is Btyp : constant Entity_Id := Base_Type (Underlying_Type (Etype (N))); Value : constant Ureal := Realval (N); Negative : Boolean; Fraction : UI; Exponent : UI; Res : UI; Exponent_Size : Uint; -- Number of bits for the exponent Fraction_Size : Uint; -- Number of bits for the fraction Uintp_Mark : constant Uintp.Save_Mark := Mark; -- Use the mark & release feature to delete temporaries begin -- Extract the sign now Negative := UR_Is_Negative (Value); -- Decompose the number Decompose_Int (Btyp, abs Value, Fraction, Exponent, Round_Even); -- Number of bits for the fraction, leading fraction bit is implicit Fraction_Size := Machine_Mantissa_Value (Btyp) - Int'(1); -- Number of bits for the exponent (one bit for the sign) Exponent_Size := RM_Size (Btyp) - Fraction_Size - Int'(1); if Fraction = Uint_0 then -- Handle zero Res := Uint_0; elsif Exponent <= -(Uint_2 ** (Exponent_Size - 1)) then -- Underflow Res := Uint_0; else -- Check for overflow pragma Assert (Exponent < Uint_2 ** (Exponent_Size - 1)); -- MSB of the fraction must be 1 pragma Assert (Fraction / Uint_2 ** Fraction_Size = Uint_1); -- Remove the redudant most significant fraction bit Fraction := Fraction - Uint_2 ** Fraction_Size; -- Build the fraction part. Note that this field is in mixed -- endianness: words are stored using little endianness, while bytes -- in words are stored using big endianness. Res := Uint_0; for I in 1 .. UI_To_Int (RM_Size (Btyp)) / 16 loop Res := (Res * (Uint_2 ** 16)) + (Fraction mod (Uint_2 ** 16)); Fraction := Fraction / (Uint_2 ** 16); end loop; -- The sign bit if Negative then Res := Res + Int (2**15); end if; -- The exponent Res := Res + (Exponent + Uint_2 ** (Exponent_Size - 1)) * Uint_2 ** (15 - Exponent_Size); -- Until now, we have created an unsigned number, but an underlying -- type is a signed type. Convert to a signed number to avoid -- overflow in gigi. if Res >= Uint_2 ** (Exponent_Size + Fraction_Size) then Res := Res - Uint_2 ** (Exponent_Size + Fraction_Size + 1); end if; end if; Release_And_Save (Uintp_Mark, Res); return Res; end Get_Vax_Real_Literal_As_Signed; ---------------------- -- Expand_Vax_Valid -- ---------------------- procedure Expand_Vax_Valid (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); Pref : constant Node_Id := Prefix (N); Ptyp : constant Entity_Id := Root_Type (Etype (Pref)); Rtyp : constant Entity_Id := Etype (N); Vtyp : RE_Id; Func : RE_Id; begin if Digits_Value (Ptyp) = VAXFF_Digits then Func := RE_Valid_F; Vtyp := RE_F; elsif Digits_Value (Ptyp) = VAXDF_Digits then Func := RE_Valid_D; Vtyp := RE_D; else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits); Func := RE_Valid_G; Vtyp := RE_G; end if; Rewrite (N, Convert_To (Rtyp, Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (Func), Loc), Parameter_Associations => New_List ( Convert_To (RTE (Vtyp), Pref))))); Analyze_And_Resolve (N); end Expand_Vax_Valid; end Exp_VFpt;