This patch restores the functionality of debug switch -gnatdL to the behavior
prior to revision 255412. The existing behavior has been associated with
switch -gnatd_i.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-12-15 Hristian Kirtchev <kirtc...@adacore.com>
* 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.
gcc/testsuite/
2017-12-15 Hristian Kirtchev <kirtc...@adacore.com>
* gnat.dg/abe_pkg.adb, gnat.dg/abe_pkg.ads: New testcase.
Index: checks.adb
===================================================================
--- checks.adb (revision 255678)
+++ checks.adb (working copy)
@@ -6819,7 +6819,7 @@
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;
Index: debug.adb
===================================================================
--- debug.adb (revision 255678)
+++ debug.adb (working copy)
@@ -153,7 +153,7 @@
-- 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 @@
-- 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 @@
-- 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 @@
-- 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.
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 255680)
+++ exp_ch6.adb (working copy)
@@ -5356,7 +5356,7 @@
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
Index: exp_ch7.adb
===================================================================
--- exp_ch7.adb (revision 255680)
+++ exp_ch7.adb (working copy)
@@ -4200,13 +4200,11 @@
----------------------------
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 @@
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
-- <statements> -- possibly with handlers
@@ -4336,14 +4336,15 @@
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;
Index: exp_unst.adb
===================================================================
--- exp_unst.adb (revision 255680)
+++ exp_unst.adb (working copy)
@@ -302,6 +302,16 @@
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 @@
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 @@
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
Index: exp_util.adb
===================================================================
--- exp_util.adb (revision 255678)
+++ exp_util.adb (working copy)
@@ -10701,8 +10701,8 @@
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 @@
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 @@
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 @@
| 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 @@
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;
Index: libgnat/s-tsmona.adb
===================================================================
--- libgnat/s-tsmona.adb (revision 255678)
+++ libgnat/s-tsmona.adb (working copy)
@@ -48,9 +48,9 @@
-- 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);
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 255678)
+++ rtsfind.ads (working copy)
@@ -542,8 +542,8 @@
RE_Null,
+ RO_CA_Clock_Time, -- Ada.Calendar
RO_CA_Time, -- Ada.Calendar
- RO_CA_Clock_Time, -- Ada.Calendar
RO_CA_Delay_For, -- Ada.Calendar.Delays
RO_CA_Delay_Until, -- Ada.Calendar.Delays
@@ -1780,8 +1780,8 @@
RE_Null => RTU_Null,
+ RO_CA_Clock_Time => Ada_Calendar,
RO_CA_Time => Ada_Calendar,
- RO_CA_Clock_Time => Ada_Calendar,
RO_CA_Delay_For => Ada_Calendar_Delays,
RO_CA_Delay_Until => Ada_Calendar_Delays,
Index: sem_elab.adb
===================================================================
--- sem_elab.adb (revision 255678)
+++ sem_elab.adb (working copy)
@@ -405,12 +405,20 @@
-- 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 @@
-- -gnatd_a
-- -gnatd_e
-- -gnatd.G
+ -- -gnatd_i
-- -gnatdL
-- -gnatd_p
-- -gnatd.U
@@ -1781,6 +1790,13 @@
-----------------------
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 @@
-- 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 @@
(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 @@
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 @@
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)
Index: switch-c.adb
===================================================================
--- switch-c.adb (revision 255678)
+++ switch-c.adb (working copy)
@@ -950,11 +950,11 @@
-- 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 @@
-- 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;
Index: ../testsuite/gnat.dg/abe_pkg.ads
===================================================================
--- ../testsuite/gnat.dg/abe_pkg.ads (revision 0)
+++ ../testsuite/gnat.dg/abe_pkg.ads (revision 0)
@@ -0,0 +1,8 @@
+package ABE_Pkg is
+ procedure ABE;
+
+ generic
+ package Gen is
+ procedure Force_Body;
+ end Gen;
+end ABE_Pkg;
Index: ../testsuite/gnat.dg/abe_pkg.adb
===================================================================
--- ../testsuite/gnat.dg/abe_pkg.adb (revision 0)
+++ ../testsuite/gnat.dg/abe_pkg.adb (revision 0)
@@ -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;
