From 22862ba6d688c95d9f9577746d212183a11c44da Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Mon, 22 Jul 2019 13:57:46 +0000 Subject: [PATCH] [Ada] Usage of signed type in array bounds in CCG 2019-07-22 Javier Miranda gcc/ada/ * exp_ch4.adb (Size_In_Storage_Elements): Improve the expansion to handle array indexes that are modular type. (Expand_N_Allocator): For 32-bit targets improve the generation of the runtime check associated with large arrays supporting arrays initialized with a qualified expression. * libgnat/s-imenne.adb (Image_Enumeration_8, Image_Enumeration_16, Image_Enumeration_32): Define the index of Index_Table with range Natural'First .. Names'Length since in the worst case all the literals of the enumeration type would be single letter literals and the Table built by the frontend would have as many components as the length of the names string. As a result of this enhancement, the internal tables declared using Index_Table have a length closer to the real needs, thus avoiding the declaration of large arrays on 32-bit CCG targets. From-SVN: r273685 --- gcc/ada/ChangeLog | 17 +++++ gcc/ada/exp_ch4.adb | 167 ++++++++++++++++++++++++++++++++++++++----- gcc/ada/libgnat/s-imenne.adb | 9 ++- 3 files changed, 173 insertions(+), 20 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f47d247..ac990be 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2019-07-22 Javier Miranda + + * exp_ch4.adb (Size_In_Storage_Elements): Improve the expansion + to handle array indexes that are modular type. + (Expand_N_Allocator): For 32-bit targets improve the generation + of the runtime check associated with large arrays supporting + arrays initialized with a qualified expression. + * libgnat/s-imenne.adb (Image_Enumeration_8, + Image_Enumeration_16, Image_Enumeration_32): Define the index of + Index_Table with range Natural'First .. Names'Length since in + the worst case all the literals of the enumeration type would be + single letter literals and the Table built by the frontend would + have as many components as the length of the names string. As a + result of this enhancement, the internal tables declared using + Index_Table have a length closer to the real needs, thus + avoiding the declaration of large arrays on 32-bit CCG targets. + 2019-07-22 Yannick Moy * sem_ch3.adb (Constrain_Access): Issue a message about ignored diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 7ea96de..117d6d6 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -4249,9 +4249,12 @@ package body Exp_Ch4 is function Size_In_Storage_Elements (E : Entity_Id) return Node_Id; -- Given a constrained array type E, returns a node representing the - -- code to compute the size in storage elements for the given type. - -- This is done without using the attribute (which malfunctions for - -- large sizes ???) + -- code to compute a close approximation of the size in storage elements + -- for the given type; for indexes that are modular types we compute + -- 'Last - First (instead of 'Length) because for large arrays computing + -- 'Last -'First + 1 causes overflow. This is done without using the + -- attribute 'Size_In_Storage_Elements (which malfunctions for large + -- sizes ???) ------------------------- -- Rewrite_Coextension -- @@ -4310,17 +4313,77 @@ package body Exp_Ch4 is -- just a fraction of a storage element??? declare + Idx : Node_Id := First_Index (E); Len : Node_Id; Res : Node_Id; pragma Warnings (Off, Res); begin for J in 1 .. Number_Dimensions (E) loop - Len := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (E, Loc), - Attribute_Name => Name_Length, - Expressions => New_List (Make_Integer_Literal (Loc, J))); + + if not Is_Modular_Integer_Type (Etype (Idx)) then + Len := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Length, + Expressions => New_List + (Make_Integer_Literal (Loc, J))); + + -- For indexes that are modular types we cannot generate code + -- to compute 'Length since for large arrays 'Last -'First + 1 + -- causes overflow; therefore we compute 'Last - 'First (which + -- is not the exact number of components but it is valid for + -- the purpose of this runtime check on 32-bit targets) + + else + declare + Len_Minus_1_Expr : Node_Id; + Test_Gt : Node_Id; + + begin + Test_Gt := + Make_Op_Gt (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Last, + Expressions => + New_List (Make_Integer_Literal (Loc, J))), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_First, + Expressions => + New_List (Make_Integer_Literal (Loc, J)))); + + Len_Minus_1_Expr := + Convert_To (Standard_Unsigned, + Make_Op_Subtract (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_Last, + Expressions => + New_List + (Make_Integer_Literal (Loc, J))), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (E, Loc), + Attribute_Name => Name_First, + Expressions => + New_List + (Make_Integer_Literal (Loc, J))))); + + -- Handle superflat arrays, i.e. arrays with such bounds + -- as 4 .. 2, to insure that the result is correct. + + -- Generate: + -- (if X'Last > X'First then X'Last - X'First else 0) + + Len := + Make_If_Expression (Loc, + Expressions => New_List ( + Test_Gt, + Len_Minus_1_Expr, + Make_Integer_Literal (Loc, Uint_0))); + end; + end if; if J = 1 then Res := Len; @@ -4331,6 +4394,8 @@ package body Exp_Ch4 is Left_Opnd => Res, Right_Opnd => Len); end if; + + Next_Index (Idx); end loop; return @@ -4573,15 +4638,83 @@ package body Exp_Ch4 is -- apply the check for constrained arrays, and manually compute the -- value of the attribute ??? - if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then - Insert_Action (N, - Make_Raise_Storage_Error (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => Size_In_Storage_Elements (Etyp), - Right_Opnd => - Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))), - Reason => SE_Object_Too_Large)); + -- The check on No_Initialization is used here to prevent generating + -- this runtime check twice when the allocator is locally replaced by + -- the expander by another one. + + if Is_Array_Type (Etyp) and then not No_Initialization (N) then + declare + Cond : Node_Id; + Ins_Nod : Node_Id := N; + Siz_Typ : Entity_Id := Etyp; + Expr : Node_Id; + + begin + -- For unconstrained array types initialized with a qualified + -- expression we use its type to perform this check + + if not Is_Constrained (Etyp) + and then not No_Initialization (N) + and then Nkind (Expression (N)) = N_Qualified_Expression + then + Expr := Expression (Expression (N)); + Siz_Typ := Etype (Expression (Expression (N))); + + -- If the qualified expression has been moved to an internal + -- temporary (to remove side effects) then we must insert + -- the runtime check before its declaration to ensure that + -- the check is performed before the execution of the code + -- computing the qualified expression. + + if Nkind (Expr) = N_Identifier + and then Is_Internal_Name (Chars (Expr)) + and then + Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Ins_Nod := Parent (Entity (Expr)); + else + Ins_Nod := Expr; + end if; + end if; + + if Is_Constrained (Siz_Typ) + and then Ekind (Siz_Typ) /= E_String_Literal_Subtype + then + -- For CCG targets the largest array may have up to 2**31-1 + -- components (i.e. 2 Gigabytes if each array component is + -- 1-byte). This insures that fat pointer fields do not + -- overflow, since they are 32-bit integer types, and also + -- insures that 'Length can be computed at run time. + + if Modify_Tree_For_C then + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Size_In_Storage_Elements (Siz_Typ), + Right_Opnd => Make_Integer_Literal (Loc, + Uint_2 ** 31 - Uint_1)); + + -- For native targets the largest object is 3.5 gigabytes + + else + Cond := + Make_Op_Gt (Loc, + Left_Opnd => Size_In_Storage_Elements (Siz_Typ), + Right_Opnd => Make_Integer_Literal (Loc, + Uint_7 * (Uint_2 ** 29))); + end if; + + Insert_Action (Ins_Nod, + Make_Raise_Storage_Error (Loc, + Condition => Cond, + Reason => SE_Object_Too_Large)); + + if Entity (Cond) = Standard_True then + Error_Msg_N + ("object too large: Storage_Error will be raised at " + & "run time??", N); + end if; + end if; + end; end if; end if; diff --git a/gcc/ada/libgnat/s-imenne.adb b/gcc/ada/libgnat/s-imenne.adb index 2ea9fc7..30df1a4 100644 --- a/gcc/ada/libgnat/s-imenne.adb +++ b/gcc/ada/libgnat/s-imenne.adb @@ -49,7 +49,8 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Natural_8; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -79,7 +80,8 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Natural_16; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is @@ -109,7 +111,8 @@ package body System.Img_Enum_New is pragma Assert (S'First = 1); type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Natural_32; type Index_Table_Ptr is access Index_Table; function To_Index_Table_Ptr is -- 2.7.4