From: Javier Miranda Date: Tue, 15 Feb 2022 19:09:48 +0000 (+0000) Subject: [Ada] Compiler crash on -gnata -O2 X-Git-Tag: basepoints/gcc-14~6797 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=d663778287d3bd908b5e059f640ca6a02bb0f487;p=thirdparty%2Fgcc.git [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 --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; ----------------------------