From b3801819f495f925bc7c26f03e4e98f448423839 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Fri, 15 Dec 2017 11:16:14 +0000 Subject: [PATCH] gnat_and_program_execution.rst: Update section "Dynamic Stack Usage Analysis" to include more details about... gcc/ada/ 2017-12-15 Patrick Bernardi * doc/gnat_ugn/gnat_and_program_execution.rst: Update section "Dynamic Stack Usage Analysis" to include more details about GNAT_STACK_LIMIT. 2017-12-15 Hristian Kirtchev * exp_util.adb (Add_Own_DIC): Ensure that the expression of the pragma is available (Is_Verifiable_DIC_Pragma): Moved from Sem_Util. * sem_util.adb (Has_Full_Default_Initialization): Has_Fully_Default_Initializing_DIC_Pragma is now used to determine whether a type has full default initialization due to pragma Default_Initial_Condition. (Has_Fully_Default_Initializing_DIC_Pragma): New routine. (Is_Verifiable_DIC_Pragma): Moved to Exp_Util. * sem_util.ads (Has_Fully_Default_Initializing_DIC_Pragma): New routine. (Is_Verifiable_DIC_Pragma): Moved to Exp_Util. * sem_warn.adb (Is_OK_Fully_Initialized): Has_Fully_Default_Initializing_DIC_Pragma is now used to determine whether a type has full default initialization due to pragma Default_Initial_Condition. 2017-12-15 Hristian Kirtchev * sem_prag.adb (Match_Constituent): Do not quietly accept constants as suitable constituents. * exp_util.adb: Minor reformatting. 2017-12-15 Ed Schonberg * exp_aggr.adb (In_Place_Assign_OK): Extend the predicate to recognize an array aggregate in an allocator, when the designated type is unconstrained and the upper bound of the aggregate belongs to the base type of the index. 2017-12-15 Bob Duff * exp_ch6.adb (Expand_N_Extended_Return_Statement, Expand_Simple_Function_Return): Assert that the b-i-p-ness of the caller and callee match. Otherwise, we would need some substantial changes to allow b-i-p calls non-b-i-p, and vice versa. gcc/testsuite/ 2017-12-15 Hristian Kirtchev * gnat.dg/dflt_init_cond.adb, gnat.dg/dflt_init_cond_pkg.ads: New testcase. From-SVN: r255685 --- gcc/ada/ChangeLog | 43 +++++++++++ .../gnat_ugn/gnat_and_program_execution.rst | 15 +++- gcc/ada/exp_aggr.adb | 20 ++++- gcc/ada/exp_ch6.adb | 24 +++++- gcc/ada/exp_util.adb | 22 +++++- gcc/ada/sem_prag.adb | 25 ++----- gcc/ada/sem_util.adb | 73 ++++++++++++------- gcc/ada/sem_util.ads | 14 ++-- gcc/ada/sem_warn.adb | 15 ++-- gcc/testsuite/ChangeLog | 5 ++ gcc/testsuite/gnat.dg/dflt_init_cond.adb | 12 +++ gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads | 11 +++ 12 files changed, 211 insertions(+), 68 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/dflt_init_cond.adb create mode 100644 gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5dcc378b5cb..c86b361a264 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,46 @@ +2017-12-15 Patrick Bernardi + + * doc/gnat_ugn/gnat_and_program_execution.rst: Update section "Dynamic + Stack Usage Analysis" to include more details about GNAT_STACK_LIMIT. + +2017-12-15 Hristian Kirtchev + + * exp_util.adb (Add_Own_DIC): Ensure that the expression of the pragma + is available (Is_Verifiable_DIC_Pragma): Moved from Sem_Util. + * sem_util.adb (Has_Full_Default_Initialization): + Has_Fully_Default_Initializing_DIC_Pragma is now used to determine + whether a type has full default initialization due to pragma + Default_Initial_Condition. + (Has_Fully_Default_Initializing_DIC_Pragma): New routine. + (Is_Verifiable_DIC_Pragma): Moved to Exp_Util. + * sem_util.ads (Has_Fully_Default_Initializing_DIC_Pragma): New + routine. + (Is_Verifiable_DIC_Pragma): Moved to Exp_Util. + * sem_warn.adb (Is_OK_Fully_Initialized): + Has_Fully_Default_Initializing_DIC_Pragma is now used to determine + whether a type has full default initialization due to pragma + Default_Initial_Condition. + +2017-12-15 Hristian Kirtchev + + * sem_prag.adb (Match_Constituent): Do not quietly accept constants as + suitable constituents. + * exp_util.adb: Minor reformatting. + +2017-12-15 Ed Schonberg + + * exp_aggr.adb (In_Place_Assign_OK): Extend the predicate to recognize + an array aggregate in an allocator, when the designated type is + unconstrained and the upper bound of the aggregate belongs to the base + type of the index. + +2017-12-15 Bob Duff + + * exp_ch6.adb (Expand_N_Extended_Return_Statement, + Expand_Simple_Function_Return): Assert that the b-i-p-ness of the + caller and callee match. Otherwise, we would need some substantial + changes to allow b-i-p calls non-b-i-p, and vice versa. + 2017-12-15 Ed Schonberg * exp_unst.adb (Unnest_Subprograms): Nothing to do if the main unit is diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst index e350cb9d2db..6ce22f4a01e 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -3817,11 +3817,20 @@ where: is not entirely analyzed, and it's not possible to know exactly how much has actually been used. -The environment task stack, e.g., the stack that contains the main unit, is -only processed when the environment variable GNAT_STACK_LIMIT is set. +By default the environment task stack, the stack that contains the main unit, +is not processed. To enable processing of the environment task stack, the +environment variable GNAT_STACK_LIMIT needs to be set to the maximum size of +the environment task stack. This amount is given in kilobytes. For example: + + :: + + $ set GNAT_STACK_LIMIT 1600 + +would specify to the analyzer that the environment task stack has a limit +of 1.6 megabytes. Any stack usage beyond this will be ignored by the analysis. The package ``GNAT.Task_Stack_Usage`` provides facilities to get -stack usage reports at run-time. See its body for the details. +stack-usage reports at run time. See its body for the details. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 581e31cfb92..e2313f29e62 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5537,13 +5537,29 @@ package body Exp_Aggr is Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi); if not Compile_Time_Known_Value (Aggr_Lo) - or else not Compile_Time_Known_Value (Aggr_Hi) or else not Compile_Time_Known_Value (Obj_Lo) or else not Compile_Time_Known_Value (Obj_Hi) or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo) - or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) then return False; + + -- For an assignment statement we require static matching + -- of bounds. Ditto for an allocator whose qualified + -- expression is a constrained type. If the expression in + -- the allocator is an unconstrained array, we accept an + -- upper bound that is not static, to allow for non-static + -- expressions of the base type. Clearly there are further + -- possibilities (with diminishing returns) for safely + -- building arrays in place here. + + elsif Nkind (Parent (N)) = N_Assignment_Statement + or else Is_Constrained (Etype (Parent (N))) + then + if not Compile_Time_Known_Value (Aggr_Hi) + or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi) + then + return False; + end if; end if; Next_Index (Aggr_In); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index add30b6c28d..f207b5b13dd 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4751,6 +4751,17 @@ package body Exp_Ch6 is if Nkind (Ret_Obj_Decl) = N_Object_Declaration then Exp := Expression (Ret_Obj_Decl); + + -- Assert that if F says "return R : T := G(...) do..." + -- then F and G are both b-i-p, or neither b-i-p. + + if Nkind (Exp) = N_Function_Call then + pragma Assert (Ekind (Current_Scope) = E_Function); + pragma Assert + (Is_Build_In_Place_Function (Current_Scope) = + Is_Build_In_Place_Function_Call (Exp)); + null; + end if; else Exp := Empty; end if; @@ -6446,6 +6457,17 @@ package body Exp_Ch6 is end if; end if; + -- Assert that if F says "return G(...);" + -- then F and G are both b-i-p, or neither b-i-p. + + if Nkind (Exp) = N_Function_Call then + pragma Assert (Ekind (Scope_Id) = E_Function); + pragma Assert + (Is_Build_In_Place_Function (Scope_Id) = + Is_Build_In_Place_Function_Call (Exp)); + null; + end if; + -- For the case of a simple return that does not come from an -- extended return, in the case of build-in-place, we rewrite -- "return ;" to be: @@ -7095,8 +7117,6 @@ package body Exp_Ch6 is return Empty; end Associated_Expr; - -- Start of processing for Expand_Simple_Function_Return - begin if not Positionals_Exhausted then Disc_Exp := First (Expressions (Discrim_Source)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 959d32bd603..a4797c7e6db 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -165,6 +165,10 @@ package body Exp_Util is -- Force evaluation of bounds of a slice, which may be given by a range -- or by a subtype indication with or without a constraint. + function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean; + -- Determine whether pragma Default_Initial_Condition denoted by Prag has + -- an assertion expression that should be verified at run time. + function Make_CW_Equivalent_Type (T : Entity_Id; E : Node_Id) return Entity_Id; @@ -1500,6 +1504,7 @@ package body Exp_Util is -- Start of processing for Add_Own_DIC begin + pragma Assert (Present (DIC_Expr)); Expr := New_Copy_Tree (DIC_Expr); -- Perform the following substitution: @@ -1733,8 +1738,6 @@ package body Exp_Util is -- Produce an empty completing body in the following cases: -- * Assertions are disabled -- * The DIC Assertion_Policy is Ignore - -- * Pragma DIC appears without an argument - -- * Pragma DIC appears with argument "null" if No (Stmts) then Stmts := New_List (Make_Null_Statement (Loc)); @@ -8715,6 +8718,21 @@ package body Exp_Util is and then Is_Itype (Full_Typ); end Is_Untagged_Private_Derivation; + ------------------------------ + -- Is_Verifiable_DIC_Pragma -- + ------------------------------ + + function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is + Args : constant List_Id := Pragma_Argument_Associations (Prag); + + begin + -- To qualify as verifiable, a DIC pragma must have a non-null argument + + return + Present (Args) + and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null; + end Is_Verifiable_DIC_Pragma; + --------------------------- -- Is_Volatile_Reference -- --------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 86602ad7cd3..16113e1cfd9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -27327,25 +27327,14 @@ package body Sem_Prag is end loop; end if; - -- Constants are part of the hidden state of a package, but - -- the compiler cannot determine whether they have variable - -- input (SPARK RM 7.1.1(2)) and cannot classify them as a - -- hidden state. Accept the constant quietly even if it is - -- a visible state or lacks a Part_Of indicator. + -- At this point it is known that the constituent is not + -- part of the package hidden state and cannot be used in + -- a refinement (SPARK RM 7.2.2(9)). - if Ekind (Constit_Id) = E_Constant then - Collect_Constituent; - - -- If we get here, then the constituent is not a hidden - -- state of the related package and may not be used in a - -- refinement (SPARK RM 7.2.2(9)). - - else - Error_Msg_Name_1 := Chars (Spec_Id); - SPARK_Msg_NE - ("cannot use & in refinement, constituent is not a " - & "hidden state of package %", Constit, Constit_Id); - end if; + Error_Msg_Name_1 := Chars (Spec_Id); + SPARK_Msg_NE + ("cannot use & in refinement, constituent is not a hidden " + & "state of package %", Constit, Constit_Id); end if; end Match_Constituent; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 5bdbd5b372b..688ad7bfe32 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10384,19 +10384,16 @@ package body Sem_Util is function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is Comp : Entity_Id; - Prag : Node_Id; begin - -- A type subject to pragma Default_Initial_Condition is fully default - -- initialized when the pragma appears with a non-null argument. Since - -- any type may act as the full view of a private type, this check must - -- be performed prior to the specialized tests below. + -- A type subject to pragma Default_Initial_Condition may be fully + -- default initialized depending on inheritance and the argument of + -- the pragma. Since any type may act as the full view of a private + -- type, this check must be performed prior to the specialized tests + -- below. - if Has_DIC (Typ) then - Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); - pragma Assert (Present (Prag)); - - return Is_Verifiable_DIC_Pragma (Prag); + if Has_Fully_Default_Initializing_DIC_Pragma (Typ) then + return True; end if; -- A scalar type is fully default initialized if it is subject to aspect @@ -10463,6 +10460,47 @@ package body Sem_Util is end if; end Has_Full_Default_Initialization; + ----------------------------------------------- + -- Has_Fully_Default_Initializing_DIC_Pragma -- + ----------------------------------------------- + + function Has_Fully_Default_Initializing_DIC_Pragma + (Typ : Entity_Id) return Boolean + is + Args : List_Id; + Prag : Node_Id; + + begin + -- A type that inherits pragma Default_Initial_Condition from a parent + -- type is automatically fully default initialized. + + if Has_Inherited_DIC (Typ) then + return True; + + -- Otherwise the type is fully default initialized only when the pragma + -- appears without an argument, or the argument is non-null. + + elsif Has_Own_DIC (Typ) then + Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); + pragma Assert (Present (Prag)); + Args := Pragma_Argument_Associations (Prag); + + -- The pragma appears without an argument in which case it defaults + -- to True. + + if No (Args) then + return True; + + -- The pragma appears with a non-null expression + + elsif Nkind (Get_Pragma_Arg (First (Args))) /= N_Null then + return True; + end if; + end if; + + return False; + end Has_Fully_Default_Initializing_DIC_Pragma; + -------------------- -- Has_Infinities -- -------------------- @@ -17018,21 +17056,6 @@ package body Sem_Util is end if; end Is_Variable; - ------------------------------ - -- Is_Verifiable_DIC_Pragma -- - ------------------------------ - - function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is - Args : constant List_Id := Pragma_Argument_Associations (Prag); - - begin - -- To qualify as verifiable, a DIC pragma must have a non-null argument - - return - Present (Args) - and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null; - end Is_Verifiable_DIC_Pragma; - --------------------------- -- Is_Visibly_Controlled -- --------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e94515dcf07..f368eaa257d 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1238,8 +1238,14 @@ package Sem_Util is -- either include a default expression or have a type which defines -- full default initialization. In the case of type extensions, the -- parent type defines full default initialization. - -- * A task type - -- * A private type whose Default_Initial_Condition is non-null + -- * A task type + -- * A private type with pragma Default_Initial_Condition that provides + -- full default initialization. + + function Has_Fully_Default_Initializing_DIC_Pragma + (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ has a suitable Default_Initial_Condition + -- pragma which provides the full default initialization of the type. function Has_Infinities (E : Entity_Id) return Boolean; -- Determines if the range of the floating-point type E includes @@ -1980,10 +1986,6 @@ package Sem_Util is -- default is True since this routine is commonly invoked as part of the -- semantic analysis and it must not be disturbed by the rewriten nodes. - function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean; - -- Determine whether pragma Default_Initial_Condition denoted by Prag has - -- an assertion expression which should be verified at runtime. - function Is_Visibly_Controlled (T : Entity_Id) return Boolean; -- Check whether T is derived from a visibly controlled type. This is true -- if the root type is declared in Ada.Finalization. If T is derived diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index ff94cf84e41..ce557242d28 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1742,21 +1742,16 @@ package body Sem_Warn is ----------------------------- function Is_OK_Fully_Initialized return Boolean is - Prag : Node_Id; - begin if Is_Access_Type (Typ) and then Is_Dereferenced (N) then return False; - -- A type subject to pragma Default_Initial_Condition is fully - -- default initialized when the pragma appears with a non-null - -- argument (SPARK RM 3.1 and SPARK RM 7.3.3). - - elsif Has_DIC (Typ) then - Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition); - pragma Assert (Present (Prag)); + -- A type subject to pragma Default_Initial_Condition may be fully + -- default initialized depending on inheritance and the argument of + -- the pragma (SPARK RM 3.1 and SPARK RM 7.3.3). - return Is_Verifiable_DIC_Pragma (Prag); + elsif Has_Fully_Default_Initializing_DIC_Pragma (Typ) then + return True; else return Is_Fully_Initialized_Type (Typ); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 8d6825ae43a..e8d45ac18ce 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2017-12-15 Hristian Kirtchev + + * gnat.dg/dflt_init_cond.adb, gnat.dg/dflt_init_cond_pkg.ads: New + testcase. + 2017-12-15 Hristian Kirtchev * gnat.dg/expr_func_main.adb, gnat.dg/expr_func_pkg.ads, diff --git a/gcc/testsuite/gnat.dg/dflt_init_cond.adb b/gcc/testsuite/gnat.dg/dflt_init_cond.adb new file mode 100644 index 00000000000..1c4cd64529f --- /dev/null +++ b/gcc/testsuite/gnat.dg/dflt_init_cond.adb @@ -0,0 +1,12 @@ +-- { dg-do compile } + +with Dflt_Init_Cond_Pkg; use Dflt_Init_Cond_Pkg; + +procedure Dflt_Init_Cond is + E : Explicit; + I : Implicit; + +begin + Read (E); + Read (I); +end Dflt_Init_Cond; diff --git a/gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads b/gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads new file mode 100644 index 00000000000..e1955cde69d --- /dev/null +++ b/gcc/testsuite/gnat.dg/dflt_init_cond_pkg.ads @@ -0,0 +1,11 @@ +package Dflt_Init_Cond_Pkg is + type Explicit is limited private with Default_Initial_Condition => True; + type Implicit is limited private with Default_Initial_Condition; + + procedure Read (Obj : Explicit); + procedure Read (Obj : Implicit); + +private + type Implicit is access all Integer; + type Explicit is access all Integer; +end Dflt_Init_Cond_Pkg; -- 2.30.2