From c581c5205ae33fdf22ec27cd30047dd45abfb085 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Fri, 15 Dec 2017 10:21:24 +0000 Subject: [PATCH] exp_unst.adb (Unnest_Subprograms): Nothing to do if the main unit is a generic package body. gcc/ada/ 2017-12-15 Ed Schonberg * exp_unst.adb (Unnest_Subprograms): Nothing to do if the main unit is a generic package body. Unnesting is only an issue when generating code, and if the main unit is generic then nested instance bodies have not been created and analyzed, and unnesting will crash in the absence of those bodies, 2017-12-15 Hristian Kirtchev * inline.adb (Add_Inlined_Body): Do not add a function which is completed by an expression function defined in the same context as the initial declaration because the completing body is not in a package body. (Is_Non_Loading_Expression_Function): New routine. 2017-12-15 Hristian Kirtchev * debug.adb: Move the functionality of -gnatdL to -gnatd_i. Restore the behavior of -gnatdL from before revision 255412. * sem_elab.adb: Update the section of compiler switches. (Build_Call_Marker): Do not create a marker for a call which originates from an expanded spec or body of an instantiated gener, does not invoke a generic formal subprogram, the target is external to the instance, and -gnatdL is in effect. (In_External_Context): New routine. (Process_Conditional_ABE_Activation_Impl): Update the uses of -gnatdL and associated flag. (Process_Conditional_ABE_Call): Update the uses of -gnatdL and associated flag. * switch-c.adb (Scan_Front_End_Switches): Switch -gnatJ now sets switch -gnatd_i. * exp_unst.adb: Minor typo fixes and edits. 2017-12-15 Ed Schonberg * sem_ch6.adb (Possible_Freeze): Do not set Delayed_Freeze on an subprogram instantiation, now that the enclosing wrapper package carries an explicit freeze node. THis prevents freeze nodes for the subprogram for appearing in the wrong scope. This is relevant when the generic subprogram has a private or incomplete formal type and the instance appears within a package that declares the actual type for the instantiation, and that type has itself a delayed freeze. 2017-12-15 Patrick Bernardi * doc/gnat_ugn/gnat_and_program_execution.rst: Removed references to the environment variable GNAT_STACK_LIMIT from the Stack Overflow Checking section as it is no longer used by any of our supported targets. gcc/testsuite/ 2017-12-15 Hristian Kirtchev * gnat.dg/expr_func_main.adb, gnat.dg/expr_func_pkg.ads, gnat.dg/expr_func_pkg.adb: New testcase. 2017-12-15 Hristian Kirtchev * gnat.dg/abe_pkg.adb, gnat.dg/abe_pkg.ads: New testcase. 2017-12-15 Ed Schonberg * gnat.dg/subp_inst.adb, gnat.dg/subp_inst_pkg.adb, gnat.dg/subp_inst_pkg.ads: New testcase. From-SVN: r255683 --- gcc/ada/checks.adb | 2 +- gcc/ada/debug.adb | 13 ++- .../gnat_ugn/gnat_and_program_execution.rst | 35 ++----- gcc/ada/exp_ch6.adb | 2 +- gcc/ada/exp_ch7.adb | 35 +++---- gcc/ada/exp_unst.adb | 15 ++- gcc/ada/exp_util.adb | 58 +++++++----- gcc/ada/gnat_ugn.texi | 40 ++------ gcc/ada/inline.adb | 63 ++++++++++++- gcc/ada/libgnat/s-tsmona.adb | 6 +- gcc/ada/rtsfind.ads | 4 +- gcc/ada/sem_ch6.adb | 15 ++- gcc/ada/sem_elab.adb | 94 +++++++++++++++++-- gcc/ada/switch-c.adb | 27 +++--- gcc/testsuite/ChangeLog | 14 +++ gcc/testsuite/gnat.dg/abe_pkg.adb | 13 +++ gcc/testsuite/gnat.dg/abe_pkg.ads | 8 ++ gcc/testsuite/gnat.dg/expr_func_main.adb | 9 ++ gcc/testsuite/gnat.dg/expr_func_pkg.adb | 7 ++ gcc/testsuite/gnat.dg/expr_func_pkg.ads | 6 ++ gcc/testsuite/gnat.dg/subp_inst.adb | 26 +++++ gcc/testsuite/gnat.dg/subp_inst_pkg.adb | 20 ++++ gcc/testsuite/gnat.dg/subp_inst_pkg.ads | 13 +++ 23 files changed, 387 insertions(+), 138 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/abe_pkg.adb create mode 100644 gcc/testsuite/gnat.dg/abe_pkg.ads create mode 100644 gcc/testsuite/gnat.dg/expr_func_main.adb create mode 100644 gcc/testsuite/gnat.dg/expr_func_pkg.adb create mode 100644 gcc/testsuite/gnat.dg/expr_func_pkg.ads create mode 100644 gcc/testsuite/gnat.dg/subp_inst.adb create mode 100644 gcc/testsuite/gnat.dg/subp_inst_pkg.adb create mode 100644 gcc/testsuite/gnat.dg/subp_inst_pkg.ads diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 6fe75a185c2..9c39e4c834d 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6819,7 +6819,7 @@ package body Checks is if Nkind (N) /= N_Attribute_Reference and then (not Is_Entity_Name (N) - or else Treat_As_Volatile (Entity (N))) + or else Treat_As_Volatile (Entity (N))) then Force_Evaluation (N, Mode => Strict); end if; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 0a14cecadd2..05b2c31d54e 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -153,7 +153,7 @@ package body Debug is -- d_f -- d_g -- d_h - -- d_i + -- d_i Ignore activations and calls to instances for elaboration -- d_j -- d_k -- d_l @@ -479,8 +479,8 @@ package body Debug is -- error messages are target dependent and irrelevant. -- dL The compiler ignores calls in instances and invoke subprograms - -- which are external to the instance for the static elaboration - -- model. This switch is orthogonal to d.G. + -- which are external to the instance for both the static and dynamic + -- elaboration models. -- dM Assume all variables have been modified, and ignore current value -- indications. This debug flag disconnects the tracking of constant @@ -734,8 +734,7 @@ package body Debug is -- d.G Previously the compiler ignored calls via generic formal parameters -- when doing the analysis for the static elaboration model. This is -- now fixed, but we provide this debug flag to revert to the previous - -- situation of ignoring such calls to aid in transition. This switch - -- is orthogonal to dL. + -- situation of ignoring such calls to aid in transition. -- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress -- the call to gigi in ASIS_Mode. @@ -832,6 +831,10 @@ package body Debug is -- control, conditional entry calls, timed entry calls, and requeue -- statements in both the static and dynamic elaboration models. + -- d_i The compiler ignores calls and task activations when they target a + -- subprogram or task type defined in an external instance for both + -- the static and dynamic elaboration models. + -- d_p The compiler ignores calls to subprograms which verify the run-time -- semantics of invariants and postconditions in both the static and -- dynamic elaboration models. 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 8f9f37cc0d8..e350cb9d2db 100644 --- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst +++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst @@ -3722,33 +3722,14 @@ that any use of the stack (for procedure calls or for declaring local variables in declare blocks) does not exceed the available stack space. If the space is exceeded, then a ``Storage_Error`` exception is raised. -For declared tasks, the stack size is controlled by the size -given in an applicable ``Storage_Size`` pragma or by the value specified -at bind time with ``-d`` (:ref:`Switches_for_gnatbind`) or is set to -the default size as defined in the GNAT runtime otherwise. - -.. index:: GNAT_STACK_LIMIT - -For the environment task, the stack size depends on -system defaults and is unknown to the compiler. Stack checking -may still work correctly if a fixed -size stack is allocated, but this cannot be guaranteed. -To ensure that a clean exception is signalled for stack -overflow, set the environment variable -:envvar:`GNAT_STACK_LIMIT` to indicate the maximum -stack area that can be used, as in: - - :: - - $ SET GNAT_STACK_LIMIT 1600 - -The limit is given in kilobytes, so the above declaration would -set the stack limit of the environment task to 1.6 megabytes. -Note that the only purpose of this usage is to limit the amount -of stack used by the environment task. If it is necessary to -increase the amount of stack for the environment task, then this -is an operating systems issue, and must be addressed with the -appropriate operating systems commands. +For declared tasks, the default stack size is defined by the GNAT runtime, +whose size may be modified at bind time through the ``-d`` bind switch +(:ref:`Switches_for_gnatbind`). Task specific stack sizes may be set using the +``Storage_Size`` pragma. + +For the environment task, the stack size is determined by the operating system. +Consequently, to modify the size of the environment task please refer to your +operating system documentation. .. _Static_Stack_Usage_Analysis: diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 43731c80239..add30b6c28d 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5356,7 +5356,7 @@ package body Exp_Ch6 is Else_Statements => New_List ( Make_Raise_Program_Error (Loc, - Reason => PE_All_Guards_Closed))); + Reason => PE_All_Guards_Closed))); -- If a separate initialization assignment was created -- earlier, append that following the assignment of the diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 4ce2ea1c2c0..4dcb38dde02 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4200,13 +4200,11 @@ package body Exp_Ch7 is ---------------------------- procedure Expand_Cleanup_Actions (N : Node_Id) is - pragma Assert - (Nkind_In (N, - N_Extended_Return_Statement, - N_Block_Statement, - N_Subprogram_Body, - N_Task_Body, - N_Entry_Body)); + pragma Assert (Nkind_In (N, N_Block_Statement, + N_Entry_Body, + N_Extended_Return_Statement, + N_Subprogram_Body, + N_Task_Body)); Scop : constant Entity_Id := Current_Scope; @@ -4311,11 +4309,13 @@ package body Exp_Ch7 is end if; -- If an extended return statement contains something like + -- -- X := F (...); + -- -- where F is a build-in-place function call returning a controlled - -- type, then a temporary object will be implicitly declared as part of - -- the statement list, and this will need cleanup. In such cases, we - -- transform: + -- type, then a temporary object will be implicitly declared as part + -- of the statement list, and this will need cleanup. In such cases, + -- we transform: -- -- return Result : T := ... do -- -- possibly with handlers @@ -4336,14 +4336,15 @@ package body Exp_Ch7 is if Nkind (N) = N_Extended_Return_Statement then declare Block : constant Node_Id := - Make_Block_Statement (Sloc (N), - Declarations => Empty_List, - Handled_Statement_Sequence => - Handled_Statement_Sequence (N)); + Make_Block_Statement (Sloc (N), + Declarations => Empty_List, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N)); begin - Set_Handled_Statement_Sequence - (N, Make_Handled_Sequence_Of_Statements (Sloc (N), - Statements => New_List (Block))); + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Sloc (N), + Statements => New_List (Block))); + Analyze (Block); end; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 558e9868524..c522c232490 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -302,6 +302,16 @@ package body Exp_Unst is return; end if; + -- If the main unit is a package body then we need to examine the spec + -- to determine whether the main unit is generic (the scope stack is not + -- present when this is called on the main unit). + + if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body + and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit))) + then + return; + end if; + -- At least for now, do not unnest anything but main source unit if not In_Extended_Main_Source_Unit (Subp_Body) then @@ -553,8 +563,8 @@ package body Exp_Unst is Ent := Entity (Name (N)); -- We are only interested in calls to subprograms nested - -- within Subp. Calls to Subp itself or to subprograms that - -- are outside the nested structure do not affect us. + -- within Subp. Calls to Subp itself or to subprograms + -- that are outside the nested structure do not affect us. if Scope_Within (Ent, Subp) then @@ -1653,7 +1663,6 @@ package body Exp_Unst is if Present (STT.ARECnF) and then Nkind (CTJ.N) /= N_Attribute_Reference then - -- CTJ.N is a call to a subprogram which may require a pointer -- to an activation record. The subprogram containing the call -- is CTJ.From and the subprogram being called is CTJ.To, so we diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b06e91a3c8b..959d32bd603 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -10701,8 +10701,8 @@ package body Exp_Util is and then not Is_Empty_List (Then_Statements (N)) and then not Are_Wrapped (Then_Statements (N)) and then Requires_Cleanup_Actions - (Then_Statements (N), - Lib_Level => False, + (L => Then_Statements (N), + Lib_Level => False, Nested_Constructs => False) then Block := Wrap_Statements_In_Block (Then_Statements (N)); @@ -10720,8 +10720,8 @@ package body Exp_Util is and then not Is_Empty_List (Else_Statements (N)) and then not Are_Wrapped (Else_Statements (N)) and then Requires_Cleanup_Actions - (Else_Statements (N), - Lib_Level => False, + (L => Else_Statements (N), + Lib_Level => False, Nested_Constructs => False) then Block := Wrap_Statements_In_Block (Else_Statements (N)); @@ -10742,8 +10742,8 @@ package body Exp_Util is if not Is_Empty_List (Statements (N)) and then not Are_Wrapped (Statements (N)) and then Requires_Cleanup_Actions - (Statements (N), - Lib_Level => False, + (L => Statements (N), + Lib_Level => False, Nested_Constructs => False) then if Nkind (N) = N_Loop_Statement @@ -11822,14 +11822,18 @@ package body Exp_Util is | N_Task_Body => return - Requires_Cleanup_Actions - (Declarations (N), At_Lib_Level, Nested_Constructs => True) - or else - (Present (Handled_Statement_Sequence (N)) - and then - Requires_Cleanup_Actions - (Statements (Handled_Statement_Sequence (N)), - At_Lib_Level, Nested_Constructs => True)); + Requires_Cleanup_Actions + (L => Declarations (N), + Lib_Level => At_Lib_Level, + Nested_Constructs => True) + or else + (Present (Handled_Statement_Sequence (N)) + and then + Requires_Cleanup_Actions + (L => + Statements (Handled_Statement_Sequence (N)), + Lib_Level => At_Lib_Level, + Nested_Constructs => True)); -- Extended return statements are the same as the above, except that -- there is no Declarations field. We do not want to clean up the @@ -11837,20 +11841,24 @@ package body Exp_Util is when N_Extended_Return_Statement => return - Present (Handled_Statement_Sequence (N)) - and then Requires_Cleanup_Actions - (Statements (Handled_Statement_Sequence (N)), - At_Lib_Level, Nested_Constructs => True); + Present (Handled_Statement_Sequence (N)) + and then Requires_Cleanup_Actions + (L => + Statements (Handled_Statement_Sequence (N)), + Lib_Level => At_Lib_Level, + Nested_Constructs => True); when N_Package_Specification => return - Requires_Cleanup_Actions - (Visible_Declarations (N), At_Lib_Level, - Nested_Constructs => True) - or else - Requires_Cleanup_Actions - (Private_Declarations (N), At_Lib_Level, - Nested_Constructs => True); + Requires_Cleanup_Actions + (L => Visible_Declarations (N), + Lib_Level => At_Lib_Level, + Nested_Constructs => True) + or else + Requires_Cleanup_Actions + (L => Private_Declarations (N), + Lib_Level => At_Lib_Level, + Nested_Constructs => True); when others => raise Program_Error; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 798743073dd..24222dc3cc0 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -21,7 +21,7 @@ @copying @quotation -GNAT User's Guide for Native Platforms , Dec 05, 2017 +GNAT User's Guide for Native Platforms , Dec 15, 2017 AdaCore @@ -23061,38 +23061,14 @@ that any use of the stack (for procedure calls or for declaring local variables in declare blocks) does not exceed the available stack space. If the space is exceeded, then a @code{Storage_Error} exception is raised. -For declared tasks, the stack size is controlled by the size -given in an applicable @code{Storage_Size} pragma or by the value specified -at bind time with @code{-d} (@ref{11f,,Switches for gnatbind}) or is set to -the default size as defined in the GNAT runtime otherwise. +For declared tasks, the default stack size is defined by the GNAT runtime, +whose size may be modified at bind time through the @code{-d} bind switch +(@ref{11f,,Switches for gnatbind}). Task specific stack sizes may be set using the +@code{Storage_Size} pragma. -@geindex GNAT_STACK_LIMIT - -For the environment task, the stack size depends on -system defaults and is unknown to the compiler. Stack checking -may still work correctly if a fixed -size stack is allocated, but this cannot be guaranteed. -To ensure that a clean exception is signalled for stack -overflow, set the environment variable -@geindex GNAT_STACK_LIMIT -@geindex environment variable; GNAT_STACK_LIMIT -@code{GNAT_STACK_LIMIT} to indicate the maximum -stack area that can be used, as in: - -@quotation - -@example -$ SET GNAT_STACK_LIMIT 1600 -@end example -@end quotation - -The limit is given in kilobytes, so the above declaration would -set the stack limit of the environment task to 1.6 megabytes. -Note that the only purpose of this usage is to limit the amount -of stack used by the environment task. If it is necessary to -increase the amount of stack for the environment task, then this -is an operating systems issue, and must be addressed with the -appropriate operating systems commands. +For the environment task, the stack size is determined by the operating system. +Consequently, to modify the size of the environment task please refer to your +operating system documentation. @node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities @anchor{gnat_ugn/gnat_and_program_execution id64}@anchor{1cb}@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{f5} diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index f97fce782f4..072a4e5db77 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -298,10 +298,65 @@ package body Inline is -- Inline_Package means that the call is considered for inlining and -- its package compiled and scanned for more inlining opportunities. + function Is_Non_Loading_Expression_Function + (Id : Entity_Id) return Boolean; + -- Determine whether arbitrary entity Id denotes a subprogram which is + -- either + -- + -- * An expression function + -- + -- * A function completed by an expression function where both the + -- spec and body are in the same context. + function Must_Inline return Inline_Level_Type; -- Inlining is only done if the call statement N is in the main unit, -- or within the body of another inlined subprogram. + ---------------------------------------- + -- Is_Non_Loading_Expression_Function -- + ---------------------------------------- + + function Is_Non_Loading_Expression_Function + (Id : Entity_Id) return Boolean + is + Body_Decl : Node_Id; + Body_Id : Entity_Id; + Spec_Decl : Node_Id; + + begin + -- A stand-alone expression function is transformed into a spec-body + -- pair in-place. Since both the spec and body are in the same list, + -- the inlining of such an expression function does not need to load + -- anything extra. + + if Is_Expression_Function (Id) then + return True; + + -- A function may be completed by an expression function + + elsif Ekind (Id) = E_Function then + Spec_Decl := Unit_Declaration_Node (Id); + + if Nkind (Spec_Decl) = N_Subprogram_Declaration then + Body_Id := Corresponding_Body (Spec_Decl); + + if Present (Body_Id) then + Body_Decl := Unit_Declaration_Node (Body_Id); + + -- The inlining of a completing expression function does + -- not need to load anything extra when both the spec and + -- body are in the same context. + + return + Was_Expression_Function (Body_Decl) + and then Parent (Spec_Decl) = Parent (Body_Decl); + end if; + end if; + end if; + + return False; + end Is_Non_Loading_Expression_Function; + ----------------- -- Must_Inline -- ----------------- @@ -415,10 +470,12 @@ package body Inline is Set_Needs_Debug_Info (E, False); end if; - -- If the subprogram is an expression function, then there is no need to - -- load any package body since the body of the function is in the spec. + -- If the subprogram is an expression function, or is completed by one + -- where both the spec and body are in the same context, then there is + -- no need to load any package body since the body of the function is + -- in the spec. - if Is_Expression_Function (E) then + if Is_Non_Loading_Expression_Function (E) then Set_Is_Called (E); return; end if; diff --git a/gcc/ada/libgnat/s-tsmona.adb b/gcc/ada/libgnat/s-tsmona.adb index e04652d4907..9ec7321e847 100644 --- a/gcc/ada/libgnat/s-tsmona.adb +++ b/gcc/ada/libgnat/s-tsmona.adb @@ -48,9 +48,9 @@ package body Module_Name is -- Get -- --------- - function Get (Addr : System.Address; - Load_Addr : access System.Address) - return String + function Get + (Addr : System.Address; + Load_Addr : access System.Address) return String is pragma Unreferenced (Addr); pragma Unreferenced (Load_Addr); diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 72c48a88bef..690933704f1 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -542,8 +542,8 @@ package Rtsfind is RE_Null, - RO_CA_Time, -- Ada.Calendar RO_CA_Clock_Time, -- Ada.Calendar + RO_CA_Time, -- Ada.Calendar RO_CA_Delay_For, -- Ada.Calendar.Delays RO_CA_Delay_Until, -- Ada.Calendar.Delays @@ -1780,8 +1780,8 @@ package Rtsfind is RE_Null => RTU_Null, - RO_CA_Time => Ada_Calendar, RO_CA_Clock_Time => Ada_Calendar, + RO_CA_Time => Ada_Calendar, RO_CA_Delay_For => Ada_Calendar_Delays, RO_CA_Delay_Until => Ada_Calendar_Delays, diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b13ca92eae8..9477c283e89 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5834,8 +5834,21 @@ package body Sem_Ch6 is --------------------- procedure Possible_Freeze (T : Entity_Id) is + Scop : constant Entity_Id := Scope (Designator); begin - if Has_Delayed_Freeze (T) and then not Is_Frozen (T) then + -- If the subprogram appears within a package instance (which + -- may be the wrapper package of a subprogram instance) the + -- freeze node for that package will freeze the subprogram at + -- the proper place, so do not emit a freeze node for the + -- subprogram, given that it may appear in the wrong scope. + + if Ekind (Scop) = E_Package + and then not Comes_From_Source (Scop) + and then Is_Generic_Instance (Scop) + then + null; + + elsif Has_Delayed_Freeze (T) and then not Is_Frozen (T) then Set_Has_Delayed_Freeze (Designator); elsif Is_Access_Type (T) diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index b2e56e62bd8..152def24b0d 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -405,12 +405,20 @@ package body Sem_Elab is -- actual subprograms through generic formal subprograms. As a -- result, the calls are not recorded or processed. -- - -- -gnatdL ignore activations and calls to instances for elaboration + -- -gnatd_i ignore activations and calls to instances for elaboration -- -- The ABE mechanism ignores calls and task activations when they -- target a subprogram or task type defined an external instance. -- As a result, the calls and task activations are not processed. -- + -- -gnatdL ignore external calls from instances for elaboration + -- + -- The ABE mechanism does not generate N_Call_Marker nodes for + -- calls which occur in expanded instances, do not invoke generic + -- actual subprograms through formal subprograms, and the target + -- is external to the instance. As a result, the calls are not + -- recorded or processed. + -- -- -gnatd.o conservative elaboration order for indirect calls -- -- The ABE mechanism treats '[Unrestricted_]Access of an entry, @@ -488,6 +496,7 @@ package body Sem_Elab is -- -gnatd_a -- -gnatd_e -- -gnatd.G + -- -gnatd_i -- -gnatdL -- -gnatd_p -- -gnatd.U @@ -1781,6 +1790,13 @@ package body Sem_Elab is ----------------------- procedure Build_Call_Marker (N : Node_Id) is + function In_External_Context + (Call : Node_Id; + Target_Attrs : Target_Attributes) return Boolean; + pragma Inline (In_External_Context); + -- Determine whether a target described by attributes Target_Attrs is + -- external to call Call which must reside within an instance. + function In_Premature_Context (Call : Node_Id) return Boolean; -- Determine whether call Call appears within a premature context @@ -1798,6 +1814,55 @@ package body Sem_Elab is -- Determine whether subprogram Subp_Id denotes a generic formal -- subprogram which appears in the "prologue" of an instantiation. + ------------------------- + -- In_External_Context -- + ------------------------- + + function In_External_Context + (Call : Node_Id; + Target_Attrs : Target_Attributes) return Boolean + is + Inst : Node_Id; + Inst_Body : Node_Id; + Inst_Decl : Node_Id; + + begin + -- Performance note: parent traversal + + Inst := Find_Enclosing_Instance (Call); + + -- The call appears within an instance + + if Present (Inst) then + + -- The call comes from the main unit and the target does not + + if In_Extended_Main_Code_Unit (Call) + and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl) + then + return True; + + -- Otherwise the target declaration must not appear within the + -- instance spec or body. + + else + Extract_Instance_Attributes + (Exp_Inst => Inst, + Inst_Decl => Inst_Decl, + Inst_Body => Inst_Body); + + -- Performance note: parent traversal + + return not In_Subtree + (N => Target_Attrs.Spec_Decl, + Root1 => Inst_Decl, + Root2 => Inst_Body); + end if; + end if; + + return False; + end In_External_Context; + -------------------------- -- In_Premature_Context -- -------------------------- @@ -1987,11 +2052,28 @@ package body Sem_Elab is (Target_Id => Target_Id, Attrs => Target_Attrs); + -- Nothing to do when the call appears within the expanded spec or + -- body of an instantiated generic, the call does not invoke a generic + -- formal subprogram, the target is external to the instance, and switch + -- -gnatdL (ignore external calls from instances for elaboration) is in + -- effect. + + if Debug_Flag_LL + and then not Is_Generic_Formal_Subp (Entity (Call_Nam)) + + -- Performance note: parent traversal + + and then In_External_Context + (Call => N, + Target_Attrs => Target_Attrs) + then + return; + -- Nothing to do when the call invokes an assertion pragma procedure -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is -- in effect. - if Debug_Flag_Underscore_P + elsif Debug_Flag_Underscore_P and then Is_Assertion_Pragma_Target (Target_Id) then return; @@ -8611,10 +8693,10 @@ package body Sem_Elab is end if; -- Nothing to do when the call activates a task whose type is defined - -- within an instance and switch -gnatdL (ignore activations and calls + -- within an instance and switch -gnatd_i (ignore activations and calls -- to instances for elaboration) is in effect. - if Debug_Flag_LL + if Debug_Flag_Underscore_I and then In_External_Instance (N => Call, Target_Decl => Task_Attrs.Task_Decl) @@ -8980,10 +9062,10 @@ package body Sem_Elab is end if; -- Nothing to do when the call invokes a target defined within an - -- instance and switch -gnatdL (ignore activations and calls to + -- instance and switch -gnatd_i (ignore activations and calls to -- instances for elaboration) is in effect. - if Debug_Flag_LL + if Debug_Flag_Underscore_I and then In_External_Instance (N => Call, Target_Decl => Target_Attrs.Spec_Decl) diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index c6ba9797725..57cddd0259f 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -950,11 +950,11 @@ package body Switch.C is -- Common relaxations for both ABE mechanisms -- - -- -gnatd.G (ignore calls through generic formal parameters for - -- elaboration) - -- -gnatd.U (ignore indirect calls for static elaboration) - -- -gnatd.y (disable implicit pragma Elaborate_All on task - -- bodies) + -- -gnatd.G (ignore calls through generic formal parameters + -- for elaboration) + -- -gnatd.U (ignore indirect calls for static elaboration) + -- -gnatd.y (disable implicit pragma Elaborate_All on task + -- bodies) Debug_Flag_Dot_GG := True; Debug_Flag_Dot_UU := True; @@ -967,17 +967,20 @@ package body Switch.C is -- Relaxations to the default ABE mechanism -- - -- -gnatd_a (stop elaboration checks on accept or select - -- statement) - -- -gnatd_e (ignore entry calls and requeue statements for - -- elaboration) - -- -gnatd_p (ignore assertion pragmas for elaboration) - -- -gnatdL (ignore activations and calls to instances for - -- elaboration) + -- -gnatd_a (stop elaboration checks on accept or select + -- statement) + -- -gnatd_e (ignore entry calls and requeue statements for + -- elaboration) + -- -gnatd_i (ignore activations and calls to instances for + -- elaboration) + -- -gnatd_p (ignore assertion pragmas for elaboration) + -- -gnatdL (ignore external calls from instances for + -- elaboration) else Debug_Flag_Underscore_A := True; Debug_Flag_Underscore_E := True; + Debug_Flag_Underscore_I := True; Debug_Flag_Underscore_P := True; Debug_Flag_LL := True; end if; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a2992686bd6..8d6825ae43a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,17 @@ +2017-12-15 Hristian Kirtchev + + * gnat.dg/expr_func_main.adb, gnat.dg/expr_func_pkg.ads, + gnat.dg/expr_func_pkg.adb: New testcase. + +2017-12-15 Hristian Kirtchev + + * gnat.dg/abe_pkg.adb, gnat.dg/abe_pkg.ads: New testcase. + +2017-12-15 Ed Schonberg + + * gnat.dg/subp_inst.adb, gnat.dg/subp_inst_pkg.adb, + gnat.dg/subp_inst_pkg.ads: New testcase. + 2017-12-15 Julia Koval * gcc.target/i386/avx512f-aesenclast-2.c: New test. diff --git a/gcc/testsuite/gnat.dg/abe_pkg.adb b/gcc/testsuite/gnat.dg/abe_pkg.adb new file mode 100644 index 00000000000..7c09b850ddb --- /dev/null +++ b/gcc/testsuite/gnat.dg/abe_pkg.adb @@ -0,0 +1,13 @@ +-- { dg-do compile } +-- { dg-options "-gnatJ" } +package body ABE_Pkg is + package body Gen is + procedure Force_Body is begin null; end Force_Body; + begin + ABE; + end Gen; + + package Inst is new Gen; + + procedure ABE is begin null; end ABE; +end ABE_Pkg; diff --git a/gcc/testsuite/gnat.dg/abe_pkg.ads b/gcc/testsuite/gnat.dg/abe_pkg.ads new file mode 100644 index 00000000000..483a8871d06 --- /dev/null +++ b/gcc/testsuite/gnat.dg/abe_pkg.ads @@ -0,0 +1,8 @@ +package ABE_Pkg is + procedure ABE; + + generic + package Gen is + procedure Force_Body; + end Gen; +end ABE_Pkg; diff --git a/gcc/testsuite/gnat.dg/expr_func_main.adb b/gcc/testsuite/gnat.dg/expr_func_main.adb new file mode 100644 index 00000000000..2ea5b4aa76d --- /dev/null +++ b/gcc/testsuite/gnat.dg/expr_func_main.adb @@ -0,0 +1,9 @@ +-- { dg-do compile } + +with Expr_Func_Pkg; use Expr_Func_Pkg; + +procedure Expr_Func_Main is + Val : Boolean := Expr_Func (456); +begin + null; +end Expr_Func_Main; diff --git a/gcc/testsuite/gnat.dg/expr_func_pkg.adb b/gcc/testsuite/gnat.dg/expr_func_pkg.adb new file mode 100644 index 00000000000..de519aecc48 --- /dev/null +++ b/gcc/testsuite/gnat.dg/expr_func_pkg.adb @@ -0,0 +1,7 @@ +package body Expr_Func_Pkg is + function Func (Val : Integer) return Boolean is + begin + Error; -- { dg-error "\"Error\" is undefined" } + return Val = 123; + end Func; +end Expr_Func_Pkg; diff --git a/gcc/testsuite/gnat.dg/expr_func_pkg.ads b/gcc/testsuite/gnat.dg/expr_func_pkg.ads new file mode 100644 index 00000000000..0640a7d043d --- /dev/null +++ b/gcc/testsuite/gnat.dg/expr_func_pkg.ads @@ -0,0 +1,6 @@ +package Expr_Func_Pkg is + function Func (Val : Integer) return Boolean with Inline; + + function Expr_Func (Val : Integer) return Boolean; + function Expr_Func (Val : Integer) return Boolean is (True); +end Expr_Func_Pkg; diff --git a/gcc/testsuite/gnat.dg/subp_inst.adb b/gcc/testsuite/gnat.dg/subp_inst.adb new file mode 100644 index 00000000000..6205750293b --- /dev/null +++ b/gcc/testsuite/gnat.dg/subp_inst.adb @@ -0,0 +1,26 @@ +-- { dg-do compile } +with Subp_Inst_Pkg; +procedure Subp_Inst is + procedure Test_Access_Image is + package Nested is + type T is private; + + type T_General_Access is access all T; + type T_Access is access T; + function Image1 is new Subp_Inst_Pkg.Image (T, T_Access); + function Image2 is new Subp_Inst_Pkg.Image (T, T_General_Access); + function Image3 is new Subp_Inst_Pkg.T_Image (T); + private + type T is null record; + end Nested; + + A : aliased Nested.T; + AG : aliased constant Nested.T_General_Access := A'Access; + AA : aliased constant Nested.T_Access := new Nested.T; + begin + null; + end Test_Access_Image; + +begin + Test_Access_Image; +end Subp_Inst; diff --git a/gcc/testsuite/gnat.dg/subp_inst_pkg.adb b/gcc/testsuite/gnat.dg/subp_inst_pkg.adb new file mode 100644 index 00000000000..8fd2663fbde --- /dev/null +++ b/gcc/testsuite/gnat.dg/subp_inst_pkg.adb @@ -0,0 +1,20 @@ +with Ada.Unchecked_Conversion; +with System.Address_Image; +package body Subp_Inst_Pkg is + + function Image (Val : T_Access) return String is + function Convert is new Ada.Unchecked_Conversion + (T_Access, System.Address); + begin + return System.Address_Image (Convert (Val)); + end Image; + + function T_Image (Val : access T) return String is + type T_Access is access all T; + function Convert is new Ada.Unchecked_Conversion + (T_Access, System.Address); + begin + return System.Address_Image (Convert (Val)); + end T_Image; + +end Subp_Inst_Pkg; diff --git a/gcc/testsuite/gnat.dg/subp_inst_pkg.ads b/gcc/testsuite/gnat.dg/subp_inst_pkg.ads new file mode 100644 index 00000000000..636b0863f90 --- /dev/null +++ b/gcc/testsuite/gnat.dg/subp_inst_pkg.ads @@ -0,0 +1,13 @@ +package Subp_Inst_Pkg is + pragma Pure; + + generic + type T; + type T_Access is access T; + function Image (Val : T_Access) return String; + + generic + type T; + function T_Image (Val : access T) return String; + +end Subp_Inst_Pkg; -- 2.30.2