From: Eric Botcazou Date: Tue, 17 May 2022 06:27:11 +0000 (+0200) Subject: [Ada] Move registering code for predefined primitives to Exp_Disp X-Git-Tag: basepoints/gcc-14~6264 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=a9f5f2cd642689ae58f27aa23dff5c8d7c7bb016;p=thirdparty%2Fgcc.git [Ada] Move registering code for predefined primitives to Exp_Disp This avoids making Expand_Interface_Thunk visible from the outside. No functional changes. gcc/ada/ * exp_ch6.adb (Freeze_Subprogram.Register_Predefined_DT_Entry): Move procedure to... * exp_disp.ads (Expand_Interface_Thunk): Move declaration to... (Register_Predefined_Primitive): Declare. * exp_disp.adb (Expand_Interface_Thunk): ...here. (Register_Predefined_Primitive): ...here and change into a function returning List_Id. --- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 8bbc5154e04..3fcf51a18bb 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7828,109 +7828,9 @@ package body Exp_Ch6 is ----------------------- procedure Freeze_Subprogram (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - - procedure Register_Predefined_DT_Entry (Prim : Entity_Id); - -- (Ada 2005): Register a predefined primitive in all the secondary - -- dispatch tables of its primitive type. - - ---------------------------------- - -- Register_Predefined_DT_Entry -- - ---------------------------------- - - procedure Register_Predefined_DT_Entry (Prim : Entity_Id) is - Iface_DT_Ptr : Elmt_Id; - L : List_Id; - Tagged_Typ : Entity_Id; - Thunk_Id : Entity_Id; - Thunk_Code : Node_Id; - - begin - Tagged_Typ := Find_Dispatching_Type (Prim); - - if No (Access_Disp_Table (Tagged_Typ)) - or else not Has_Interfaces (Tagged_Typ) - or else not RTE_Available (RE_Interface_Tag) - or else Restriction_Active (No_Dispatching_Calls) - then - return; - end if; - - -- Skip the first two access-to-dispatch-table pointers since they - -- leads to the primary dispatch table (predefined DT and user - -- defined DT). We are only concerned with the secondary dispatch - -- table pointers. Note that the access-to- dispatch-table pointer - -- corresponds to the first implemented interface retrieved below. - - Iface_DT_Ptr := - Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); - - while Present (Iface_DT_Ptr) - and then Ekind (Node (Iface_DT_Ptr)) = E_Constant - loop - pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); - Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code, - Iface => Related_Type (Node (Iface_DT_Ptr))); - - if Present (Thunk_Code) then - L := New_List ( - Thunk_Code, - - Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => - New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc), - Position => DT_Position (Prim), - Address_Node => - Unchecked_Convert_To (RTE (RE_Prim_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Thunk_Id, Loc), - Attribute_Name => Name_Unrestricted_Access))), - - Build_Set_Predefined_Prim_Op_Address (Loc, - Tag_Node => - New_Occurrence_Of - (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), - Loc), - Position => DT_Position (Prim), - Address_Node => - Unchecked_Convert_To (RTE (RE_Prim_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Prim, Loc), - Attribute_Name => Name_Unrestricted_Access)))); - - if No (Actions (N)) then - Set_Actions (N, L); - - else - Append_List (L, Actions (N)); - end if; - end if; - - -- Skip the tag of the predefined primitives dispatch table - - Next_Elmt (Iface_DT_Ptr); - pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); - - -- Skip tag of the no-thunks dispatch table - - Next_Elmt (Iface_DT_Ptr); - pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); - - -- Skip tag of predefined primitives no-thunks dispatch table - - Next_Elmt (Iface_DT_Ptr); - pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); - - Next_Elmt (Iface_DT_Ptr); - end loop; - end Register_Predefined_DT_Entry; - - -- Local variables - + Loc : constant Source_Ptr := Sloc (N); Subp : constant Entity_Id := Entity (N); - -- Start of processing for Freeze_Subprogram - begin -- We suppress the initialization of the dispatch table entry when -- not Tagged_Type_Expansion because the dispatching mechanism is @@ -7985,10 +7885,12 @@ package body Exp_Ch6 is or else Present (Interface_Alias (Subp)) then if Is_Predefined_Dispatching_Operation (Subp) then - Register_Predefined_DT_Entry (Subp); + L := Register_Predefined_Primitive (Loc, Subp); + else + L := New_List; end if; - L := Register_Primitive (Loc, Prim => Subp); + Append_List_To (L, Register_Primitive (Loc, Subp)); if Is_Empty_List (L) then null; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index f16cfdca948..7f6bb819030 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -80,6 +80,20 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- of the default primitive operations. + procedure Expand_Interface_Thunk + (Prim : Entity_Id; + Thunk_Id : out Entity_Id; + Thunk_Code : out Node_Id; + Iface : Entity_Id); + -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we + -- generate additional subprograms (thunks) associated with each primitive + -- Prim to have a layout compatible with the C++ ABI. The thunk displaces + -- the pointers to the actuals that depend on the controlling type before + -- transferring control to the target subprogram. If there is no need to + -- generate the thunk, then Thunk_Id is set to Empty. Otherwise Thunk_Id + -- is set to the defining identifier of the thunk and Thunk_Code to the + -- code generated for the thunk respectively. + function Has_DT (Typ : Entity_Id) return Boolean; pragma Inline (Has_DT); -- Returns true if we generate a dispatch table for tagged type Typ @@ -7131,6 +7145,96 @@ package body Exp_Disp is end if; end Prim_Op_Kind; + ----------------------------------- + -- Register_Predefined_Primitive -- + ----------------------------------- + + function Register_Predefined_Primitive + (Loc : Source_Ptr; + Prim : Entity_Id) return List_Id + is + L : constant List_Id := New_List; + Tagged_Typ : constant Entity_Id := Find_Dispatching_Type (Prim); + + Iface_DT_Ptr : Elmt_Id; + Thunk_Id : Entity_Id; + Thunk_Code : Node_Id; + + begin + if No (Access_Disp_Table (Tagged_Typ)) + or else not Has_Interfaces (Tagged_Typ) + or else not RTE_Available (RE_Interface_Tag) + or else Restriction_Active (No_Dispatching_Calls) + then + return L; + end if; + + -- Skip the first two access-to-dispatch-table pointers since they + -- leads to the primary dispatch table (predefined DT and user + -- defined DT). We are only concerned with the secondary dispatch + -- table pointers. Note that the access-to- dispatch-table pointer + -- corresponds to the first implemented interface retrieved below. + + Iface_DT_Ptr := + Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Tagged_Typ)))); + + while Present (Iface_DT_Ptr) + and then Ekind (Node (Iface_DT_Ptr)) = E_Constant + loop + pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); + + Expand_Interface_Thunk + (Prim, Thunk_Id, Thunk_Code, Related_Type (Node (Iface_DT_Ptr))); + + if Present (Thunk_Id) then + Append_To (L, Thunk_Code); + + Append_To (L, + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => + New_Occurrence_Of (Node (Next_Elmt (Iface_DT_Ptr)), Loc), + Position => DT_Position (Prim), + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Thunk_Id, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + + Append_To (L, + Build_Set_Predefined_Prim_Op_Address (Loc, + Tag_Node => + New_Occurrence_Of + (Node (Next_Elmt (Next_Elmt (Next_Elmt (Iface_DT_Ptr)))), + Loc), + Position => DT_Position (Prim), + Address_Node => + Unchecked_Convert_To (RTE (RE_Prim_Ptr), + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Prim, Loc), + Attribute_Name => Name_Unrestricted_Access)))); + end if; + + -- Skip the tag of the predefined primitives dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip tag of the no-thunks dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); + + -- Skip tag of predefined primitives no-thunks dispatch table + + Next_Elmt (Iface_DT_Ptr); + pragma Assert (not Has_Thunks (Node (Iface_DT_Ptr))); + + Next_Elmt (Iface_DT_Ptr); + end loop; + + return L; + end Register_Predefined_Primitive; + ------------------------ -- Register_Primitive -- ------------------------ diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index b122e59cb95..a02e44980cc 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -233,20 +233,6 @@ package Exp_Disp is -- to the object to give access to the interface tag associated with the -- dispatch table of the target type. - procedure Expand_Interface_Thunk - (Prim : Entity_Id; - Thunk_Id : out Entity_Id; - Thunk_Code : out Node_Id; - Iface : Entity_Id); - -- Ada 2005 (AI-251): When a tagged type implements abstract interfaces we - -- generate additional subprograms (thunks) associated with each primitive - -- Prim to have a layout compatible with the C++ ABI. The thunk displaces - -- the pointers to the actuals that depend on the controlling type before - -- transferring control to the target subprogram. If there is no need to - -- generate the thunk then Thunk_Id and Thunk_Code are set to Empty. - -- Otherwise they are set to the defining identifier and the subprogram - -- body of the generated thunk. - function Has_CPP_Constructors (Typ : Entity_Id) return Boolean; -- Returns true if the type has CPP constructors @@ -337,6 +323,15 @@ package Exp_Disp is -- tagged types this routine imports the forward declaration of the tag -- entity, that will be declared and exported by Make_DT. + function Register_Predefined_Primitive + (Loc : Source_Ptr; + Prim : Entity_Id) return List_Id; + -- Ada 2005: Register a predefined primitive in all the secondary dispatch + -- tables of its primitive type. + -- + -- The caller is responsible for inserting the generated code in the + -- proper place. + function Register_Primitive (Loc : Source_Ptr; Prim : Entity_Id) return List_Id;