https://gcc.gnu.org/g:debafaf88c2a32b12a09ed6779b2c669eb886c01
commit r17-775-gdebafaf88c2a32b12a09ed6779b2c669eb886c01 Author: Marc Poulhiès <[email protected]> Date: Fri Dec 5 11:24:56 2025 +0100 ada: fix: drop renamings along with dropped subp During unnesting, the compiler may drop some subp if reachability analysis decides it's never used. This change adds tracking for subp renamings, making sure renamings are also dropped with the subp. When traversing the tree, when looking at a subp renaming declaration, it's possible that the Subps entry (accessed through Subps_Index) for the renamed subp has not yet been created. In this case, the renaming is recorded in a "pending" list, and moved later when the Subps entry is created. gcc/ada/ChangeLog: * exp_unst.adb (Maybe_Subp_Index): New non throwing version of Subp_Index. (Nullify_Renamings, Move_Pending_Renamings): New. (Register_Subprogram): Record subp renamings. Call Nullify_Renamings when a subp is dropped. (with Elist): Moved to... * exp_unst.ads (with Elist): ... here. (Subp_Entry): Add Renamings component. (Pending_Renamings): New list. Diff: --- gcc/ada/exp_unst.adb | 157 +++++++++++++++++++++++++++++++++++++++++++++++---- gcc/ada/exp_unst.ads | 12 ++++ 2 files changed, 159 insertions(+), 10 deletions(-) diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 601318e10d59..84db16ef3b88 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -27,7 +27,6 @@ with Atree; use Atree; with Debug; use Debug; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; -with Elists; use Elists; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; @@ -55,6 +54,13 @@ package body Exp_Unst is -- Local Subprograms -- ----------------------- + function Maybe_Subp_Index (Sub : Entity_Id) return SI_Type; + -- Returns the subps index value if it has been set, 0 if not + + procedure Nullify_Renamings (Renamings : Elist_Id); + -- Iterates over all renamings in the Renamings list and replace them with + -- null statements. + procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False); -- Subp is a library-level subprogram which has nested subprograms, and @@ -264,8 +270,14 @@ package body Exp_Unst is ---------------- function Subp_Index (Sub : Entity_Id) return SI_Type is - E : Entity_Id := Sub; + Ret : constant SI_Type := Maybe_Subp_Index (Sub); + begin + pragma Assert (Ret /= 0); + return Ret; + end Subp_Index; + function Maybe_Subp_Index (Sub : Entity_Id) return SI_Type is + E : Entity_Id := Sub; begin pragma Assert (Is_Subprogram (E)); @@ -283,9 +295,54 @@ package body Exp_Unst is end if; end if; - pragma Assert (Subps_Index (E) /= Uint_0); - return SI_Type (UI_To_Int (Subps_Index (E))); - end Subp_Index; + if not Field_Is_Initial_Zero (E, F_Subps_Index) then + return SI_Type (UI_To_Int (Subps_Index (E))); + else + -- Field has not been set, don't try to access it yet + return 0; + end if; + end Maybe_Subp_Index; + + procedure Nullify_Renamings (Renamings : Elist_Id) is + Iterator : Elmt_Id := First_Elmt (Renamings); + Nod : Node_Id; + F_Nod : Node_Id; + begin + if Debug_Flag_Dot_3 and then Present (Iterator) then + Nod := Node (Iterator); + Write_Str ("Dropping renamings for "); + Write_Name (Chars (Entity (Name (Nod)))); + Write_Eol; + end if; + + while Present (Iterator) loop + Nod := Node (Iterator); + + if Debug_Flag_Dot_3 then + Write_Str (" - "); + Write_Name (Chars (Defining_Unit_Name (Specification (Nod)))); + Write_Eol; + end if; + + -- Remove the freeze node if there is one + + F_Nod := Freeze_Node (Defining_Unit_Name + (Specification (Nod))); + if Present (F_Nod) then + Rewrite (F_Nod, + Make_Null_Statement (Sloc (Nod))); + end if; + + Rewrite (Nod, + Make_Null_Statement (Sloc (Nod))); + + Next_Elmt (Iterator); + end loop; + + while Present (First_Elmt (Renamings)) loop + Remove_Last_Elmt (Renamings); + end loop; + end Nullify_Renamings; ----------------------- -- Unnest_Subprogram -- @@ -482,6 +539,11 @@ package body Exp_Unst is -- is an access type, check whether the designated type -- has dynamic bounds. + procedure Move_Pending_Renamings (Subp : Entity_Id; + Renamings : in out Elist_Id); + -- Move all pending renamings that are renaming Subp to its own + -- Renamings list. + procedure Note_Uplevel_Ref (E : Entity_Id; N : Node_Id; @@ -759,17 +821,41 @@ package body Exp_Unst is Urefs.Append ((N, Full_E, Caller, Callee)); end Note_Uplevel_Ref; + procedure Move_Pending_Renamings (Subp : Entity_Id; + Renamings : in out Elist_Id) is + Iterator : Elmt_Id := First_Elmt (Pending_Renamings); + Nod : Node_Id; + begin + while Present (Iterator) loop + Nod := Node (Iterator); + + if Entity (Name (Nod)) = Subp then + Append_New_Elmt (Nod, Renamings); + end if; + Next_Elmt (Iterator); + end loop; + + Iterator := First_Elmt (Renamings); + while Present (Iterator) loop + Remove (Pending_Renamings, Node (Iterator)); + Next_Elmt (Iterator); + end loop; + end Move_Pending_Renamings; + ------------------------- -- Register_Subprogram -- ------------------------- procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is L : constant Nat := Get_Level (Subp, E); - + Renamings : Elist_Id := New_Elmt_List; begin - -- Subprograms declared in tasks and protected types cannot be - -- eliminated because calls to them may be in other units, so - -- they must be treated as reachable. + Move_Pending_Renamings (E, Renamings); + + -- Subprograms declared in tasks and protected types or whose + -- address is taken (through attribute Address or Access) + -- cannot be eliminated because calls to them may be in other + -- units, so they must be treated as reachable. Subps.Append ((Ent => E, @@ -786,7 +872,8 @@ package body Exp_Unst is ARECnT => Empty, ARECnPT => Empty, ARECnP => Empty, - ARECnU => Empty)); + ARECnU => Empty, + Renamings => Renamings)); Set_Subps_Index (E, UI_From_Int (Subps.Last)); @@ -1222,6 +1309,54 @@ package body Exp_Unst is return Skip; end if; + when N_Subprogram_Renaming_Declaration => + -- Record the subprogram renaming. If the reachability + -- analysis decides to drop the procedure, we also need to + -- drop all the associated renamings. + + if Nkind (Name (N)) in N_Has_Entity then + declare + E : constant Entity_Id := Entity (Name (N)); + SE : Subp_Entry; + begin + -- Do not record renamings for something not a + -- subprogram. e.g. + -- function t return boolean renames true; + + if Is_Subprogram (E) then + if Maybe_Subp_Index (E) /= 0 + and then Enclosing_Subprogram (E) /= Empty + then + SE := Subps.Table (Subp_Index (E)); + Append_Elmt (N, SE.Renamings); + + if Debug_Flag_Dot_3 then + Write_Str ("Record renaming "); + Write_Name (Chars (Entity (Name (N)))); + Write_Str (" for subp "); + Write_Name (Chars (SE.Ent)); + Write_Str (" at "); + Write_Location (Sloc (E)); + Write_Eol; + end if; + else + Append_Elmt (N, Pending_Renamings); + + if Debug_Flag_Dot_3 then + Write_Str ("Record pending renaming "); + Write_Name (Chars ( + Defining_Unit_Name (Specification (N)))); + Write_Str (" for subp "); + Write_Name (Chars (E)); + Write_Str (" at "); + Write_Location (Sloc (E)); + Write_Eol; + end if; + end if; + end if; + end; + end if; + -- Otherwise record an uplevel reference in a local identifier when others => @@ -1531,6 +1666,8 @@ package body Exp_Unst is if Present (STJ.Bod) then Spec := Corresponding_Spec (STJ.Bod); + Nullify_Renamings (STJ.Renamings); + if Present (Spec) then Decl := Parent (Declaration_Node (Spec)); Rewrite (Decl, Make_Null_Statement (Sloc (Decl))); diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index b710ff5ecd41..0fcad7f103c6 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -27,6 +27,7 @@ with Table; with Types; use Types; +with Elists; use Elists; package Exp_Unst is @@ -696,8 +697,19 @@ package Exp_Unst is -- activation record that references the ARECnF pointer (which points -- the activation record one level higher, thus forming the chain). + Renamings : Elist_Id; + -- This list contains all renamings of this subprogram. It is used when + -- the subprogram is dropped because it's unreachable: all renamings + -- must also be dropped. + end record; + Pending_Renamings : Elist_Id := New_Elmt_List; + -- This is a list of subprogram renamings that are waiting for their + -- corresponding Subp_Entry to be created. Once the Subp_Entry is + -- available, the compiler moves the renaming entry from this list to + -- the Subp_Entry.Renamings list. + package Subps is new Table.Table ( Table_Component_Type => Subp_Entry, Table_Index_Type => SI_Type,
