public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-410] [Ada] Compiler crash on -gnata -O2
@ 2022-05-13 8:09 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-13 8:09 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:d663778287d3bd908b5e059f640ca6a02bb0f487
commit r13-410-gd663778287d3bd908b5e059f640ca6a02bb0f487
Author: Javier Miranda <miranda@adacore.com>
Date: Tue Feb 15 19:09:48 2022 +0000
[Ada] Compiler crash on -gnata -O2
gcc/ada/
* contracts.adb (Build_Unique_Name): New subprogram.
(Make_Class_Precondition_Subps): Use Build_Unique_Name to
generate the names of the call helpers and the name of indirect
call wrappers.
* freeze.adb (Needs_Wrapper): Remove dead code.
(Check_Inherited_Conditions): Defer building helpers and ICW
until all the dispatch table wrappers have been built and
analyzed. Required to ensure uniqueness in their names because
when building these wrappers for overlapped subprograms their
homonym number is not definite until they have been analyzed.
Diff:
---
gcc/ada/contracts.adb | 39 ++++++++++++++-----
gcc/ada/freeze.adb | 102 ++++++++++++++++++++++++++++----------------------
2 files changed, 88 insertions(+), 53 deletions(-)
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index 3cda36aaa39..7ce3cfac91d 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -3630,6 +3630,10 @@ package body Contracts is
-- and append it to the freezing actions of Tagged_Type. Is_Dynamic
-- controls building the static or dynamic version of the helper.
+ function Build_Unique_Name (Suffix : String) return Name_Id;
+ -- Build an unique new name adding suffix to Subp_Id name (plus its
+ -- homonym number for values bigger than 1).
+
-------------------------------
-- Add_Indirect_Call_Wrapper --
-------------------------------
@@ -3710,9 +3714,7 @@ package body Contracts is
function Build_ICW_Decl return Node_Id is
ICW_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Subp_Id),
- Suffix => "ICW",
- Suffix_Index => Source_Offset (Loc)));
+ Build_Unique_Name (Suffix => "ICW"));
Decl : Node_Id;
Spec : Node_Id;
@@ -4049,6 +4051,29 @@ package body Contracts is
end if;
end Add_Call_Helper;
+ -----------------------
+ -- Build_Unique_Name --
+ -----------------------
+
+ function Build_Unique_Name (Suffix : String) return Name_Id is
+ begin
+ -- Append the homonym number. Strip the leading space character in
+ -- the image of natural numbers. Also do not add the homonym value
+ -- of 1.
+
+ if Has_Homonym (Subp_Id) and then Homonym_Number (Subp_Id) > 1 then
+ declare
+ S : constant String := Homonym_Number (Subp_Id)'Img;
+
+ begin
+ return New_External_Name (Chars (Subp_Id),
+ Suffix => Suffix & "_" & S (2 .. S'Last));
+ end;
+ end if;
+
+ return New_External_Name (Chars (Subp_Id), Suffix);
+ end Build_Unique_Name;
+
-- Local variables
Helper_Id : Entity_Id;
@@ -4070,9 +4095,7 @@ package body Contracts is
Helper_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Subp_Id),
- Suffix => "DP",
- Suffix_Index => Source_Offset (Loc)));
+ Build_Unique_Name (Suffix => "DP"));
Add_Call_Helper (Helper_Id, Is_Dynamic => True);
-- Link original subprogram to helper and vice versa
@@ -4089,9 +4112,7 @@ package body Contracts is
Helper_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Subp_Id),
- Suffix => "SP",
- Suffix_Index => Source_Offset (Loc)));
+ Build_Unique_Name (Suffix => "SP"));
Add_Call_Helper (Helper_Id, Is_Dynamic => False);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index bc8d958f440..7d90f512245 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1741,17 +1741,6 @@ package body Freeze is
(Nkind (Parent (N)) /= N_Attribute_Reference
or else Attribute_Name (Parent (N)) /= Name_Class)
then
- -- The check does not apply to dispatching calls within the
- -- condition, but only to calls whose static tag is that of
- -- the parent type.
-
- if Is_Subprogram (Entity (N))
- and then Nkind (Parent (N)) = N_Function_Call
- and then Present (Controlling_Argument (Parent (N)))
- then
- return OK;
- end if;
-
-- Determine whether entity has a renaming
New_E := Get_Mapped_Entity (Entity (N));
@@ -1795,6 +1784,10 @@ package body Freeze is
Ifaces_Listed : Boolean := False;
-- Cache the list of interface operations inherited by R
+ Wrappers_List : Elist_Id := No_Elist;
+ -- List containing identifiers of built wrappers. Used to defer building
+ -- and analyzing their class-wide precondition subprograms.
+
-- Start of processing for Check_Inherited_Conditions
begin
@@ -1985,16 +1978,21 @@ package body Freeze is
Prim_Prev_E : constant Entity_Id := Prev_Entity (Prim);
begin
- -- The wrapper must be analyzed in the scope of its wrapped
- -- primitive (to ensure its correct decoration).
-
- Push_Scope (Scope (Prim));
-
DTW_Spec := Build_DTW_Spec (Par_Prim);
DTW_Id := Defining_Entity (DTW_Spec);
DTW_Decl := Make_Subprogram_Declaration (Loc,
Specification => DTW_Spec);
+ -- The spec of the wrapper has been built using the source
+ -- location of its parent primitive; we must update it now
+ -- (with the source location of the internal primitive built
+ -- by Derive_Subprogram that will override this wrapper) to
+ -- avoid inlining conflicts between internally built helpers
+ -- for class-wide pre/postconditions of the parent and the
+ -- helpers built for this wrapper.
+
+ Set_Sloc (DTW_Id, Sloc (Prim));
+
-- For inherited class-wide preconditions the DTW wrapper
-- reuses the ICW of the parent (which checks the parent
-- interpretation of the class-wide preconditions); the
@@ -2121,42 +2119,58 @@ package body Freeze is
Register_Primitive (Loc, DTW_Id));
end if;
- -- Build the helper and ICW for the DTW
+ -- Defer building helpers and ICW for the DTW. Required to
+ -- ensure uniqueness in their names because when building
+ -- these wrappers for overlapped subprograms their homonym
+ -- number is not definite until all these dispatch table
+ -- wrappers of tagged type R have been analyzed.
if Present (Indirect_Call_Wrapper (Par_Prim)) then
- declare
- CW_Subp : Entity_Id;
- Decl_N : Node_Id;
- Body_N : Node_Id;
-
- begin
- Merge_Class_Conditions (DTW_Id);
- Make_Class_Precondition_Subps (DTW_Id,
- Late_Overriding => Late_Overriding);
-
- CW_Subp := Static_Call_Helper (DTW_Id);
- Decl_N := Unit_Declaration_Node (CW_Subp);
- Analyze (Decl_N);
-
- -- If the DTW was built for a late-overriding primitive
- -- its body must be analyzed now (since the tagged type
- -- is already frozen).
-
- if Late_Overriding then
- Body_N :=
- Unit_Declaration_Node
- (Corresponding_Body (Decl_N));
- Analyze (Body_N);
- end if;
- end;
+ Append_New_Elmt (DTW_Id, Wrappers_List);
end if;
-
- Pop_Scope;
end;
end if;
Next_Elmt (Op_Node);
end loop;
+
+ -- Build and analyze deferred class-wide precondition subprograms of
+ -- built wrappers.
+
+ if Present (Wrappers_List) then
+ declare
+ Body_N : Node_Id;
+ CW_Subp : Entity_Id;
+ Decl_N : Node_Id;
+ DTW_Id : Entity_Id;
+ Elmt : Elmt_Id;
+
+ begin
+ Elmt := First_Elmt (Wrappers_List);
+
+ while Present (Elmt) loop
+ DTW_Id := Node (Elmt);
+ Next_Elmt (Elmt);
+
+ Merge_Class_Conditions (DTW_Id);
+ Make_Class_Precondition_Subps (DTW_Id, Late_Overriding);
+
+ CW_Subp := Static_Call_Helper (DTW_Id);
+ Decl_N := Unit_Declaration_Node (CW_Subp);
+ Analyze (Decl_N);
+
+ -- If the DTW was built for a late-overriding primitive
+ -- its body must be analyzed now (since the tagged type
+ -- is already frozen).
+
+ if Late_Overriding then
+ Body_N :=
+ Unit_Declaration_Node (Corresponding_Body (Decl_N));
+ Analyze (Body_N);
+ end if;
+ end loop;
+ end;
+ end if;
end Check_Inherited_Conditions;
----------------------------
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-13 8:09 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-13 8:09 [gcc r13-410] [Ada] Compiler crash on -gnata -O2 Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).