From 341e0bb6c54e541637031f30492d584a8e5e98f5 Mon Sep 17 00:00:00 2001 From: Justin Squirek Date: Mon, 28 May 2018 08:53:36 +0000 Subject: [PATCH] [Ada] Spurious constraint error on array of null-excluding components This patch fixes an issue whereby the compiler would raise spurious runtime errors when an array of null-excluding components was initialized with an expression which required the secondary stack (such as with an concatination operation) due to certain generated checks which were incorrected performed on internal object declarations. 2018-05-28 Justin Squirek gcc/ada/ * exp_ch3.adb (Build_Initialization_Call): Add logic to pass the appropriate actual to match new formal. (Init_Formals): Add new formal *_skip_null_excluding_check * exp_util.adb, exp_util.ads (Enclosing_Init_Proc): Added to fetch the enclosing Init_Proc from the current scope. (Inside_Init_Proc): Refactored to use Enclosing_Init_Proc (Needs_Conditional_Null_Excluding_Check): Added to factorize the predicate used to determine how to generate an Init_Proc for a given type. (Needs_Constant_Address): Minor reformatting * sem_res.adb (Resolve_Null): Add logic to generate a conditional check in certain cases gcc/testsuite/ * gnat.dg/array31.adb: New testcase. From-SVN: r260822 --- gcc/ada/ChangeLog | 16 ++++ gcc/ada/exp_ch3.adb | 41 ++++++++ gcc/ada/exp_util.adb | 153 +++++++++++++++++------------- gcc/ada/exp_util.ads | 10 ++ gcc/ada/sem_res.adb | 41 ++++++-- gcc/testsuite/ChangeLog | 4 + gcc/testsuite/gnat.dg/array31.adb | 15 +++ 7 files changed, 209 insertions(+), 71 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/array31.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2ab132351bc..a6edf80758d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2018-05-28 Justin Squirek + + * exp_ch3.adb + (Build_Initialization_Call): Add logic to pass the appropriate actual to match + new formal. + (Init_Formals): Add new formal *_skip_null_excluding_check + * exp_util.adb, exp_util.ads + (Enclosing_Init_Proc): Added to fetch the enclosing Init_Proc from the current + scope. + (Inside_Init_Proc): Refactored to use Enclosing_Init_Proc + (Needs_Conditional_Null_Excluding_Check): Added to factorize the predicate + used to determine how to generate an Init_Proc for a given type. + (Needs_Constant_Address): Minor reformatting + * sem_res.adb + (Resolve_Null): Add logic to generate a conditional check in certain cases + 2018-05-28 Hristian Kirtchev * exp_aggr.adb, gnatlink.adb, sem_ch6.adb, sem_res.adb, sem_util.adb: diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index db93b6453af..689c67c2e7b 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1550,6 +1550,29 @@ package body Exp_Ch3 is Decl := Empty; end if; + -- Handle the optionally generated formal *_skip_null_excluding_checks + + if Needs_Conditional_Null_Excluding_Check (Full_Init_Type) then + + -- Look at the associated node for the object we are referencing and + -- verify that we are expanding a call to an Init_Proc for an + -- internally generated object declaration before passing True and + -- skipping the relevant checks. + + if Nkind (Id_Ref) in N_Has_Entity + and then Comes_From_Source (Associated_Node (Id_Ref)) + then + Append_To (Args, + New_Occurrence_Of (Standard_True, Loc)); + + -- Otherwise, we pass False to perform null excluding checks + + else + Append_To (Args, + New_Occurrence_Of (Standard_False, Loc)); + end if; + end if; + -- Add discriminant values if discriminants are present if Has_Discriminants (Full_Init_Type) then @@ -8643,6 +8666,24 @@ package body Exp_Ch3 is Parameter_Type => New_Occurrence_Of (Standard_String, Loc))); end if; + -- Due to certain edge cases such as arrays with null excluding + -- components being built with the secondary stack it becomes necessary + -- to add a formal to the Init_Proc which controls whether we raise + -- constraint errors on generated calls for internal object + -- declarations. + + if Needs_Conditional_Null_Excluding_Check (Typ) then + Append_To (Formals, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + New_External_Name (Chars + (Component_Type (Typ)), "_skip_null_excluding_check")), + In_Present => True, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))); + end if; + return Formals; exception diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 256f6bb9fff..e1b92f322e6 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4751,6 +4751,26 @@ package body Exp_Util is return New_Exp; end Duplicate_Subexpr_Move_Checks; + ------------------------- + -- Enclosing_Init_Proc -- + ------------------------- + + function Enclosing_Init_Proc return Entity_Id is + S : Entity_Id; + + begin + S := Current_Scope; + while Present (S) and then S /= Standard_Standard loop + if Is_Init_Proc (S) then + return S; + else + S := Scope (S); + end if; + end loop; + + return Empty; + end Enclosing_Init_Proc; + -------------------- -- Ensure_Defined -- -------------------- @@ -7534,19 +7554,10 @@ package body Exp_Util is ---------------------- function Inside_Init_Proc return Boolean is - S : Entity_Id; + Proc : constant Entity_Id := Enclosing_Init_Proc; begin - S := Current_Scope; - while Present (S) and then S /= Standard_Standard loop - if Is_Init_Proc (S) then - return True; - else - S := Scope (S); - end if; - end loop; - - return False; + return Proc /= Empty; end Inside_Init_Proc; ---------------------------- @@ -10430,6 +10441,72 @@ package body Exp_Util is end if; end May_Generate_Large_Temp; + -------------------------------------------- + -- Needs_Conditional_Null_Excluding_Check -- + -------------------------------------------- + + function Needs_Conditional_Null_Excluding_Check + (Typ : Entity_Id) return Boolean + is + begin + return Is_Array_Type (Typ) + and then Can_Never_Be_Null (Component_Type (Typ)); + end Needs_Conditional_Null_Excluding_Check; + + ---------------------------- + -- Needs_Constant_Address -- + ---------------------------- + + function Needs_Constant_Address + (Decl : Node_Id; + Typ : Entity_Id) return Boolean + is + begin + -- If we have no initialization of any kind, then we don't need to place + -- any restrictions on the address clause, because the object will be + -- elaborated after the address clause is evaluated. This happens if the + -- declaration has no initial expression, or the type has no implicit + -- initialization, or the object is imported. + + -- The same holds for all initialized scalar types and all access types. + -- Packed bit arrays of size up to 64 are represented using a modular + -- type with an initialization (to zero) and can be processed like other + -- initialized scalar types. + + -- If the type is controlled, code to attach the object to a + -- finalization chain is generated at the point of declaration, and + -- therefore the elaboration of the object cannot be delayed: the + -- address expression must be a constant. + + if No (Expression (Decl)) + and then not Needs_Finalization (Typ) + and then + (not Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Imported (Defining_Identifier (Decl))) + then + return False; + + elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ)) + or else Is_Access_Type (Typ) + or else + (Is_Bit_Packed_Array (Typ) + and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))) + then + return False; + + else + + -- Otherwise, we require the address clause to be constant because + -- the call to the initialization procedure (or the attach code) has + -- to happen at the point of the declaration. + + -- Actually the IP call has been moved to the freeze actions anyway, + -- so maybe we can relax this restriction??? + + return True; + end if; + end Needs_Constant_Address; + ------------------------ -- Needs_Finalization -- ------------------------ @@ -10518,60 +10595,6 @@ package body Exp_Util is end if; end Needs_Finalization; - ---------------------------- - -- Needs_Constant_Address -- - ---------------------------- - - function Needs_Constant_Address - (Decl : Node_Id; - Typ : Entity_Id) return Boolean - is - begin - -- If we have no initialization of any kind, then we don't need to place - -- any restrictions on the address clause, because the object will be - -- elaborated after the address clause is evaluated. This happens if the - -- declaration has no initial expression, or the type has no implicit - -- initialization, or the object is imported. - - -- The same holds for all initialized scalar types and all access types. - -- Packed bit arrays of size up to 64 are represented using a modular - -- type with an initialization (to zero) and can be processed like other - -- initialized scalar types. - - -- If the type is controlled, code to attach the object to a - -- finalization chain is generated at the point of declaration, and - -- therefore the elaboration of the object cannot be delayed: the - -- address expression must be a constant. - - if No (Expression (Decl)) - and then not Needs_Finalization (Typ) - and then - (not Has_Non_Null_Base_Init_Proc (Typ) - or else Is_Imported (Defining_Identifier (Decl))) - then - return False; - - elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ)) - or else Is_Access_Type (Typ) - or else - (Is_Bit_Packed_Array (Typ) - and then Is_Modular_Integer_Type (Packed_Array_Impl_Type (Typ))) - then - return False; - - else - - -- Otherwise, we require the address clause to be constant because - -- the call to the initialization procedure (or the attach code) has - -- to happen at the point of the declaration. - - -- Actually the IP call has been moved to the freeze actions anyway, - -- so maybe we can relax this restriction??? - - return True; - end if; - end Needs_Constant_Address; - ---------------------------- -- New_Class_Wide_Subtype -- ---------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index f9a828896f3..0f78442596a 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -505,6 +505,11 @@ package Exp_Util is -- elaborated before the original expression Exp, so that there is no need -- to repeat the checks. + function Enclosing_Init_Proc return Entity_Id; + -- Obtain the entity associated with the enclosing type Init_Proc by + -- examining the current scope. If not inside an Init_Proc at the point of + -- call Empty will be returned. + procedure Ensure_Defined (Typ : Entity_Id; N : Node_Id); -- This procedure ensures that type referenced by Typ is defined. For the -- case of a type other than an Itype, nothing needs to be done, since @@ -916,6 +921,11 @@ package Exp_Util is -- caller has to check whether stack checking is actually enabled in order -- to guide the expansion (typically of a function call). + function Needs_Conditional_Null_Excluding_Check + (Typ : Entity_Id) return Boolean; + -- Check if a type meets certain properties that require it to have a + -- conditional null-excluding check within its Init_Proc. + function Needs_Constant_Address (Decl : Node_Id; Typ : Entity_Id) return Boolean; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index c30e869fec9..327bf3148f9 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9116,22 +9116,51 @@ package body Sem_Res is end if; -- Ada 2005 (AI-231): Generate the null-excluding check in case of - -- assignment to a null-excluding object + -- assignment to a null-excluding object. if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (Typ) and then Nkind (Parent (N)) = N_Assignment_Statement then - if not Inside_Init_Proc then + if Inside_Init_Proc then + + -- Decide whether to generate an if_statement around our + -- null-excluding check to avoid them on certain internal object + -- declarations by looking at the type the current Init_Proc + -- belongs to. + + -- Generate: + -- if T1b_skip_null_excluding_check then + -- [constraint_error "access check failed"] + -- end if; + + if Needs_Conditional_Null_Excluding_Check + (Etype (First_Formal (Enclosing_Init_Proc))) + then + Insert_Action (N, + Make_If_Statement (Loc, + Condition => + Make_Identifier (Loc, + New_External_Name + (Chars (Typ), "_skip_null_excluding_check")), + Then_Statements => + New_List ( + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)))); + + -- Otherwise, simply create the check + + else + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Reason => CE_Access_Check_Failed)); + end if; + else Insert_Action (Compile_Time_Constraint_Error (N, "(Ada 2005) null not allowed in null-excluding objects??"), Make_Raise_Constraint_Error (Loc, Reason => CE_Access_Check_Failed)); - else - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Reason => CE_Access_Check_Failed)); end if; end if; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8c3f007bc61..3717830a1b2 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-05-28 Justin Squirek + + * gnat.dg/array31.adb: New testcase. + 2018-05-28 Justin Squirek * gnat.dg/warn15-core-main.adb, gnat.dg/warn15-core.ads, diff --git a/gcc/testsuite/gnat.dg/array31.adb b/gcc/testsuite/gnat.dg/array31.adb new file mode 100644 index 00000000000..b60474828ef --- /dev/null +++ b/gcc/testsuite/gnat.dg/array31.adb @@ -0,0 +1,15 @@ +-- { dg-do run } + +procedure Array31 is + + type Boolean_Access is access Boolean; + + type Boolean_Access_Array is + array (Positive range <>) of not null Boolean_Access; + + X : constant Boolean_Access_Array := (1 => new Boolean'(False)); + Y : constant Boolean_Access_Array := X & X; + +begin + null; +end; -- 2.30.2