From af93b89d8a144f0008b22553ff59c0286a13ddd9 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Mon, 2 May 2022 10:07:38 +0200 Subject: [PATCH] [Ada] Minor tweaks to dispatching support code No functional changes. gcc/ada/ * exp_disp.ads (Expand_Interface_Thunk): Change type of Prim. * exp_disp.adb (Expand_Interface_Thunk): Declare Is_Predef_Op earlier, do not initialize Iface_Formal, use No idiom and tweaks comments. (Register_Primitive): Declare L earlier and tweak comments. * sem_disp.adb (Check_Dispatching_Operation): Move tests out of loop. --- gcc/ada/exp_disp.adb | 50 +++++++++++++++++++++++++++----------------------- gcc/ada/exp_disp.ads | 2 +- gcc/ada/sem_disp.adb | 10 +++++----- 3 files changed, 33 insertions(+), 29 deletions(-) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 1f43458..8666902 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1731,26 +1731,26 @@ package body Exp_Disp is ---------------------------- procedure Expand_Interface_Thunk - (Prim : Node_Id; + (Prim : Entity_Id; Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id; Iface : Entity_Id) is - Loc : constant Source_Ptr := Sloc (Prim); - Actuals : constant List_Id := New_List; - Decl : constant List_Id := New_List; - Formals : constant List_Id := New_List; - Target : constant Entity_Id := Ultimate_Alias (Prim); + Actuals : constant List_Id := New_List; + Decl : constant List_Id := New_List; + Formals : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Prim); + Target : constant Entity_Id := Ultimate_Alias (Prim); + Is_Predef_Op : constant Boolean := + Is_Predefined_Dispatching_Operation (Prim) + or else Is_Predefined_Dispatching_Operation (Target); Decl_1 : Node_Id; Decl_2 : Node_Id; Expr : Node_Id; Formal : Node_Id; Ftyp : Entity_Id; - Iface_Formal : Node_Id := Empty; -- initialize to prevent warning - Is_Predef_Op : constant Boolean := - Is_Predefined_Dispatching_Operation (Prim) - or else Is_Predefined_Dispatching_Operation (Target); + Iface_Formal : Node_Id; New_Arg : Node_Id; Offset_To_Top : Node_Id; Target_Formal : Entity_Id; @@ -1764,16 +1764,17 @@ package body Exp_Disp is if Is_Eliminated (Target) then return; - -- In case of primitives that are functions without formals and a - -- controlling result there is no need to build the thunk. + -- No thunk needed if the primitive has no formals. In this case, this + -- must be a function with a controlling result. - elsif not Present (First_Formal (Target)) then + elsif No (First_Formal (Target)) then pragma Assert (Ekind (Target) = E_Function and then Has_Controlling_Result (Target)); + return; end if; - -- Duplicate the formals of the Target primitive. In the thunk, the type + -- Duplicate the formals of the target primitive. In the thunk, the type -- of the controlling formal is the covered interface type (instead of -- the target tagged type). Done to avoid problems with discriminated -- tagged types because, if the controlling type has discriminants with @@ -1785,14 +1786,14 @@ package body Exp_Disp is -- because they don't have available the Interface_Alias attribute (see -- Sem_Ch3.Add_Internal_Interface_Entities). - if not Is_Predef_Op then + if Is_Predef_Op then + Iface_Formal := Empty; + else Iface_Formal := First_Formal (Interface_Alias (Prim)); end if; Formal := First_Formal (Target); while Present (Formal) loop - Ftyp := Etype (Formal); - -- Use the interface type as the type of the controlling formal (see -- comment above). @@ -1814,10 +1815,10 @@ package body Exp_Disp is -- Sanity check performed to ensure the proper controlling type -- when the thunk has exactly one controlling parameter and it - -- comes first. In such case the GCC backend reuses the C++ + -- comes first. In such a case, the GCC back end reuses the C++ -- thunks machinery which perform a computation equivalent to -- the code generated by the expander; for other cases the GCC - -- backend translates the expanded code unmodified. However, as + -- back end translates the expanded code unmodified. However, as -- a generalization, the check is performed for all controlling -- types. @@ -7115,12 +7116,13 @@ package body Exp_Disp is (Loc : Source_Ptr; Prim : Entity_Id) return List_Id is + L : constant List_Id := New_List; + DT_Ptr : Entity_Id; Iface_Prim : Entity_Id; Iface_Typ : Entity_Id; Iface_DT_Ptr : Entity_Id; Iface_DT_Elmt : Elmt_Id; - L : constant List_Id := New_List; Pos : Uint; Tag : Entity_Id; Tag_Typ : Entity_Id; @@ -7130,7 +7132,7 @@ package body Exp_Disp is begin pragma Assert (not Restriction_Active (No_Dispatching_Calls)); - -- Do not register in the dispatch table eliminated primitives + -- Do not register eliminated primitives in the dispatch table if not RTE_Available (RE_Tag) or else Is_Eliminated (Ultimate_Alias (Prim)) @@ -7139,10 +7141,12 @@ package body Exp_Disp is return L; end if; + -- Primitive associated with a tagged type + if not Present (Interface_Alias (Prim)) then Tag_Typ := Scope (DTC_Entity (Prim)); - Pos := DT_Position (Prim); - Tag := First_Tag_Component (Tag_Typ); + Pos := DT_Position (Prim); + Tag := First_Tag_Component (Tag_Typ); if Is_Predefined_Dispatching_Operation (Prim) or else Is_Predefined_Dispatching_Alias (Prim) diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 96eae30..b122e59 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -234,7 +234,7 @@ package Exp_Disp is -- dispatch table of the target type. procedure Expand_Interface_Thunk - (Prim : Node_Id; + (Prim : Entity_Id; Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id; Iface : Entity_Id); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 3e75a47..79af10a 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1728,7 +1728,11 @@ package body Sem_Disp is -- emitted after those tables are built, to prevent access before -- elaboration in gigi. - if Body_Is_Last_Primitive and then Expander_Active then + if Body_Is_Last_Primitive + and then not Building_Static_DT (Tagged_Type) + and then Expander_Active + and then Tagged_Type_Expansion + then declare Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp); Elmt : Elmt_Id; @@ -1739,13 +1743,9 @@ package body Sem_Disp is while Present (Elmt) loop Prim := Node (Elmt); - -- No code required to register primitives in VM targets - if Present (Alias (Prim)) and then Present (Interface_Alias (Prim)) and then Alias (Prim) = Subp - and then not Building_Static_DT (Tagged_Type) - and then Tagged_Type_Expansion then Insert_Actions_After (Subp_Body, Register_Primitive (Sloc (Subp_Body), Prim => Prim)); -- 2.7.4