diff options
Diffstat (limited to 'gcc/ada/exp_pakd.adb')
| -rw-r--r-- | gcc/ada/exp_pakd.adb | 188 |
1 files changed, 144 insertions, 44 deletions
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index e8c607adda5..a0440cae4b5 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 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- -- @@ -31,9 +31,9 @@ with Exp_Dbug; use Exp_Dbug; with Exp_Util; use Exp_Util; with Nlists; use Nlists; with Nmake; use Nmake; -with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; @@ -298,7 +298,7 @@ package body Exp_Pakd is -- a packed array whose component size is N. RE_Null is used as a null -- entry, for the cases where a library routine is not used. - Set_Id : E_Array := + Set_Id : constant E_Array := (01 => RE_Null, 02 => RE_Null, 03 => RE_Set_03, @@ -368,7 +368,7 @@ package body Exp_Pakd is -- not be fully aligned. This only affects the even sizes, since for the -- odd sizes, we do not get any fixed alignment in any case. - SetU_Id : E_Array := + SetU_Id : constant E_Array := (01 => RE_Null, 02 => RE_Null, 03 => RE_Set_03, @@ -515,10 +515,10 @@ package body Exp_Pakd is -- On return: -- -- Obj is the object containing the desired bit field. It is of type - -- Unsigned or Long_Long_Unsigned, and is either the entire value, - -- for the small static case, or the proper selected byte from the - -- array in the large or dynamic case. This node is analyzed and - -- resolved on return. + -- Unsigned, Long_Unsigned, or Long_Long_Unsigned, and is either the + -- entire value, for the small static case, or the proper selected byte + -- from the array in the large or dynamic case. This node is analyzed + -- and resolved on return. -- -- Shift is a node representing the shift count to be used in the -- rotate right instruction that positions the field for access. @@ -768,7 +768,7 @@ package body Exp_Pakd is -- Set Esize and RM_Size to the actual size of the packed object -- Do not reset RM_Size if already set, as happens in the case - -- of a modular type + -- of a modular type. Set_Esize (PAT, Esiz); @@ -887,7 +887,7 @@ package body Exp_Pakd is Set_Packed_Array_Type (Typ, PAT); declare - Indexes : List_Id := New_List; + Indexes : constant List_Id := New_List; Indx : Node_Id; Indx_Typ : Entity_Id; Enum_Case : Boolean; @@ -1049,43 +1049,63 @@ package body Exp_Pakd is -- Temporarily attach the length expression to the tree and analyze -- and resolve it, so that we can test its value. We assume that the - -- total length fits in type Integer. + -- total length fits in type Integer. This expression may involve + -- discriminants, so we treat it as a default/per-object expression. Set_Parent (Len_Expr, Typ); - Analyze_And_Resolve (Len_Expr, Standard_Integer); + Analyze_Per_Use_Expression (Len_Expr, Standard_Integer); -- Use a modular type if possible. We can do this if we are we -- have static bounds, and the length is small enough, and the -- length is not zero. We exclude the zero length case because the -- size of things is always at least one, and the zero length object - -- would have an anomous size + -- would have an anomous size. if Compile_Time_Known_Value (Len_Expr) then Len_Bits := Expr_Value (Len_Expr) * Csize; -- We normally consider small enough to mean no larger than the - -- value of System_Max_Binary_Modulus_Power, except that in - -- No_Run_Time mode, we use the Word Size on machines for - -- which double length shifts are not generated in line. + -- value of System_Max_Binary_Modulus_Power, checking that in the + -- case of values longer than word size, we have long shifts. if Len_Bits > 0 and then (Len_Bits <= System_Word_Size or else (Len_Bits <= System_Max_Binary_Modulus_Power - and then (not No_Run_Time - or else - Long_Shifts_Inlined_On_Target))) + and then Support_Long_Shifts_On_Target)) + + -- Also test for alignment given. If an alignment is given which + -- is smaller than the natural modular alignment, force the array + -- of bytes representation to accommodate the alignment. + + and then + (No (Alignment_Clause (Typ)) + or else + Alignment (Typ) >= ((Len_Bits + System_Storage_Unit) + / System_Storage_Unit)) then -- We can use the modular type, it has the form: -- subtype tttPn is btyp -- range 0 .. 2 ** (Esize (Typ) * Csize) - 1; - -- Here Siz is 1, 2 or 4, as computed above, and btyp is either - -- Unsigned or Long_Long_Unsigned depending on the length. + -- The bounds are statically known, and btyp is one + -- of the unsigned types, depending on the length. If the + -- type is its first subtype, i.e. it is a user-defined + -- type, no object of the type will be larger, and it is + -- worthwhile to use a small unsigned type. - if Len_Bits <= Standard_Integer_Size then + if Len_Bits <= Standard_Short_Integer_Size + and then First_Subtype (Typ) = Typ + then + Btyp := RTE (RE_Short_Unsigned); + + elsif Len_Bits <= Standard_Integer_Size then Btyp := RTE (RE_Unsigned); + + elsif Len_Bits <= Standard_Long_Integer_Size then + Btyp := RTE (RE_Long_Unsigned); + else Btyp := RTE (RE_Long_Long_Unsigned); end if; @@ -1187,9 +1207,15 @@ package body Exp_Pakd is PAT : Entity_Id; Ctyp : Entity_Id; Csiz : Int; - Shift : Node_Id; Cmask : Uint; + Shift : Node_Id; + -- The expression for the shift value that is required + + Shift_Used : Boolean := False; + -- Set True if Shift has been used in the generated code at least + -- once, so that it must be duplicated if used again + New_Lhs : Node_Id; New_Rhs : Node_Id; @@ -1200,6 +1226,33 @@ package body Exp_Pakd is -- contains the value. Otherwise Rhs_Val_Known is set False, and -- the Rhs_Val is undefined. + function Get_Shift return Node_Id; + -- Function used to get the value of Shift, making sure that it + -- gets duplicated if the function is called more than once. + + --------------- + -- Get_Shift -- + --------------- + + function Get_Shift return Node_Id is + begin + -- If we used the shift value already, then duplicate it. We + -- set a temporary parent in case actions have to be inserted. + + if Shift_Used then + Set_Parent (Shift, N); + return Duplicate_Subexpr_No_Checks (Shift); + + -- If first time, use Shift unchanged, and set flag for first use + + else + Shift_Used := True; + return Shift; + end if; + end Get_Shift; + + -- Start of processing for Expand_Bit_Packed_Element_Set + begin pragma Assert (Is_Bit_Packed_Array (Etype (Prefix (Lhs)))); @@ -1290,7 +1343,7 @@ package body Exp_Pakd is end if; New_Lhs := Duplicate_Subexpr (Obj, True); - New_Rhs := Duplicate_Subexpr (Obj); + New_Rhs := Duplicate_Subexpr_No_Checks (Obj); -- First we deal with the "and" @@ -1304,7 +1357,7 @@ package body Exp_Pakd is Mask1 := Make_Integer_Literal (Loc, Modulus (Etype (Obj)) - 1 - - (Cmask * (2 ** Expr_Value (Shift)))); + (Cmask * (2 ** Expr_Value (Get_Shift)))); Set_Print_In_Hex (Mask1); else @@ -1312,7 +1365,7 @@ package body Exp_Pakd is Set_Print_In_Hex (Lit); Mask1 := Make_Op_Not (Loc, - Right_Opnd => Make_Shift_Left (Lit, Shift)); + Right_Opnd => Make_Shift_Left (Lit, Get_Shift)); end if; New_Rhs := @@ -1366,11 +1419,11 @@ package body Exp_Pakd is begin if Rhs_Val_Known - and then Compile_Time_Known_Value (Shift) + and then Compile_Time_Known_Value (Get_Shift) then Or_Rhs := Make_Integer_Literal (Loc, - Rhs_Val * (2 ** Expr_Value (Shift))); + Rhs_Val * (2 ** Expr_Value (Get_Shift))); Set_Print_In_Hex (Or_Rhs); else @@ -1407,7 +1460,7 @@ package body Exp_Pakd is Fixup_Rhs; end if; - Or_Rhs := Make_Shift_Left (Rhs, Shift); + Or_Rhs := Make_Shift_Left (Rhs, Get_Shift); end if; if Nkind (New_Rhs) = N_Op_And then @@ -1446,6 +1499,13 @@ package body Exp_Pakd is Atyp : Entity_Id; begin + if No (Bits_nn) then + + -- Error, most likely High_Integrity_Mode restriction. + + return; + end if; + -- Acquire proper Set entity. We use the aligned or unaligned -- case as appropriate. @@ -1462,11 +1522,18 @@ package body Exp_Pakd is Atyp := Etype (Obj); Compute_Linear_Subscript (Atyp, Lhs, Subscr); + -- Below we must make the assumption that Obj is + -- at least byte aligned, since otherwise its address + -- cannot be taken. The assumption holds since the + -- only arrays that can be misaligned are small packed + -- arrays which are implemented as a modular type, and + -- that is not the case here. + Rewrite (N, Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Set_nn, Loc), Parameter_Associations => New_List ( - Make_Byte_Aligned_Attribute_Reference (Loc, + Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => Obj), Subscr, @@ -1652,7 +1719,12 @@ package body Exp_Pakd is -- convert to the base type, since this would be unconstrained, and -- hence not have a corresponding packed array type set. - if Is_Modular_Integer_Type (PAT) then + -- Note that both operands must be modular for this code to be used. + + if Is_Modular_Integer_Type (PAT) + and then + Is_Modular_Integer_Type (Etype (R)) + then declare P : Node_Id; @@ -1686,6 +1758,11 @@ package body Exp_Pakd is -- operands in bits. Then we replace the expression by a reference -- to Result. + -- Note that if we are mixing a modular and array operand, everything + -- works fine, since we ensure that the modular representation has the + -- same physical layout as the array representation (that's what the + -- left justified modular stuff in the big-endian case is about). + else declare Result_Ent : constant Entity_Id := @@ -1818,6 +1895,11 @@ package body Exp_Pakd is Left_Opnd => Make_Shift_Right (Obj, Shift), Right_Opnd => Lit); + -- We neded to analyze this before we do the unchecked convert + -- below, but we need it temporarily attached to the tree for + -- this analysis (hence the temporary Set_Parent call). + + Set_Parent (Arg, Parent (N)); Analyze_And_Resolve (Arg); Rewrite (N, @@ -1850,12 +1932,18 @@ package body Exp_Pakd is Compute_Linear_Subscript (Atyp, N, Subscr); + -- Below we make the assumption that Obj is at least byte + -- aligned, since otherwise its address cannot be taken. + -- The assumption holds since the only arrays that can be + -- misaligned are small packed arrays which are implemented + -- as a modular type, and that is not the case here. + Rewrite (N, Unchecked_Convert_To (Ctyp, Make_Function_Call (Loc, Name => New_Occurrence_Of (Get_nn, Loc), Parameter_Associations => New_List ( - Make_Byte_Aligned_Attribute_Reference (Loc, + Make_Attribute_Reference (Loc, Attribute_Name => Name_Address, Prefix => Obj), Subscr)))); @@ -2220,9 +2308,19 @@ package body Exp_Pakd is return Known_Aligned_Enough (Prefix (Obj), Csiz); end if; - -- If not selected or indexed component, must be aligned + elsif Nkind (Obj) = N_Type_Conversion then + return Known_Aligned_Enough (Expression (Obj), Csiz); + -- For a formal parameter, it is safer to assume that it is not + -- aligned, because the formal may be unconstrained while the actual + -- is constrained. In this situation, a small constrained packed + -- array, represented in modular form, may be unaligned. + + elsif Is_Entity_Name (Obj) then + return not Is_Formal (Entity (Obj)); else + + -- If none of the above, must be aligned return True; end if; end Known_Aligned_Enough; @@ -2288,20 +2386,24 @@ package body Exp_Pakd is Source_Siz := UI_To_Int (RM_Size (Source_Typ)); Target_Siz := UI_To_Int (RM_Size (Target_Typ)); + -- First step, if the source type is not a discrete type, then we + -- first convert to a modular type of the source length, since + -- otherwise, on a big-endian machine, we get left-justification. + -- We do it for little-endian machines as well, because there might + -- be junk bits that are not cleared if the type is not numeric. + + if Source_Siz /= Target_Siz + and then not Is_Discrete_Type (Source_Typ) + then + Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src); + end if; + -- In the big endian case, if the lengths of the two types differ, -- then we must worry about possible left justification in the -- conversion, and avoiding that is what this is all about. if Bytes_Big_Endian and then Source_Siz /= Target_Siz then - -- First step, if the source type is not a discrete type, then we - -- first convert to a modular type of the source length, since - -- otherwise, on a big-endian machine, we get left-justification. - - if not Is_Discrete_Type (Source_Typ) then - Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src); - end if; - -- Next step. If the target is not a discrete type, then we first -- convert to a modular type of the target length, since -- otherwise, on a big-endian machine, we get left-justification. @@ -2390,14 +2492,12 @@ package body Exp_Pakd is Shift : out Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Ctyp : Entity_Id; PAT : Entity_Id; Otyp : Entity_Id; Csiz : Uint; Osiz : Uint; begin - Ctyp := Component_Type (Atyp); Csiz := Component_Size (Atyp); Convert_To_PAT_Type (Obj); @@ -2407,7 +2507,7 @@ package body Exp_Pakd is if Is_Array_Type (PAT) then Otyp := Component_Type (PAT); - Osiz := Esize (Otyp); + Osiz := Component_Size (PAT); else Otyp := PAT; |